Compare commits

...

2 Commits

Author SHA1 Message Date
c6f2bc157c Attach tags to books
Closes #8
2018-08-14 23:31:59 +03:00
100c9e3ee3 Attaching tags 2018-08-14 23:20:18 +03:00
4 changed files with 42 additions and 15 deletions

View File

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

View File

@ -11,6 +11,7 @@ module Database
, fromRel , fromRel
, fromRels , fromRels
, toRel , toRel
, transaction
, SeldaT ) , SeldaT )
where where
@ -18,7 +19,7 @@ import Data.Generics.Product
import Control.Lens (view) import Control.Lens (view)
import Data.Pool (Pool, withResource) import Data.Pool (Pool, withResource)
import Database.Selda.Backend (SeldaConnection, runSeldaT, SeldaT) 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 Database.Selda.Generic (gen, fromRel, fromRels, toRel)
import ClassyPrelude import ClassyPrelude

View File

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

View File

@ -2,9 +2,11 @@
{-# Language TypeOperators #-} {-# Language TypeOperators #-}
{-# Language DataKinds #-} {-# Language DataKinds #-}
{-# Language DuplicateRecordFields #-} {-# Language DuplicateRecordFields #-}
{-# Language NamedFieldPuns #-}
module Database.Tag module Database.Tag
( def ( def
, booksTags , booksTags
, attachTag
, upsertTag , upsertTag
, Tag(..) ) where , Tag(..) ) where
@ -12,11 +14,12 @@ import ClassyPrelude
import Database.Schema import Database.Schema
import Database import Database
import Database.Selda import Database.Selda
import Database.Selda.Generic
upsertTag :: (MonadMask m, MonadIO m, MonadSelda m) => Username -> Text -> m Tag 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 -- 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 [userId] <- query userQ
void $ upsert (gen tags) (predicate userId) id [toRel (Tag def tag userId)] void $ upsert (gen tags) (predicate userId) id [toRel (Tag def tag userId)]
[t] <- fromRels <$> query (tagQ userId) [t] <- fromRels <$> query (tagQ userId)
@ -41,3 +44,14 @@ booksTags bookId = fromRels <$> query q
restrict (tagId .== tagId') restrict (tagId .== tagId')
restrict (bookId' .== literal bookId) restrict (bookId' .== literal bookId)
return tag 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'