Migrations properly through flyway

src/API/Books.hs

@@ -1,3 +1,4 @@
+{-# Language DuplicateRecordFields #-}
 {-# Language DataKinds #-}
 {-# Language TypeFamilies #-}
 {-# Language TypeOperators #-}
@@ -11,6 +12,7 @@
 {-# Language FlexibleInstances #-}
 {-# Language TypeApplications #-}
 {-# Language DataKinds #-}
+{-# Language NamedFieldPuns #-}
 module API.Books where
 
 import Servant hiding (contentType)
@@ -26,7 +28,14 @@ import Database
 import Control.Lens
 import Data.Generics.Product
 
-data JsonBook = JsonBook { contentType :: Text
+data JsonBook = JsonBook { identifier :: BookID
+                         , contentType :: Text
+                         , title :: Maybe Text
+                         , description :: Maybe Text
+                         , channels :: [JsonChannel] }
+              deriving (Generic, Show)
+
+data PostBook = PostBook { contentType :: Text
                          , title :: Maybe Text
                          , description :: Maybe Text
                          , channels :: [JsonChannel] }
@@ -35,15 +44,27 @@ data JsonBook = JsonBook { contentType :: Text
 
 instance ToJSON JsonBook
 instance FromJSON JsonBook
+instance ToJSON PostBook
+instance FromJSON PostBook
 
 type API = Auth '[SA.BasicAuth, SA.JWT] SafeUser :> BaseAPI
 
 type BaseAPI = "books" :> Get '[JSON] [JsonBook]
-      --  :<|> "books" :> ReqBody '[JSON] JsonBook :> PUT JsonBook
-      --  :<|> "books" :> Param "book_id" BookID :> ReqBody '[JSON] JsonBook :> PUT 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
 
 handler :: ServerT API AppM
-handler user = listBooksHandler user
+handler user = listBooksHandler user :<|> postBookMetaHandler user :<|> putBookMetaHandler user
+
+postBookMetaHandler :: AuthResult SafeUser -> PostBook -> AppM JsonBook
+postBookMetaHandler auth PostBook{..} = flip requireLoggedIn auth $ \SafeUser{username} -> do
+  mIdentifier <- runDB $ insertBook username Book{identifier=def,contentHash=Nothing,..}
+  maybe (throwM err403{errBody="Could not insert book"}) (\identifier -> pure JsonBook{..}) mIdentifier
+
+
+putBookMetaHandler :: AuthResult SafeUser -> BookID -> JsonBook -> AppM JsonBook
+putBookMetaHandler _ _ _ = throwM err403
 
 listBooksHandler :: AuthResult SafeUser -> AppM [JsonBook]
 listBooksHandler = requireLoggedIn $ \user -> do
@@ -51,4 +72,4 @@ listBooksHandler = requireLoggedIn $ \user -> do
     where
       augment Book{identifier=bookId,..} = do
         channels <- fmap (\Channel{..} -> JsonChannel{..}) <$> booksChannels bookId
-        pure JsonBook{..}
+        pure JsonBook{identifier=bookId,..}

src/Database/Book.hs

@@ -1,13 +1,19 @@
 {-# Language TypeApplications #-}
 {-# Language DataKinds #-}
-module Database.Book (usersBooks, Book(..)) where
+module Database.Book
+  ( def
+  , insertBook
+  , usersBooks
+  , Book(..)
+  , BookID) where
 
 import ClassyPrelude
 import Database.Schema
 import Database
 import Database.Selda
+import Database.Selda.Generic
 
-usersBooks :: (MonadMask m, MonadIO m) => Username -> SeldaT m [Book]
+usersBooks :: (MonadSelda m, MonadMask m, MonadIO m) => Username -> m [Book]
 usersBooks username = fromRels <$> query q
   where
     q = do
@@ -19,3 +25,14 @@ usersBooks username = fromRels <$> query q
       restrict (userId .== userId')
       return book
 
+-- Always inserts
+insertBook :: (MonadSelda m, MonadMask m, MonadIO m) => Username -> Book -> m (Maybe BookID)
+insertBook username book = do
+  bookId <- BookID . fromRowId <$> insertGenWithPK books [book]
+  mUserId <- query $ do
+    userId :*: _ :*: username' :*: _ <- select (gen users)
+    restrict (username' .== literal username)
+    return userId
+  forM (listToMaybe mUserId) $ \userId -> do
+    void $ insertGen userBooks [UserBook userId bookId]
+    return bookId

src/Database/Schema.hs

@@ -42,7 +42,7 @@ instance SqlType Username where
 
 newtype UserID = UserID {unUserID :: Int} deriving (Show)
 
-newtype BookID = BookID {unBookID :: Int} deriving (Show)
+newtype BookID = BookID {unBookID :: Int} deriving (Show, ToJSON, FromJSON, FromHttpApiData)
 
 newtype ChannelID = ChannelID {unChannelID :: Int} deriving (Show)
 
@@ -52,6 +52,7 @@ instance SqlType UserID where
   mkLit = LCustom . LInt . unUserID
   fromSql (SqlInt x) = UserID x
   fromSql _ = error "fromSql: Bad userid"
+  sqlType _ = TRowID
   defaultValue = mkLit (UserID (-1))
 instance SqlType BookID where
   mkLit = LCustom . LInt . unBookID
@@ -98,7 +99,7 @@ users = genTable "users" [ (email :: User HashedPassword -> Email) :- uniqueGen
 newtype HashDigest = HashDigest { unHex :: Text } deriving Show
 -- XXX: Add an identifier for the book
 data Book = Book { identifier :: BookID
-                 , contentHash :: HashDigest
+                 , contentHash :: Maybe HashDigest
                  , contentType :: Text
                  , title :: Maybe Text
                  , description :: Maybe Text }
@@ -111,7 +112,7 @@ instance SqlType HashDigest where
   defaultValue = mkLit (HashDigest "") -- Doesn't really make sense
 
 books :: GenTable Book
-books = genTable "books" [ (identifier :: Book -> BookID) :- primaryGen ]
+books = genTable "books" [ (identifier :: Book -> BookID) :- autoPrimaryGen ]
 
 data UserBook = UserBook { user :: UserID
                          , book :: BookID }