MasseR/ebook-manager
1
0
Fork 0
Code Issues 9 Pull Requests Releases Wiki Activity

Attaching tags

Browse Source
This commit is contained in:
Mats Rauhala 2018-08-14 23:20:18 +03:00
parent cae136d38d
commit 100c9e3ee3
1 changed files with 14 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
src/Database/Tag.hs
View File

@ -2,9 +2,11 @@
{-# Language TypeOperators #-} {-# Language TypeOperators #-}
{-# Language DataKinds #-} {-# Language DataKinds #-}
{-# Language DuplicateRecordFields #-} {-# Language DuplicateRecordFields #-}
{-# Language NamedFieldPuns #-}
module Database.Tag module Database.Tag
( def ( def
, booksTags , booksTags
, attachTag
, upsertTag , upsertTag
, Tag(..) ) where , Tag(..) ) where
@ -12,6 +14,7 @@ import ClassyPrelude
import Database.Schema import Database.Schema
import Database import Database
import Database.Selda import Database.Selda
import Database.Selda.Generic
upsertTag :: (MonadMask m, MonadIO m, MonadSelda m) => Username -> Text -> m Tag upsertTag :: (MonadMask m, MonadIO m, MonadSelda m) => Username -> Text -> m Tag
upsertTag username tag = transaction $ do upsertTag username tag = transaction $ do
@ -41,3 +44,14 @@ booksTags bookId = fromRels <$> query q
restrict (tagId .== tagId') restrict (tagId .== tagId')
restrict (bookId' .== literal bookId) restrict (bookId' .== literal bookId)
return tag return tag
attachTag :: (MonadMask m, MonadIO m, MonadSelda m) => Username -> BookID -> Text -> m ()
attachTag username bookId tag = transaction $ do
Tag{identifier} <- upsertTag username tag
unlessM (null <$> query (tagQ identifier)) $
void $ insertGen bookTags [BookTag identifier bookId]
where
tagQ tagId = do
(tagId' :*: bookId') <- select (gen bookTags)
restrict (tagId' .== literal tagId .&& bookId' .== literal bookId)
return tagId'