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 b1dbfe9..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