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

Reading and writing binary files

Browse Source
This commit is contained in:
Mats Rauhala 2018-08-08 23:56:16 +03:00
parent 84a838e141
commit 1a8646df46
8 changed files with 153 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
config/devel.dhall
View File

@ -6,5 +6,8 @@
, password = "devel"
, host = "localhost"
, database = "postgres"
},
store = {
path = "/tmp/ebooks/"
}
}

5
ebook-manager.cabal
View File

@ -28,6 +28,7 @@ executable ebook-manager
, Database.Channel
, Database.Schema
, Database.User
, Datastore
, Server
, Server.Auth
, Types
@ -41,12 +42,14 @@ executable ebook-manager
, classy-prelude
, cryptonite
, dhall
, directory
, foreign-store
, generic-lens
, http-api-data
, jose
, lens
, lucid
, memory
, monad-logger
, mtl
, pandoc
@ -61,8 +64,8 @@ executable ebook-manager
, servant-auth-server
, servant-docs
, servant-lucid
, servant-server
, servant-multipart
, servant-server
, text
, transformers
, wai

2
migrations/V1__Initial_database.sql
View File

@ -13,7 +13,7 @@ WITH (
) ;
CREATE TABLE public.books (
identifier bigserial NOT NULL,
"contentHash" text NULL,
"contentHash" bytea NULL,
"contentType" text NOT NULL,
title text NULL,
description text NULL,

39
src/API/Books.hs
View File

@ -28,6 +28,12 @@ import Database
import Control.Lens
import Data.Generics.Product
import Control.Monad.Trans.Maybe
import qualified Datastore as DS
import Data.ByteArray (convert)
import Crypto.Hash (digestFromByteString)
data JsonBook = JsonBook { identifier :: BookID
, contentType :: Text
, title :: Maybe Text
@ -51,11 +57,36 @@ type API = Auth '[SA.BasicAuth, SA.JWT] SafeUser :> BaseAPI
type BaseAPI = "books" :> Get '[JSON] [JsonBook]
:<|> "books" :> ReqBody '[JSON] PostBook :> Post '[JSON] JsonBook
:<|> "books" :> Capture "book_id" BookID :> ReqBody '[JSON] JsonBook :> Post '[JSON] JsonBook
-- :<|> "books" :> Capture "book_id" BookID :> ReqBody '[JSON] JsonBook :> PUT JsonBook
:<|> "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
handler :: ServerT API AppM
handler user = listBooksHandler user :<|> postBookMetaHandler user :<|> putBookMetaHandler user
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
postBookMetaHandler :: AuthResult SafeUser -> PostBook -> AppM JsonBook
postBookMetaHandler auth PostBook{..} = flip requireLoggedIn auth $ \SafeUser{username} -> do
@ -65,7 +96,7 @@ postBookMetaHandler auth PostBook{..} = flip requireLoggedIn auth $ \SafeUser{us
putBookMetaHandler :: AuthResult SafeUser -> BookID -> JsonBook -> AppM JsonBook
putBookMetaHandler auth bookId b@JsonBook{..}
| bookId == identifier = flip requireLoggedIn auth $ \SafeUser{username=owner} ->
| bookId == identifier = requireBookOwner auth bookId $ \SafeUser{username=owner} ->
maybe (throwM err403) (const (return b)) =<< runDB (updateBook UpdateBook{..})
| otherwise = throwM err403

6
src/Configuration.hs
View File

@ -12,8 +12,12 @@ data Pg = Pg { username :: Text
, database :: Text }
deriving (Show, Generic)
newtype Store = Store { path :: Text } deriving (Show, Generic)
newtype Config = Config { database :: Pg } deriving (Show, Generic)
data Config = Config { database :: Pg
, store :: Store }
deriving (Show, Generic)
instance Interpret Pg
instance Interpret Store
instance Interpret Config

54
src/Database/Book.hs
View File

@ -1,14 +1,20 @@
{-# 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
@ -22,9 +28,20 @@ usersBooks username = fromRels <$> query q
where
q = do
userId :*: _ :*: username' :*: _ <- select (gen users)
book@(_ :*: _ :*: _ :*: _ :*: _ :*: owner) <- select (gen books)
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
@ -49,15 +66,29 @@ data UpdateBook = UpdateBook { identifier :: BookID
, description :: Maybe Text
, owner :: Username }
updateBook :: (MonadSelda m, MonadMask m, MonadIO m) => UpdateBook -> m (Maybe UpdateBook)
updateBook book@UpdateBook{..} = do
mUserId <- query $ do
userId :*: _ :*: username :*: _ <- select (gen users)
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 owner)
restrict (username' .== literal username)
restrict (bookId .== literal identifier)
return userId
return (userId :*: bookId)
updateBook :: (MonadSelda m, MonadMask m, MonadIO m) => UpdateBook -> m (Maybe UpdateBook)
updateBook book@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
@ -66,3 +97,12 @@ updateBook book@UpdateBook{..} = do
where
_ :*: _ :*: pContentType :*: pTitle :*: pDescription :*: _ = selectors (gen books)
predicate (bookId :*: _) = bookId .== literal identifier
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

6
src/Database/Schema.hs
View File

@ -96,7 +96,7 @@ users = genTable "users" [ (email :: User HashedPassword -> Email) :- uniqueGen
, (identifier :: User HashedPassword -> UserID) :- autoPrimaryGen ]
-- | Book type
newtype HashDigest = HashDigest { unHex :: Text } deriving Show
newtype HashDigest = HashDigest { unHex :: ByteString } deriving Show
-- XXX: Add an identifier for the book
data Book = Book { identifier :: BookID
, contentHash :: Maybe HashDigest
@ -107,8 +107,8 @@ data Book = Book { identifier :: BookID
deriving (Show, Generic)
instance SqlType HashDigest where
mkLit = LCustom . LText . unHex
fromSql (SqlString x) = HashDigest x
mkLit = LCustom . LBlob . unHex
fromSql (SqlBlob x) = HashDigest x
fromSql _ = error "fromSql: Not a valid hash digest"
defaultValue = mkLit (HashDigest "") -- Doesn't really make sense

54
src/Datastore.hs Normal file
View File

@ -0,0 +1,54 @@
{-# Language TypeFamilies #-}
{-# Language GeneralizedNewtypeDeriving #-}
{-# Language TypeApplications #-}
{-# Language DataKinds #-}
{-# Language FlexibleContexts #-}
{-# Language TypeSynonymInstances #-}
{-# Language FlexibleInstances #-}
module Datastore where
import ClassyPrelude
import Types
import Crypto.Hash
import Data.Generics.Product
import Control.Lens
import System.Directory (doesFileExist, createDirectoryIfMissing)
-- I might change the implementation at some point
class Monad m => MonadDS m where
type Key m :: *
put :: ByteString -> m (Key m)
get :: Key m -> m (Maybe ByteString)
instance MonadDS AppM where
type Key AppM = Digest SHA256
put = putLocal
get = getLocal
putLocal :: ( MonadIO m
, HasField' "config" r config
, HasField' "store" config store
, HasField' "path" store Text
, MonadReader r m)
=> ByteString -> m (Digest SHA256)
putLocal bs = do
store <- unpack <$> view (field @"config" . field @"store" . field @"path")
liftIO $ createDirectoryIfMissing True store
let key = hashWith SHA256 bs
writeFile (store </> show key) bs
return key
getLocal :: ( MonadIO m
, HasField' "config" r config
, HasField' "store" config store
, HasField' "path" store Text
, MonadReader r m)
=> Digest SHA256 -> m (Maybe ByteString)
getLocal key = do
store <- unpack <$> view (field @"config" . field @"store" . field @"path")
liftIO $ createDirectoryIfMissing True store
let file = store </> show key
exists <- liftIO $ doesFileExist file
if exists then Just <$> readFile file else pure Nothing