From bb7ab38b925e0be156184b0b2e7fca1e56b2315b Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Tue, 7 Aug 2018 23:25:21 +0300 Subject: [PATCH] Migrations properly through flyway --- migrations/V1__Initial_databas.sql | 9 ---- migrations/V1__Initial_database.sql | 71 +++++++++++++++++++++++++++++ src/API/Books.hs | 31 +++++++++++-- src/Database/Book.hs | 21 ++++++++- src/Database/Schema.hs | 7 +-- 5 files changed, 120 insertions(+), 19 deletions(-) delete mode 100644 migrations/V1__Initial_databas.sql create mode 100644 migrations/V1__Initial_database.sql diff --git a/migrations/V1__Initial_databas.sql b/migrations/V1__Initial_databas.sql deleted file mode 100644 index ad87669..0000000 --- a/migrations/V1__Initial_databas.sql +++ /dev/null @@ -1,9 +0,0 @@ -CREATE TABLE public.users ( - email text NOT NULL, - username text NOT NULL, - "password" bytea NOT NULL, - CONSTRAINT users_pkey PRIMARY KEY (email) -) -WITH ( - OIDS=FALSE -) ; diff --git a/migrations/V1__Initial_database.sql b/migrations/V1__Initial_database.sql new file mode 100644 index 0000000..43d0673 --- /dev/null +++ b/migrations/V1__Initial_database.sql @@ -0,0 +1,71 @@ +CREATE TABLE public.users ( + identifier bigserial NOT NULL, + email text NOT NULL, + username text NOT NULL, + "role" text NOT NULL, + "password" bytea NOT NULL, + CONSTRAINT users_email_key UNIQUE (email), + CONSTRAINT users_pkey PRIMARY KEY (identifier), + CONSTRAINT users_username_key UNIQUE (username) +) +WITH ( + OIDS=FALSE +) ; +CREATE TABLE public.books ( + identifier bigserial NOT NULL, + "contentHash" text NULL, + "contentType" text NOT NULL, + title text NULL, + description text NULL, + CONSTRAINT books_pkey PRIMARY KEY (identifier) +) +WITH ( + OIDS=FALSE +) ; +CREATE TABLE public.channels ( + identifier bigserial NOT NULL, + channel text NOT NULL, + "owner" bigserial NOT NULL, + CONSTRAINT channels_pkey PRIMARY KEY (identifier), + CONSTRAINT fk0_owner FOREIGN KEY (owner) REFERENCES users(identifier) +) +WITH ( + OIDS=FALSE +) ; +CREATE TABLE public.tags ( + identifier bigserial NOT NULL, + tag text NOT NULL, + "owner" bigserial NOT NULL, + CONSTRAINT tags_pkey PRIMARY KEY (identifier), + CONSTRAINT fk0_owner FOREIGN KEY (owner) REFERENCES users(identifier) +) +WITH ( + OIDS=FALSE +) ; +CREATE TABLE public.book_channels ( + channel int8 NOT NULL, + book int8 NOT NULL, + CONSTRAINT fk0_channel FOREIGN KEY (channel) REFERENCES channels(identifier), + CONSTRAINT fk1_book FOREIGN KEY (book) REFERENCES books(identifier) +) +WITH ( + OIDS=FALSE +) ; +CREATE TABLE public.book_tags ( + tag int8 NOT NULL, + book int8 NOT NULL, + CONSTRAINT fk0_tag FOREIGN KEY (tag) REFERENCES tags(identifier), + CONSTRAINT fk1_book FOREIGN KEY (book) REFERENCES books(identifier) +) +WITH ( + OIDS=FALSE +) ; +CREATE TABLE public.user_book ( + "user" bigserial NOT NULL, + book int8 NOT NULL, + CONSTRAINT fk0_user FOREIGN KEY ("user") REFERENCES users(identifier), + CONSTRAINT fk1_book FOREIGN KEY (book) REFERENCES books(identifier) +) +WITH ( + OIDS=FALSE +) ; diff --git a/src/API/Books.hs b/src/API/Books.hs index d9e4d8e..4943a60 100644 --- a/src/API/Books.hs +++ b/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,..} diff --git a/src/Database/Book.hs b/src/Database/Book.hs index 251d44e..3af9f79 100644 --- a/src/Database/Book.hs +++ b/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 diff --git a/src/Database/Schema.hs b/src/Database/Schema.hs index aa498ad..0162fa3 100644 --- a/src/Database/Schema.hs +++ b/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 }