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

Upgrade

Browse Source
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/
config/config.dhall
/ctags
/TAGS
/result*
/backend/config

4
backend/backend.cabal
View File

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

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

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

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

@ -16,17 +16,17 @@
{-# Language ScopedTypeVariables #-}
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 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
-- 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 #-}
module API.Channels (API, handler, JsonChannel(..)) where
import Servant
import Types
import ClassyPrelude
import Server.Auth
import Servant.Auth as SA
import Control.Lens
import Control.Monad.Catch (throwM, MonadThrow)
import Control.Monad.Logger
import Data.Aeson
import Data.Generics.Product
import Database
import Database.Channel
import Data.Aeson
import Control.Lens
import Data.Generics.Product
import Servant
import Servant.Auth as SA
import Server.Auth
import Types
data JsonChannel = JsonChannel { channel :: Text
, visibility :: Visibility }

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

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

16
backend/src/Database.hs
View File

@ -15,15 +15,17 @@ module Database
, SeldaT )
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 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 q = do

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

@ -18,18 +18,17 @@ module Database.Book
, BookID) where
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.Channel (booksChannels, attachChannel, clearChannels)
import Database.Schema (books, users, Username, Book(..), BookID(..), UserID, HashDigest(..))
import Database.Selda
import Database.Selda.Generic
import Control.Lens (view)
import Data.Generics.Product
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
where
q = do
@ -41,7 +40,7 @@ usersBooks username = fromRels <$> query q
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
where
q = do
@ -56,7 +55,7 @@ data InsertBook = InsertBook { contentType :: Text
, owner :: Username }
-- 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
mUserId <- query $ do
userId :*: _ :*: username' :*: _ <- select (gen users)
@ -75,7 +74,7 @@ data UpdateBook = UpdateBook { identifier :: BookID
, channels :: [Text] }
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
where
q = do
@ -83,7 +82,7 @@ bookExists identifier = not . null <$> query q
restrict (bookId .== literal identifier)
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)
bookOwner' :: BookID -> Username -> Query s (Col s UserID :*: Col s BookID)
@ -95,7 +94,7 @@ bookOwner' identifier username = do
restrict (bookId .== literal identifier)
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
clearTags identifier >> connectTags
clearChannels identifier >> connectChannels
@ -114,7 +113,7 @@ updateBook UpdateBook{..} = do
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
mBook <- getBook bookId username
forM mBook $ \Book{..} -> do
@ -122,7 +121,7 @@ getUpdateBook bookId username = do
tags <- map (view (field @"tag")) <$> booksTags bookId
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
mOwner <- query (bookOwner' identifier owner)
void $ forM (listToMaybe mOwner) $ \_ ->

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

@ -17,14 +17,15 @@ module Database.Channel
where
import ClassyPrelude
import Database.Schema
import Control.Monad.Catch (MonadMask)
import Database
import Database.Schema
import Database.Selda
import Database.Selda.Generic
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
where
q = do
@ -32,10 +33,10 @@ getChannel identifier = listToMaybe . fromRels <$> query q
restrict (channelId .== literal identifier)
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
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
where
q = do
@ -56,7 +57,7 @@ userChannels username = fromRels <$> query q
restrict (username' .== literal username)
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
void $ update (gen channels) predicate (\channel -> channel `with` [pVis := literal visibility])
getChannel channelId
@ -81,7 +82,7 @@ insertChannel username channel visibility = runMaybeT $ do
restrict (user .== literal username)
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
where
q = do
@ -94,7 +95,7 @@ channelBooks username identifier = fromRels <$> query q
restrict (bookId .== bookId')
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
where
q = do
@ -104,7 +105,7 @@ booksChannels bookId = fromRels <$> query q
restrict (bookId' .== literal bookId)
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
mCh <- fromRels <$> query channelQ
forM_ mCh $ \Channel{identifier} ->
@ -123,5 +124,5 @@ attachChannel username bookId channel = do
restrict (channel' .== literal channel)
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)

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

@ -12,13 +12,14 @@ module Database.Tag
, Tag(..) ) where
import ClassyPrelude
import Database.Schema
import Control.Monad.Catch (MonadCatch)
import Control.Monad.Trans.Maybe
import Database
import Database.Schema
import Database.Selda
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
userId <- MaybeT (listToMaybe <$> query userQ)
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)
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
where
q = do
@ -44,7 +45,7 @@ booksTags bookId = fromRels <$> query q
restrict (bookId' .== literal bookId)
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
maybeT <- upsertTag username tag
forM_ maybeT $ \Tag{identifier} -> do
@ -56,6 +57,6 @@ attachTag username bookId tag = do
restrict (tagId' .== literal tagId .&& bookId' .== literal bookId)
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)

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

@ -5,20 +5,21 @@
module Database.User where
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.Schema
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
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) =
getUser' username >>= maybe insert' (const (return $ Left UserExistsError))
where

15
backend/src/Datastore.hs
View File

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

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

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

1
backend/src/Main.hs
View File

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

9
backend/src/Server.hs
View File

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

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

@ -14,16 +14,17 @@ module Server.Auth
where
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.Generics.Product
import Database
import Database.Schema
import Database.User
import Database
import Types
import Control.Lens (view)
import Data.Generics.Product
import Servant (err401)
import Control.Monad.Logger
import Servant.Auth.Server as SAS
import Types
-- generic-lens can convert similar types to this
-- 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
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 _ u = $logError (pack (show u)) >> throwM err401

2
common/common.cabal
View File

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

3
default.nix
View File

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

4
nixpkgs-version.json
View File

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

3
project.nix
View File

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