Support for multiproject builds with nix

- Closes #28

backend/src/Database/Book.hs

@@ -0,0 +1,132 @@
+{-# Language TypeApplications #-}
+{-# Language TypeOperators #-}
+{-# Language DataKinds #-}
+{-# Language DuplicateRecordFields #-}
+module Database.Book
+  ( def
+  , insertBook
+  , getBook
+  , bookExists
+  , updateBook
+  , isBookOwner
+  , setContent
+  , InsertBook(..)
+  , UpdateBook(..)
+  , usersBooks
+  , Book(..)
+  , HashDigest(..)
+  , BookID) where
+
+import ClassyPrelude
+import Database.Schema (books, users, Username, Book(..), BookID(..), UserID, HashDigest(..))
+import Database
+import Database.Selda
+import Database.Selda.Generic
+
+import Control.Lens (view)
+import Data.Generics.Product
+
+import Database.Tag (booksTags, attachTag, clearTags)
+import Database.Channel (booksChannels, attachChannel, clearChannels)
+
+usersBooks :: (MonadSelda m, MonadMask m, MonadIO m) => Username -> m [Book]
+usersBooks username = fromRels <$> query q
+  where
+    q = do
+      userId :*: _ :*: username' :*: _ <- select (gen users)
+      book@(_ :*: digest :*: _ :*: _ :*: _ :*: owner) <- select (gen books)
+      restrict (username' .== literal username)
+      restrict (userId .== owner)
+      restrict (not_ (isNull digest))
+      return book
+
+
+getBook :: (MonadSelda m, MonadMask m, MonadIO m) => BookID -> Username -> m (Maybe Book)
+getBook identifier owner = listToMaybe . fromRels <$> query q
+  where
+    q = do
+      _ :*: bookId <- bookOwner' identifier owner
+      book@(bookId' :*: _) <- select (gen books)
+      restrict (bookId .== bookId')
+      return book
+
+data InsertBook = InsertBook { contentType :: Text
+                             , title :: Text
+                             , description :: Maybe Text
+                             , owner :: Username }
+
+-- Always inserts
+insertBook :: (MonadSelda m, MonadMask m, MonadIO m) => InsertBook -> m (Maybe BookID)
+insertBook InsertBook{..} = do
+  mUserId <- query $ do
+    userId :*: _ :*: username' :*: _ <- select (gen users)
+    restrict (username' .== literal owner)
+    return userId
+  forM (listToMaybe mUserId) $ \userId -> do
+    let book = Book{owner=userId,identifier=def,contentHash=Nothing,..}
+    BookID . fromRowId <$> insertGenWithPK books [book]
+
+data UpdateBook = UpdateBook { identifier :: BookID
+                             , contentType :: Text
+                             , title :: Text
+                             , description :: Maybe Text
+                             , owner :: Username
+                             , tags :: [Text]
+                             , channels :: [Text] }
+                deriving (Show, Generic)
+
+bookExists :: (MonadSelda m, MonadMask m, MonadIO m) => BookID -> m Bool
+bookExists identifier = not . null <$> query q
+  where
+    q = do
+      (bookId :*: _) <- select (gen books)
+      restrict (bookId .== literal identifier)
+      return bookId
+
+isBookOwner :: (MonadSelda m, MonadIO m, MonadThrow m) => BookID -> Username -> m Bool
+isBookOwner identifier username = not . null <$> query (bookOwner' identifier username)
+
+bookOwner' :: BookID -> Username -> Query s (Col s UserID :*: Col s BookID)
+bookOwner' identifier username = do
+  userId :*: _ :*: username' :*: _ <- select (gen users)
+  bookId :*: _ :*: _ :*: _ :*: _ :*: bookOwner <- select (gen books)
+  restrict (userId .== bookOwner)
+  restrict (username' .== literal username)
+  restrict (bookId .== literal identifier)
+  return (userId :*: bookId)
+
+updateBook :: (MonadSelda m, MonadMask m, MonadIO m) => UpdateBook -> m (Maybe UpdateBook)
+updateBook UpdateBook{..} = do
+  clearTags identifier >> connectTags
+  clearChannels identifier >> connectChannels
+  updateBook'
+  getUpdateBook identifier owner
+  where
+    connectTags = mapM_ (attachTag owner identifier) tags
+    connectChannels = mapM_ (attachChannel owner identifier) channels
+    updateBook' = do
+      mUserId <- query (bookOwner' identifier owner)
+      forM_ (listToMaybe mUserId) $ \_userId -> do
+        update_ (gen books) predicate (\b -> b `with` [ pContentType := literal contentType
+                                                      , pTitle := literal title
+                                                      , pDescription := literal description ])
+    _ :*: _ :*: pContentType :*: pTitle :*: pDescription :*: _ = selectors (gen books)
+    predicate (bookId :*: _) = bookId .== literal identifier
+
+
+getUpdateBook :: (MonadMask m, MonadIO m, MonadSelda m) => BookID -> Username -> m (Maybe UpdateBook)
+getUpdateBook bookId username = do
+  mBook <- getBook bookId username
+  forM mBook $ \Book{..} -> do
+    channels <- map (view (field @"channel")) <$> booksChannels bookId
+    tags <- map (view (field @"tag")) <$> booksTags bookId
+    return UpdateBook{owner=username,..}
+
+setContent :: (MonadSelda m, MonadMask m, MonadIO m) => BookID -> Username -> HashDigest -> m ()
+setContent identifier owner digest = do
+  mOwner <- query (bookOwner' identifier owner)
+  void $ forM (listToMaybe mOwner) $ \_ ->
+    update_ (gen books) predicate (\b -> b `with` [ pHash := literal (Just digest)])
+  where
+    _ :*: pHash :*: _ = selectors (gen books)
+    predicate (bookId :*: _) = bookId .== literal identifier