src/Configuration.hs Upserting books

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

src/Database/Tag.hs

@@ -4,11 +4,40 @@
 {-# Language DuplicateRecordFields #-}
 module Database.Tag
   ( def
-  , Tag(..)
+  , booksTags
-  , TagID
+  , upsertTag
-  ) where
+  , Tag(..) ) where
 
 import ClassyPrelude
-import Database
 import Database.Schema
+import Database
 import Database.Selda
+
+upsertTag :: (MonadMask m, MonadIO m, MonadSelda m) => Username -> Text -> m Tag
+upsertTag username tag = transaction $ do
+  -- I want this to error out if some data is invariant is wrong and roll back
+  -- the transaction
+  [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