ihp-ide-1.5.0: Test/SchemaCompilerSpec.hs
{-|
Module: Test.SchemaCompilerSpec
Copyright: (c) digitally induced GmbH, 2020
-}
module Test.SchemaCompilerSpec where
import Test.Hspec
import IHP.Prelude
import IHP.SchemaCompiler
import IHP.Postgres.Types
import qualified Data.Text as Text
import Test.IDE.SchemaDesigner.ParserSpec (parseSqlStatements)
tests = do
describe "SchemaCompiler" do
describe "compileEnumDataDefinitions" do
it "should deal with enum values that have spaces" do
let statement = CreateEnumType { name = "mood", values = ["happy", "very happy", "sad", "very sad"] }
let output = compileStatementPreview [statement] statement |> Text.strip
output `shouldBe` [trimming|
data Mood = Happy | VeryHappy | Sad | VerySad deriving (Eq, Show, Read, Enum, Bounded, Ord)
instance FromField Mood where
fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "happy") = pure Happy
fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "very happy") = pure VeryHappy
fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "sad") = pure Sad
fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "very sad") = pure VerySad
fromField field (Just value) = returnError ConversionFailed field ("Unexpected value for enum value. Got: " <> Data.String.Conversions.cs value)
fromField field Nothing = returnError UnexpectedNull field "Unexpected null for enum value"
instance Default Mood where def = Happy
instance ToField Mood where
toField Happy = toField ("happy" :: Text)
toField VeryHappy = toField ("very happy" :: Text)
toField Sad = toField ("sad" :: Text)
toField VerySad = toField ("very sad" :: Text)
instance InputValue Mood where
inputValue Happy = "happy" :: Text
inputValue VeryHappy = "very happy" :: Text
inputValue Sad = "sad" :: Text
inputValue VerySad = "very sad" :: Text
instance DeepSeq.NFData Mood where rnf a = seq a ()
instance IHP.Controller.Param.ParamReader Mood where readParameter = IHP.Controller.Param.enumParamReader; readParameterJSON = IHP.Controller.Param.enumParamReaderJSON
textToEnumMoodMap :: HashMap.HashMap Text Mood
textToEnumMoodMap = HashMap.fromList [("happy", Happy), ("very happy", VeryHappy), ("sad", Sad), ("very sad", VerySad)]
textToEnumMood :: Text -> Maybe Mood
textToEnumMood t = HashMap.lookup t textToEnumMoodMap
instance Hasql.Implicits.Encoders.DefaultParamEncoder Mood where
defaultParam = Hasql.Encoders.nonNullable (Hasql.Encoders.enum (Just "public") "mood" inputValue)
instance Hasql.Implicits.Encoders.DefaultParamEncoder (Maybe Mood) where
defaultParam = Hasql.Encoders.nullable (Hasql.Encoders.enum (Just "public") "mood" inputValue)
instance Hasql.Implicits.Encoders.DefaultParamEncoder [Mood] where
defaultParam = Hasql.Encoders.nonNullable $ Hasql.Encoders.foldableArray $ Hasql.Encoders.nonNullable (Hasql.Encoders.enum (Just "public") "mood" inputValue)
instance Mapping.IsScalar Mood where
encoder = Hasql.Encoders.enum (Just "public") "mood" inputValue
decoder = Hasql.Decoders.enum (Just "public") "mood" textToEnumMood
|]
it "should deal with enums that have no values" do
-- https://github.com/digitallyinduced/ihp/issues/1026
-- Empty enums typically happen when an enum was just created in the schema designer and no value has been added yet by the user
let statement = CreateEnumType { name = "mood", values = [] }
let output = compileStatementPreview [statement] statement |> Text.strip
-- We don't generate anything when no values are defined as there's nothing you could do with the enum yet
-- An empty data declaration is not really useful in this case
output `shouldBe` mempty
it "should not pluralize values" do
-- See https://github.com/digitallyinduced/ihp/issues/767
let statement = CreateEnumType { name = "Province", values = ["Alberta", "BritishColumbia", "Saskatchewan", "Manitoba", "Ontario", "Quebec", "NovaScotia", "NewBrunswick", "PrinceEdwardIsland", "NewfoundlandAndLabrador"] }
let output = compileStatementPreview [statement] statement |> Text.strip
output `shouldBe` [trimming|
data Province = Alberta | Britishcolumbia | Saskatchewan | Manitoba | Ontario | Quebec | Novascotia | Newbrunswick | Princeedwardisland | Newfoundlandandlabrador deriving (Eq, Show, Read, Enum, Bounded, Ord)
instance FromField Province where
fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "Alberta") = pure Alberta
fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "BritishColumbia") = pure Britishcolumbia
fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "Saskatchewan") = pure Saskatchewan
fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "Manitoba") = pure Manitoba
fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "Ontario") = pure Ontario
fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "Quebec") = pure Quebec
fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "NovaScotia") = pure Novascotia
fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "NewBrunswick") = pure Newbrunswick
fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "PrinceEdwardIsland") = pure Princeedwardisland
fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "NewfoundlandAndLabrador") = pure Newfoundlandandlabrador
fromField field (Just value) = returnError ConversionFailed field ("Unexpected value for enum value. Got: " <> Data.String.Conversions.cs value)
fromField field Nothing = returnError UnexpectedNull field "Unexpected null for enum value"
instance Default Province where def = Alberta
instance ToField Province where
toField Alberta = toField ("Alberta" :: Text)
toField Britishcolumbia = toField ("BritishColumbia" :: Text)
toField Saskatchewan = toField ("Saskatchewan" :: Text)
toField Manitoba = toField ("Manitoba" :: Text)
toField Ontario = toField ("Ontario" :: Text)
toField Quebec = toField ("Quebec" :: Text)
toField Novascotia = toField ("NovaScotia" :: Text)
toField Newbrunswick = toField ("NewBrunswick" :: Text)
toField Princeedwardisland = toField ("PrinceEdwardIsland" :: Text)
toField Newfoundlandandlabrador = toField ("NewfoundlandAndLabrador" :: Text)
instance InputValue Province where
inputValue Alberta = "Alberta" :: Text
inputValue Britishcolumbia = "BritishColumbia" :: Text
inputValue Saskatchewan = "Saskatchewan" :: Text
inputValue Manitoba = "Manitoba" :: Text
inputValue Ontario = "Ontario" :: Text
inputValue Quebec = "Quebec" :: Text
inputValue Novascotia = "NovaScotia" :: Text
inputValue Newbrunswick = "NewBrunswick" :: Text
inputValue Princeedwardisland = "PrinceEdwardIsland" :: Text
inputValue Newfoundlandandlabrador = "NewfoundlandAndLabrador" :: Text
instance DeepSeq.NFData Province where rnf a = seq a ()
instance IHP.Controller.Param.ParamReader Province where readParameter = IHP.Controller.Param.enumParamReader; readParameterJSON = IHP.Controller.Param.enumParamReaderJSON
textToEnumProvinceMap :: HashMap.HashMap Text Province
textToEnumProvinceMap = HashMap.fromList [("Alberta", Alberta), ("BritishColumbia", Britishcolumbia), ("Saskatchewan", Saskatchewan), ("Manitoba", Manitoba), ("Ontario", Ontario), ("Quebec", Quebec), ("NovaScotia", Novascotia), ("NewBrunswick", Newbrunswick), ("PrinceEdwardIsland", Princeedwardisland), ("NewfoundlandAndLabrador", Newfoundlandandlabrador)]
textToEnumProvince :: Text -> Maybe Province
textToEnumProvince t = HashMap.lookup t textToEnumProvinceMap
instance Hasql.Implicits.Encoders.DefaultParamEncoder Province where
defaultParam = Hasql.Encoders.nonNullable (Hasql.Encoders.enum (Just "public") "province" inputValue)
instance Hasql.Implicits.Encoders.DefaultParamEncoder (Maybe Province) where
defaultParam = Hasql.Encoders.nullable (Hasql.Encoders.enum (Just "public") "province" inputValue)
instance Hasql.Implicits.Encoders.DefaultParamEncoder [Province] where
defaultParam = Hasql.Encoders.nonNullable $ Hasql.Encoders.foldableArray $ Hasql.Encoders.nonNullable (Hasql.Encoders.enum (Just "public") "province" inputValue)
instance Mapping.IsScalar Province where
encoder = Hasql.Encoders.enum (Just "public") "province" inputValue
decoder = Hasql.Decoders.enum (Just "public") "province" textToEnumProvince
|]
it "should deal with duplicate enum values" do
let enum1 = CreateEnumType { name = "property_type", values = ["APARTMENT", "HOUSE"] }
let enum2 = CreateEnumType { name = "apartment_type", values = ["LOFT", "APARTMENT"] }
let output = compileStatementPreview [enum1, enum2] enum1 |> Text.strip
output `shouldBe` [trimming|
data PropertyType = PropertyTypeApartment | House deriving (Eq, Show, Read, Enum, Bounded, Ord)
instance FromField PropertyType where
fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "APARTMENT") = pure PropertyTypeApartment
fromField field (Just value) | value == (Data.Text.Encoding.encodeUtf8 "HOUSE") = pure House
fromField field (Just value) = returnError ConversionFailed field ("Unexpected value for enum value. Got: " <> Data.String.Conversions.cs value)
fromField field Nothing = returnError UnexpectedNull field "Unexpected null for enum value"
instance Default PropertyType where def = PropertyTypeApartment
instance ToField PropertyType where
toField PropertyTypeApartment = toField ("APARTMENT" :: Text)
toField House = toField ("HOUSE" :: Text)
instance InputValue PropertyType where
inputValue PropertyTypeApartment = "APARTMENT" :: Text
inputValue House = "HOUSE" :: Text
instance DeepSeq.NFData PropertyType where rnf a = seq a ()
instance IHP.Controller.Param.ParamReader PropertyType where readParameter = IHP.Controller.Param.enumParamReader; readParameterJSON = IHP.Controller.Param.enumParamReaderJSON
textToEnumPropertyTypeMap :: HashMap.HashMap Text PropertyType
textToEnumPropertyTypeMap = HashMap.fromList [("APARTMENT", PropertyTypeApartment), ("HOUSE", House)]
textToEnumPropertyType :: Text -> Maybe PropertyType
textToEnumPropertyType t = HashMap.lookup t textToEnumPropertyTypeMap
instance Hasql.Implicits.Encoders.DefaultParamEncoder PropertyType where
defaultParam = Hasql.Encoders.nonNullable (Hasql.Encoders.enum (Just "public") "property_type" inputValue)
instance Hasql.Implicits.Encoders.DefaultParamEncoder (Maybe PropertyType) where
defaultParam = Hasql.Encoders.nullable (Hasql.Encoders.enum (Just "public") "property_type" inputValue)
instance Hasql.Implicits.Encoders.DefaultParamEncoder [PropertyType] where
defaultParam = Hasql.Encoders.nonNullable $ Hasql.Encoders.foldableArray $ Hasql.Encoders.nonNullable (Hasql.Encoders.enum (Just "public") "property_type" inputValue)
instance Mapping.IsScalar PropertyType where
encoder = Hasql.Encoders.enum (Just "public") "property_type" inputValue
decoder = Hasql.Decoders.enum (Just "public") "property_type" textToEnumPropertyType
|]
describe "compileCreate" do
let statement = StatementCreateTable $ (table "users") {
columns = [ col "id" PUUID ],
primaryKeyConstraint = PrimaryKeyConstraint ["id"]
}
let compileOutput = compileStatementPreview [statement] statement |> Text.strip
it "should compile CanCreate instance with sqlQuery" $ \statement -> do
getInstanceDecl "CanCreate" compileOutput `shouldBe` [trimming|
instance CanCreate Generated.ActualTypes.User where
create = createUser
createMany = createManyUser
createRecordDiscardResult = createRecordDiscardResultUser
|]
it "should compile CanUpdate instance with sqlQuery" $ \statement -> do
getInstanceDecl "CanUpdate" compileOutput `shouldBe` [trimming|
instance CanUpdate Generated.ActualTypes.User where
updateRecord = updateRecordUser
updateRecordDiscardResult = updateRecordDiscardResultUser
|]
it "should compile CanUpdate instance with an array type with an explicit cast" do
let statement = StatementCreateTable $ (table "users") {
columns = [ (col "id" PUUID) { notNull = True, isUnique = True }, col "ids" (PArray PUUID)],
primaryKeyConstraint = PrimaryKeyConstraint ["id"]
}
let compileOutput = compileStatementPreview [statement] statement |> Text.strip
getInstanceDecl "CanUpdate" compileOutput `shouldBe` [trimming|
instance CanUpdate Generated.ActualTypes.User where
updateRecord = updateRecordUser
updateRecordDiscardResult = updateRecordDiscardResultUser
|]
it "should deal with double default values" do
let statement = StatementCreateTable (table "users")
{ columns =
[ (col "id" PUUID) { notNull = True, isUnique = True }
, col "ids" (PArray PUUID)
, (col "electricity_unit_price" PDouble) { defaultValue = Just (TypeCastExpression (DoubleExpression 0.17) PDouble), notNull = True }
]
, primaryKeyConstraint = PrimaryKeyConstraint ["id"]
}
let compileOutput = compileStatementPreview [statement] statement |> Text.strip
compileOutput `shouldBe` [trimming|
data User' = User {id :: (Id' "users"), ids :: (Maybe [UUID]), electricityUnitPrice :: Double, meta :: MetaBag} deriving (Eq, Show)
type instance PrimaryKey "users" = UUID
type User = User'
type instance GetTableName (User') = "users"
type instance GetModelByTableName "users" = User
instance Default (Id' "users") where def = Id def
instance IHP.ModelSupport.Table (User') where
tableName = "users"
columnNames = ["id","ids","electricity_unit_price"]
primaryKeyColumnNames = ["id"]
instance InputValue Generated.ActualTypes.User where inputValue = IHP.ModelSupport.recordToInputValue
instance FromRow Generated.ActualTypes.User where
fromRow = do
id <- field
ids <- field
electricityUnitPrice <- field
let theRecord = Generated.ActualTypes.User id ids electricityUnitPrice def { originalDatabaseRecord = Just (Data.Dynamic.toDyn theRecord) }
pure theRecord
instance FromRowHasql Generated.ActualTypes.User where
hasqlRowDecoder = Generated.Statements.RowDecoderUser.rowDecoder
type instance GetModelName (User') = "User"
instance CanCreate Generated.ActualTypes.User where
create = createUser
createMany = createManyUser
createRecordDiscardResult = createRecordDiscardResultUser
createUser :: (?modelContext :: ModelContext) => Generated.ActualTypes.User -> IO Generated.ActualTypes.User
createUser model = do
let pool = ?modelContext.hasqlPool
let touched = model.meta.touchedFields
sqlStatementHasql pool model (Generated.Statements.CreateUser.statement touched)
createManyUser :: (?modelContext :: ModelContext) => [Generated.ActualTypes.User] -> IO [Generated.ActualTypes.User]
createManyUser [] = pure []
createManyUser models = do
let pool = ?modelContext.hasqlPool
sqlStatementHasql pool models (Generated.Statements.CreateManyUser.statement (List.length models))
createRecordDiscardResultUser :: (?modelContext :: ModelContext) => Generated.ActualTypes.User -> IO ()
createRecordDiscardResultUser model = do
let pool = ?modelContext.hasqlPool
let touched = model.meta.touchedFields
sqlStatementHasql pool model (Generated.Statements.CreateUser.discardResultStatement touched)
instance CanUpdate Generated.ActualTypes.User where
updateRecord = updateRecordUser
updateRecordDiscardResult = updateRecordDiscardResultUser
updateRecordUser :: (?modelContext :: ModelContext) => Generated.ActualTypes.User -> IO Generated.ActualTypes.User
updateRecordUser model = do
let touched = model.meta.touchedFields
if touched == 0 then pure model else do
let pool = ?modelContext.hasqlPool
sqlStatementHasql pool model (Generated.Statements.UpdateUser.statement touched)
updateRecordDiscardResultUser :: (?modelContext :: ModelContext) => Generated.ActualTypes.User -> IO ()
updateRecordDiscardResultUser model = do
let touched = model.meta.touchedFields
unless (touched == 0) $ do
let pool = ?modelContext.hasqlPool
sqlStatementHasql pool model (Generated.Statements.UpdateUser.discardResultStatement touched)
instance Record Generated.ActualTypes.User where
{-# INLINE newRecord #-}
newRecord = Generated.ActualTypes.User def def 0.17 def
instance QueryBuilder.FilterPrimaryKey "users" where
filterWhereId id builder =
builder |> QueryBuilder.filterWhere (#id, id)
{-# INLINE filterWhereId #-}
instance FieldBit "id" (User') where fieldBit = 1
instance FieldBit "ids" (User') where fieldBit = 2
instance FieldBit "electricityUnitPrice" (User') where fieldBit = 4
|]
it "should deal with integer default values for double columns" do
let statement = StatementCreateTable (table "users")
{ columns =
[ (col "id" PUUID) { notNull = True, isUnique = True }
, col "ids" (PArray PUUID)
, (col "electricity_unit_price" PDouble) { defaultValue = Just (IntExpression 0), notNull = True }
]
, primaryKeyConstraint = PrimaryKeyConstraint ["id"]
}
let compileOutput = compileStatementPreview [statement] statement |> Text.strip
compileOutput `shouldBe` [trimming|
data User' = User {id :: (Id' "users"), ids :: (Maybe [UUID]), electricityUnitPrice :: Double, meta :: MetaBag} deriving (Eq, Show)
type instance PrimaryKey "users" = UUID
type User = User'
type instance GetTableName (User') = "users"
type instance GetModelByTableName "users" = User
instance Default (Id' "users") where def = Id def
instance IHP.ModelSupport.Table (User') where
tableName = "users"
columnNames = ["id","ids","electricity_unit_price"]
primaryKeyColumnNames = ["id"]
instance InputValue Generated.ActualTypes.User where inputValue = IHP.ModelSupport.recordToInputValue
instance FromRow Generated.ActualTypes.User where
fromRow = do
id <- field
ids <- field
electricityUnitPrice <- field
let theRecord = Generated.ActualTypes.User id ids electricityUnitPrice def { originalDatabaseRecord = Just (Data.Dynamic.toDyn theRecord) }
pure theRecord
instance FromRowHasql Generated.ActualTypes.User where
hasqlRowDecoder = Generated.Statements.RowDecoderUser.rowDecoder
type instance GetModelName (User') = "User"
instance CanCreate Generated.ActualTypes.User where
create = createUser
createMany = createManyUser
createRecordDiscardResult = createRecordDiscardResultUser
createUser :: (?modelContext :: ModelContext) => Generated.ActualTypes.User -> IO Generated.ActualTypes.User
createUser model = do
let pool = ?modelContext.hasqlPool
let touched = model.meta.touchedFields
sqlStatementHasql pool model (Generated.Statements.CreateUser.statement touched)
createManyUser :: (?modelContext :: ModelContext) => [Generated.ActualTypes.User] -> IO [Generated.ActualTypes.User]
createManyUser [] = pure []
createManyUser models = do
let pool = ?modelContext.hasqlPool
sqlStatementHasql pool models (Generated.Statements.CreateManyUser.statement (List.length models))
createRecordDiscardResultUser :: (?modelContext :: ModelContext) => Generated.ActualTypes.User -> IO ()
createRecordDiscardResultUser model = do
let pool = ?modelContext.hasqlPool
let touched = model.meta.touchedFields
sqlStatementHasql pool model (Generated.Statements.CreateUser.discardResultStatement touched)
instance CanUpdate Generated.ActualTypes.User where
updateRecord = updateRecordUser
updateRecordDiscardResult = updateRecordDiscardResultUser
updateRecordUser :: (?modelContext :: ModelContext) => Generated.ActualTypes.User -> IO Generated.ActualTypes.User
updateRecordUser model = do
let touched = model.meta.touchedFields
if touched == 0 then pure model else do
let pool = ?modelContext.hasqlPool
sqlStatementHasql pool model (Generated.Statements.UpdateUser.statement touched)
updateRecordDiscardResultUser :: (?modelContext :: ModelContext) => Generated.ActualTypes.User -> IO ()
updateRecordDiscardResultUser model = do
let touched = model.meta.touchedFields
unless (touched == 0) $ do
let pool = ?modelContext.hasqlPool
sqlStatementHasql pool model (Generated.Statements.UpdateUser.discardResultStatement touched)
instance Record Generated.ActualTypes.User where
{-# INLINE newRecord #-}
newRecord = Generated.ActualTypes.User def def 0 def
instance QueryBuilder.FilterPrimaryKey "users" where
filterWhereId id builder =
builder |> QueryBuilder.filterWhere (#id, id)
{-# INLINE filterWhereId #-}
instance FieldBit "id" (User') where fieldBit = 1
instance FieldBit "ids" (User') where fieldBit = 2
instance FieldBit "electricityUnitPrice" (User') where fieldBit = 4
|]
it "should not touch GENERATED columns" do
let statement = StatementCreateTable (table "users")
{ columns =
[ (col "id" PUUID) { notNull = True, isUnique = True }
, (col "ts" PTSVector) { notNull = True, generator = Just (ColumnGenerator { generate = VarExpression "someResult", stored = False }) }
]
, primaryKeyConstraint = PrimaryKeyConstraint ["id"]
}
let compileOutput = compileStatementPreview [statement] statement |> Text.strip
compileOutput `shouldBe` [trimming|
data User' = User {id :: (Id' "users"), ts :: (Maybe Tsvector), meta :: MetaBag} deriving (Eq, Show)
type instance PrimaryKey "users" = UUID
type User = User'
type instance GetTableName (User') = "users"
type instance GetModelByTableName "users" = User
instance Default (Id' "users") where def = Id def
instance IHP.ModelSupport.Table (User') where
tableName = "users"
columnNames = ["id","ts"]
primaryKeyColumnNames = ["id"]
instance InputValue Generated.ActualTypes.User where inputValue = IHP.ModelSupport.recordToInputValue
instance FromRow Generated.ActualTypes.User where
fromRow = do
id <- field
ts <- field
let theRecord = Generated.ActualTypes.User id ts def { originalDatabaseRecord = Just (Data.Dynamic.toDyn theRecord) }
pure theRecord
instance FromRowHasql Generated.ActualTypes.User where
hasqlRowDecoder = Generated.Statements.RowDecoderUser.rowDecoder
type instance GetModelName (User') = "User"
instance CanCreate Generated.ActualTypes.User where
create = createUser
createMany = createManyUser
createRecordDiscardResult = createRecordDiscardResultUser
createUser :: (?modelContext :: ModelContext) => Generated.ActualTypes.User -> IO Generated.ActualTypes.User
createUser model = do
let pool = ?modelContext.hasqlPool
sqlStatementHasql pool model Generated.Statements.CreateUser.statement
createManyUser :: (?modelContext :: ModelContext) => [Generated.ActualTypes.User] -> IO [Generated.ActualTypes.User]
createManyUser [] = pure []
createManyUser models = do
let pool = ?modelContext.hasqlPool
sqlStatementHasql pool models (Generated.Statements.CreateManyUser.statement (List.length models))
createRecordDiscardResultUser :: (?modelContext :: ModelContext) => Generated.ActualTypes.User -> IO ()
createRecordDiscardResultUser model = do
let pool = ?modelContext.hasqlPool
sqlStatementHasql pool model Generated.Statements.CreateUser.discardResultStatement
instance CanUpdate Generated.ActualTypes.User where
updateRecord = updateRecordUser
updateRecordDiscardResult = updateRecordDiscardResultUser
updateRecordUser :: (?modelContext :: ModelContext) => Generated.ActualTypes.User -> IO Generated.ActualTypes.User
updateRecordUser model = do
let touched = model.meta.touchedFields
if touched == 0 then pure model else do
let pool = ?modelContext.hasqlPool
sqlStatementHasql pool model (Generated.Statements.UpdateUser.statement touched)
updateRecordDiscardResultUser :: (?modelContext :: ModelContext) => Generated.ActualTypes.User -> IO ()
updateRecordDiscardResultUser model = do
let touched = model.meta.touchedFields
unless (touched == 0) $ do
let pool = ?modelContext.hasqlPool
sqlStatementHasql pool model (Generated.Statements.UpdateUser.discardResultStatement touched)
instance Record Generated.ActualTypes.User where
{-# INLINE newRecord #-}
newRecord = Generated.ActualTypes.User def def def
instance QueryBuilder.FilterPrimaryKey "users" where
filterWhereId id builder =
builder |> QueryBuilder.filterWhere (#id, id)
{-# INLINE filterWhereId #-}
instance FieldBit "id" (User') where fieldBit = 1
instance FieldBit "ts" (User') where fieldBit = 2
|]
it "should handle tablets with generated columns" do
let statement = StatementCreateTable CreateTable
{ name = "posts"
, columns =
[ (col "id" PUUID) { notNull = True, isUnique = True }
, (col "title" PText) { notNull = True }
, (col "body" PText) { notNull = True }
, (col "body_index_col" PTSVector) { generator = Just (ColumnGenerator { generate = CallExpression "to_tsvector" [TextExpression "english", CallExpression "coalesce" [VarExpression "body", TextExpression ""]], stored = True }) }
]
, primaryKeyConstraint = PrimaryKeyConstraint ["id"]
, constraints = []
, unlogged = False
, inherits = Nothing
}
let compileOutput = compileStatementPreview [statement] statement |> Text.strip
-- The key point: RETURNING clause should include body_index_col even though it's generated
getInstanceDecl "CanCreate" compileOutput `shouldBe` [trimming|
instance CanCreate Generated.ActualTypes.Post where
create = createPost
createMany = createManyPost
createRecordDiscardResult = createRecordDiscardResultPost
|]
getInstanceDecl "CanUpdate" compileOutput `shouldBe` [trimming|
instance CanUpdate Generated.ActualTypes.Post where
updateRecord = updateRecordPost
updateRecordDiscardResult = updateRecordDiscardResultPost
|]
it "should deal with multiple has many relationships to the same table" do
let statements = parseSqlStatements [trimming|
CREATE TABLE landing_pages (
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL
);
CREATE TABLE paragraph_ctas (
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
landing_page_id UUID NOT NULL,
to_landing_page_id UUID NOT NULL
);
ALTER TABLE paragraph_ctas ADD CONSTRAINT paragraph_ctas_ref_landing_page_id FOREIGN KEY (landing_page_id) REFERENCES landing_pages (id) ON DELETE NO ACTION;
ALTER TABLE paragraph_ctas ADD CONSTRAINT paragraph_ctas_ref_to_landing_page_id FOREIGN KEY (to_landing_page_id) REFERENCES landing_pages (id) ON DELETE NO ACTION;
|]
let
isTargetTable :: Statement -> Bool
isTargetTable (StatementCreateTable CreateTable { name }) = name == "landing_pages"
isTargetTable otherwise = False
let (Just statement) = find isTargetTable statements
let compileOutput = compileStatementPreview statements statement |> Text.strip
compileOutput `shouldBe` [trimming|
data LandingPage' paragraphCtasLandingPages paragraphCtasToLandingPages = LandingPage {id :: (Id' "landing_pages"), paragraphCtasLandingPages :: paragraphCtasLandingPages, paragraphCtasToLandingPages :: paragraphCtasToLandingPages, meta :: MetaBag} deriving (Eq, Show)
type instance PrimaryKey "landing_pages" = UUID
type LandingPage = LandingPage' (QueryBuilder.QueryBuilder "paragraph_ctas") (QueryBuilder.QueryBuilder "paragraph_ctas")
type instance GetTableName (LandingPage' _ _) = "landing_pages"
type instance GetModelByTableName "landing_pages" = LandingPage
instance Default (Id' "landing_pages") where def = Id def
instance IHP.ModelSupport.Table (LandingPage' paragraphCtasLandingPages paragraphCtasToLandingPages) where
tableName = "landing_pages"
columnNames = ["id"]
primaryKeyColumnNames = ["id"]
instance InputValue Generated.ActualTypes.LandingPage where inputValue = IHP.ModelSupport.recordToInputValue
instance FromRow Generated.ActualTypes.LandingPage where
fromRow = do
id <- field
let theRecord = Generated.ActualTypes.LandingPage id (QueryBuilder.filterWhere (#landingPageId, id) (QueryBuilder.query @ParagraphCta)) (QueryBuilder.filterWhere (#toLandingPageId, id) (QueryBuilder.query @ParagraphCta)) def { originalDatabaseRecord = Just (Data.Dynamic.toDyn theRecord) }
pure theRecord
instance FromRowHasql Generated.ActualTypes.LandingPage where
hasqlRowDecoder = Generated.Statements.RowDecoderLandingPage.rowDecoder
type instance GetModelName (LandingPage' _ _) = "LandingPage"
instance CanCreate Generated.ActualTypes.LandingPage where
create = createLandingPage
createMany = createManyLandingPage
createRecordDiscardResult = createRecordDiscardResultLandingPage
createLandingPage :: (?modelContext :: ModelContext) => Generated.ActualTypes.LandingPage -> IO Generated.ActualTypes.LandingPage
createLandingPage model = do
let pool = ?modelContext.hasqlPool
let touched = model.meta.touchedFields
sqlStatementHasql pool model (Generated.Statements.CreateLandingPage.statement touched)
createManyLandingPage :: (?modelContext :: ModelContext) => [Generated.ActualTypes.LandingPage] -> IO [Generated.ActualTypes.LandingPage]
createManyLandingPage [] = pure []
createManyLandingPage models = do
let pool = ?modelContext.hasqlPool
sqlStatementHasql pool models (Generated.Statements.CreateManyLandingPage.statement (List.length models))
createRecordDiscardResultLandingPage :: (?modelContext :: ModelContext) => Generated.ActualTypes.LandingPage -> IO ()
createRecordDiscardResultLandingPage model = do
let pool = ?modelContext.hasqlPool
let touched = model.meta.touchedFields
sqlStatementHasql pool model (Generated.Statements.CreateLandingPage.discardResultStatement touched)
instance CanUpdate Generated.ActualTypes.LandingPage where
updateRecord = updateRecordLandingPage
updateRecordDiscardResult = updateRecordDiscardResultLandingPage
updateRecordLandingPage :: (?modelContext :: ModelContext) => Generated.ActualTypes.LandingPage -> IO Generated.ActualTypes.LandingPage
updateRecordLandingPage model = do
let touched = model.meta.touchedFields
if touched == 0 then pure model else do
let pool = ?modelContext.hasqlPool
sqlStatementHasql pool model (Generated.Statements.UpdateLandingPage.statement touched)
updateRecordDiscardResultLandingPage :: (?modelContext :: ModelContext) => Generated.ActualTypes.LandingPage -> IO ()
updateRecordDiscardResultLandingPage model = do
let touched = model.meta.touchedFields
unless (touched == 0) $ do
let pool = ?modelContext.hasqlPool
sqlStatementHasql pool model (Generated.Statements.UpdateLandingPage.discardResultStatement touched)
instance Record Generated.ActualTypes.LandingPage where
{-# INLINE newRecord #-}
newRecord = Generated.ActualTypes.LandingPage def def def def
instance QueryBuilder.FilterPrimaryKey "landing_pages" where
filterWhereId id builder =
builder |> QueryBuilder.filterWhere (#id, id)
{-# INLINE filterWhereId #-}
instance FieldBit "id" (LandingPage' paragraphCtasLandingPages paragraphCtasToLandingPages) where fieldBit = 1
|]
it "should not use DEFAULT for array columns" do
let statement = StatementCreateTable (table "users")
{ columns =
[ (col "id" PUUID) { notNull = True, isUnique = True }
, (col "keywords" (PArray PText)) { defaultValue = Just (VarExpression "NULL") }
]
, primaryKeyConstraint = PrimaryKeyConstraint ["id"]
}
let compileOutput = compileStatementPreview [statement] statement |> Text.strip
getInstanceDecl "CanCreate" compileOutput `shouldBe` [trimming|
instance CanCreate Generated.ActualTypes.User where
create = createUser
createMany = createManyUser
createRecordDiscardResult = createRecordDiscardResultUser
|]
describe "compileStatementPreview for table with arbitrarily named primary key" do
let statements = parseSqlStatements [trimming|
CREATE TABLE things (
thing_arbitrary_ident UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL
);
CREATE TABLE others (
other_arbitrary_ident UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
thing_ref UUID NOT NULL
);
ALTER TABLE others ADD CONSTRAINT other_thing_refs FOREIGN KEY (thing_ref) REFERENCES things (thing_arbitrary_ident) ON DELETE NO ACTION;
|]
let
isTargetTable :: Statement -> Bool
isTargetTable (StatementCreateTable CreateTable { name }) = name == "things"
isTargetTable otherwise = False
let (Just statement) = find isTargetTable statements
let compileOutput = compileStatementPreview statements statement |> Text.strip
it "should compile CanCreate instance with sqlQuery" $ \statement -> do
getInstanceDecl "CanCreate" compileOutput `shouldBe` [trimming|
instance CanCreate Generated.ActualTypes.Thing where
create = createThing
createMany = createManyThing
createRecordDiscardResult = createRecordDiscardResultThing
|]
it "should compile CanUpdate instance with sqlQuery" $ \statement -> do
getInstanceDecl "CanUpdate" compileOutput `shouldBe` [trimming|
instance CanUpdate Generated.ActualTypes.Thing where
updateRecord = updateRecordThing
updateRecordDiscardResult = updateRecordDiscardResultThing
|]
it "should compile FromRow instance" $ \statement -> do
getInstanceDecl "FromRow" compileOutput `shouldBe` [trimming|
instance FromRow Generated.ActualTypes.Thing where
fromRow = do
thingArbitraryIdent <- field
let theRecord = Generated.ActualTypes.Thing thingArbitraryIdent (QueryBuilder.filterWhere (#thingRef, thingArbitraryIdent) (QueryBuilder.query @Other)) def { originalDatabaseRecord = Just (Data.Dynamic.toDyn theRecord) }
pure theRecord
|]
it "should compile Table instance" $ \statement -> do
getInstanceDecl "IHP.ModelSupport.Table" compileOutput `shouldBe` [trimming|
instance IHP.ModelSupport.Table (Thing' others) where
tableName = "things"
columnNames = ["thing_arbitrary_ident"]
primaryKeyColumnNames = ["thing_arbitrary_ident"]
|]
it "should compile QueryBuilder.FilterPrimaryKey instance" $ \statement -> do
getInstanceDecl "QueryBuilder.FilterPrimaryKey" compileOutput `shouldBe` [trimming|
instance QueryBuilder.FilterPrimaryKey "things" where
filterWhereId thingArbitraryIdent builder =
builder |> QueryBuilder.filterWhere (#thingArbitraryIdent, thingArbitraryIdent)
{-# INLINE filterWhereId #-}
|]
describe "compileStatementPreview for table with composite primary key" do
let statements = parseSqlStatements [trimming|
CREATE TABLE bits (
bit_arbitrary_ident UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL
);
CREATE TABLE parts (
part_arbitrary_ident UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL
);
CREATE TABLE bit_part_refs (
bit_ref UUID NOT NULL,
part_ref UUID NOT NULL,
PRIMARY KEY(bit_ref, part_ref)
);
ALTER TABLE bit_part_refs ADD CONSTRAINT bit_part_bit_refs FOREIGN KEY (bit_ref) REFERENCES bits (bit_arbitrary_ident) ON DELETE NO ACTION;
ALTER TABLE bit_part_refs ADD CONSTRAINT bit_part_part_refs FOREIGN KEY (part_ref) REFERENCES parts (part_arbitrary_ident) ON DELETE NO ACTION;
|]
let
isNamedTable :: Text -> Statement -> Bool
isNamedTable targetName (StatementCreateTable CreateTable { name }) = name == targetName
isNamedTable _ _ = False
let (Just statement) = find (isNamedTable "bit_part_refs") statements
let compileOutput = compileStatementPreview statements statement |> Text.strip
it "should compile CanCreate instance with sqlQuery" $ \statement -> do
getInstanceDecl "CanCreate" compileOutput `shouldBe` [trimming|
instance CanCreate Generated.ActualTypes.BitPartRef where
create = createBitPartRef
createMany = createManyBitPartRef
createRecordDiscardResult = createRecordDiscardResultBitPartRef
|]
it "should compile CanUpdate instance with sqlQuery" $ \statement -> do
getInstanceDecl "CanUpdate" compileOutput `shouldBe` [trimming|
instance CanUpdate Generated.ActualTypes.BitPartRef where
updateRecord = updateRecordBitPartRef
updateRecordDiscardResult = updateRecordDiscardResultBitPartRef
|]
it "should compile FromRow instance" $ \statement -> do
getInstanceDecl "FromRow" compileOutput `shouldBe` [trimming|
instance FromRow Generated.ActualTypes.BitPartRef where
fromRow = do
bitRef <- field
partRef <- field
let theRecord = Generated.ActualTypes.BitPartRef bitRef partRef def { originalDatabaseRecord = Just (Data.Dynamic.toDyn theRecord) }
pure theRecord
|]
it "should compile Table instance" $ \statement -> do
getInstanceDecl "IHP.ModelSupport.Table" compileOutput `shouldBe` [trimming|
instance IHP.ModelSupport.Table (BitPartRef' bitRef partRef) where
tableName = "bit_part_refs"
columnNames = ["bit_ref","part_ref"]
primaryKeyColumnNames = ["bit_ref","part_ref"]
|]
it "should compile FromRow instance of table that references part of a composite key" $ \statement -> do
let (Just statement) = find (isNamedTable "parts") statements
let compileOutput = compileStatementPreview statements statement |> Text.strip
getInstanceDecl "FromRow" compileOutput `shouldBe` [trimming|
instance FromRow Generated.ActualTypes.Part where
fromRow = do
partArbitraryIdent <- field
let theRecord = Generated.ActualTypes.Part partArbitraryIdent (QueryBuilder.filterWhere (#partRef, partArbitraryIdent) (QueryBuilder.query @BitPartRef)) def { originalDatabaseRecord = Just (Data.Dynamic.toDyn theRecord) }
pure theRecord
|]
it "should compile QueryBuilder.FilterPrimaryKey instance" $ \statement -> do
getInstanceDecl "QueryBuilder.FilterPrimaryKey" compileOutput `shouldBe` [trimming|
instance QueryBuilder.FilterPrimaryKey "bit_part_refs" where
filterWhereId (Id (bitRef, partRef)) builder =
builder |> QueryBuilder.filterWhere (#bitRef, bitRef) |> QueryBuilder.filterWhere (#partRef, partRef)
{-# INLINE filterWhereId #-}
|]
describe "compileFilterPrimaryKeyInstance" do
it "should compile FilterPrimaryKey instance when primary key is called id" do
let statement = StatementCreateTable $ (table "things") {
columns = [ (col "id" PUUID) { notNull = True, isUnique = True } ],
primaryKeyConstraint = PrimaryKeyConstraint ["id"]
}
let compileOutput = compileStatementPreview [statement] statement |> Text.strip
getInstanceDecl "QueryBuilder.FilterPrimaryKey" compileOutput `shouldBe` [trimming|
instance QueryBuilder.FilterPrimaryKey "things" where
filterWhereId id builder =
builder |> QueryBuilder.filterWhere (#id, id)
{-# INLINE filterWhereId #-}
|]
describe "needsHasFieldId" do
let
isNamedTable :: Text -> Statement -> Bool
isNamedTable targetName (StatementCreateTable CreateTable { name }) = name == targetName
isNamedTable _ _ = False
it "should not generate HasField id for composite PK table with an id column" do
let statements = parseSqlStatements [trimming|
CREATE TABLE ideas_votes (
id INT NOT NULL,
idea_id UUID NOT NULL,
parent_id UUID NOT NULL,
PRIMARY KEY(idea_id, parent_id)
);
|]
let (Just statement) = find (isNamedTable "ideas_votes") statements
let compileOutput = compileStatementPreview statements statement |> Text.strip
-- Should NOT contain a generated HasField "id" instance since the table has a column named "id"
compileOutput `shouldNotSatisfy` (Text.isInfixOf "instance HasField \"id\"")
it "should not generate HasField id for single non-id PK table with an id column" do
let statements = parseSqlStatements [trimming|
CREATE TABLE things (
id INT NOT NULL,
code TEXT PRIMARY KEY NOT NULL
);
|]
let (Just statement) = find (isNamedTable "things") statements
let compileOutput = compileStatementPreview statements statement |> Text.strip
-- Should NOT contain a generated HasField "id" instance since the table has a column named "id"
compileOutput `shouldNotSatisfy` (Text.isInfixOf "instance HasField \"id\"")
it "should generate HasField id for composite PK table without an id column" do
let statements = parseSqlStatements [trimming|
CREATE TABLE bit_part_refs (
bit_ref UUID NOT NULL,
part_ref UUID NOT NULL,
PRIMARY KEY(bit_ref, part_ref)
);
|]
let (Just statement) = find (isNamedTable "bit_part_refs") statements
let compileOutput = compileStatementPreview statements statement |> Text.strip
-- Should contain a generated HasField "id" instance for the composite PK
compileOutput `shouldSatisfy` (Text.isInfixOf "instance HasField \"id\"")
describe "FK referencing non-PK column" do
it "should not generate type parameters or Include instances for non-PK FK columns" do
let statements = parseSqlStatements [trimming|
CREATE TABLE users (
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
email TEXT NOT NULL UNIQUE
);
CREATE TABLE logins (
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
user_email TEXT NOT NULL
);
ALTER TABLE logins ADD CONSTRAINT logins_ref_user_email FOREIGN KEY (user_email) REFERENCES users (email) ON DELETE NO ACTION;
|]
let
isTargetTable :: Text -> Statement -> Bool
isTargetTable targetName (StatementCreateTable CreateTable { name }) = name == targetName
isTargetTable _ _ = False
let (Just loginStatement) = find (isTargetTable "logins") statements
let compileOutput = compileStatementPreview statements loginStatement |> Text.strip
-- userEmail should be Text (not Id' "users"), and no type parameter for it
compileOutput `shouldSatisfy` ("userEmail :: Text" `Text.isInfixOf`)
-- Should NOT have Include instance for userEmail (since it's not a PK-based FK)
compileOutput `shouldSatisfy` (not . ("Include \"userEmail\"" `Text.isInfixOf`))
it "should not generate has-many QueryBuilder field on the referenced table for non-PK FK" do
let statements = parseSqlStatements [trimming|
CREATE TABLE users (
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
email TEXT NOT NULL UNIQUE
);
CREATE TABLE logins (
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
user_email TEXT NOT NULL
);
ALTER TABLE logins ADD CONSTRAINT logins_ref_user_email FOREIGN KEY (user_email) REFERENCES users (email) ON DELETE NO ACTION;
|]
let
isTargetTable :: Text -> Statement -> Bool
isTargetTable targetName (StatementCreateTable CreateTable { name }) = name == targetName
isTargetTable _ _ = False
let (Just userStatement) = find (isTargetTable "users") statements
let compileOutput = compileStatementPreview statements userStatement |> Text.strip
-- Users table should NOT have a has-many logins Include instance
compileOutput `shouldSatisfy` (not . ("Include \"logins\"" `Text.isInfixOf`))
describe "simple mode (compileRelationSupport = False)" do
let simpleOptions = previewCompilerOptions { compileRelationSupport = False }
it "should produce no type parameters and no QueryBuilder fields for a table with FK and has-many relations" do
let statements = parseSqlStatements [trimming|
CREATE TABLE users (
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL
);
CREATE TABLE posts (
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
title TEXT NOT NULL,
user_id UUID NOT NULL
);
CREATE TABLE comments (
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
post_id UUID NOT NULL,
body TEXT NOT NULL
);
ALTER TABLE posts ADD CONSTRAINT posts_ref_user_id FOREIGN KEY (user_id) REFERENCES users (id) ON DELETE NO ACTION;
ALTER TABLE comments ADD CONSTRAINT comments_ref_post_id FOREIGN KEY (post_id) REFERENCES posts (id) ON DELETE NO ACTION;
|]
let
isTargetTable :: Text -> Statement -> Bool
isTargetTable targetName (StatementCreateTable CreateTable { name }) = name == targetName
isTargetTable _ _ = False
let (Just postStatement) = find (isTargetTable "posts") statements
let compileOutput = compileStatementPreviewWith simpleOptions statements postStatement |> Text.strip
-- data Post' has no type parameters, no QueryBuilder field, and userId has concrete type
compileOutput `shouldBe` [trimming|
data Post' = Post {id :: (Id' "posts"), title :: Text, userId :: (Id' "users"), meta :: MetaBag} deriving (Eq, Show)
type instance PrimaryKey "posts" = UUID
type Post = Post'
type instance GetTableName (Post') = "posts"
type instance GetModelByTableName "posts" = Post
instance Default (Id' "posts") where def = Id def
instance IHP.ModelSupport.Table (Post') where
tableName = "posts"
columnNames = ["id","title","user_id"]
primaryKeyColumnNames = ["id"]
instance InputValue Generated.ActualTypes.Post where inputValue = IHP.ModelSupport.recordToInputValue
instance FromRow Generated.ActualTypes.Post where
fromRow = do
id <- field
title <- field
userId <- field
let theRecord = Generated.ActualTypes.Post id title userId def { originalDatabaseRecord = Just (Data.Dynamic.toDyn theRecord) }
pure theRecord
instance FromRowHasql Generated.ActualTypes.Post where
hasqlRowDecoder = Generated.Statements.RowDecoderPost.rowDecoder
type instance GetModelName (Post') = "Post"
instance CanCreate Generated.ActualTypes.Post where
create = createPost
createMany = createManyPost
createRecordDiscardResult = createRecordDiscardResultPost
createPost :: (?modelContext :: ModelContext) => Generated.ActualTypes.Post -> IO Generated.ActualTypes.Post
createPost model = do
let pool = ?modelContext.hasqlPool
let touched = model.meta.touchedFields
sqlStatementHasql pool model (Generated.Statements.CreatePost.statement touched)
createManyPost :: (?modelContext :: ModelContext) => [Generated.ActualTypes.Post] -> IO [Generated.ActualTypes.Post]
createManyPost [] = pure []
createManyPost models = do
let pool = ?modelContext.hasqlPool
sqlStatementHasql pool models (Generated.Statements.CreateManyPost.statement (List.length models))
createRecordDiscardResultPost :: (?modelContext :: ModelContext) => Generated.ActualTypes.Post -> IO ()
createRecordDiscardResultPost model = do
let pool = ?modelContext.hasqlPool
let touched = model.meta.touchedFields
sqlStatementHasql pool model (Generated.Statements.CreatePost.discardResultStatement touched)
instance CanUpdate Generated.ActualTypes.Post where
updateRecord = updateRecordPost
updateRecordDiscardResult = updateRecordDiscardResultPost
updateRecordPost :: (?modelContext :: ModelContext) => Generated.ActualTypes.Post -> IO Generated.ActualTypes.Post
updateRecordPost model = do
let touched = model.meta.touchedFields
if touched == 0 then pure model else do
let pool = ?modelContext.hasqlPool
sqlStatementHasql pool model (Generated.Statements.UpdatePost.statement touched)
updateRecordDiscardResultPost :: (?modelContext :: ModelContext) => Generated.ActualTypes.Post -> IO ()
updateRecordDiscardResultPost model = do
let touched = model.meta.touchedFields
unless (touched == 0) $ do
let pool = ?modelContext.hasqlPool
sqlStatementHasql pool model (Generated.Statements.UpdatePost.discardResultStatement touched)
instance Record Generated.ActualTypes.Post where
{-# INLINE newRecord #-}
newRecord = Generated.ActualTypes.Post def def def def
instance QueryBuilder.FilterPrimaryKey "posts" where
filterWhereId id builder =
builder |> QueryBuilder.filterWhere (#id, id)
{-# INLINE filterWhereId #-}
instance FieldBit "id" (Post') where fieldBit = 1
instance FieldBit "title" (Post') where fieldBit = 2
instance FieldBit "userId" (Post') where fieldBit = 4
|]
it "should produce no type parameters for a table that is referenced by other tables" do
let statements = parseSqlStatements [trimming|
CREATE TABLE users (
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL
);
CREATE TABLE posts (
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
user_id UUID NOT NULL
);
ALTER TABLE posts ADD CONSTRAINT posts_ref_user_id FOREIGN KEY (user_id) REFERENCES users (id) ON DELETE NO ACTION;
|]
let
isTargetTable :: Text -> Statement -> Bool
isTargetTable targetName (StatementCreateTable CreateTable { name }) = name == targetName
isTargetTable _ _ = False
let (Just userStatement) = find (isTargetTable "users") statements
let compileOutput = compileStatementPreviewWith simpleOptions statements userStatement |> Text.strip
-- User has no has-many posts field, no type parameters
getInstanceDecl "Record" compileOutput `shouldBe` [trimming|
instance Record Generated.ActualTypes.User where
{-# INLINE newRecord #-}
newRecord = Generated.ActualTypes.User def def
|]
it "should use the referenced column's type when FK points to a non-PK column" do
let statements = parseSqlStatements [trimming|
CREATE TABLE users (
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
email TEXT NOT NULL UNIQUE
);
CREATE TABLE logins (
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
user_email TEXT NOT NULL
);
ALTER TABLE logins ADD CONSTRAINT logins_ref_user_email FOREIGN KEY (user_email) REFERENCES users (email) ON DELETE NO ACTION;
|]
let
isTargetTable :: Text -> Statement -> Bool
isTargetTable targetName (StatementCreateTable CreateTable { name }) = name == targetName
isTargetTable _ _ = False
let (Just loginStatement) = find (isTargetTable "logins") statements
let compileOutput = compileStatementPreviewWith simpleOptions statements loginStatement |> Text.strip
-- userEmail should be Text, not Id' "users"
compileOutput `shouldSatisfy` ("userEmail :: Text" `Text.isInfixOf`)
describe "statement module content" do
let statements =
[ StatementCreateTable CreateTable
{ name = "posts"
, columns =
[ (col "id" PUUID) { notNull = True, isUnique = True }
, (col "title" PText) { notNull = True }
, (col "body" PText) { notNull = True }
]
, primaryKeyConstraint = PrimaryKeyConstraint ["id"]
, constraints = []
, unlogged = False
, inherits = Nothing
}
]
let [StatementCreateTable theTable] = statements
let ?schema = Schema statements
let ?compilerOptions = fullCompileOptions
it "should generate correct RowDecoder statement module" do
let output = compileRowDecoderModule theTable
getStatementBody output `shouldBe` [trimming|
rowDecoder :: Decoders.Row Generated.ActualTypes.Post
rowDecoder = do
id <- Decoders.column (Decoders.nonNullable Mapping.decoder)
title <- Decoders.column (Decoders.nonNullable Decoders.text)
body <- Decoders.column (Decoders.nonNullable Decoders.text)
pure (let theRecord = Generated.ActualTypes.Post id title body def { originalDatabaseRecord = Just (Data.Dynamic.toDyn theRecord) } in theRecord)
|]
it "should generate nonNullable decoder for PRIMARY KEY column even without explicit NOT NULL (#2531)" do
let bugStatements =
[ StatementCreateTable CreateTable
{ name = "bars"
, columns =
[ (col "id" PUUID) { defaultValue = Just (CallExpression "uuid_generate_v4" []) }
, (col "ticker" PText) { notNull = True }
, (col "date" PDate) { notNull = True }
]
, primaryKeyConstraint = PrimaryKeyConstraint ["id"]
, constraints = []
, unlogged = False
, inherits = Nothing
}
]
let [StatementCreateTable bugTable] = bugStatements
let ?schema = Schema bugStatements
let output = compileRowDecoderModule bugTable
getStatementBody output `shouldBe` [trimming|
rowDecoder :: Decoders.Row Generated.ActualTypes.Bar
rowDecoder = do
id <- Decoders.column (Decoders.nonNullable Mapping.decoder)
ticker <- Decoders.column (Decoders.nonNullable Decoders.text)
date <- Decoders.column (Decoders.nonNullable Decoders.date)
pure (let theRecord = Generated.ActualTypes.Bar id ticker date def { originalDatabaseRecord = Just (Data.Dynamic.toDyn theRecord) } in theRecord)
|]
it "should generate correct Create statement module" do
let output = compileCreateStatement theTable
getStatementBody output `shouldBe` [trimming|
statement :: Statement.Statement Generated.ActualTypes.Post Generated.ActualTypes.Post
statement = Statement.preparable sqlReturningResult encoder decoder
discardResultStatement :: Statement.Statement Generated.ActualTypes.Post ()
discardResultStatement = Statement.preparable sqlDiscardResult encoder Decoders.noResult
sql :: Bool -> Text
sql returning = "INSERT INTO posts (id, title, body) VALUES ($$1, $$2, $$3)"
<> if returning then " RETURNING id, title, body" else ""
sqlReturningResult :: Text
sqlReturningResult = sql True
sqlDiscardResult :: Text
sqlDiscardResult = sql False
encoder :: Encoders.Params Generated.ActualTypes.Post
encoder =
mconcat
[ (.id) >$$< Encoders.param (Encoders.nonNullable Mapping.encoder)
, (.title) >$$< Encoders.param (Encoders.nonNullable Encoders.text)
, (.body) >$$< Encoders.param (Encoders.nonNullable Encoders.text)
]
decoder :: Decoders.Result Generated.ActualTypes.Post
decoder = Decoders.singleRow RowDecoder.rowDecoder
|]
it "should generate correct Update statement module" do
let output = compileUpdateStatement theTable
getStatementBody output `shouldBe` [trimming|
statement :: Integer -> Statement.Statement Generated.ActualTypes.Post Generated.ActualTypes.Post
statement touchedFields = Statement.preparable (sql touchedFields True) (encoder touchedFields) decoder
discardResultStatement :: Integer -> Statement.Statement Generated.ActualTypes.Post ()
discardResultStatement touchedFields = Statement.preparable (sql touchedFields False) (encoder touchedFields) Decoders.noResult
sql :: Integer -> Bool -> Text
sql touchedFields returning =
let setEntries = catMaybes
[ if testBit touchedFields 1 then Just "title" else Nothing
, if testBit touchedFields 2 then Just "body" else Nothing
]
setClauses = [col <> " = $$" <> Text.pack (show i) | (i, col) <- zip [1..] setEntries]
pkIdx = length setEntries + 1
whereClause = \startIdx -> "id" <> " = $$" <> Text.pack (show startIdx)
returningClause = if returning then " RETURNING id, title, body" else ""
in "UPDATE posts SET " <> Text.intercalate ", " setClauses <> " WHERE " <> whereClause pkIdx <> returningClause
encoder :: Integer -> Encoders.Params Generated.ActualTypes.Post
encoder touchedFields = mconcat (catMaybes
[ if testBit touchedFields 1 then Just ((.title) >$$< Encoders.param (Encoders.nonNullable Encoders.text)) else Nothing
, if testBit touchedFields 2 then Just ((.body) >$$< Encoders.param (Encoders.nonNullable Encoders.text)) else Nothing
])
<> ((.id) >$$< Encoders.param (Encoders.nonNullable Mapping.encoder))
decoder :: Decoders.Result Generated.ActualTypes.Post
decoder = Decoders.singleRow RowDecoder.rowDecoder
|]
it "should generate correct FetchById statement module" do
let output = compileFetchByIdStatement theTable
getStatementBody output `shouldBe` [trimming|
statement :: Statement.Statement (Id' "posts") (Maybe Generated.ActualTypes.Post)
statement = Statement.preparable sql encoder decoder
sql :: Text
sql = "SELECT id, title, body FROM posts WHERE id = $$1 LIMIT 1"
encoder :: Encoders.Params (Id' "posts")
encoder = Encoders.param (Encoders.nonNullable Mapping.encoder)
decoder :: Decoders.Result (Maybe Generated.ActualTypes.Post)
decoder = Decoders.rowMaybe RowDecoder.rowDecoder
|]
it "should generate correct CreateMany statement module" do
let output = compileCreateManyStatement theTable
getStatementBody output `shouldBe` [trimming|
statement :: Int -> Statement.Statement [Generated.ActualTypes.Post] [Generated.ActualTypes.Post]
statement count = Statement.unpreparable (sql count) (encoder count) decoder
sql :: Int -> Text
sql count = "INSERT INTO posts (id, title, body) VALUES "
<> Text.intercalate ", " [valueGroup (i * 3) | i <- [0..count - 1]]
<> " RETURNING id, title, body"
where
valueGroup offset = "(" <> Text.intercalate ", " ["$$" <> Text.pack (show (offset + j)) | j <- [1..3]] <> ")"
encoder :: Int -> Encoders.Params [Generated.ActualTypes.Post]
encoder count = mconcat [contramap (!! i) singleEncoder | i <- [0..count - 1]]
singleEncoder :: Encoders.Params Generated.ActualTypes.Post
singleEncoder =
mconcat
[ (.id) >$$< Encoders.param (Encoders.nonNullable Mapping.encoder)
, (.title) >$$< Encoders.param (Encoders.nonNullable Encoders.text)
, (.body) >$$< Encoders.param (Encoders.nonNullable Encoders.text)
]
decoder :: Decoders.Result [Generated.ActualTypes.Post]
decoder = Decoders.rowList RowDecoder.rowDecoder
|]
it "should use correct bit indices for columns in Update" do
let snakeStatements =
[ StatementCreateTable CreateTable
{ name = "blog_posts"
, columns =
[ (col "id" PUUID) { notNull = True, isUnique = True }
, (col "post_title" PText) { notNull = True }
]
, primaryKeyConstraint = PrimaryKeyConstraint ["id"]
, constraints = []
, unlogged = False
, inherits = Nothing
}
]
let [StatementCreateTable snakeTable] = snakeStatements
let ?schema = Schema snakeStatements
let output = compileUpdateStatement snakeTable
-- post_title is at index 1 in the columns list, so testBit should use 1
output `shouldSatisfy` Text.isInfixOf "testBit touchedFields 1"
it "should generate correct dynamic Create statement module with DEFAULT columns" do
let defaultStatements =
[ StatementCreateTable CreateTable
{ name = "posts"
, columns =
[ (col "id" PUUID) { notNull = True, isUnique = True, defaultValue = Just (CallExpression "uuid_generate_v4" []) }
, (col "title" PText) { notNull = True }
, (col "created_at" PTimestampWithTimezone) { notNull = True, defaultValue = Just (CallExpression "now" []) }
]
, primaryKeyConstraint = PrimaryKeyConstraint ["id"]
, constraints = []
, unlogged = False
, inherits = Nothing
}
]
let [StatementCreateTable defaultTable] = defaultStatements
let ?schema = Schema defaultStatements
let output = compileCreateStatement defaultTable
getStatementBody output `shouldBe` [trimming|
statement :: Integer -> Statement.Statement Generated.ActualTypes.Post Generated.ActualTypes.Post
statement touchedFields = Statement.preparable (sql touchedFields True) (encoder touchedFields) decoder
discardResultStatement :: Integer -> Statement.Statement Generated.ActualTypes.Post ()
discardResultStatement touchedFields = Statement.preparable (sql touchedFields False) (encoder touchedFields) Decoders.noResult
sql :: Integer -> Bool -> Text
sql touchedFields returning =
let entries = catMaybes
[ if testBit touchedFields 0 then Just "id" else Nothing
, Just "title"
, if testBit touchedFields 2 then Just "created_at" else Nothing
]
columns = Text.intercalate ", " entries
placeholders = Text.intercalate ", " ["$$" <> Text.pack (show i) | i <- [1 .. length entries]]
returningClause = if returning then " RETURNING id, title, created_at" else ""
in if null entries
then "INSERT INTO posts DEFAULT VALUES" <> returningClause
else "INSERT INTO posts (" <> columns <> ") VALUES (" <> placeholders <> ")" <> returningClause
encoder :: Integer -> Encoders.Params Generated.ActualTypes.Post
encoder touchedFields = mconcat $$ catMaybes
[ if testBit touchedFields 0 then Just ((.id) >$$< Encoders.param (Encoders.nonNullable Mapping.encoder)) else Nothing
, Just ((.title) >$$< Encoders.param (Encoders.nonNullable Encoders.text))
, if testBit touchedFields 2 then Just ((.createdAt) >$$< Encoders.param (Encoders.nonNullable Encoders.timestamptz)) else Nothing
]
decoder :: Decoders.Result Generated.ActualTypes.Post
decoder = Decoders.singleRow RowDecoder.rowDecoder
|]
describe "table inheritance (INHERITS)" do
let statements = parseSqlStatements [trimming|
CREATE TABLE posts (
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
title TEXT NOT NULL,
body TEXT NOT NULL
);
CREATE TABLE post_revisions (
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
revision_content TEXT NOT NULL
) INHERITS (posts);
|]
let
isNamedTable :: Text -> Statement -> Bool
isNamedTable targetName (StatementCreateTable CreateTable { name }) = name == targetName
isNamedTable _ _ = False
let (Just childStatement) = find (isNamedTable "post_revisions") statements
let compileOutput = compileStatementPreview statements childStatement |> Text.strip
it "should include inherited columns in FromRow instance" do
getInstanceDecl "FromRow" compileOutput `shouldBe` [trimming|
instance FromRow Generated.ActualTypes.PostRevision where
fromRow = do
id <- field
revisionContent <- field
title <- field
body <- field
let theRecord = Generated.ActualTypes.PostRevision id revisionContent title body def { originalDatabaseRecord = Just (Data.Dynamic.toDyn theRecord) }
pure theRecord
|]
it "should include inherited columns in Table instance" do
getInstanceDecl "IHP.ModelSupport.Table" compileOutput `shouldBe` [trimming|
instance IHP.ModelSupport.Table (PostRevision') where
tableName = "post_revisions"
columnNames = ["id","revision_content","title","body"]
primaryKeyColumnNames = ["id"]
|]
it "should include inherited columns in Record instance" do
getInstanceDecl "Record" compileOutput `shouldBe` [trimming|
instance Record Generated.ActualTypes.PostRevision where
{-# INLINE newRecord #-}
newRecord = Generated.ActualTypes.PostRevision def def def def def
|]
-- | Extract the body of a statement module (everything after the import block)
getStatementBody :: Text -> Text
getStatementBody full =
Text.splitOn "\n" full
|> dropWhile (\line -> "import " `isPrefixOf` line || isEmpty line || "-- " `isPrefixOf` line || "{-#" `isPrefixOf` line || "module " `isPrefixOf` line)
|> Text.unlines
|> Text.strip
getInstanceDecl :: Text -> Text -> Text
getInstanceDecl instanceName full =
Text.splitOn "\n" full
|> findInstanceDecl
|> takeInstanceDecl
|> Text.unlines
|> Text.strip
where
findInstanceDecl (line:rest)
| ("instance " <> instanceName) `isPrefixOf` line = line : rest
| otherwise = findInstanceDecl rest
findInstanceDecl [] = error ("didn't find instance declaration of " <> instanceName)
takeInstanceDecl (line:rest)
| isEmpty line = []
| otherwise = line : takeInstanceDecl rest
takeInstanceDecl [] = [] -- EOF reached