Complete functions for tags

src/Database/Tag.hs

@@ -16,15 +16,13 @@ import Database.Schema
 import Database
 import Database.Selda
 import Database.Selda.Generic
+import Control.Monad.Trans.Maybe
 
-upsertTag :: (MonadMask m, MonadIO m, MonadSelda m) => Username -> Text -> m Tag
+upsertTag :: (MonadMask m, MonadIO m, MonadSelda m) => Username -> Text -> m (Maybe Tag)
-upsertTag username tag = do
+upsertTag username tag = runMaybeT $ do
-  -- I want this to error out if some data is invariant is wrong and roll back
+  userId <- MaybeT (listToMaybe <$> query userQ)
-  -- the transaction. Also as a side note, run this in a transaction plz
+  void $ lift $ upsert (gen tags) (predicate userId) id [toRel (Tag def tag userId)]
-  [userId] <- query userQ
+  MaybeT (listToMaybe . fromRels <$> query (tagQ userId))
-  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
@@ -48,9 +46,10 @@ booksTags bookId = fromRels <$> query q
 
 attachTag :: (MonadMask m, MonadIO m, MonadSelda m) => Username -> BookID -> Text -> m ()
 attachTag username bookId tag = do
-  Tag{identifier} <- upsertTag username tag
+  maybeT <- upsertTag username tag
-  whenM (null <$> query (tagQ identifier)) $
+  forM_ maybeT $ \Tag{identifier} -> do
-    void $ insertGen bookTags [BookTag identifier bookId]
+    whenM (null <$> query (tagQ identifier)) $
+      void $ insertGen bookTags [BookTag identifier bookId]
   where
     tagQ tagId = do
       (tagId' :*: bookId') <- select (gen bookTags)