Reading and writing binary files

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