ebook-manager/src/API/Books.hs

110 lines
4.3 KiB
Haskell
Raw Normal View History

2018-08-07 23:25:21 +03:00
{-# Language DuplicateRecordFields #-}
2018-08-05 23:42:37 +03:00
{-# Language DataKinds #-}
{-# Language TypeFamilies #-}
{-# Language TypeOperators #-}
{-# Language NoImplicitPrelude #-}
{-# Language MultiParamTypeClasses #-}
{-# Language OverloadedStrings #-}
{-# Language TemplateHaskell #-}
{-# Language QuasiQuotes #-}
{-# Language RecordWildCards #-}
{-# Language DeriveGeneric #-}
{-# Language FlexibleInstances #-}
{-# Language TypeApplications #-}
{-# Language DataKinds #-}
2018-08-07 23:25:21 +03:00
{-# Language NamedFieldPuns #-}
2018-08-05 23:42:37 +03:00
module API.Books where
import Servant hiding (contentType)
import Types
import ClassyPrelude
import Server.Auth
import Servant.Auth as SA
import Data.Aeson
import API.Channels (JsonChannel(..))
import Database.Book
import Database.Channel
import Database
import Control.Lens
import Data.Generics.Product
2018-08-08 23:56:16 +03:00
import Control.Monad.Trans.Maybe
import qualified Datastore as DS
import Data.ByteArray (convert)
import Crypto.Hash (digestFromByteString)
2018-08-07 23:25:21 +03:00
data JsonBook = JsonBook { identifier :: BookID
, contentType :: Text
, title :: Maybe Text
, description :: Maybe Text
, channels :: [JsonChannel] }
deriving (Generic, Show)
data PostBook = PostBook { contentType :: Text
2018-08-05 23:42:37 +03:00
, title :: Maybe Text
, description :: Maybe Text
, channels :: [JsonChannel] }
deriving (Generic, Show)
2018-08-06 00:09:41 +03:00
2018-08-05 23:42:37 +03:00
instance ToJSON JsonBook
instance FromJSON JsonBook
2018-08-07 23:25:21 +03:00
instance ToJSON PostBook
instance FromJSON PostBook
2018-08-05 23:42:37 +03:00
type API = Auth '[SA.BasicAuth, SA.JWT] SafeUser :> BaseAPI
type BaseAPI = "books" :> Get '[JSON] [JsonBook]
2018-08-07 23:25:21 +03:00
:<|> "books" :> ReqBody '[JSON] PostBook :> Post '[JSON] JsonBook
2018-08-08 23:56:16 +03:00
:<|> "books" :> Capture "book_id" BookID :> "meta" :> ReqBody '[JSON] JsonBook :> Put '[JSON] JsonBook
:<|> "books" :> Capture "book_id" BookID :> ReqBody '[OctetStream] ByteString :> Put '[JSON] NoContent
:<|> "books" :> Capture "book_id" BookID :> Get '[OctetStream] ByteString
2018-08-05 23:42:37 +03:00
handler :: ServerT API AppM
2018-08-08 23:56:16 +03:00
handler user = listBooksHandler user
:<|> postBookMetaHandler user
:<|> putBookMetaHandler user
:<|> putBookContentHandler user
:<|> getBookContentHandler user
getBookContentHandler :: AuthResult SafeUser -> BookID -> AppM ByteString
getBookContentHandler auth bookId = requireBookOwner auth bookId $ \SafeUser{username} -> do
content <- runMaybeT $ do
Book{contentHash=mHash} <- MaybeT $ runDB (getBook bookId username)
contentHash <- MaybeT $ return (mHash >>= digestFromByteString . unHex)
MaybeT $ DS.get contentHash
maybe (throwM err404) return content
requireBookOwner :: AuthResult SafeUser -> BookID -> (SafeUser -> AppM a) -> AppM a
requireBookOwner auth bookId f = flip requireLoggedIn auth $ \u@SafeUser{username} -> do
exists <- runDB $ bookExists bookId
unless exists $ throwM err404
runDB (isBookOwner bookId username) >>= \o -> if o then f u else throwM err403
putBookContentHandler :: AuthResult SafeUser -> BookID -> ByteString -> AppM NoContent
putBookContentHandler auth bookId content = requireBookOwner auth bookId $ \SafeUser{username} -> do
key <- HashDigest . convert <$> DS.put content
runDB (setContent bookId username key)
return NoContent
2018-08-07 23:25:21 +03:00
postBookMetaHandler :: AuthResult SafeUser -> PostBook -> AppM JsonBook
postBookMetaHandler auth PostBook{..} = flip requireLoggedIn auth $ \SafeUser{username} -> do
2018-08-08 21:58:36 +03:00
mIdentifier <- runDB $ insertBook InsertBook{owner=username,..}
2018-08-07 23:25:21 +03:00
maybe (throwM err403{errBody="Could not insert book"}) (\identifier -> pure JsonBook{..}) mIdentifier
putBookMetaHandler :: AuthResult SafeUser -> BookID -> JsonBook -> AppM JsonBook
2018-08-08 22:21:15 +03:00
putBookMetaHandler auth bookId b@JsonBook{..}
2018-08-08 23:56:16 +03:00
| bookId == identifier = requireBookOwner auth bookId $ \SafeUser{username=owner} ->
2018-08-08 22:21:15 +03:00
maybe (throwM err403) (const (return b)) =<< runDB (updateBook UpdateBook{..})
| otherwise = throwM err403
2018-08-05 23:42:37 +03:00
listBooksHandler :: AuthResult SafeUser -> AppM [JsonBook]
listBooksHandler = requireLoggedIn $ \user -> do
runDB (usersBooks (view (field @"username") user) >>= mapM augment)
where
2018-08-08 21:58:36 +03:00
augment Book{identifier=bookId,contentType,title,description} = do
2018-08-07 22:27:05 +03:00
channels <- fmap (\Channel{..} -> JsonChannel{..}) <$> booksChannels bookId
2018-08-07 23:25:21 +03:00
pure JsonBook{identifier=bookId,..}