From 5ff629902c4611649780a16936011b7da2211b85 Mon Sep 17 00:00:00 2001
From: Mats Rauhala <mats.rauhala@iki.fi>
Date: Tue, 14 Aug 2018 23:48:54 +0300
Subject: [PATCH]  #12 Attach channels to books

- Closes #12
---
 src/Database/Book.hs    | 12 +++++++-----
 src/Database/Channel.hs | 26 ++++++++++++++++++++++++++
 src/Database/Tag.hs     |  5 +++++
 3 files changed, 38 insertions(+), 5 deletions(-)

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)
+
-- 
2.47.0