From 8b04f3760e4c535b902f098978971793c2ae54fc Mon Sep 17 00:00:00 2001 From: MasseR Date: Wed, 15 Aug 2018 22:10:15 +0300 Subject: [PATCH] Complete functions (#15) --- src/API/Books.hs | 4 ++-- src/Database/Book.hs | 23 ++++++++++++++++++----- src/Database/Channel.hs | 10 +++++----- src/Database/Tag.hs | 21 ++++++++++----------- 4 files changed, 35 insertions(+), 23 deletions(-) diff --git a/src/API/Books.hs b/src/API/Books.hs index 1448b08..3cb0369 100644 --- a/src/API/Books.hs +++ b/src/API/Books.hs @@ -97,9 +97,9 @@ postBookMetaHandler auth PostBook{..} = flip requireLoggedIn auth $ \SafeUser{us putBookMetaHandler :: AuthResult SafeUser -> BookID -> JsonBook -> AppM JsonBook -putBookMetaHandler auth bookId b@JsonBook{..} +putBookMetaHandler auth bookId JsonBook{..} | bookId == identifier = requireBookOwner auth bookId $ \SafeUser{username=owner} -> - maybe (throwM err403) (const (return b)) =<< runDB (updateBook UpdateBook{..}) + maybe (throwM err403) (return . view (super @JsonBook)) =<< runDB (updateBook UpdateBook{..}) | otherwise = throwM err403 listBooksHandler :: AuthResult SafeUser -> AppM [JsonBook] diff --git a/src/Database/Book.hs b/src/Database/Book.hs index b397687..eb78b9d 100644 --- a/src/Database/Book.hs +++ b/src/Database/Book.hs @@ -23,8 +23,11 @@ import Database import Database.Selda import Database.Selda.Generic -import Database.Tag (attachTag, clearTags) -import Database.Channel (attachChannel, clearChannels) +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 username = fromRels <$> query q @@ -70,6 +73,7 @@ data UpdateBook = UpdateBook { identifier :: BookID , owner :: Username , tags :: [Text] , channels :: [Text] } + deriving (Show, Generic) bookExists :: (MonadSelda m, MonadMask m, MonadIO m) => BookID -> m Bool bookExists identifier = not . null <$> query q @@ -92,23 +96,32 @@ bookOwner' identifier username = do return (userId :*: bookId) updateBook :: (MonadSelda m, MonadMask m, MonadIO m) => UpdateBook -> m (Maybe UpdateBook) -updateBook book@UpdateBook{..} = do +updateBook UpdateBook{..} = do clearTags identifier >> connectTags clearChannels identifier >> connectChannels updateBook' + getUpdateBook identifier owner where connectTags = mapM_ (attachTag owner identifier) tags connectChannels = mapM_ (attachChannel owner identifier) channels updateBook' = do mUserId <- query (bookOwner' identifier owner) - forM (listToMaybe mUserId) $ \_userId -> do + forM_ (listToMaybe mUserId) $ \_userId -> do update_ (gen books) predicate (\b -> b `with` [ pContentType := literal contentType , pTitle := literal title , pDescription := literal description ]) - return book _ :*: _ :*: pContentType :*: pTitle :*: pDescription :*: _ = selectors (gen books) predicate (bookId :*: _) = bookId .== literal identifier + +getUpdateBook :: (MonadMask m, MonadIO m, MonadSelda m) => BookID -> Username -> m (Maybe UpdateBook) +getUpdateBook bookId username = do + mBook <- getBook bookId username + forM mBook $ \Book{..} -> do + channels <- map (view (field @"channel")) <$> booksChannels bookId + tags <- map (view (field @"tag")) <$> booksTags bookId + return UpdateBook{owner=username,..} + setContent :: (MonadSelda m, MonadMask m, MonadIO m) => BookID -> Username -> HashDigest -> m () setContent identifier owner digest = do mOwner <- query (bookOwner' identifier owner) diff --git a/src/Database/Channel.hs b/src/Database/Channel.hs index 9011863..4e4d33a 100644 --- a/src/Database/Channel.hs +++ b/src/Database/Channel.hs @@ -39,7 +39,7 @@ insertChannel username channel = do restrict (user .== literal username) return userId -booksChannels :: (MonadMask m, MonadIO m) => BookID -> SeldaT m [Channel] +booksChannels :: (MonadSelda m, MonadMask m, MonadIO m) => BookID -> m [Channel] booksChannels bookId = fromRels <$> query q where q = do @@ -51,10 +51,10 @@ booksChannels bookId = fromRels <$> query q attachChannel :: (MonadMask m, MonadIO m, MonadSelda m) => Username -> BookID -> Text -> m () attachChannel username bookId channel = do - -- XXX: test what happens if channel doesn't exist - [Channel{identifier}] <- fromRels <$> query channelQ - whenM (null <$> query (attachQ identifier)) $ - void $ insertGen bookChannels [BookChannel identifier bookId] + mCh <- fromRels <$> query channelQ + forM_ mCh $ \Channel{identifier} -> + whenM (null <$> query (attachQ identifier)) $ + void $ insertGen bookChannels [BookChannel identifier bookId] where attachQ channelId = do (channelId' :*: bookId') <- select (gen bookChannels) diff --git a/src/Database/Tag.hs b/src/Database/Tag.hs index 590e65a..482c794 100644 --- a/src/Database/Tag.hs +++ b/src/Database/Tag.hs @@ -16,15 +16,13 @@ import Database.Schema import Database import Database.Selda import Database.Selda.Generic +import Control.Monad.Trans.Maybe -upsertTag :: (MonadMask m, MonadIO m, MonadSelda m) => Username -> Text -> m Tag -upsertTag username tag = do - -- I want this to error out if some data is invariant is wrong and roll back - -- the transaction. Also as a side note, run this in a transaction plz - [userId] <- query userQ - void $ upsert (gen tags) (predicate userId) id [toRel (Tag def tag userId)] - [t] <- fromRels <$> query (tagQ userId) - return t +upsertTag :: (MonadMask 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)] + MaybeT (listToMaybe . fromRels <$> query (tagQ userId)) where predicate userId (_ :*: tag' :*: owner) = tag' .== literal tag .&& owner .== literal userId tagQ userId = do @@ -48,9 +46,10 @@ booksTags bookId = fromRels <$> query q attachTag :: (MonadMask m, MonadIO m, MonadSelda m) => Username -> BookID -> Text -> m () attachTag username bookId tag = do - Tag{identifier} <- upsertTag username tag - whenM (null <$> query (tagQ identifier)) $ - void $ insertGen bookTags [BookTag identifier bookId] + maybeT <- upsertTag username tag + forM_ maybeT $ \Tag{identifier} -> do + whenM (null <$> query (tagQ identifier)) $ + void $ insertGen bookTags [BookTag identifier bookId] where tagQ tagId = do (tagId' :*: bookId') <- select (gen bookTags)