Migrations properly through flyway

This commit is contained in:
Mats Rauhala 2018-08-07 23:25:21 +03:00
parent 5dac8374fd
commit bb7ab38b92
5 changed files with 120 additions and 19 deletions

View File

@ -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
) ;

View File

@ -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
) ;

View File

@ -1,3 +1,4 @@
{-# Language DuplicateRecordFields #-}
{-# Language DataKinds #-} {-# Language DataKinds #-}
{-# Language TypeFamilies #-} {-# Language TypeFamilies #-}
{-# Language TypeOperators #-} {-# Language TypeOperators #-}
@ -11,6 +12,7 @@
{-# Language FlexibleInstances #-} {-# Language FlexibleInstances #-}
{-# Language TypeApplications #-} {-# Language TypeApplications #-}
{-# Language DataKinds #-} {-# Language DataKinds #-}
{-# Language NamedFieldPuns #-}
module API.Books where module API.Books where
import Servant hiding (contentType) import Servant hiding (contentType)
@ -26,7 +28,14 @@ import Database
import Control.Lens import Control.Lens
import Data.Generics.Product 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 , title :: Maybe Text
, description :: Maybe Text , description :: Maybe Text
, channels :: [JsonChannel] } , channels :: [JsonChannel] }
@ -35,15 +44,27 @@ data JsonBook = JsonBook { contentType :: Text
instance ToJSON JsonBook instance ToJSON JsonBook
instance FromJSON JsonBook instance FromJSON JsonBook
instance ToJSON PostBook
instance FromJSON PostBook
type API = Auth '[SA.BasicAuth, SA.JWT] SafeUser :> BaseAPI type API = Auth '[SA.BasicAuth, SA.JWT] SafeUser :> BaseAPI
type BaseAPI = "books" :> Get '[JSON] [JsonBook] type BaseAPI = "books" :> Get '[JSON] [JsonBook]
-- :<|> "books" :> ReqBody '[JSON] JsonBook :> PUT JsonBook :<|> "books" :> ReqBody '[JSON] PostBook :> Post '[JSON] JsonBook
-- :<|> "books" :> Param "book_id" BookID :> ReqBody '[JSON] JsonBook :> PUT 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 :: 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 :: AuthResult SafeUser -> AppM [JsonBook]
listBooksHandler = requireLoggedIn $ \user -> do listBooksHandler = requireLoggedIn $ \user -> do
@ -51,4 +72,4 @@ listBooksHandler = requireLoggedIn $ \user -> do
where where
augment Book{identifier=bookId,..} = do augment Book{identifier=bookId,..} = do
channels <- fmap (\Channel{..} -> JsonChannel{..}) <$> booksChannels bookId channels <- fmap (\Channel{..} -> JsonChannel{..}) <$> booksChannels bookId
pure JsonBook{..} pure JsonBook{identifier=bookId,..}

View File

@ -1,13 +1,19 @@
{-# Language TypeApplications #-} {-# Language TypeApplications #-}
{-# Language DataKinds #-} {-# Language DataKinds #-}
module Database.Book (usersBooks, Book(..)) where module Database.Book
( def
, insertBook
, usersBooks
, Book(..)
, BookID) where
import ClassyPrelude import ClassyPrelude
import Database.Schema import Database.Schema
import Database import Database
import Database.Selda 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 usersBooks username = fromRels <$> query q
where where
q = do q = do
@ -19,3 +25,14 @@ usersBooks username = fromRels <$> query q
restrict (userId .== userId') restrict (userId .== userId')
return book 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

View File

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