From d823a678c6f4635f45435976497f6d06557b3292 Mon Sep 17 00:00:00 2001
From: Mats Rauhala <mats.rauhala@iki.fi>
Date: Tue, 14 Aug 2018 23:05:22 +0300
Subject: [PATCH] src/Configuration.hs Upserting books

---
 src/Database/Tag.hs | 38 ++++++++++++++++++++++++++++++++++++--
 1 file changed, 36 insertions(+), 2 deletions(-)

diff --git a/src/Database/Tag.hs b/src/Database/Tag.hs
index 39c28a1..3830d17 100644
--- a/src/Database/Tag.hs
+++ b/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