src/Configuration.hs Upserting books

src/Database/Tag.hs

@@ -2,8 +2,42 @@
 {-# Language TypeOperators #-}
 {-# Language DataKinds #-}
 {-# Language DuplicateRecordFields #-}
-module Database.Tag () where
+module Database.Tag
+  ( def
+  , booksTags
+  , upsertTag
+  , Tag(..) ) where
 
--- Nothing here yet
+import ClassyPrelude
+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