Compare commits

..

No commits in common. "dc32120ca8ad176d313014e255da85d7a7d60aca" and "f5f6c9ced90d6f53ccdaa4143ab56d7135d0c1a3" have entirely different histories.

17 changed files with 36 additions and 92 deletions

View File

@ -18,20 +18,20 @@ cabal-version: >=1.10
executable backend executable backend
main-is: Main.hs main-is: Main.hs
other-modules: Devel.Main other-modules: Devel.Main
, API
, API.Books
, API.Catalogue
, API.Channels
, API.Users
, Database , Database
, Database.Book , Database.Book
, Database.Channel , Database.Channel
, Database.Schema
, Database.Tag , Database.Tag
, Database.Schema
, Database.User , Database.User
, Datastore , Datastore
, Servant.XML , Servant.XML
, Server , Server
, Server.API
, Server.API.Books
, Server.API.Catalogue
, Server.API.Channels
, Server.API.Users
, Server.Auth , Server.Auth
, Types , Types
, View , View

View File

@ -9,7 +9,7 @@
{-# Language RecordWildCards #-} {-# Language RecordWildCards #-}
{-# Language DeriveGeneric #-} {-# Language DeriveGeneric #-}
{-# Language FlexibleInstances #-} {-# Language FlexibleInstances #-}
module Server.API (API, handler) where module API (API, handler) where
import Servant import Servant
@ -18,10 +18,10 @@ import Types
import View import View
import qualified Server.API.Users as Users import qualified API.Users as Users
import qualified Server.API.Channels as Channels import qualified API.Channels as Channels
import qualified Server.API.Books as Books import qualified API.Books as Books
import qualified Server.API.Catalogue as Catalogue import qualified API.Catalogue as Catalogue
data Index = Index data Index = Index

View File

@ -13,7 +13,7 @@
{-# Language TypeApplications #-} {-# Language TypeApplications #-}
{-# Language DataKinds #-} {-# Language DataKinds #-}
{-# Language NamedFieldPuns #-} {-# Language NamedFieldPuns #-}
module Server.API.Books where module API.Books where
import Servant hiding (contentType) import Servant hiding (contentType)
import Types import Types

View File

@ -14,7 +14,7 @@
{-# Language TemplateHaskell #-} {-# Language TemplateHaskell #-}
{-# Language MultiParamTypeClasses #-} {-# Language MultiParamTypeClasses #-}
{-# Language ScopedTypeVariables #-} {-# Language ScopedTypeVariables #-}
module Server.API.Catalogue (VersionedAPI, handler) where module API.Catalogue (VersionedAPI, handler) where
import Types import Types
import Servant hiding (contentType) import Servant hiding (contentType)
@ -26,7 +26,7 @@ import Servant.XML
import qualified Database.Channel as Channel import qualified Database.Channel as Channel
import Database.Book (Book(..)) import Database.Book (Book(..))
import Database import Database
import qualified Server.API.Books as API.Books import qualified API.Books
-- This is my first try on going to versioned apis, things might change -- This is my first try on going to versioned apis, things might change
-- I think my rule of thumb is that you can add new things as you want, but -- I think my rule of thumb is that you can add new things as you want, but

View File

@ -13,7 +13,7 @@
{-# Language DataKinds #-} {-# Language DataKinds #-}
{-# Language DuplicateRecordFields #-} {-# Language DuplicateRecordFields #-}
{-# Language NamedFieldPuns #-} {-# Language NamedFieldPuns #-}
module Server.API.Channels (API, handler, JsonChannel(..)) where module API.Channels (API, handler, JsonChannel(..)) where
import Servant import Servant
import Types import Types

View File

@ -5,7 +5,7 @@
{-# Language TypeOperators #-} {-# Language TypeOperators #-}
{-# Language DuplicateRecordFields #-} {-# Language DuplicateRecordFields #-}
{-# Language TypeApplications #-} {-# Language TypeApplications #-}
module Server.API.Users where module API.Users where
import Servant import Servant
import ClassyPrelude import ClassyPrelude

View File

@ -18,6 +18,9 @@ newtype PlainPassword = PlainPassword Text deriving (Show, ToJSON, FromJSON, ToH
newtype HashedPassword = HashedPassword {unHashed :: ByteString} newtype HashedPassword = HashedPassword {unHashed :: ByteString}
data NoPassword = NoPassword data NoPassword = NoPassword
newtype Email = Email { unEmail :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData)
newtype Username = Username { unUsername :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData)
instance SqlType HashedPassword where instance SqlType HashedPassword where
mkLit = LCustom . LBlob . unHashed mkLit = LCustom . LBlob . unHashed

View File

@ -12,7 +12,7 @@
{-# Language TypeApplications #-} {-# Language TypeApplications #-}
module Server where module Server where
import qualified Server.API as API import qualified API as API
import Server.Auth (authCheck) import Server.Auth (authCheck)
import Servant import Servant
import Types import Types

View File

@ -24,8 +24,21 @@ import Control.Lens (view)
import Data.Generics.Product import Data.Generics.Product
import Servant (err401) import Servant (err401)
import Control.Monad.Logger import Control.Monad.Logger
import Auth (SafeUser(..))
-- generic-lens can convert similar types to this
-- I'm trying out servant-auth-server which uses a jwt style login. IIRC anyone
-- can open the jwt token and view what's inside, you just can't modify it.
--
-- Is it a problem that a human readable username and email are visible?
data SafeUser = SafeUser { email :: Email
, username :: Username
, role :: Role }
deriving (Show, Generic)
instance ToJSON SafeUser where
instance FromJSON SafeUser where
instance ToJWT SafeUser where
instance FromJWT SafeUser where
type instance BasicAuthCfg = BasicAuthData -> IO (AuthResult SafeUser) type instance BasicAuthCfg = BasicAuthData -> IO (AuthResult SafeUser)

View File

@ -15,27 +15,14 @@ cabal-version: >=1.10
library library
exposed-modules: Configuration exposed-modules: Configuration
, Data.Versioned , Data.Versioned
, API
, API.Books
, API.Catalogue
, API.Channels
, API.Users
, Auth
-- other-extensions: -- other-extensions:
build-depends: base >=4.10 && <4.11 build-depends: base >=4.10 && <4.11
, aeson
, classy-prelude , classy-prelude
, dhall , dhall
, foreign-store , foreign-store
, generic-lens , generic-lens
, lens , lens
, mtl , mtl
, servant
, servant-auth
, servant-auth-server
, servant-docs
, servant-lucid
, servant-multipart
, text , text
, transformers , transformers
hs-source-dirs: src hs-source-dirs: src
@ -43,6 +30,4 @@ library
, NoImplicitPrelude , NoImplicitPrelude
, OverloadedStrings , OverloadedStrings
, RecordWildCards , RecordWildCards
, TypeOperators
, DataKinds
default-language: Haskell2010 default-language: Haskell2010

View File

@ -1 +0,0 @@
module API where

View File

@ -1 +0,0 @@
module API.Books where

View File

@ -1 +0,0 @@
module API.Catalogue where

View File

@ -1,27 +0,0 @@
{-# Language DuplicateRecordFields #-}
module API.Channels (API) where
import Auth
import ClassyPrelude
import Data.Aeson
import Servant.API
import Servant.Auth as SA
data JsonChannel = JsonChannel { channel :: Text
, visibility :: Visibility }
deriving (Show, Generic)
data UpdateChannel = UpdateChannel { identifier :: ChannelID
, channel :: Text
, visibility :: Visibility }
deriving (Show, Generic)
instance ToJSON JsonChannel
instance FromJSON JsonChannel
instance ToJSON UpdateChannel
instance FromJSON UpdateChannel
type API = Auth '[SA.BasicAuth, SA.Cookie, SA.JWT] SafeUser :> BaseAPI
type BaseAPI = "channels" :> ReqBody '[JSON] JsonChannel :> Post '[JSON] UpdateChannel
:<|> "channels" :> Capture "channel_id" ChannelID :> ReqBody '[JSON] UpdateChannel :> Put '[JSON] UpdateChannel
:<|> "channels" :> Get '[JSON] [JsonChannel]

View File

@ -1 +0,0 @@
module API.Users where

View File

@ -1,26 +0,0 @@
{-# Language GeneralizedNewtypeDeriving #-}
module Auth where
import ClassyPrelude
import Data.Aeson
import Servant.Auth.Server (ToJWT, FromJWT)
import Servant.API
-- generic-lens can convert similar types to this
-- I'm trying out servant-auth-server which uses a jwt style login. IIRC anyone
-- can open the jwt token and view what's inside, you just can't modify it.
--
-- Is it a problem that a human readable username and email are visible?
newtype Email = Email { unEmail :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData)
newtype Username = Username { unUsername :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData)
data SafeUser = SafeUser { email :: Email
, username :: Username
}
deriving (Show, Generic)
instance ToJSON SafeUser where
instance FromJSON SafeUser where
instance ToJWT SafeUser where
instance FromJWT SafeUser where

View File

@ -21,13 +21,13 @@ let
mkShell = name: pkg: mkShell = name: pkg:
let let
n = "${name}-shell"; n = "${name}-shell";
deps = haskellPackages.ghcWithPackages (pkgs: pkg.buildInputs); deps = haskellPackages.ghcWithPackages (pkgs: pkg.nativeBuildInputs);
in in
{ {
name = "${n}"; name = "${n}";
value = nixpkgs.buildEnv { value = nixpkgs.buildEnv {
name = "${n}"; name = "${n}";
paths = tools ++ [deps]; paths = tools;
buildInputs = tools ++ [deps]; buildInputs = tools ++ [deps];
}; };
}; };