132 lines
4.9 KiB
Haskell
132 lines
4.9 KiB
Haskell
{-# 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 Control.Lens (view)
|
|
import Control.Monad.Catch (MonadCatch)
|
|
import Data.Generics.Product
|
|
import Database
|
|
import Database.Channel (booksChannels, attachChannel, clearChannels)
|
|
import Database.Schema (books, users, Username, Book(..), BookID(..), UserID, HashDigest(..))
|
|
import Database.Selda
|
|
import Database.Selda.Generic
|
|
import Database.Tag (booksTags, attachTag, clearTags)
|
|
|
|
usersBooks :: (MonadSelda 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, 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, 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, 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) => 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 :: (MonadCatch m, MonadSelda 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 :: (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, 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
|