Reading and writing binary files
This commit is contained in:
parent
84a838e141
commit
1a8646df46
@ -6,5 +6,8 @@
|
||||
, password = "devel"
|
||||
, host = "localhost"
|
||||
, database = "postgres"
|
||||
},
|
||||
store = {
|
||||
path = "/tmp/ebooks/"
|
||||
}
|
||||
}
|
||||
|
@ -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
|
||||
|
@ -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,
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
54
src/Datastore.hs
Normal 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
|
Loading…
Reference in New Issue
Block a user