Reading and writing binary files

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
 

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

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

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
 

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