packages feed

pg-schema 0.7.0.1 → 0.7.1.0

raw patch · 14 files changed

+557/−115 lines, 14 filesdep +postgresql-libpq

Dependencies added: postgresql-libpq

Files

ChangeLog.md view
@@ -1,5 +1,18 @@ # Changelog for pg-schema +## 0.7.1.0+- Condition DSL: `(=??)` on nullable columns generates SQL+  `IS NOT DISTINCT FROM` (same null-safe key equality as upsertJSON)+- Improve transaction behavior for insertJSON/upsertJSON+- Add tests for insertJSON/upsertJSON with transactions+- `upsertJSON` / `upsertJSON_`: optional `ON CONFLICT` targets include NOT NULL+  unique keys (primary key still first), then nullable unique keys when the table+  has no NOT NULL UK; `UPDATE` by key uses `IS NOT DISTINCT FROM` for key columns;+  `IdentityCandidates` (compile-time) lists every PK/UK from the schema+- `insertJSON` / `insertJSON_`: insert-only (plain `INSERT`, no `ON CONFLICT` or+  `UPDATE`; duplicate keys fail at the database)+- Rename `AllMandatoryOrHasPKTree` to `AllMandatoryOrHasKeyTree`+ ## 0.7.0.1 - Bug fixing (upsertJSON_ without change fields: on conflict do nothing)
pg-schema.cabal view
@@ -1,6 +1,6 @@ cabal-version:  3.12 name:           pg-schema-version:        0.7.0.1+version:        0.7.1.0 category:       Database author:         Dmitry Olshansky maintainer:     olshanskydr@gmail.com@@ -41,7 +41,7 @@     data Order = Order { num :: Text, createdAt :: Day, items :: [OrdPos] } deriving Generic     data OrdPos = OrdPos { id :: Int32, num :: Int32, article :: Article, price :: Double } deriving Generic     data Article = Article { id :: Int32, name :: Text } deriving Generic-    type MyAnn tabName = 'Ann 5 CamelToSnake MySch ("dbSchema" ->> tabName)+    type MyAnn tabName = 'Ann CamelToSnake MySch 5 ("dbSchema" ->> tabName)         ...     do       -- insert an order with order positions@@ -155,6 +155,7 @@     , directory >= 1.3 && < 1.5     , exceptions >= 0.9 && < 0.11     , mtl >= 2.0 && < 2.4+    , postgresql-libpq >= 0.11 && < 0.12     , postgresql-simple >= 0.6 && < 0.8     , scientific >= 0.2 && < 0.4     , singletons >= 3.0.3 && < 3.1@@ -227,6 +228,7 @@     , aeson     , bytestring     , pg-schema+    , postgresql-libpq >= 0.11 && < 0.12     , postgresql-simple >= 0.6 && < 0.8     , text   default-language: GHC2021@@ -240,6 +242,7 @@   ghc-options: -Wall  test-suite test-gen+  type:             exitcode-stdio-1.0   main-is:          Main.hs   other-modules:     -- Paths and PackageInfo@@ -253,6 +256,7 @@     , bytestring >= 0.12.2 && < 0.13     , directory >= 1.3.9 && < 1.4     , pg-schema+    , postgresql-libpq >= 0.11 && < 0.12     , postgresql-simple >= 0.6 && < 0.8   hs-source-dirs:   test-gen   default-language: GHC2021@@ -266,6 +270,8 @@     Tests.BaseConverts     Tests.Conditions     Tests.Hierarchy+    Tests.InsertJSONTransaction+    Tests.UpsertUniqueKey     Tests.Path     Utils     -- Paths and PackageInfo
src/PgSchema/Ann.hs view
@@ -357,10 +357,10 @@   => FromRow (PgTag ann r) where     fromRow = PgTag <$> fromRowCols @ann @colsCase @cols --- >>> type AnnRel = 'Ann RenamerId PgCatalog (PGC "pg_constraint")+-- >>> type AnnRel = 'Ann RenamerId PgCatalog 1 (PGC "pg_constraint") -- >>> (r1 :: [PgTag AnnRel ( ("conkey" := Int16))]) <- query_ conn "select 1::int2" -- >>> r1--- [PgTag {unPgTag = PgTag {unPgTag = 1}}]+-- [PgTag {unPgTag = "conkey" =: 1}]  class ToRowCols (ann :: Ann) (colsCase :: ColsCase) (cols :: [ColInfo NameNSK]) r   where@@ -644,7 +644,7 @@       :$$: Text "" )   CheckRef ann fldDbName b b = () ----------------------------------------------------------------------------------- Node-level checks for Mandatory / PK (analogue of CheckNodeAll*)+-- Node-level checks for Mandatory / upsert keys (CheckNodeAll* analogue) --------------------------------------------------------------------------------  -- | One-table check that all mandatory fields are present@@ -660,23 +660,34 @@     :$$: Text "Table: " :<>: ShowType tab     :$$: Text "Missing mandatory fields: " :<>: ShowType rest ) --- | One-table check that all mandatory fields are present--- or all PK fields are present-type family CheckAllMandatoryOrHasPK (ann :: Ann) (rs :: [Symbol]) :: Constraint where-  CheckAllMandatoryOrHasPK ('Ann ren sch d tab) rs = CheckAllMandatoryOrHasPK'-    (RestMandatory sch tab rs) (RestPK sch tab rs) ('Ann ren sch d tab) rs+-- | All mandatory fields in @rs@, or a full primary key, or a full eligible+-- unique key (see 'IdentityCandidates').+type family CheckAllMandatoryOrHasKey (ann :: Ann) (rs :: [Symbol]) :: Constraint where+  CheckAllMandatoryOrHasKey ('Ann ren sch d tab) rs = CheckAllMandatoryOrHasKey'+    (RestMandatory sch tab rs) (IdentityCandidates sch tab)+    ('Ann ren sch d tab) rs -type family CheckAllMandatoryOrHasPK' (restMandatory :: [Symbol]) (restPK :: [Symbol]) (ann :: Ann) (rs :: [Symbol]) :: Constraint where-  CheckAllMandatoryOrHasPK' '[] rpk ann rs = ()-  CheckAllMandatoryOrHasPK' rm '[] ann rs = ()-  CheckAllMandatoryOrHasPK' rm rpk ('Ann ren sch d tab) rs = TypeError-    (  Text "We can't upsert data because for table " :<>: ShowType tab-    :$$: Text "either not all mandatory fields or not all PK fields are present."-    :$$: Text "Missing mandatory fields: " :<>: ShowType rm-    :$$: Text "Missing PK fields: " :<>: ShowType rpk )+type family CheckAllMandatoryOrHasKey' (restMandatory :: [Symbol]) (cands :: [[Symbol]]) (ann :: Ann) (rs :: [Symbol]) :: Constraint where+  CheckAllMandatoryOrHasKey' '[] _ ann rs = ()+  CheckAllMandatoryOrHasKey' rm cands ann rs = HasAnyFullIdentity rs cands ann -genDefunSymbols [ ''CheckAllMandatory, ''CheckAllMandatoryOrHasPK]+type family HasAnyFullIdentity (rs :: [Symbol]) (cands :: [[Symbol]]) ann :: Constraint where+  HasAnyFullIdentity rs '[] ('Ann _ sch _ tab) =+    TypeError+      (  Text "We can't upsert data because for table " :<>: ShowType tab+      :$$: Text "not all mandatory fields are present and no full primary or"+      :$$: Text "unique key is covered by record fields."+      :$$: Text "Missing mandatory fields: " :<>: ShowType (RestMandatory sch tab rs)+      :$$: Text "Possible keys: " :<>: ShowType (IdentityCandidates sch tab) )+  HasAnyFullIdentity rs (k ': ks) ann =+    HasAnyFullIdentity' (RestKey rs k) rs ks ann +type family HasAnyFullIdentity' (restKey :: [Symbol]) (rs :: [Symbol]) (ks :: [[Symbol]]) ann :: Constraint where+  HasAnyFullIdentity' '[] rs ks ann = ()+  HasAnyFullIdentity' (_ ': _) rs ks ann = HasAnyFullIdentity rs ks ann++genDefunSymbols [ ''CheckAllMandatory, ''CheckAllMandatoryOrHasKey]+ -------------------------------------------------------------------------------- -- Recursive AllMandatory / PK for tree (JSON insert / upsert) --------------------------------------------------------------------------------@@ -698,11 +709,11 @@   AllMandatoryTree ann r rFlds =     WalkLevelAnn CheckAllMandatorySym0 ann (TRecordInfo ann r) rFlds -type family AllMandatoryOrHasPKTree (ann :: Ann) (r :: Type) (rFlds :: [Symbol])+type family AllMandatoryOrHasKeyTree (ann :: Ann) (r :: Type) (rFlds :: [Symbol])   :: Constraint where-  AllMandatoryOrHasPKTree ann [r] rFlds = AllMandatoryOrHasPKTree ann r rFlds-  AllMandatoryOrHasPKTree ann r rFlds =-    WalkLevelAnn CheckAllMandatoryOrHasPKSym0 ann (TRecordInfo ann r) rFlds+  AllMandatoryOrHasKeyTree ann [r] rFlds = AllMandatoryOrHasKeyTree ann r rFlds+  AllMandatoryOrHasKeyTree ann r rFlds =+    WalkLevelAnn CheckAllMandatoryOrHasKeySym0 ann (TRecordInfo ann r) rFlds  -------------------------------------------------------------------------------- -- Returning tree must be subtree of input tree (with path)
src/PgSchema/DML.hs view
@@ -16,7 +16,7 @@ -- data Order = Order { num :: Text, createdAt :: Day, items :: [OrdPos] } deriving Generic -- data OrdPos = OrdPos { id :: Int32, num :: Int32, article :: Article, price :: Double } deriving Generic -- data Article = Article { id :: Int32, name :: Text } deriving Generic--- type MyAnn tabName = 'Ann 5 CamelToSnake MySch ("dbSchema" ->> tabName)+-- type MyAnn tabName = 'Ann CamelToSnake MySch 5 ("dbSchema" ->> tabName) --     ... -- do --   void $ insertJSON_ (MyAnn "orders") conn@@ -43,10 +43,10 @@ -- JSON internally. Child data is carried in list fields: the field’s name (after 'Renamer') names -- the FK constraint in the database and thus selects the child table and link; -- each list element supplies one child row’s columns, with nested lists for further--- children in the same way. For strict inserts,--- 'insertJSON' and 'insertJSON_' require every mandatory column at each node;--- 'upsertJSON' / 'upsertJSON_' relax that so each row can be resolved by keys and--- optional columns (see their Haddock). Plain 'insertSch' / 'insertSch_' follow the+-- children in the same way. 'insertJSON' / 'insertJSON_' require every mandatory+-- column and emit plain @INSERT@ only (duplicates fail in the database).+-- 'upsertJSON' / 'upsertJSON_' relax mandatory requirements and may @UPDATE@ or+-- @INSERT … ON CONFLICT …@ (see their Haddock). Plain 'insertSch' / 'insertSch_' follow the -- same safety story for flat (non-tree) rows. -- -- 'selectSch' decodes each row into a Haskell type @r@ whose fields describe the@@ -82,6 +82,9 @@   -- *** Conditions   -- | Example: @"name" =? "John"@   , (<?),(>?),(<=?),(>=?),(=?)+  -- | Null-safe equality on nullable columns (@IS NOT DISTINCT FROM@).+  -- | Example: @"suffix" =?? (Just "a")@+  , (=??)   -- | Example: @"name" ~~? "%joh%"@   ,(~=?),(~~?)   , (|||), (&&&), pnot, pnull, pin, pinArr@@ -101,7 +104,7 @@   , UpdateReturning, UpdateNonReturning, CRecInfo(..)   -- ** Tree-base Insert/Upsert   , insertJSON, insertJSON_, upsertJSON, upsertJSON_, insertJSONText, insertJSONText_-  , TreeIn, TreeOut, AllMandatoryTree, AllMandatoryOrHasPKTree, TreeSch+  , TreeIn, TreeOut, AllMandatoryTree, AllMandatoryOrHasKeyTree, TreeSch   , InsertTreeNonReturning, InsertTreeReturning   , UpsertTreeNonReturning, UpsertTreeReturning, TRecordInfo   -- ** Delete
src/PgSchema/DML/Insert/Types.hs view
@@ -60,14 +60,16 @@  -- | Upsert tree without @RETURNING@. ----- Check that all mandatory fields or primary keys are present in all tables in tree.+-- Check that all mandatory fields or a full primary / eligible unique key are+-- present at each tree node. -- Reference fields in the child tables are not checked - they are inserted automatically. type UpsertTreeNonReturning ann r =-  (TreeSch ann, TreeIn ann r, AllMandatoryOrHasPKTree ann r '[])+  (TreeSch ann, TreeIn ann r, AllMandatoryOrHasKeyTree ann r '[])  -- | Upsert tree with @RETURNING@. ----- Check that all mandatory fields or primary keys are present in all tables in tree.+-- Check that all mandatory fields or a full primary / eligible unique key are+-- present at each tree node. -- Reference fields in the child tables are not checked - they are inserted automatically. -- -- It also checks that we get returnings only from the tables we upserted into.
src/PgSchema/DML/InsertJSON.hs view
@@ -18,30 +18,35 @@ import Data.Traversable import PgSchema.Ann import PgSchema.DML.Insert.Types+import Database.PostgreSQL.LibPQ qualified as PQ import Database.PostgreSQL.Simple+import Database.PostgreSQL.Simple.Internal (withConnection) import PgSchema.Schema import PgSchema.Types import Data.String-import GHC.Int import PgSchema.Utils.Internal import Prelude as P   -- | Insert records into a table and its children using JSON data internally. ----- Like 'upsertJSON', but requires all mandatory columns at every node (insert-only constraint).+-- Uses the same SQL pipeline as 'upsertJSON', but each row is a plain @INSERT@+-- (no @UPDATE@, no @INSERT … ON CONFLICT …@). Any duplicate primary or unique key+-- raises a PostgreSQL error.+--+-- Requires all mandatory columns at every node (see 'InsertTreeReturning').  insertJSON   :: forall ann -> forall r r'. InsertTreeReturning ann r r'   => Connection -> [r] -> IO ([r'], Text)-insertJSON ann @r @r' = insertJSONImpl ann @r @r'+insertJSON ann @r @r' conn rs = insertJSONImpl ann @r @r' conn rs True  -- | Like 'insertJSON', but does not return rows. -- insertJSON_   :: forall ann -> forall r. InsertTreeNonReturning ann r   => Connection -> [r] -> IO Text-insertJSON_ ann @r = insertJSONImpl_ ann @r+insertJSON_ ann @r conn rs = insertJSONImpl_ ann @r conn rs True  -- | Upsert a forest of rows into the root table and its /child/ tables in one -- round-trip, using JSON inside PostgreSQL (same pipeline as 'insertJSON').@@ -59,37 +64,41 @@ -- -- __What to supply at each node:__ at every level, each row must either include -- all mandatory columns (for columns that are mandatory in the schema /sense of--- this API/) or, alternatively, enough primary-key columns to identify an existing--- row. Foreign-key columns that are filled in by the parent level (for example+-- this API/) or, alternatively, enough columns to identify an existing row via+-- the primary key or a unique constraint (including constraints with nullable+-- columns when the table has no @NOT NULL@ unique constraint besides PK).+-- If a nullable key column is @null@ in the payload, conflict/update semantics+-- follow PostgreSQL (see haddock on 'upsertJSON').+-- Foreign-key columns that are filled in by the parent level (for example -- after an auto-generated id on insert) do /not/ need to be present on the child -- payload. -- -- __Insert vs update vs upsert per row:__ the engine picks one of @INSERT@, -- @UPDATE@, or @UPSERT@ from the keys and mandatory fields you provide: ----- * all mandatory fields present and /no/ primary key  →  @INSERT@--- * primary key present, not all mandatory fields      →  @UPDATE@--- * primary key present /and/ all mandatory fields    →  @UPSERT@+-- * all mandatory fields present and no full identity key  →  @INSERT@+-- * identity (PK or first eligible unique whose columns are all in the node), not all mandatory  →  @UPDATE@+-- * identity present /and/ all mandatory fields  →  @UPSERT@ (@INSERT … ON CONFLICT …@) ----- 'insertJSON' is the same execution path but adds a stricter type-level--- constraint: /every/ mandatory field must be present (pure inserts). 'upsertJSON'--- relaxes that so updates and upserts are expressible as in the rules above.+-- 'insertJSON' shares this execution path but is insert-only at runtime and+-- requires /every/ mandatory field at compile time. 'upsertJSON' relaxes both. upsertJSON   :: forall ann -> forall r r'. UpsertTreeReturning ann r r'   => Connection -> [r] -> IO ([r'], Text)-upsertJSON ann @r @r' = insertJSONImpl ann @r @r'+upsertJSON ann @r @r' conn rs = insertJSONImpl ann @r @r' conn rs False  -- | Like 'upsertJSON', but does not return rows. -- upsertJSON_   :: forall ann -> forall r. UpsertTreeNonReturning ann r   => Connection -> [r] -> IO Text-upsertJSON_ ann @r = insertJSONImpl_ ann @r+upsertJSON_ ann @r conn rs = insertJSONImpl_ ann @r conn rs False  insertJSONImpl   :: forall ann -> forall r r'. (TreeSch ann, TreeIn ann r, TreeOut ann r')-  => Connection -> [r] -> IO ([r'], Text)-insertJSONImpl ann @r @r' conn rs = withTransactionIfNot conn do+  => Connection -> [r] -> Bool -> IO ([r'], Text)+  -- ^ @Bool@ is @isInsertOnly@.+insertJSONImpl ann @r @r' conn rs isInsertOnly = withTransactionIfNot conn do   let sql' = T.unpack sql in trace' sql' $ void $ execute_ conn $ fromString sql'   [Only res] <- let q = "select pg_temp.__ins(?)" in     traceShow' q@@ -98,40 +107,54 @@   void $ execute_ conn "drop function pg_temp.__ins"   pure (unPgTag @ann @r' <$> res, sql)   where-    sql = insertJSONText ann @r @r'+    sql = insertJSONText' isInsertOnly (typDefMap @(AnnSch ann)) (tabInfoMap @(AnnSch ann))+      (getRecordInfo @ann @r) (getRecordInfo @ann @r').fields  withTransactionIfNot :: Connection -> IO a -> IO a withTransactionIfNot conn act = do-  isInTrans <- any (isJust @Int64 . fromOnly)-    <$> query_ conn "SELECT txid_current_if_assigned()"-  (if isInTrans then id else withTransaction conn) act+  stat <- withConnection conn PQ.transactionStatus+  case stat of+    PQ.TransIdle -> withTransaction conn act+    PQ.TransInTrans -> act+    PQ.TransInError -> act+    PQ.TransActive ->+      error "PgSchema.DML.InsertJSON.withTransactionIfNot: connection is active"+    PQ.TransUnknown ->+      error "PgSchema.DML.InsertJSON.withTransactionIfNot: \+        \unknown transaction status"  insertJSONImpl_   :: forall ann -> forall r. (TreeSch ann, TreeIn ann r)-  => Connection -> [r] -> IO Text-insertJSONImpl_ ann @r conn rs = withTransactionIfNot conn do+  => Connection -> [r] -> Bool -> IO Text+insertJSONImpl_ ann @r conn rs isInsertOnly = withTransactionIfNot conn do   void $ trace' (T.unpack sql) $ execute_ conn $ fromString $ T.unpack sql   void $ execute conn "call pg_temp.__ins(?)" $ Only $ PgTag @ann @r <$> rs   sql <$ execute_ conn "drop procedure pg_temp.__ins"   where-    sql = insertJSONText_ ann @r+    sql = insertJSONText' isInsertOnly (typDefMap @(AnnSch ann)) (tabInfoMap @(AnnSch ann))+      (getRecordInfo @ann @r) []  insertJSONText_ :: forall ann -> forall r s.   (IsString s, Monoid s, Ord s, TreeSch ann, CRecInfo ann r) => s-insertJSONText_ ann @r = insertJSONText' (typDefMap @(AnnSch ann)) (tabInfoMap @(AnnSch ann))-  (getRecordInfo @ann @r) []+insertJSONText_ ann @r =+  insertJSONText' True (typDefMap @(AnnSch ann)) (tabInfoMap @(AnnSch ann))+    (getRecordInfo @ann @r) []  insertJSONText :: forall ann -> forall r r'.   ( TreeSch ann, CRecInfo ann r, CRecInfo ann r'   , IsString s, Monoid s, Ord s ) => s insertJSONText ann @r @r' =-  insertJSONText' (typDefMap @(AnnSch ann)) (tabInfoMap @(AnnSch ann))+  insertJSONText' True (typDefMap @(AnnSch ann)) (tabInfoMap @(AnnSch ann))     (getRecordInfo @ann @r) (getRecordInfo @ann @r').fields +-- | @isInsertOnly@: plain @INSERT@ only ('insertJSON'); 'False' enables upsert+-- key resolution ('upsertJSON'). insertJSONText'   :: forall s. (IsString s, Monoid s, Ord s)-  => M.Map NameNS TypDef -> M.Map NameNS TabInfo -> RecordInfo Text -> [FieldInfo Text] -> s-insertJSONText' mapTypes mapTabs ir qfs = unlines'+  => Bool+  -> M.Map NameNS TypDef -> M.Map NameNS TabInfo -> RecordInfo Text+  -> [FieldInfo Text] -> s+insertJSONText' isInsertOnly mapTypes mapTabs ir qfs = unlines'   [ maybe     "create or replace procedure pg_temp.__ins(data_0 jsonb) as $$"     (const "create or replace function pg_temp.__ins(data_0 jsonb) returns jsonb as $$")@@ -145,7 +168,8 @@   , "$$ language plpgsql;" ]   where     (mbRes, (decl, body)) =-      evalRWS (insertJSONTextM mapTypes mapTabs ir qfs [] []) ("  ",0) 0+      evalRWS (insertJSONTextM isInsertOnly mapTypes mapTabs ir qfs [] [])+        ("  ",0) 0  type MonadInsert s = RWS (s, Int) ([s],[s]) Int -- R: (leading spaces to format code, number of table in tree)@@ -160,11 +184,26 @@   , info :: v }   deriving (Eq, Show) +-- | Runtime conflict/update targets: PK, then @NOT NULL@ unique constraints,+-- then nullable unique constraints only when the table has no @NOT NULL@ UK.+-- Compile-time checks use all keys from 'IdentityCandidates'.+identityCandidatesFromTab :: TabInfo -> [[Text]]+identityCandidatesFromTab ti =+  P.filter (not . P.null) [ti.tiDef.tdKey] <> notNullUks <> nullUks+  where+    isNullable = (== Just True) . fmap (.fdNullable) . (`M.lookup` ti.tiFlds)+    (nullUks, notNullUks) = L.partition (P.any isNullable) ti.tiDef.tdUniq++mandatoryDbNames :: TabInfo -> [Text]+mandatoryDbNames ti =+  M.keys $ M.filter (\fd -> not $ fd.fdNullable || fd.fdHasDefault) ti.tiFlds+ insertJSONTextM   :: forall s. (IsString s, Monoid s, Ord s)-  => M.Map NameNS TypDef -> M.Map NameNS TabInfo -> RecordInfo Text+  => Bool+  -> M.Map NameNS TypDef -> M.Map NameNS TabInfo -> RecordInfo Text   -> [FieldInfo Text] -> [s] -> [s] -> MonadInsert s (Maybe s)-insertJSONTextM mapTypes mapTabs ri qfs fromFields toVars = do+insertJSONTextM isInsertOnly mapTypes mapTabs ri qfs fromFields toVars = do   (spaces, n) <- ask   let     sn = show' n@@ -179,13 +218,21 @@     startLoop =       ["for " <> rowN <> " in select * from jsonb_array_elements("       <> dataN <> ")", "loop"]-    (ins, op) = case mbKeyMand of-      Just (pk, mflds)-        | not $ P.null $ mflds L.\\ (fromFields <> (fst <$> plains)) ->-          (addSemiColon (upd0 <> rets), UPD)-        | P.null $ pk L.\\ (fromFields <> (fst <$> plainsPK)) -> (ups0 pk, UPS)-      _ -> (addSemiColon (ins0 <> rets), INS)+    (ins, op) = resolve       where+        jsonFld ip = case mapTypes M.!? ip.info.fdType of+          Just (TypDef "A" (Just t) _) ->+            "case when jsonb_typeof(" <> rowN <> ".value->'" <> fld <> "') = 'array'"+            <> " then (select coalesce(array_agg(__x)::" <> fromText (qualName t) <> "[], '{}')"+            <> " from jsonb_array_elements_text(" <> rowN <> ".value->'" <> fld <> "') __x) else null end"+          _+            | tn == "json" || tn == "jsonb" -> "(" <> rowN <> ".value->'" <> fld <> "')"+            | otherwise                     -> "(" <> rowN <> ".value->>'" <> fld <> "')::" <> ty+          where+            fld = fromText ip.jsonName+            ty  = fromText (qualName ip.info.fdType)+            tn  = ip.info.fdType.nnsName+        plains = iplains <&> \ip -> (fromText ip.dbName, jsonFld ip)         srcFlds = fromFields <> (fst <$> plains)         srcVars = toVars <> (jsonFld <$> iplains)         srcMap = M.fromList $ P.zip srcFlds srcVars@@ -198,13 +245,27 @@         ins0 =           [ "  insert into " <> qualTabName <> "(" <> intercalate' ", " srcFlds <> ")"           , "    values (" <> intercalate' ", " srcVars <> ")"]+        mbTab = mapTabs M.!? ri.tabName+        mflds = foldMap (fmap fromText . mandatoryDbNames) mbTab+        keyNames+          | isInsertOnly = []+          | otherwise = F.fold $ L.find (P.null . (L.\\ srcFlds))+              $ fmap fromText <$> foldMap identityCandidatesFromTab mbTab+        (plainsKey, plainsOthers) =+          L.partition ((`L.elem` keyNames) . fst) plains         sWhere = "where " <> intercalate' " and "-            ( L.zipWith nameVal fromFields toVars <> (uncurry nameVal <$> plainsPK))+            ( L.zipWith nameVal fromFields toVars+            <> (uncurry keyValDistinct <$> plainsKey))         upd0 =           [ "  update " <> qualTabName           , "    set " <> intercalate' ", " (uncurry nameVal <$> plains)           , "    " <> sWhere]-        ups0 pk+        qretVars = (<> sn) <$> qretFlds+        rets+          | noRets = []+          | otherwise = ["    returning " <> intercalate' ", " qretFlds+            <> " into " <> intercalate' ", " qretVars]+        ups0 conflictCols           | L.null plainsOthers = case mbSetVars of             Just xs -> ins0 <> [ "    on conflict do nothing;"]               <> ["  " <> intercalate' " " xs]@@ -214,31 +275,17 @@                 , "      from " <> qualTabName                 , "      " <> sWhere <> ";"                 , "  end if;"]-          | L.null pk = addSemiColon ins0 -- support for tables without PK+          | P.null conflictCols = addSemiColon ins0           | otherwise = addSemiColon $ ins0-            <> [ "    on conflict (" <> intercalate' ", " pk <> ")"+            <> [ "    on conflict (" <> intercalate' ", " conflictCols <> ")"               , "      do update set " <> intercalate' ", " (plainsOthers <&>                   \(name, _) -> name <> " = " <> "EXCLUDED." <> name) ]             <> rets-        qretVars = (<> sn) <$> qretFlds-        plains = iplains <&> \ip -> (fromText ip.dbName, jsonFld ip)-        (plainsPK, plainsOthers) = L.partition ((`L.elem` foldMap fst mbKeyMand) . fst) plains-        jsonFld ip = case mapTypes M.!? ip.info.fdType of-          Just (TypDef "A" (Just t) _) ->-            "case when jsonb_typeof(" <> rowN <> ".value->'" <> fld <> "') = 'array'"-            <> " then (select coalesce(array_agg(__x)::" <> fromText (qualName t) <> "[], '{}')"-            <> " from jsonb_array_elements_text(" <> rowN <> ".value->'" <> fld <> "') __x) else null end"-          _-            | tn == "json" || tn == "jsonb" -> "(" <> rowN <> ".value->'" <> fld <> "')"-            | otherwise                     -> "(" <> rowN <> ".value->>'" <> fld <> "')::" <> ty-          where-            fld = fromText ip.jsonName-            ty  = fromText (qualName ip.info.fdType)-            tn  = ip.info.fdType.nnsName-        rets-          | noRets = []-          | otherwise = ["    returning " <> intercalate' ", " qretFlds-            <> " into " <> intercalate' ", " qretVars]+        resolve+          | not isInsertOnly, not $ P.null $ mflds L.\\ srcFlds =+            (addSemiColon (upd0 <> rets), UPD)+          | not isInsertOnly, not $ P.null keyNames = (ups0 keyNames, UPS)+          | otherwise = (addSemiColon (ins0 <> rets), INS)     endLoop = "end loop;"     processChildren = do       (spaces', _) <- ask@@ -250,7 +297,8 @@         let           qfs' = foldMap ((.fields) . snd)             $ L.find (\(qc, _) -> qc.jsonName == child.jsonName) qchildren-        mbArr <- local (second $ const n') $ insertJSONTextM mapTypes mapTabs+        mbArr <- local (second $ const n') $ insertJSONTextM isInsertOnly+          mapTypes mapTabs           childRi qfs' (fromText . (.fromName) <$> child.info)           ((<> sn) . fromText . (.toName) <$> child.info)         pure (fromText child.jsonName, mbArr)@@ -279,10 +327,6 @@       _ -> P.id) mempty     (iplains, ichildren) = splitFields ri.fields     (qplains, qchildren) = splitFields qfs-    mbKeyMand = mapTabs M.!? ri.tabName <&> ((,)-      <$> fmap fromText . (.tiDef.tdKey)-      <*> fmap fromText . M.keys-        . M.filter (\fd -> not $ fd.fdNullable || fd.fdHasDefault) . (.tiFlds))     qualTabName = fromText (qualName ri.tabName)     qcFlds = fmap ((,) <$> (.toName) <*> qualName . (.toDef.fdType))       $ nubBy ((==) `on` (.toName)) $ ichildren >>= (\x -> (fst x).info)@@ -290,6 +334,7 @@     qretPairs = fmap (bimap fromText fromText)       $ nubBy ((==) `on` fst) $ qcFlds <> qpFlds     nameVal name val = name <> " = " <> val+    keyValDistinct name val = name <> " IS NOT DISTINCT FROM " <> val     noRets = P.null qplains && P.null ichildren     qretFlds = fst <$> qretPairs     addSemiColon = \case
src/PgSchema/DML/Select/Types.hs view
@@ -233,7 +233,7 @@  -- | Comparison constructors; each is paired with its corresponding operator -- (e.g. '(:=)' with '(=?)').-data Cmp = (:=) | (:<=) | (:>=) | (:>) | (:<) | Like | ILike+data Cmp = (:=) | (:<=) | (:>=) | (:>) | (:<) | Like | ILike | NotDistinctFrom   deriving (Show, Eq, Generic)  -- | Just boolean operations@@ -248,6 +248,7 @@   (:>)  -> ">"   Like  -> "like"   ILike -> "ilike"+  NotDistinctFrom -> "is not distinct from"  {- | RWS-Monad to generate condition. * Read: Stack of numbers of parent tables. The top is "current table"@@ -419,6 +420,7 @@ {-# INLINE (<=?) #-} {-# INLINE (>=?) #-} {-# INLINE (=?) #-}+{-# INLINE (=??) #-} {-# INLINE (~=?) #-} {-# INLINE (~~?) #-} (<?),(>?),(<=?),(>=?),(=?)@@ -428,11 +430,19 @@ x <=? b = Cmp @x (:<=) b x >=? b = Cmp @x (:>=) b x =? b = Cmp @x (:=) b+-- | Null-safe equality (@IS NOT DISTINCT FROM@) for nullable columns only.+(=??)+  :: forall fld -> forall ren sch tab v+  . ( CDBFieldNullable sch tab (ApplyRenamer ren fld)+    , CDBValue sch tab (ApplyRenamer ren fld) v+    )+  => v -> Cond ren sch tab+x =?? b = Cmp @x NotDistinctFrom b (~=?),(~~?)   :: forall fld -> forall ren sch tab v. CDBValue sch tab (ApplyRenamer ren fld) v => v -> Cond ren sch tab x ~=? b  = Cmp @x Like b x ~~? b  = Cmp @x ILike b-infix 4 <?, >?, <=?, >=?, =?, ~=?, ~~?+infix 4 <?, >?, <=?, >=?, =?, =??, ~=?, ~~?  data OrdDirection = Asc | Desc deriving Show
src/PgSchema/Schema.hs view
@@ -136,15 +136,27 @@  type RestMandatory sch t rs = RestMandatory' sch t rs (TdFlds (TTabDef sch t)) '[] -type family RestPK' (rs :: [Symbol]) (fs :: [Symbol]) (res :: [Symbol]) :: [Symbol] where-  RestPK' rs '[] res = res-  RestPK' rs (fld ': fs) res = RestPK'' rs fs fld res (Elem' fld rs)+type family RestKey' (rs :: [Symbol]) (fs :: [Symbol]) (res :: [Symbol]) :: [Symbol] where+  RestKey' rs '[] res = res+  RestKey' rs (fld ': fs) res = RestKey'' rs fs fld res (Elem' fld rs) -type family RestPK'' rs fs fld (res :: [Symbol]) (b :: Bool) :: [Symbol] where-  RestPK'' rs fs fld res 'True = RestPK' rs fs res-  RestPK'' rs fs fld res 'False = RestPK' rs fs (fld ': res)+type family RestKey'' rs fs fld (res :: [Symbol]) (b :: Bool) :: [Symbol] where+  RestKey'' rs fs fld res 'True = RestKey' rs fs res+  RestKey'' rs fs fld res 'False = RestKey' rs fs (fld ': res) -type RestPK sch t rs = RestPK' rs (TdKey (TTabDef sch t)) '[]+-- | Columns still missing from @rs@ to complete candidate key @keyCols@.+type RestKey rs keyCols = RestKey' rs keyCols '[]++type family AppendPK (pk :: [Symbol]) (uks :: [[Symbol]]) :: [[Symbol]] where+  AppendPK '[] uks = uks+  AppendPK pk uks = pk ': uks++-- | Keys accepted by 'CheckAllMandatoryOrHasKey': PK plus every unique+-- constraint from the schema (catalog order). Runtime key choice uses+-- 'PgSchema.DML.InsertJSON.identityCandidatesFromTab' and its priority rules.+type family IdentityCandidates sch tab :: [[Symbol]] where+  IdentityCandidates sch tab =+    AppendPK (TdKey (TTabDef sch tab)) (TdUniq (TTabDef sch tab))  simpleType :: Text -> TypDef simpleType c = TypDef c Nothing []
src/PgSchema/Types.hs view
@@ -397,9 +397,71 @@ --   synonym below). -- newtype PgTag s t = PgTag { unPgTag :: t }-  deriving stock (Show, Read, Eq, Ord, Functor, Foldable, Traversable)+  deriving stock (Eq, Ord, Functor, Foldable, Traversable)   deriving newtype (Semigroup, Monoid) +-- | Parse legacy @PgTag { unPgTag = … }@ (and minor spacing variants).+--+-- >>> P.show (fst (P.head (readsPgTagLegacy "PgTag { unPgTag = 9 }" :: [(PgTag "z" Int, String)])))+-- "\"z\" =: 9"+readsPgTagLegacy :: Read t => ReadS (PgTag s t)+readsPgTagLegacy r =+  [ (PgTag v, z)+  | ("PgTag", r1) <- lex r+  , ("{", r2) <- lex r1+  , ("unPgTag", r3) <- lex r2+  , ("=", r4) <- lex r3+  , (v, r5) <- reads r4+  , ("}", z) <- lex r5+  ]++-- | When @s :: 'Symbol'@ and @t@ is 'Show', render like @\"field\" =: value@:+--+-- >>> P.show ("ownerId" =: (1 :: Int))+-- "\"ownerId\" =: 1"+instance {-# OVERLAPPING #-} (KnownSymbol s, Show t) =>+  Show (PgTag (s :: Symbol) t) where+  showsPrec p (PgTag x) =+    showParen (p > 5) $+      showString (P.show (TL.symbolVal (Proxy @s) :: String))+        . showString " =: "+        . showsPrec 6 x++-- | Accept @\"field\" =: value@ or the legacy @PgTag { unPgTag = … }@ form:+--+-- >>> P.show (read "\"x\" =: 42" :: PgTag "x" Int)+-- "\"x\" =: 42"+-- >>> P.show (read "PgTag { unPgTag = 42 }" :: PgTag "x" Int)+-- "\"x\" =: 42"+instance {-# OVERLAPPING #-} (KnownSymbol s, Read t) =>+  Read (PgTag (s :: Symbol) t) where+  readsPrec p r =+    readParen (p > 5) tryEqColon r P.++ readParen (p > 11) readsPgTagLegacy r+    where+      tryEqColon s =+        [ (PgTag a, u)+        | (expected, t) <- reads s+        , expected == (TL.symbolVal (Proxy @s) :: String)+        , ("=:", u0) <- lex t+        , (a, u) <- readsPrec 6 u0+        ]++-- | If @s@ is not a 'Symbol', fall back to record-style 'Show':+--+-- >>> P.show (PgTag @Bool (42 :: Int))+-- "PgTag {unPgTag = 42}"+instance {-# OVERLAPPABLE #-} Show t => Show (PgTag s t) where+  showsPrec p (PgTag x) =+    showParen (p > 11) $+      showString "PgTag {unPgTag = " . shows x . showString "}"++-- | Uses only 'readsPgTagLegacy' (see there for a doctest).+--+-- >>> P.show (read "PgTag { unPgTag = 42 }" :: PgTag Bool Int)+-- "PgTag {unPgTag = 42}"+instance {-# OVERLAPPABLE #-} Read t => Read (PgTag s t) where+  readsPrec p = readParen (p > 11) readsPgTagLegacy+ type s := t = PgTag s t infixr 5 := @@ -409,7 +471,6 @@  newtype UnsafeCol (flds :: [Symbol]) (expr :: Symbol) res = UnsafeCol   { getUnsafeCol :: res }-  -- deriving newtype (FromField, FromJSON)  instance (FromField res, AllFields sch tab flds, CheckExpr flds expr) =>   FromField (PgTag '(sch, tab :: NameNSK) (UnsafeCol flds expr res)) where
test-gen/Main.hs view
@@ -90,6 +90,16 @@         constraint leaf_mid2_fk foreign key (root_id, seq) references mid2 (root_id, seq) on delete cascade       ); +      -- Upsert by nullable unique key when table has no NOT NULL UK.+      create table nullable_uq_row (+        id     serial primary key,+        code   text not null,+        suffix text,+        name   text not null,+        note   text,+        constraint nullable_uq_row_code_suffix_uq unique (code, suffix)+      );+       -- Table for array types (nullable elements, no 2D arrays).       create table arrays (         id             serial primary key,
test-pgs/Main.hs view
@@ -10,6 +10,8 @@  import Tests.BaseConverts import Tests.Hierarchy+import Tests.InsertJSONTransaction+import Tests.UpsertUniqueKey import Tests.Conditions  prop_not_implemented :: Property@@ -34,6 +36,26 @@       , testProperty "Duplicate field names in root and nested structure" $ prop_hier_duplicate_names_root_nested pool       -- , testProperty "Optional parent FK on root (dim_a_id)" $       --     prop_hier_insert_optional_parent_dim_a pool+      ]+    , testGroup "InsertJSON transactions (test_dml)"+      [ testProperty "Standalone call commits" $+          prop_insertJSON_standalone_commits pool+      , testProperty "Outer transaction is not committed" $+          prop_insertJSON_respects_outer_transaction pool+      , testProperty "BEGIN without prior writes rolls back" $+          prop_insertJSON_begin_without_prior_writes pool+      , testProperty "Failure rolls back standalone transaction" $+          prop_insertJSON_rolls_back_on_failure pool+      ]+    , testGroup "Upsert by unique key (test_dml)"+      [ testProperty "upsertJSON on composite unique without PK in payload" $+          prop_upsert_json_by_composite_unique pool+      , testProperty "upsertJSON on nullable unique without NOT NULL UK" $+          prop_upsert_json_by_nullable_unique pool+      , testProperty "upsertJSON UPDATE by nullable unique key" $+          prop_upsert_json_update_by_nullable_unique pool+      , testProperty "upsertJSON null in nullable key inserts again" $+          prop_upsert_json_nullable_key_null_inserts_twice pool       ]     , testGroup "Query (test_dml)"       [ testProperty "'Simple' queries" $ prop_cond_query pool
test-pgs/Sch.hs view
@@ -71,11 +71,12 @@   TTabDefSch ( "test_pgs" ->> "leaf" ) = 'TabDef '[ "root_id","seq","leaf_no","value","category","created_at" ] '[ "root_id","seq","leaf_no" ] '[  ]   TTabDefSch ( "test_pgs" ->> "mid1" ) = 'TabDef '[ "id","root_id","pos","flag","sort_key","payload" ] '[ "id" ] '[  ]   TTabDefSch ( "test_pgs" ->> "mid2" ) = 'TabDef '[ "root_id","seq","kind","flag","priority","payload" ] '[ "root_id","seq" ] '[  ]+  TTabDefSch ( "test_pgs" ->> "nullable_uq_row" ) = 'TabDef '[ "id","code","suffix","name","note" ] '[ "id" ] '[ '[ "code","suffix" ] ]   TTabDefSch ( "test_pgs" ->> "root" ) = 'TabDef '[ "id","code","grp","name","created_at","dim_a_id","dim_b_id" ] '[ "id" ] '[ '[ "code","grp" ] ]   TTabDefSch name = TE.TypeError (TE.Text "In schema " TE.:<>: TE.ShowType Sch TE.:$$: TE.Text "table " TE.:<>: TE.ShowType name TE.:<>: TE.Text " is not defined."     TE.:$$: TE.Text ""     TE.:$$: TE.Text "Valid values are:"-    TE.:$$: TE.Text "  Tables: test_pgs.arrays, test_pgs.base_arr_converts, test_pgs.base_converts, test_pgs.dim, test_pgs.ext_arr_converts, test_pgs.ext_converts, test_pgs.leaf, test_pgs.mid1, test_pgs.mid2, test_pgs.root."+    TE.:$$: TE.Text "  Tables: test_pgs.arrays, test_pgs.base_arr_converts, test_pgs.base_converts, test_pgs.dim, test_pgs.ext_arr_converts, test_pgs.ext_converts, test_pgs.leaf, test_pgs.mid1, test_pgs.mid2, test_pgs.nullable_uq_row, test_pgs.root."     TE.:$$: TE.Text "") instance (ToStar (TTabDef Sch name), ToStar name) => CTabDef Sch name where   type TTabDef Sch name = TTabDefSch name@@ -117,13 +118,15 @@    TFromSch ( "test_pgs" ->> "mid2" ) = '[ ( "test_pgs" ->> "mid2_root_fk" ) ] +  TFromSch ( "test_pgs" ->> "nullable_uq_row" ) = '[  ]+   TFromSch ( "test_pgs" ->> "root" ) = '[ ( "test_pgs" ->> "root_dim_a_fk" )     ,( "test_pgs" ->> "root_dim_b_fk" ) ]    TFromSch tab = TE.TypeError (TE.Text "In schema " TE.:<>: TE.ShowType Sch TE.:$$: TE.Text "TFrom for table " TE.:<>: TE.ShowType tab TE.:<>: TE.Text " is not defined."     TE.:$$: TE.Text ""     TE.:$$: TE.Text "Valid values are:"-    TE.:$$: TE.Text "  Tables: test_pgs.arrays, test_pgs.base_arr_converts, test_pgs.base_converts, test_pgs.dim, test_pgs.ext_arr_converts, test_pgs.ext_converts, test_pgs.leaf, test_pgs.mid1, test_pgs.mid2, test_pgs.root."+    TE.:$$: TE.Text "  Tables: test_pgs.arrays, test_pgs.base_arr_converts, test_pgs.base_converts, test_pgs.dim, test_pgs.ext_arr_converts, test_pgs.ext_converts, test_pgs.leaf, test_pgs.mid1, test_pgs.mid2, test_pgs.nullable_uq_row, test_pgs.root."     TE.:$$: TE.Text "")  type family TToSch (tab :: NameNSK) :: [NameNSK] where@@ -146,13 +149,15 @@    TToSch ( "test_pgs" ->> "mid2" ) = '[ ( "test_pgs" ->> "leaf_mid2_fk" ) ] +  TToSch ( "test_pgs" ->> "nullable_uq_row" ) = '[  ]+   TToSch ( "test_pgs" ->> "root" ) = '[ ( "test_pgs" ->> "arrays_root_fk" )     ,( "test_pgs" ->> "mid1_root_fk" ),( "test_pgs" ->> "mid2_root_fk" ) ]    TToSch tab = TE.TypeError (TE.Text "In schema " TE.:<>: TE.ShowType Sch TE.:$$: TE.Text "TTo for table " TE.:<>: TE.ShowType tab TE.:<>: TE.Text " is not defined."     TE.:$$: TE.Text ""     TE.:$$: TE.Text "Valid values are:"-    TE.:$$: TE.Text "  Tables: test_pgs.arrays, test_pgs.base_arr_converts, test_pgs.base_converts, test_pgs.dim, test_pgs.ext_arr_converts, test_pgs.ext_converts, test_pgs.leaf, test_pgs.mid1, test_pgs.mid2, test_pgs.root."+    TE.:$$: TE.Text "  Tables: test_pgs.arrays, test_pgs.base_arr_converts, test_pgs.base_converts, test_pgs.dim, test_pgs.ext_arr_converts, test_pgs.ext_converts, test_pgs.leaf, test_pgs.mid1, test_pgs.mid2, test_pgs.nullable_uq_row, test_pgs.root."     TE.:$$: TE.Text "") instance CTabRels Sch tab where   type TFrom Sch tab = TFromSch tab@@ -313,6 +318,21 @@     TE.:$$: TE.Text ""     TE.:$$: TE.Text "Your source or target type or renaimer is probably invalid."     TE.:$$: TE.Text "")+  TDBFieldInfoSch ( "test_pgs" ->> "nullable_uq_row" ) "code" = 'RFPlain ('FldDef ( "pg_catalog" ->> "text" ) 'False 'False)+  TDBFieldInfoSch ( "test_pgs" ->> "nullable_uq_row" ) "id" = 'RFPlain ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'True)+  TDBFieldInfoSch ( "test_pgs" ->> "nullable_uq_row" ) "name" = 'RFPlain ('FldDef ( "pg_catalog" ->> "text" ) 'False 'False)+  TDBFieldInfoSch ( "test_pgs" ->> "nullable_uq_row" ) "note" = 'RFPlain ('FldDef ( "pg_catalog" ->> "text" ) 'True 'False)+  TDBFieldInfoSch ( "test_pgs" ->> "nullable_uq_row" ) "suffix" = 'RFPlain ('FldDef ( "pg_catalog" ->> "text" ) 'True 'False)+  TDBFieldInfoSch ( "test_pgs" ->> "nullable_uq_row" ) f = TE.TypeError (TE.Text "In schema " TE.:<>: TE.ShowType Sch+    TE.:$$: TE.Text "for table " TE.:<>: TE.ShowType ( "test_pgs" ->> "nullable_uq_row" )+    TE.:$$: TE.Text "name " TE.:<>: TE.ShowType f TE.:<>: TE.Text " is not defined."+    TE.:$$: TE.Text ""+    TE.:$$: TE.Text "Valid values are:"+    TE.:$$: TE.Text "  Fields: id, code, suffix, name, note."+    TE.:$$: TE.Text "  Foreign key constraints: ."+    TE.:$$: TE.Text ""+    TE.:$$: TE.Text "Your source or target type or renaimer is probably invalid."+    TE.:$$: TE.Text "")   TDBFieldInfoSch ( "test_pgs" ->> "root" ) "code" = 'RFPlain ('FldDef ( "pg_catalog" ->> "text" ) 'False 'False)   TDBFieldInfoSch ( "test_pgs" ->> "root" ) "created_at" = 'RFPlain ('FldDef ( "pg_catalog" ->> "timestamptz" ) 'False 'True)   TDBFieldInfoSch ( "test_pgs" ->> "root" ) "dim_a_id" = 'RFPlain ('FldDef ( "pg_catalog" ->> "int4" ) 'True 'False)@@ -348,10 +368,11 @@  instance CSchema Sch where   type TTabs Sch = '[ ( "test_pgs" ->> "arrays" ),( "test_pgs" ->> "base_arr_converts" )-    ,( "test_pgs" ->> "base_converts" ),( "test_pgs" ->> "dim" )-    ,( "test_pgs" ->> "ext_arr_converts" ),( "test_pgs" ->> "ext_converts" )-    ,( "test_pgs" ->> "leaf" ),( "test_pgs" ->> "mid1" )-    ,( "test_pgs" ->> "mid2" ),( "test_pgs" ->> "root" ) ]+    ,( "test_pgs" ->> "base_converts" )+    ,( "test_pgs" ->> "dim" ),( "test_pgs" ->> "ext_arr_converts" )+    ,( "test_pgs" ->> "ext_converts" ),( "test_pgs" ->> "leaf" )+    ,( "test_pgs" ->> "mid1" ),( "test_pgs" ->> "mid2" )+    ,( "test_pgs" ->> "nullable_uq_row" ),( "test_pgs" ->> "root" ) ]    type TTypes Sch = '[ ( "pg_catalog" ->> "_bool" )     ,( "pg_catalog" ->> "_bytea" ),( "pg_catalog" ->> "_date" )
+ test-pgs/Tests/InsertJSONTransaction.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE BlockArguments #-}+module Tests.InsertJSONTransaction where++import Control.Exception (SomeException, try)+import Control.Monad (void, when)+import Data.Functor+import Data.Int (Int32, Int64)+import Data.List qualified as L+import Data.Pool as Pool+import Data.Text (Text)+import Database.PostgreSQL.Simple+import Hedgehog+import Utils+import PgSchema.DML++type RootRec = "code" := Text :. "grp" := Int32 :. "name" := Text :. "someEmpty" := ()++type RootSel = "code" := Text :. "grp" := Int32 :. "name" := Text++eqRoot :: RootRec -> RootRec -> Bool+eqRoot (a1 :. b1 :. c1) (a2 :. b2 :. c2) = (a1, b1) == (a2, b2)++countRoots :: Connection -> IO Int64+countRoots conn = do+  [cnt] <- fst <$> selSch "root" conn qpEmpty+  pure $ unAggr @ACount $ unPgTag @"cnt" cnt++countRootsCode :: Connection -> Text -> IO Int64+countRootsCode conn code = do+  [cnt] <- fst <$> selSch "root" conn (qRoot $ qWhere $ "code" =? code)+  pure $ unAggr @ACount $ unPgTag @"cnt" cnt++clearRoots :: Connection -> IO ()+clearRoots conn = void $ delByCond "root" conn mempty++prop_insertJSON_standalone_commits :: Pool Connection -> Property+prop_insertJSON_standalone_commits pool = property do+  rootsIn <- forAll (L.nubBy eqRoot <$> genData' RootRec 1 5)+  evalIO do+    Pool.withResource pool clearRoots+    Pool.withResource pool \conn -> void $ insJSON_ "root" conn rootsIn+    Pool.withResource pool \conn -> do+      n <- countRoots conn+      when (n /= fromIntegral (length rootsIn)) $+        fail $ "expected " <> show (length rootsIn) <> " rows, got " <> show n++prop_insertJSON_respects_outer_transaction :: Pool Connection -> Property+prop_insertJSON_respects_outer_transaction pool = property do+  rootsIn <- forAll (L.nubBy eqRoot <$> genData' RootRec 1 5)+  evalIO do+    Pool.withResource pool clearRoots+    Pool.withResource pool \conn -> do+      execute_ conn "begin"+      void $ insJSON_ "root" conn rootsIn+      n <- countRoots conn+      when (n /= fromIntegral (length rootsIn)) $+        fail $ "expected " <> show (length rootsIn) <> " rows in session, got "+          <> show n+      Pool.withResource pool \conn2 -> do+        n2 <- countRoots conn2+        when (n2 /= 0) $+          fail $ "uncommitted rows visible in other session: " <> show n2+      rollback conn+    Pool.withResource pool \conn -> do+      n <- countRoots conn+      when (n /= 0) $+        fail $ "rows remained after rollback: " <> show n++prop_insertJSON_begin_without_prior_writes :: Pool Connection -> Property+prop_insertJSON_begin_without_prior_writes pool = property do+  rootsIn <- forAll (L.nubBy eqRoot <$> genData' RootRec 1 5)+  evalIO do+    Pool.withResource pool clearRoots+    Pool.withResource pool \conn -> do+      execute_ conn "begin"+      void $ insJSON_ "root" conn rootsIn+      rollback conn+    Pool.withResource pool \conn -> do+      n <- countRoots conn+      when (n /= 0) $+        fail $ "rows remained after rollback from empty begin: " <> show n++prop_insertJSON_rolls_back_on_failure :: Pool Connection -> Property+prop_insertJSON_rolls_back_on_failure pool = property do+  evalIO do+    Pool.withResource pool clearRoots+    let+      row :: RootRec+      row = "code" =: "dup_tx" :. "grp" =: (1 :: Int32)+        :. "name" =: "x" :. "someEmpty" =: ()+    Pool.withResource pool \conn -> do+      res <- try @SomeException $ insJSON_ "root" conn [row, row]+      case res of+        Left _ -> pure ()+        Right _ -> fail "expected unique violation"+      n <- countRootsCode conn "dup_tx"+      when (n /= 0) $+        fail $ "partial insert remained after failure: " <> show n+    Pool.withResource pool \conn -> do+      n <- countRootsCode conn "dup_tx"+      when (n /= 0) $+        fail $ "failed insert visible in other session: " <> show n
+ test-pgs/Tests/UpsertUniqueKey.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE BlockArguments #-}+module Tests.UpsertUniqueKey where++import Control.Monad (void, when)+import Data.Int (Int32)+import Data.Maybe (Maybe(..))+import Data.List qualified as L+import Data.Pool as Pool+import Data.Text (Text)+import Database.PostgreSQL.Simple (Connection)+import Hedgehog (Property, discard, evalIO, forAll, property, withTests)+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import PgSchema.DML+import Utils++type RootRec =+  "code" := Text :. "grp" := Int32 :. "name" := Text :. "someEmpty" := ()++type RootSel = "code" := Text :. "grp" := Int32 :. "name" := Text++-- | Upsert by composite unique @(code, grp)@ when PK @id@ is omitted; second call+-- updates the same row.+prop_upsert_json_by_composite_unique :: Pool Connection -> Property+prop_upsert_json_by_composite_unique pool = withTests 5 $ property do+  code <- forAll (Gen.text (Range.linear 3 24) Gen.alphaNum)+  name1 <- forAll (Gen.text (Range.linear 1 24) Gen.alphaNum)+  name2 <- forAll (Gen.text (Range.linear 1 24) Gen.alphaNum)+  when (name1 == name2) discard+  let grp = 4242 :: Int32+  evalIO $ Pool.withResource pool \conn -> do+    void $ delByCond "root" conn ("code" =? code)+    let+      row1 :: RootRec+      row1 = "code" =: code :. "grp" =: grp :. "name" =: name1 :. "someEmpty" =: ()+      row2 :: RootRec+      row2 = "code" =: code :. "grp" =: grp :. "name" =: name2 :. "someEmpty" =: ()+    void $ upsJSON_ "root" conn [row1]+    void $ upsJSON_ "root" conn [row2]+    (rows :: [RootSel], _) <- selSch "root" conn $+      qRoot $ qWhere $ "code" =? code &&& "grp" =? grp+    case rows of+      [_ :. _ :. n] ->+        when (unPgTag n /= name2) $+          fail $ "expected updated name " <> show name2 <> ", got " <> show (unPgTag n)+      _ -> fail $ "expected 1 row, got " <> show (L.length rows)++-- | Upsert by nullable unique @(code, suffix)@ when table has no NOT NULL UK.+prop_upsert_json_by_nullable_unique :: Pool Connection -> Property+prop_upsert_json_by_nullable_unique pool = withTests 5 $ property do+  code <- forAll (Gen.text (Range.linear 3 24) Gen.alphaNum)+  suffix <- forAll (Gen.text (Range.linear 1 12) Gen.alphaNum)+  name1 <- forAll (Gen.text (Range.linear 1 24) Gen.alphaNum)+  name2 <- forAll (Gen.text (Range.linear 1 24) Gen.alphaNum)+  when (name1 == name2) discard+  let sfx = Just suffix+  evalIO $ Pool.withResource pool \conn -> do+    void $ delByCond "nullable_uq_row" conn ("code" =? code)+    let+      row1 = "code" =: code :. "suffix" =: sfx :. "name" =: name1+        :. "note" =: (Nothing :: Maybe Text) :. "someEmpty" =: ()+      row2 = "code" =: code :. "suffix" =: sfx :. "name" =: name2+        :. "note" =: (Nothing :: Maybe Text) :. "someEmpty" =: ()+    void $ upsJSON_ "nullable_uq_row" conn [row1]+    void $ upsJSON_ "nullable_uq_row" conn [row2]+    (rows :: ["name" := Text], _) <- selSch "nullable_uq_row" conn $+      qRoot $ qWhere $ "code" =? code &&& "suffix" =?? sfx+    case rows of+      [n] ->  when (unPgTag n /= name2) $ fail+        $ "expected updated name " <> show name2 <> ", got " <> show (unPgTag n)+      _ -> fail $ "expected 1 row, got " <> show (L.length rows)++-- | UPDATE branch: key only + optional field, mandatory @name@ omitted.+prop_upsert_json_update_by_nullable_unique :: Pool Connection -> Property+prop_upsert_json_update_by_nullable_unique pool = withTests 5 $ property do+  code <- forAll (Gen.text (Range.linear 3 24) Gen.alphaNum)+  suffix <- forAll (Gen.text (Range.linear 1 12) Gen.alphaNum)+  note1 <- forAll (Gen.text (Range.linear 1 24) Gen.alphaNum)+  note2 <- forAll (Gen.text (Range.linear 1 24) Gen.alphaNum)+  when (note1 == note2) discard+  let+    sfx = Just suffix+    fullName = "seed-name"+  evalIO $ Pool.withResource pool \conn -> do+    void $ delByCond "nullable_uq_row" conn ("code" =? code)+    let+      seed =+        "code" =: code :. "suffix" =: sfx :. "name" =: fullName+          :. "note" =: Just note1 :. "someEmpty" =: ()+      patch =+        "code" =: code :. "suffix" =: sfx :. "note" =: Just note2+          :. "someEmpty" =: ()+    void $ upsJSON_ "nullable_uq_row" conn [seed]+    void $ upsJSON_ "nullable_uq_row" conn [patch]+    (rows :: ["name" := Text :. "note" := Maybe Text], _) <-+      selSch "nullable_uq_row" conn+        $ qRoot $ qWhere $ "code" =? code &&& "suffix" =?? sfx+    case rows of+      [nm :. note] -> do+        when (unPgTag note /= Just note2) $+          fail $ "expected note " <> show note2 <> ", got " <> show (unPgTag note)+        when (unPgTag nm /= fullName) $+          fail $ "name should be unchanged, got " <> show (unPgTag nm)+      _ -> fail $ "expected 1 row, got " <> show (L.length rows)++-- | NULL in nullable key column: classic UNIQUE allows duplicate keys.+prop_upsert_json_nullable_key_null_inserts_twice :: Pool Connection -> Property+prop_upsert_json_nullable_key_null_inserts_twice pool = withTests 3 $ property do+  code <- forAll (Gen.text (Range.linear 3 24) Gen.alphaNum)+  name1 <- forAll (Gen.text (Range.linear 1 16) Gen.alphaNum)+  name2 <- forAll (Gen.text (Range.linear 1 16) Gen.alphaNum)+  when (name1 == name2) discard+  evalIO $ Pool.withResource pool \conn -> do+    void $ delByCond "nullable_uq_row" conn ("code" =? code)+    let+      row nm =+        "code" =: code :. "suffix" =: (Nothing :: Maybe Text) :. "name" =: nm+          :. "note" =: (Nothing :: Maybe Text) :. "someEmpty" =: ()+    void $ upsJSON_ "nullable_uq_row" conn [row name1]+    void $ upsJSON_ "nullable_uq_row" conn [row name2]+    (rows :: ["code" := Text], _) <- selSch "nullable_uq_row" conn $+      qRoot $ qWhere $ "code" =? code &&& pnull "suffix"+    when (L.length rows /= 2) $+      fail $ "expected 2 rows with null suffix, got " <> show (L.length rows)