diff --git a/config/devel.dhall b/config/devel.dhall index 83d0368..c8cc7a1 100644 --- a/config/devel.dhall +++ b/config/devel.dhall @@ -6,5 +6,8 @@ , password = "devel" , host = "localhost" , database = "postgres" + }, + store = { + path = "/tmp/ebooks/" } } diff --git a/ebook-manager.cabal b/ebook-manager.cabal index c9433a0..7731da8 100644 --- a/ebook-manager.cabal +++ b/ebook-manager.cabal @@ -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 diff --git a/migrations/V1__Initial_database.sql b/migrations/V1__Initial_database.sql index 3e919bd..865ac10 100644 --- a/migrations/V1__Initial_database.sql +++ b/migrations/V1__Initial_database.sql @@ -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, diff --git a/src/API/Books.hs b/src/API/Books.hs index 0594eb5..acbca89 100644 --- a/src/API/Books.hs +++ b/src/API/Books.hs @@ -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 diff --git a/src/Configuration.hs b/src/Configuration.hs index dcd6f96..553cd6f 100644 --- a/src/Configuration.hs +++ b/src/Configuration.hs @@ -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 diff --git a/src/Database/Book.hs b/src/Database/Book.hs index 92406ed..876290b 100644 --- a/src/Database/Book.hs +++ b/src/Database/Book.hs @@ -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 } +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 username) + restrict (bookId .== literal identifier) + return (userId :*: bookId) + updateBook :: (MonadSelda m, MonadMask m, MonadIO m) => UpdateBook -> m (Maybe UpdateBook) updateBook book@UpdateBook{..} = do - mUserId <- query $ do - userId :*: _ :*: username :*: _ <- select (gen users) - bookId :*: _ :*: _ :*: _ :*: _ :*: bookOwner <- select (gen books) - restrict (userId .== bookOwner) - restrict (username .== literal owner) - restrict (bookId .== literal identifier) - return userId + 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 diff --git a/src/Database/Schema.hs b/src/Database/Schema.hs index f4fcb18..24d50a9 100644 --- a/src/Database/Schema.hs +++ b/src/Database/Schema.hs @@ -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 diff --git a/src/Datastore.hs b/src/Datastore.hs new file mode 100644 index 0000000..a0cbd21 --- /dev/null +++ b/src/Datastore.hs @@ -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