Attach tags to books

Closes #8
This commit is contained in:
Mats Rauhala 2018-08-14 23:31:59 +03:00
parent 100c9e3ee3
commit c6f2bc157c
4 changed files with 30 additions and 17 deletions

View File

@ -21,9 +21,9 @@ import ClassyPrelude
import Server.Auth
import Servant.Auth as SA
import Data.Aeson
import API.Channels (JsonChannel(..))
import Database.Book
import Database.Channel
import Database.Tag
import Database
import Control.Lens
import Data.Generics.Product
@ -38,13 +38,15 @@ data JsonBook = JsonBook { identifier :: BookID
, contentType :: Text
, title :: Maybe Text
, description :: Maybe Text
, channels :: [JsonChannel] }
, channels :: [Text]
, tags :: [Text] }
deriving (Generic, Show)
data PostBook = PostBook { contentType :: Text
, title :: Maybe Text
, description :: Maybe Text
, channels :: [JsonChannel] }
, channels :: [Text]
, tags :: [Text] }
deriving (Generic, Show)
@ -105,5 +107,6 @@ listBooksHandler = requireLoggedIn $ \user -> do
runDB (usersBooks (view (field @"username") user) >>= mapM augment)
where
augment Book{identifier=bookId,contentType,title,description} = do
channels <- fmap (\Channel{..} -> JsonChannel{..}) <$> booksChannels bookId
channels <- fmap (view (field @"channel")) <$> booksChannels bookId
tags <- fmap (view (field @"tag")) <$> booksTags bookId
pure JsonBook{identifier=bookId,..}

View File

@ -11,6 +11,7 @@ module Database
, fromRel
, fromRels
, toRel
, transaction
, SeldaT )
where
@ -18,7 +19,7 @@ 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)
import Database.Selda (query, select, transaction)
import Database.Selda.Generic (gen, fromRel, fromRels, toRel)
import ClassyPrelude

View File

@ -18,11 +18,13 @@ module Database.Book
, BookID) where
import ClassyPrelude
import Database.Schema
import Database.Schema (books, users, Username, Book(..), BookID(..), UserID, HashDigest(..))
import Database
import Database.Selda
import Database.Selda.Generic
import Database.Tag (attachTag)
usersBooks :: (MonadSelda m, MonadMask m, MonadIO m) => Username -> m [Book]
usersBooks username = fromRels <$> query q
where
@ -64,7 +66,8 @@ data UpdateBook = UpdateBook { identifier :: BookID
, contentType :: Text
, title :: Maybe Text
, description :: Maybe Text
, owner :: Username }
, owner :: Username
, tags :: [Text]}
bookExists :: (MonadSelda m, MonadMask m, MonadIO m) => BookID -> m Bool
bookExists identifier = not . null <$> query q
@ -88,13 +91,19 @@ bookOwner' identifier username = do
updateBook :: (MonadSelda m, MonadMask m, MonadIO m) => UpdateBook -> m (Maybe UpdateBook)
updateBook book@UpdateBook{..} = do
connectChannels
connectTags
updateBook'
where
connectTags = mapM_ (attachTag owner identifier) tags
connectChannels = return ()
updateBook' = do
mUserId <- query (bookOwner' identifier owner)
forM (listToMaybe mUserId) $ \_userId -> do
update_ (gen books) predicate (\b -> b `with` [ pContentType := literal contentType
, pTitle := literal title
, pDescription := literal description ])
return book
where
_ :*: _ :*: pContentType :*: pTitle :*: pDescription :*: _ = selectors (gen books)
predicate (bookId :*: _) = bookId .== literal identifier

View File

@ -17,9 +17,9 @@ import Database.Selda
import Database.Selda.Generic
upsertTag :: (MonadMask m, MonadIO m, MonadSelda m) => Username -> Text -> m Tag
upsertTag username tag = transaction $ do
upsertTag username tag = do
-- I want this to error out if some data is invariant is wrong and roll back
-- the transaction
-- 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)
@ -46,9 +46,9 @@ booksTags bookId = fromRels <$> query q
return tag
attachTag :: (MonadMask m, MonadIO m, MonadSelda m) => Username -> BookID -> Text -> m ()
attachTag username bookId tag = transaction $ do
attachTag username bookId tag = do
Tag{identifier} <- upsertTag username tag
unlessM (null <$> query (tagQ identifier)) $
whenM (null <$> query (tagQ identifier)) $
void $ insertGen bookTags [BookTag identifier bookId]
where
tagQ tagId = do