diff --git a/ebook-manager.cabal b/ebook-manager.cabal index b574f6a..2d699d6 100644 --- a/ebook-manager.cabal +++ b/ebook-manager.cabal @@ -28,6 +28,7 @@ executable ebook-manager , Database , Database.Book , Database.Channel + , Database.Tag , Database.Schema , Database.User , Datastore diff --git a/src/API/Books.hs b/src/API/Books.hs index acbca89..1448b08 100644 --- a/src/API/Books.hs +++ b/src/API/Books.hs @@ -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,..} diff --git a/src/Database.hs b/src/Database.hs index cb0d686..ebeb307 100644 --- a/src/Database.hs +++ b/src/Database.hs @@ -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 diff --git a/src/Database/Book.hs b/src/Database/Book.hs index 876290b..37400a1 100644 --- a/src/Database/Book.hs +++ b/src/Database/Book.hs @@ -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 - 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 + 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 _ :*: _ :*: pContentType :*: pTitle :*: pDescription :*: _ = selectors (gen books) predicate (bookId :*: _) = bookId .== literal identifier diff --git a/src/Database/Channel.hs b/src/Database/Channel.hs index 3b85fe2..7da845f 100644 --- a/src/Database/Channel.hs +++ b/src/Database/Channel.hs @@ -36,11 +36,11 @@ insertChannel username channel = do return userId booksChannels :: (MonadMask m, MonadIO m) => BookID -> SeldaT m [Channel] -booksChannels contentHash = fromRels <$> query q +booksChannels bookId = fromRels <$> query q where q = do - channelId :*: contentHash' <- select (gen bookChannels) + channelId :*: bookId' <- select (gen bookChannels) ch@(channelId' :*: _) <- select (gen channels) restrict (channelId .== channelId') - restrict (contentHash' .== literal contentHash) + restrict (bookId' .== literal bookId) return ch diff --git a/src/Database/Tag.hs b/src/Database/Tag.hs new file mode 100644 index 0000000..ff6426a --- /dev/null +++ b/src/Database/Tag.hs @@ -0,0 +1,57 @@ +{-# Language TypeApplications #-} +{-# Language TypeOperators #-} +{-# Language DataKinds #-} +{-# Language DuplicateRecordFields #-} +{-# Language NamedFieldPuns #-} +module Database.Tag + ( def + , booksTags + , attachTag + , upsertTag + , Tag(..) ) where + +import ClassyPrelude +import Database.Schema +import Database +import Database.Selda +import Database.Selda.Generic + +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 + where + predicate userId (_ :*: tag' :*: owner) = tag' .== literal tag .&& owner .== literal userId + tagQ userId = do + t@(_ :*: tag' :*: owner) <- select (gen tags) + restrict (tag' .== literal tag .&& owner .== literal userId) + return t + userQ = do + userId :*: _ :*: username' :*: _ <- select (gen users) + restrict (username' .== literal username) + return userId + +booksTags :: (MonadMask m, MonadIO m, MonadSelda m) => BookID -> m [Tag] +booksTags bookId = fromRels <$> query q + where + q = do + tagId :*: bookId' <- select (gen bookTags) + tag@(tagId' :*: _) <- select (gen tags) + restrict (tagId .== tagId') + restrict (bookId' .== literal bookId) + return tag + +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] + where + tagQ tagId = do + (tagId' :*: bookId') <- select (gen bookTags) + restrict (tagId' .== literal tagId .&& bookId' .== literal bookId) + return tagId'