diff --git a/src/Database/Tag.hs b/src/Database/Tag.hs
index 3830d17..e806adc 100644
--- a/src/Database/Tag.hs
+++ b/src/Database/Tag.hs
@@ -2,9 +2,11 @@
 {-# Language TypeOperators #-}
 {-# Language DataKinds #-}
 {-# Language DuplicateRecordFields #-}
+{-# Language NamedFieldPuns #-}
 module Database.Tag
   ( def
   , booksTags
+  , attachTag
   , upsertTag
   , Tag(..) ) where
 
@@ -12,6 +14,7 @@ import ClassyPrelude
 import Database.Schema
 import Database
 import Database.Selda
+import Database.Selda.Generic
 
 upsertTag :: (MonadMask m, MonadIO m, MonadSelda m) => Username -> Text -> m Tag
 upsertTag username tag = transaction $ do
@@ -41,3 +44,14 @@ booksTags bookId = fromRels <$> query q
       restrict (tagId .== tagId')
       restrict (bookId' .== literal bookId)
       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'