Reading and writing binary files
This commit is contained in:
parent
84a838e141
commit
1a8646df46
@ -6,5 +6,8 @@
|
|||||||
, password = "devel"
|
, password = "devel"
|
||||||
, host = "localhost"
|
, host = "localhost"
|
||||||
, database = "postgres"
|
, database = "postgres"
|
||||||
|
},
|
||||||
|
store = {
|
||||||
|
path = "/tmp/ebooks/"
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
@ -28,6 +28,7 @@ executable ebook-manager
|
|||||||
, Database.Channel
|
, Database.Channel
|
||||||
, Database.Schema
|
, Database.Schema
|
||||||
, Database.User
|
, Database.User
|
||||||
|
, Datastore
|
||||||
, Server
|
, Server
|
||||||
, Server.Auth
|
, Server.Auth
|
||||||
, Types
|
, Types
|
||||||
@ -41,12 +42,14 @@ executable ebook-manager
|
|||||||
, classy-prelude
|
, classy-prelude
|
||||||
, cryptonite
|
, cryptonite
|
||||||
, dhall
|
, dhall
|
||||||
|
, directory
|
||||||
, foreign-store
|
, foreign-store
|
||||||
, generic-lens
|
, generic-lens
|
||||||
, http-api-data
|
, http-api-data
|
||||||
, jose
|
, jose
|
||||||
, lens
|
, lens
|
||||||
, lucid
|
, lucid
|
||||||
|
, memory
|
||||||
, monad-logger
|
, monad-logger
|
||||||
, mtl
|
, mtl
|
||||||
, pandoc
|
, pandoc
|
||||||
@ -61,8 +64,8 @@ executable ebook-manager
|
|||||||
, servant-auth-server
|
, servant-auth-server
|
||||||
, servant-docs
|
, servant-docs
|
||||||
, servant-lucid
|
, servant-lucid
|
||||||
, servant-server
|
|
||||||
, servant-multipart
|
, servant-multipart
|
||||||
|
, servant-server
|
||||||
, text
|
, text
|
||||||
, transformers
|
, transformers
|
||||||
, wai
|
, wai
|
||||||
|
@ -13,7 +13,7 @@ WITH (
|
|||||||
) ;
|
) ;
|
||||||
CREATE TABLE public.books (
|
CREATE TABLE public.books (
|
||||||
identifier bigserial NOT NULL,
|
identifier bigserial NOT NULL,
|
||||||
"contentHash" text NULL,
|
"contentHash" bytea NULL,
|
||||||
"contentType" text NOT NULL,
|
"contentType" text NOT NULL,
|
||||||
title text NULL,
|
title text NULL,
|
||||||
description text NULL,
|
description text NULL,
|
||||||
|
@ -28,6 +28,12 @@ import Database
|
|||||||
import Control.Lens
|
import Control.Lens
|
||||||
import Data.Generics.Product
|
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
|
data JsonBook = JsonBook { identifier :: BookID
|
||||||
, contentType :: Text
|
, contentType :: Text
|
||||||
, title :: Maybe Text
|
, title :: Maybe Text
|
||||||
@ -51,11 +57,36 @@ type API = Auth '[SA.BasicAuth, SA.JWT] SafeUser :> BaseAPI
|
|||||||
|
|
||||||
type BaseAPI = "books" :> Get '[JSON] [JsonBook]
|
type BaseAPI = "books" :> Get '[JSON] [JsonBook]
|
||||||
:<|> "books" :> ReqBody '[JSON] PostBook :> Post '[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 :> "meta" :> ReqBody '[JSON] JsonBook :> Put '[JSON] JsonBook
|
||||||
-- :<|> "books" :> Capture "book_id" BookID :> ReqBody '[JSON] JsonBook :> PUT 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 :: 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 :: AuthResult SafeUser -> PostBook -> AppM JsonBook
|
||||||
postBookMetaHandler auth PostBook{..} = flip requireLoggedIn auth $ \SafeUser{username} -> do
|
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 :: AuthResult SafeUser -> BookID -> JsonBook -> AppM JsonBook
|
||||||
putBookMetaHandler auth bookId b@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{..})
|
maybe (throwM err403) (const (return b)) =<< runDB (updateBook UpdateBook{..})
|
||||||
| otherwise = throwM err403
|
| otherwise = throwM err403
|
||||||
|
|
||||||
|
@ -12,8 +12,12 @@ data Pg = Pg { username :: Text
|
|||||||
, database :: Text }
|
, database :: Text }
|
||||||
deriving (Show, Generic)
|
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 Pg
|
||||||
|
instance Interpret Store
|
||||||
instance Interpret Config
|
instance Interpret Config
|
||||||
|
@ -1,14 +1,20 @@
|
|||||||
{-# Language TypeApplications #-}
|
{-# Language TypeApplications #-}
|
||||||
|
{-# Language TypeOperators #-}
|
||||||
{-# Language DataKinds #-}
|
{-# Language DataKinds #-}
|
||||||
{-# Language DuplicateRecordFields #-}
|
{-# Language DuplicateRecordFields #-}
|
||||||
module Database.Book
|
module Database.Book
|
||||||
( def
|
( def
|
||||||
, insertBook
|
, insertBook
|
||||||
|
, getBook
|
||||||
|
, bookExists
|
||||||
, updateBook
|
, updateBook
|
||||||
|
, isBookOwner
|
||||||
|
, setContent
|
||||||
, InsertBook(..)
|
, InsertBook(..)
|
||||||
, UpdateBook(..)
|
, UpdateBook(..)
|
||||||
, usersBooks
|
, usersBooks
|
||||||
, Book(..)
|
, Book(..)
|
||||||
|
, HashDigest(..)
|
||||||
, BookID) where
|
, BookID) where
|
||||||
|
|
||||||
import ClassyPrelude
|
import ClassyPrelude
|
||||||
@ -22,9 +28,20 @@ usersBooks username = fromRels <$> query q
|
|||||||
where
|
where
|
||||||
q = do
|
q = do
|
||||||
userId :*: _ :*: username' :*: _ <- select (gen users)
|
userId :*: _ :*: username' :*: _ <- select (gen users)
|
||||||
book@(_ :*: _ :*: _ :*: _ :*: _ :*: owner) <- select (gen books)
|
book@(_ :*: digest :*: _ :*: _ :*: _ :*: owner) <- select (gen books)
|
||||||
restrict (username' .== literal username)
|
restrict (username' .== literal username)
|
||||||
restrict (userId .== owner)
|
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
|
return book
|
||||||
|
|
||||||
data InsertBook = InsertBook { contentType :: Text
|
data InsertBook = InsertBook { contentType :: Text
|
||||||
@ -49,15 +66,29 @@ data UpdateBook = UpdateBook { identifier :: BookID
|
|||||||
, description :: Maybe Text
|
, description :: Maybe Text
|
||||||
, owner :: Username }
|
, owner :: Username }
|
||||||
|
|
||||||
updateBook :: (MonadSelda m, MonadMask m, MonadIO m) => UpdateBook -> m (Maybe UpdateBook)
|
bookExists :: (MonadSelda m, MonadMask m, MonadIO m) => BookID -> m Bool
|
||||||
updateBook book@UpdateBook{..} = do
|
bookExists identifier = not . null <$> query q
|
||||||
mUserId <- query $ do
|
where
|
||||||
userId :*: _ :*: username :*: _ <- select (gen users)
|
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)
|
bookId :*: _ :*: _ :*: _ :*: _ :*: bookOwner <- select (gen books)
|
||||||
restrict (userId .== bookOwner)
|
restrict (userId .== bookOwner)
|
||||||
restrict (username .== literal owner)
|
restrict (username' .== literal username)
|
||||||
restrict (bookId .== literal identifier)
|
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
|
forM (listToMaybe mUserId) $ \_userId -> do
|
||||||
update_ (gen books) predicate (\b -> b `with` [ pContentType := literal contentType
|
update_ (gen books) predicate (\b -> b `with` [ pContentType := literal contentType
|
||||||
, pTitle := literal title
|
, pTitle := literal title
|
||||||
@ -66,3 +97,12 @@ updateBook book@UpdateBook{..} = do
|
|||||||
where
|
where
|
||||||
_ :*: _ :*: pContentType :*: pTitle :*: pDescription :*: _ = selectors (gen books)
|
_ :*: _ :*: pContentType :*: pTitle :*: pDescription :*: _ = selectors (gen books)
|
||||||
predicate (bookId :*: _) = bookId .== literal identifier
|
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 ]
|
, (identifier :: User HashedPassword -> UserID) :- autoPrimaryGen ]
|
||||||
|
|
||||||
-- | Book type
|
-- | Book type
|
||||||
newtype HashDigest = HashDigest { unHex :: Text } deriving Show
|
newtype HashDigest = HashDigest { unHex :: ByteString } deriving Show
|
||||||
-- XXX: Add an identifier for the book
|
-- XXX: Add an identifier for the book
|
||||||
data Book = Book { identifier :: BookID
|
data Book = Book { identifier :: BookID
|
||||||
, contentHash :: Maybe HashDigest
|
, contentHash :: Maybe HashDigest
|
||||||
@ -107,8 +107,8 @@ data Book = Book { identifier :: BookID
|
|||||||
deriving (Show, Generic)
|
deriving (Show, Generic)
|
||||||
|
|
||||||
instance SqlType HashDigest where
|
instance SqlType HashDigest where
|
||||||
mkLit = LCustom . LText . unHex
|
mkLit = LCustom . LBlob . unHex
|
||||||
fromSql (SqlString x) = HashDigest x
|
fromSql (SqlBlob x) = HashDigest x
|
||||||
fromSql _ = error "fromSql: Not a valid hash digest"
|
fromSql _ = error "fromSql: Not a valid hash digest"
|
||||||
defaultValue = mkLit (HashDigest "") -- Doesn't really make sense
|
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