diff --git a/src/Database/Book.hs b/src/Database/Book.hs index 37400a1..b397687 100644 --- a/src/Database/Book.hs +++ b/src/Database/Book.hs @@ -23,7 +23,8 @@ import Database import Database.Selda import Database.Selda.Generic -import Database.Tag (attachTag) +import Database.Tag (attachTag, clearTags) +import Database.Channel (attachChannel, clearChannels) usersBooks :: (MonadSelda m, MonadMask m, MonadIO m) => Username -> m [Book] usersBooks username = fromRels <$> query q @@ -67,7 +68,8 @@ data UpdateBook = UpdateBook { identifier :: BookID , title :: Maybe Text , description :: Maybe Text , owner :: Username - , tags :: [Text]} + , tags :: [Text] + , channels :: [Text] } bookExists :: (MonadSelda m, MonadMask m, MonadIO m) => BookID -> m Bool bookExists identifier = not . null <$> query q @@ -91,12 +93,12 @@ bookOwner' identifier username = do updateBook :: (MonadSelda m, MonadMask m, MonadIO m) => UpdateBook -> m (Maybe UpdateBook) updateBook book@UpdateBook{..} = do - connectChannels - connectTags + clearTags identifier >> connectTags + clearChannels identifier >> connectChannels updateBook' where connectTags = mapM_ (attachTag owner identifier) tags - connectChannels = return () + connectChannels = mapM_ (attachChannel owner identifier) channels updateBook' = do mUserId <- query (bookOwner' identifier owner) forM (listToMaybe mUserId) $ \_userId -> do diff --git a/src/Database/Channel.hs b/src/Database/Channel.hs index 7da845f..9011863 100644 --- a/src/Database/Channel.hs +++ b/src/Database/Channel.hs @@ -1,8 +1,11 @@ {-# Language TypeApplications #-} {-# Language DataKinds #-} +{-# Language NamedFieldPuns #-} module Database.Channel ( userChannels , insertChannel + , attachChannel + , clearChannels , booksChannels , Channel(..) , ChannelID ) @@ -12,6 +15,7 @@ import ClassyPrelude import Database.Schema import Database import Database.Selda +import Database.Selda.Generic userChannels :: (MonadMask m, MonadIO m) => Username -> SeldaT m [Channel] userChannels username = fromRels <$> query q @@ -44,3 +48,25 @@ booksChannels bookId = fromRels <$> query q restrict (channelId .== channelId') restrict (bookId' .== literal bookId) return ch + +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] + where + attachQ channelId = do + (channelId' :*: bookId') <- select (gen bookChannels) + restrict (channelId' .== literal channelId .&& bookId' .== literal bookId) + return channelId' + channelQ = do + userId :*: _ :*: username' :*: _ <- select (gen users) + ch@(_ :*: channel' :*: owner) <- select (gen channels) + restrict (username' .== literal username) + restrict (owner .== userId) + restrict (channel' .== literal channel) + return ch + +clearChannels :: (MonadMask m, MonadIO m, MonadSelda m) => BookID -> m Int +clearChannels bookId = deleteFrom (gen bookChannels) (\(_ :*: bookId') -> bookId' .== literal bookId) diff --git a/src/Database/Tag.hs b/src/Database/Tag.hs index ff6426a..590e65a 100644 --- a/src/Database/Tag.hs +++ b/src/Database/Tag.hs @@ -8,6 +8,7 @@ module Database.Tag , booksTags , attachTag , upsertTag + , clearTags , Tag(..) ) where import ClassyPrelude @@ -55,3 +56,7 @@ attachTag username bookId tag = do (tagId' :*: bookId') <- select (gen bookTags) restrict (tagId' .== literal tagId .&& bookId' .== literal bookId) return tagId' + +clearTags :: (MonadMask m, MonadIO m, MonadSelda m) => BookID -> m Int +clearTags bookId = deleteFrom (gen bookTags) (\(_ :*: bookId') -> bookId' .== literal bookId) +