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
Download Patch File Download Diff File Expand all files Collapse all files

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