MasseR
/
ebook-manager
1
0
Fork 0
Code Issues 9 Pull Requests Releases Wiki Activity

Upgrade

This commit is contained in:
Mats Rauhala 2018-10-17 23:51:30 +03:00
parent eb770b91af
commit 8733c4d1d1
20 changed files with 133 additions and 111 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.gitignore vendored
View File

@ -1,2 +1,6 @@
dist/ dist/
config/config.dhall config/config.dhall
/ctags
/TAGS
/result*
/backend/config

4
backend/backend.cabal
View File

@ -36,7 +36,9 @@ executable backend
, Types , Types
, View , View
-- other-extensions: -- other-extensions:
build-depends: base >=4.10 && <4.11 build-depends: base >=4.10
, exceptions
, monad-control
, common , common
, aeson , aeson
, asn1-data , asn1-data

31
backend/src/API/Books.hs
View File

@ -15,24 +15,25 @@
{-# Language NamedFieldPuns #-} {-# Language NamedFieldPuns #-}
module API.Books where module API.Books where
import Servant hiding (contentType) import ClassyPrelude
import Types import Control.Lens
import ClassyPrelude import Control.Monad.Catch (throwM, MonadThrow)
import Server.Auth import Data.Aeson
import Servant.Auth as SA import Data.Generics.Product
import Data.Aeson import Database
import Database.Book import Database.Book
import Database.Channel import Database.Channel
import Database.Tag import Database.Tag
import Database import Servant hiding (contentType)
import Control.Lens import Servant.Auth as SA
import Data.Generics.Product import Server.Auth
import Types
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import qualified Datastore as DS import qualified Datastore as DS
import Data.ByteArray (convert) import Data.ByteArray (convert)
import Crypto.Hash (digestFromByteString) import Crypto.Hash (digestFromByteString)
data JsonBook = JsonBook { identifier :: BookID data JsonBook = JsonBook { identifier :: BookID
, contentType :: Text , contentType :: Text

20
backend/src/API/Catalogue.hs
View File

@ -16,17 +16,17 @@
{-# Language ScopedTypeVariables #-} {-# Language ScopedTypeVariables #-}
module API.Catalogue (VersionedAPI, handler) where module API.Catalogue (VersionedAPI, handler) where
import Types
import Servant hiding (contentType)
import ClassyPrelude
import GHC.TypeLits
import Server.Auth
import Servant.Auth as SA
import Servant.XML
import qualified Database.Channel as Channel
import Database.Book (Book(..))
import Database
import qualified API.Books import qualified API.Books
import ClassyPrelude
import Database
import Database.Book (Book(..))
import qualified Database.Channel as Channel
import GHC.TypeLits
import Servant hiding (contentType)
import Servant.Auth as SA
import Servant.XML
import Server.Auth
import Types
-- 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

15
backend/src/API/Channels.hs
View File

@ -15,17 +15,18 @@
{-# Language NamedFieldPuns #-} {-# Language NamedFieldPuns #-}
module API.Channels (API, handler, JsonChannel(..)) where module API.Channels (API, handler, JsonChannel(..)) where
import Servant
import Types
import ClassyPrelude import ClassyPrelude
import Server.Auth import Control.Lens
import Servant.Auth as SA import Control.Monad.Catch (throwM, MonadThrow)
import Control.Monad.Logger import Control.Monad.Logger
import Data.Aeson
import Data.Generics.Product
import Database import Database
import Database.Channel import Database.Channel
import Data.Aeson import Servant
import Control.Lens import Servant.Auth as SA
import Data.Generics.Product import Server.Auth
import Types
data JsonChannel = JsonChannel { channel :: Text data JsonChannel = JsonChannel { channel :: Text
, visibility :: Visibility } , visibility :: Visibility }

13
backend/src/API/Users.hs
View File

@ -7,17 +7,18 @@
{-# Language TypeApplications #-} {-# Language TypeApplications #-}
module API.Users where module API.Users where
import Servant
import ClassyPrelude import ClassyPrelude
import Types import Control.Monad.Catch (throwM, MonadThrow)
import Data.Aeson import Data.Aeson
import Web.FormUrlEncoded
import Database (runDB) import Database (runDB)
import Database.User
import Database.Schema import Database.Schema
import Server.Auth import Database.User
import Servant.Auth.Server as SAS import Servant
import Servant.Auth as SA import Servant.Auth as SA
import Servant.Auth.Server as SAS
import Server.Auth
import Types
import Web.FormUrlEncoded
data RegisterForm = RegisterForm { username :: Username data RegisterForm = RegisterForm { username :: Username

16
backend/src/Database.hs
View File

@ -15,15 +15,17 @@ module Database
, SeldaT ) , SeldaT )
where where
import Data.Generics.Product
import Control.Lens (view)
import Data.Pool (Pool, withResource)
import Database.Selda.Backend (SeldaConnection, runSeldaT, SeldaT)
import Database.Selda (query, select, transaction)
import Database.Selda.Generic (gen, fromRel, fromRels, toRel)
import ClassyPrelude import ClassyPrelude
import Control.Lens (view)
import Control.Monad.Catch (MonadMask)
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Generics.Product
import Data.Pool (Pool, withResource)
import Database.Selda (query, select, transaction)
import Database.Selda.Backend (SeldaConnection, runSeldaT, SeldaT)
import Database.Selda.Generic (gen, fromRel, fromRels, toRel)
type DBLike r m = (MonadIO m, MonadReader r m, MonadBaseControl IO m, MonadMask m, HasField' "database" r (Pool SeldaConnection)) type DBLike r m = (MonadBaseControl IO m, MonadIO m, MonadReader r m, HasField "database" r r (Pool SeldaConnection) (Pool SeldaConnection), MonadMask m)
runDB :: DBLike r m => SeldaT m a -> m a runDB :: DBLike r m => SeldaT m a -> m a
runDB q = do runDB q = do

27
backend/src/Database/Book.hs
View File

@ -18,18 +18,17 @@ module Database.Book
, BookID) where , BookID) where
import ClassyPrelude import ClassyPrelude
import Database.Schema (books, users, Username, Book(..), BookID(..), UserID, HashDigest(..)) import Control.Lens (view)
import Control.Monad.Catch (MonadCatch)
import Data.Generics.Product
import Database import Database
import Database.Channel (booksChannels, attachChannel, clearChannels)
import Database.Schema (books, users, Username, Book(..), BookID(..), UserID, HashDigest(..))
import Database.Selda import Database.Selda
import Database.Selda.Generic import Database.Selda.Generic
import Control.Lens (view)
import Data.Generics.Product
import Database.Tag (booksTags, attachTag, clearTags) import Database.Tag (booksTags, attachTag, clearTags)
import Database.Channel (booksChannels, attachChannel, clearChannels)
usersBooks :: (MonadSelda m, MonadMask m, MonadIO m) => Username -> m [Book] usersBooks :: (MonadSelda m, MonadIO m) => Username -> m [Book]
usersBooks username = fromRels <$> query q usersBooks username = fromRels <$> query q
where where
q = do q = do
@ -41,7 +40,7 @@ usersBooks username = fromRels <$> query q
return book return book
getBook :: (MonadSelda m, MonadMask m, MonadIO m) => BookID -> Username -> m (Maybe Book) getBook :: (MonadSelda m, MonadIO m) => BookID -> Username -> m (Maybe Book)
getBook identifier owner = listToMaybe . fromRels <$> query q getBook identifier owner = listToMaybe . fromRels <$> query q
where where
q = do q = do
@ -56,7 +55,7 @@ data InsertBook = InsertBook { contentType :: Text
, owner :: Username } , owner :: Username }
-- Always inserts -- Always inserts
insertBook :: (MonadSelda m, MonadMask m, MonadIO m) => InsertBook -> m (Maybe BookID) insertBook :: (MonadSelda m, MonadIO m) => InsertBook -> m (Maybe BookID)
insertBook InsertBook{..} = do insertBook InsertBook{..} = do
mUserId <- query $ do mUserId <- query $ do
userId :*: _ :*: username' :*: _ <- select (gen users) userId :*: _ :*: username' :*: _ <- select (gen users)
@ -75,7 +74,7 @@ data UpdateBook = UpdateBook { identifier :: BookID
, channels :: [Text] } , channels :: [Text] }
deriving (Show, Generic) deriving (Show, Generic)
bookExists :: (MonadSelda m, MonadMask m, MonadIO m) => BookID -> m Bool bookExists :: (MonadSelda m, MonadIO m) => BookID -> m Bool
bookExists identifier = not . null <$> query q bookExists identifier = not . null <$> query q
where where
q = do q = do
@ -83,7 +82,7 @@ bookExists identifier = not . null <$> query q
restrict (bookId .== literal identifier) restrict (bookId .== literal identifier)
return bookId return bookId
isBookOwner :: (MonadSelda m, MonadIO m, MonadThrow m) => BookID -> Username -> m Bool isBookOwner :: (MonadSelda m, MonadIO m) => BookID -> Username -> m Bool
isBookOwner identifier username = not . null <$> query (bookOwner' identifier username) isBookOwner identifier username = not . null <$> query (bookOwner' identifier username)
bookOwner' :: BookID -> Username -> Query s (Col s UserID :*: Col s BookID) bookOwner' :: BookID -> Username -> Query s (Col s UserID :*: Col s BookID)
@ -95,7 +94,7 @@ bookOwner' identifier username = do
restrict (bookId .== literal identifier) restrict (bookId .== literal identifier)
return (userId :*: bookId) return (userId :*: bookId)
updateBook :: (MonadSelda m, MonadMask m, MonadIO m) => UpdateBook -> m (Maybe UpdateBook) updateBook :: (MonadCatch m, MonadSelda m, MonadIO m) => UpdateBook -> m (Maybe UpdateBook)
updateBook UpdateBook{..} = do updateBook UpdateBook{..} = do
clearTags identifier >> connectTags clearTags identifier >> connectTags
clearChannels identifier >> connectChannels clearChannels identifier >> connectChannels
@ -114,7 +113,7 @@ updateBook UpdateBook{..} = do
predicate (bookId :*: _) = bookId .== literal identifier predicate (bookId :*: _) = bookId .== literal identifier
getUpdateBook :: (MonadMask m, MonadIO m, MonadSelda m) => BookID -> Username -> m (Maybe UpdateBook) getUpdateBook :: (MonadIO m, MonadSelda m) => BookID -> Username -> m (Maybe UpdateBook)
getUpdateBook bookId username = do getUpdateBook bookId username = do
mBook <- getBook bookId username mBook <- getBook bookId username
forM mBook $ \Book{..} -> do forM mBook $ \Book{..} -> do
@ -122,7 +121,7 @@ getUpdateBook bookId username = do
tags <- map (view (field @"tag")) <$> booksTags bookId tags <- map (view (field @"tag")) <$> booksTags bookId
return UpdateBook{owner=username,..} return UpdateBook{owner=username,..}
setContent :: (MonadSelda m, MonadMask m, MonadIO m) => BookID -> Username -> HashDigest -> m () setContent :: (MonadSelda m, MonadIO m) => BookID -> Username -> HashDigest -> m ()
setContent identifier owner digest = do setContent identifier owner digest = do
mOwner <- query (bookOwner' identifier owner) mOwner <- query (bookOwner' identifier owner)
void $ forM (listToMaybe mOwner) $ \_ -> void $ forM (listToMaybe mOwner) $ \_ ->

19
backend/src/Database/Channel.hs
View File

@ -17,14 +17,15 @@ module Database.Channel
where where
import ClassyPrelude import ClassyPrelude
import Database.Schema import Control.Monad.Catch (MonadMask)
import Database import Database
import Database.Schema
import Database.Selda import Database.Selda
import Database.Selda.Generic import Database.Selda.Generic
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
getChannel :: (MonadSelda m, MonadMask m, MonadIO m) => ChannelID -> m (Maybe Channel) getChannel :: (MonadSelda m, MonadIO m) => ChannelID -> m (Maybe Channel)
getChannel identifier = listToMaybe . fromRels <$> query q getChannel identifier = listToMaybe . fromRels <$> query q
where where
q = do q = do
@ -32,10 +33,10 @@ getChannel identifier = listToMaybe . fromRels <$> query q
restrict (channelId .== literal identifier) restrict (channelId .== literal identifier)
return ch return ch
channelExists :: (MonadSelda m, MonadMask m, MonadIO m) => ChannelID -> m Bool channelExists :: (MonadSelda m, MonadIO m) => ChannelID -> m Bool
channelExists identifier = not . null <$> getChannel identifier channelExists identifier = not . null <$> getChannel identifier
isChannelOwner :: (MonadSelda m, MonadIO m, MonadMask m) => ChannelID -> Username -> m Bool isChannelOwner :: (MonadSelda m, MonadIO m) => ChannelID -> Username -> m Bool
isChannelOwner identifier username = not . null <$> query q isChannelOwner identifier username = not . null <$> query q
where where
q = do q = do
@ -56,7 +57,7 @@ userChannels username = fromRels <$> query q
restrict (username' .== literal username) restrict (username' .== literal username)
return channel return channel
updateChannelPrivacy :: (MonadMask m, MonadIO m, MonadSelda m) => ChannelID -> Visibility -> m (Maybe Channel) updateChannelPrivacy :: (MonadIO m, MonadSelda m) => ChannelID -> Visibility -> m (Maybe Channel)
updateChannelPrivacy channelId visibility = do updateChannelPrivacy channelId visibility = do
void $ update (gen channels) predicate (\channel -> channel `with` [pVis := literal visibility]) void $ update (gen channels) predicate (\channel -> channel `with` [pVis := literal visibility])
getChannel channelId getChannel channelId
@ -81,7 +82,7 @@ insertChannel username channel visibility = runMaybeT $ do
restrict (user .== literal username) restrict (user .== literal username)
return userId return userId
channelBooks :: (MonadSelda m, MonadMask m, MonadIO m) => Username -> ChannelID -> m [Book] channelBooks :: (MonadSelda m, MonadIO m) => Username -> ChannelID -> m [Book]
channelBooks username identifier = fromRels <$> query q channelBooks username identifier = fromRels <$> query q
where where
q = do q = do
@ -94,7 +95,7 @@ channelBooks username identifier = fromRels <$> query q
restrict (bookId .== bookId') restrict (bookId .== bookId')
return book return book
booksChannels :: (MonadSelda m, MonadMask m, MonadIO m) => BookID -> m [Channel] booksChannels :: (MonadSelda m, MonadIO m) => BookID -> m [Channel]
booksChannels bookId = fromRels <$> query q booksChannels bookId = fromRels <$> query q
where where
q = do q = do
@ -104,7 +105,7 @@ booksChannels bookId = fromRels <$> query q
restrict (bookId' .== literal bookId) restrict (bookId' .== literal bookId)
return ch return ch
attachChannel :: (MonadMask m, MonadIO m, MonadSelda m) => Username -> BookID -> Text -> m () attachChannel :: (MonadIO m, MonadSelda m) => Username -> BookID -> Text -> m ()
attachChannel username bookId channel = do attachChannel username bookId channel = do
mCh <- fromRels <$> query channelQ mCh <- fromRels <$> query channelQ
forM_ mCh $ \Channel{identifier} -> forM_ mCh $ \Channel{identifier} ->
@ -123,5 +124,5 @@ attachChannel username bookId channel = do
restrict (channel' .== literal channel) restrict (channel' .== literal channel)
return ch return ch
clearChannels :: (MonadMask m, MonadIO m, MonadSelda m) => BookID -> m Int clearChannels :: (MonadIO m, MonadSelda m) => BookID -> m Int
clearChannels bookId = deleteFrom (gen bookChannels) (\(_ :*: bookId') -> bookId' .== literal bookId) clearChannels bookId = deleteFrom (gen bookChannels) (\(_ :*: bookId') -> bookId' .== literal bookId)

13
backend/src/Database/Tag.hs
View File

@ -12,13 +12,14 @@ module Database.Tag
, Tag(..) ) where , Tag(..) ) where
import ClassyPrelude import ClassyPrelude
import Database.Schema import Control.Monad.Catch (MonadCatch)
import Control.Monad.Trans.Maybe
import Database import Database
import Database.Schema
import Database.Selda import Database.Selda
import Database.Selda.Generic import Database.Selda.Generic
import Control.Monad.Trans.Maybe
upsertTag :: (MonadMask m, MonadIO m, MonadSelda m) => Username -> Text -> m (Maybe Tag) upsertTag :: (MonadCatch m, MonadIO m, MonadSelda m) => Username -> Text -> m (Maybe Tag)
upsertTag username tag = runMaybeT $ do upsertTag username tag = runMaybeT $ do
userId <- MaybeT (listToMaybe <$> query userQ) userId <- MaybeT (listToMaybe <$> query userQ)
void $ lift $ upsert (gen tags) (predicate userId) id [toRel (Tag def tag userId)] void $ lift $ upsert (gen tags) (predicate userId) id [toRel (Tag def tag userId)]
@ -34,7 +35,7 @@ upsertTag username tag = runMaybeT $ do
restrict (username' .== literal username) restrict (username' .== literal username)
return userId return userId
booksTags :: (MonadMask m, MonadIO m, MonadSelda m) => BookID -> m [Tag] booksTags :: (MonadIO m, MonadSelda m) => BookID -> m [Tag]
booksTags bookId = fromRels <$> query q booksTags bookId = fromRels <$> query q
where where
q = do q = do
@ -44,7 +45,7 @@ booksTags bookId = fromRels <$> query q
restrict (bookId' .== literal bookId) restrict (bookId' .== literal bookId)
return tag return tag
attachTag :: (MonadMask m, MonadIO m, MonadSelda m) => Username -> BookID -> Text -> m () attachTag :: (MonadCatch m, MonadIO m, MonadSelda m) => Username -> BookID -> Text -> m ()
attachTag username bookId tag = do attachTag username bookId tag = do
maybeT <- upsertTag username tag maybeT <- upsertTag username tag
forM_ maybeT $ \Tag{identifier} -> do forM_ maybeT $ \Tag{identifier} -> do
@ -56,6 +57,6 @@ attachTag username bookId tag = do
restrict (tagId' .== literal tagId .&& bookId' .== literal bookId) restrict (tagId' .== literal tagId .&& bookId' .== literal bookId)
return tagId' return tagId'
clearTags :: (MonadMask m, MonadIO m, MonadSelda m) => BookID -> m Int clearTags :: (MonadIO m, MonadSelda m) => BookID -> m Int
clearTags bookId = deleteFrom (gen bookTags) (\(_ :*: bookId') -> bookId' .== literal bookId) clearTags bookId = deleteFrom (gen bookTags) (\(_ :*: bookId') -> bookId' .== literal bookId)

15
backend/src/Database/User.hs
View File

@ -5,20 +5,21 @@
module Database.User where module Database.User where
import ClassyPrelude import ClassyPrelude
import Control.Lens (view, over, _Just)
import Control.Monad (mfilter)
import Control.Monad.Catch (MonadMask)
import Control.Monad.Logger
import Crypto.KDF.BCrypt
import Crypto.Random.Types (MonadRandom)
import Data.Generics.Product
import Database import Database
import Database.Schema import Database.Schema
import Database.Selda import Database.Selda
import Control.Lens (view, over, _Just)
import Data.Generics.Product
import Crypto.KDF.BCrypt
import Crypto.Random.Types (MonadRandom)
import Control.Monad.Logger
import Control.Monad (mfilter)
data UserExistsError = UserExistsError data UserExistsError = UserExistsError
insertUser :: (MonadLogger m, MonadIO m, MonadMask m, MonadRandom m) => Username -> Email -> PlainPassword -> SeldaT m (Either UserExistsError (User NoPassword)) insertUser :: (MonadMask m, MonadLogger m, MonadIO m, MonadRandom m) => Username -> Email -> PlainPassword -> SeldaT m (Either UserExistsError (User NoPassword))
insertUser username email (PlainPassword password) = insertUser username email (PlainPassword password) =
getUser' username >>= maybe insert' (const (return $ Left UserExistsError)) getUser' username >>= maybe insert' (const (return $ Left UserExistsError))
where where

15
backend/src/Datastore.hs
View File

@ -5,6 +5,7 @@
{-# Language FlexibleContexts #-} {-# Language FlexibleContexts #-}
{-# Language TypeSynonymInstances #-} {-# Language TypeSynonymInstances #-}
{-# Language FlexibleInstances #-} {-# Language FlexibleInstances #-}
{-# Language ScopedTypeVariables #-}
module Datastore where module Datastore where
import ClassyPrelude import ClassyPrelude
@ -28,22 +29,22 @@ instance MonadDS AppM where
get = getLocal get = getLocal
putLocal :: ( MonadIO m putLocal :: ( MonadIO m
, HasField' "config" r config , HasField "config" r r config config
, HasField' "store" config store , HasField "store" config config store store
, HasField' "path" store Text , HasField "path" store store Text Text
, MonadReader r m) , MonadReader r m)
=> ByteString -> m (Digest SHA256) => ByteString -> m (Digest SHA256)
putLocal bs = do putLocal bs = do
store <- unpack <$> view (field @"config" . field @"store" . field @"path") store :: FilePath <- unpack <$> view (field @"config" . field @"store" . field @"path")
liftIO $ createDirectoryIfMissing True store liftIO $ createDirectoryIfMissing True store
let key = hashWith SHA256 bs let key = hashWith SHA256 bs
writeFile (store </> show key) bs writeFile (store </> show key) bs
return key return key
getLocal :: ( MonadIO m getLocal :: ( MonadIO m
, HasField' "config" r config , HasField "config" r r config config
, HasField' "store" config store , HasField "store" config config store store
, HasField' "path" store Text , HasField "path" store store Text Text
, MonadReader r m) , MonadReader r m)
=> Digest SHA256 -> m (Maybe ByteString) => Digest SHA256 -> m (Maybe ByteString)
getLocal key = do getLocal key = do

15
backend/src/Devel/Main.hs
View File

@ -3,19 +3,18 @@
{-# Language FlexibleContexts #-} {-# Language FlexibleContexts #-}
module Devel.Main where module Devel.Main where
import Prelude
import Control.Monad.Trans.Reader (runReaderT)
import Main (withApp, defaultMain)
import Control.Concurrent import Control.Concurrent
import Control.Monad (void) import Control.Monad (void)
import Control.Monad.Trans.Reader (runReaderT)
import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Foreign.Store (Store(..), lookupStore, readStore, storeAction, withStore) import Database
import GHC.Word (Word32)
import Dhall (input, auto)
import Database.Schema import Database.Schema
import Database.Selda (tryCreateTable) import Database.Selda (tryCreateTable)
import Database import Dhall (input, auto)
import Foreign.Store (Store(..), lookupStore, readStore, storeAction, withStore)
import GHC.Word (Word32)
import Main (withApp, defaultMain)
import Prelude
update :: IO () update :: IO ()
update = do update = do

1
backend/src/Main.hs
View File

@ -25,6 +25,7 @@ withApp :: Config -> (App -> IO ()) -> IO ()
withApp config f = do withApp config f = do
let pgHost = view (field @"database" . field @"host") config let pgHost = view (field @"database" . field @"host") config
pgPort = 5432 pgPort = 5432
pgSchema = Nothing
pgDatabase = view (field @"database" . field @"database") config pgDatabase = view (field @"database" . field @"database") config
pgUsername = Just (view (field @"database" . field @"username") config) pgUsername = Just (view (field @"database" . field @"username") config)
pgPassword = Just (view (field @"database" . field @"password") config) pgPassword = Just (view (field @"database" . field @"password") config)

9
backend/src/Server.hs
View File

@ -10,6 +10,7 @@
{-# Language DeriveGeneric #-} {-# Language DeriveGeneric #-}
{-# Language FlexibleInstances #-} {-# Language FlexibleInstances #-}
{-# Language TypeApplications #-} {-# Language TypeApplications #-}
{-# Language ScopedTypeVariables #-}
module Server where module Server where
import qualified API as API import qualified API as API
@ -22,19 +23,21 @@ import Control.Monad.Except
import Servant.Auth.Server as SAS import Servant.Auth.Server as SAS
import Control.Lens import Control.Lens
import Data.Generics.Product import Data.Generics.Product
import Server.Auth (SafeUser)
type API = API.API :<|> "static" :> Raw type API = API.API :<|> "static" :> Raw
type Ctx = '[BasicAuthData -> IO (AuthResult SafeUser), CookieSettings, JWTSettings]
server :: App -> Application server :: App -> Application
server app = serveWithContext api cfg (enter server' API.handler :<|> serveDirectoryFileServer "static") server app = serveWithContext api cfg (hoistServerWithContext (Proxy @ API.API) (Proxy @ Ctx) server' API.handler :<|> serveDirectoryFileServer "static")
where where
myKey = view (field @"jwk") app myKey = view (field @"jwk") app
jwtCfg = defaultJWTSettings myKey jwtCfg = defaultJWTSettings myKey
authCfg = authCheck app authCfg = authCheck app
cookieSettings = SAS.defaultCookieSettings{cookieIsSecure=SAS.NotSecure} cookieSettings = SAS.defaultCookieSettings{cookieIsSecure=SAS.NotSecure}
cfg = jwtCfg :. cookieSettings :. authCfg :. EmptyContext cfg = jwtCfg :. cookieSettings :. authCfg :. EmptyContext
server' :: AppM :~> Servant.Handler server' :: AppM a -> Servant.Handler a
server' = NT (Handler . ExceptT . try . (`runReaderT` app) . (runFileLoggingT "logs/server.log")) server' = Handler . ExceptT . try . (`runReaderT` app) . (runFileLoggingT "logs/server.log")
api :: Proxy API api :: Proxy API
api = Proxy api = Proxy

15
backend/src/Server/Auth.hs
View File

@ -14,16 +14,17 @@ module Server.Auth
where where
import ClassyPrelude import ClassyPrelude
import Servant.Auth.Server as SAS import Control.Lens (view)
import Control.Monad.Logger
import Control.Monad.Catch (throwM, MonadThrow)
import Data.Aeson import Data.Aeson
import Data.Generics.Product
import Database
import Database.Schema import Database.Schema
import Database.User import Database.User
import Database
import Types
import Control.Lens (view)
import Data.Generics.Product
import Servant (err401) import Servant (err401)
import Control.Monad.Logger import Servant.Auth.Server as SAS
import Types
-- generic-lens can convert similar types to this -- generic-lens can convert similar types to this
-- I'm trying out servant-auth-server which uses a jwt style login. IIRC anyone -- I'm trying out servant-auth-server which uses a jwt style login. IIRC anyone
@ -53,6 +54,6 @@ authCheck app (BasicAuthData username password) = flip runReaderT app $
password' = PlainPassword $ decodeUtf8 password password' = PlainPassword $ decodeUtf8 password
authenticated = SAS.Authenticated . view (super @SafeUser) authenticated = SAS.Authenticated . view (super @SafeUser)
requireLoggedIn :: (MonadLogger m, MonadThrow m, Monad m) => (SafeUser -> m a) -> AuthResult SafeUser -> m a requireLoggedIn :: (MonadThrow m, MonadLogger m, Monad m) => (SafeUser -> m a) -> AuthResult SafeUser -> m a
requireLoggedIn f (Authenticated user) = f user requireLoggedIn f (Authenticated user) = f user
requireLoggedIn _ u = $logError (pack (show u)) >> throwM err401 requireLoggedIn _ u = $logError (pack (show u)) >> throwM err401

2
common/common.cabal
View File

@ -16,7 +16,7 @@ library
exposed-modules: Configuration exposed-modules: Configuration
, Data.Versioned , Data.Versioned
-- other-extensions: -- other-extensions:
build-depends: base >=4.10 && <4.11 build-depends: base >=4.10
, classy-prelude , classy-prelude
, dhall , dhall
, foreign-store , foreign-store

3
default.nix
View File

@ -5,6 +5,9 @@
common = ./common; common = ./common;
backend = ./backend; backend = ./backend;
}; };
overrides = self: super: {
generic-lens = nixpkgs.haskell.lib.dontCheck super.generic-lens;
};
tools = with haskellPackages; [ tools = with haskellPackages; [
ghcid ghcid
hasktags hasktags

4
nixpkgs-version.json
View File

@ -1,7 +1,7 @@
{ {
"url": "https://github.com/nixos/nixpkgs.git", "url": "https://github.com/nixos/nixpkgs.git",
"rev": "83a5765b1fea2472ec9cf9d179d3efd18b45c77e", "rev": "e0d250e5cf6d179e1ccc775472d89718f61fcfd1",
"date": "2018-01-08T11:52:28+01:00", "date": "2018-01-08T11:52:28+01:00",
"sha256": "01rb61dkbzjbwnb3p8lgs03a94f4584199dlr0cwdmqzaxnp506h", "sha256": "1iqpjz4czcpghbv924a5h4jvfmj6c8q6sl3b1z7blz3mi740aivs",
"fetchSubmodules": true "fetchSubmodules": true
} }

3
project.nix
View File

@ -15,13 +15,14 @@ let
overrides' = nixpkgs.lib.foldr nixpkgs.lib.composeExtensions (_: _: {}) [ overrides' = nixpkgs.lib.foldr nixpkgs.lib.composeExtensions (_: _: {}) [
(self: super: mapAttrs (name: path: self.callCabal2nix name path {}) packages) (self: super: mapAttrs (name: path: self.callCabal2nix name path {}) packages)
overrides
]; ];
haskellPackages = nixpkgs.haskellPackages.override { overrides = overrides'; }; haskellPackages = nixpkgs.haskellPackages.override { overrides = overrides'; };
packages' = mapAttrs (name: _: haskellPackages."${name}") packages; packages' = mapAttrs (name: _: haskellPackages."${name}") packages;
mkShell = name: pkg: mkShell = name: pkg:
let let
n = "${name}-shell"; n = "${name}-shell";
deps = haskellPackages.ghcWithPackages (pkgs: pkg.nativeBuildInputs); deps = haskellPackages.ghcWithHoogle (pkgs: pkg.buildInputs ++ pkg.propagatedBuildInputs);
in in
{ {
name = "${n}"; name = "${n}";