ihp-typed-sql (empty) → 1.5.0
raw patch · 13 files changed
+2764/−0 lines, 13 filesdep +aesondep +basedep +bytestring
Dependencies added: aeson, base, bytestring, containers, directory, filepath, haskell-src-meta, hasql, hasql-dynamic-statements, hasql-mapping, hasql-pool, hspec, ihp, ihp-log, ihp-typed-sql, postgresql-libpq, postgresql-syntax, postgresql-types, process, scientific, string-conversions, template-haskell, temporary, text
Files
- IHP/TypedSql.hs +38/−0
- IHP/TypedSql/Decoders.hs +216/−0
- IHP/TypedSql/Metadata.hs +362/−0
- IHP/TypedSql/ParamHints.hs +445/−0
- IHP/TypedSql/Placeholders.hs +60/−0
- IHP/TypedSql/Quoter.hs +127/−0
- IHP/TypedSql/TypeMapping.hs +136/−0
- IHP/TypedSql/Types.hs +13/−0
- LICENSE +21/−0
- Test/Test/Main.hs +10/−0
- Test/Test/TypedSqlSpec.hs +1224/−0
- changelog.md +15/−0
- ihp-typed-sql.cabal +97/−0
+ IHP/TypedSql.hs view
@@ -0,0 +1,38 @@+module IHP.TypedSql+ ( typedSql+ , TypedQuery (..)+ , sqlQueryTyped+ , sqlExecTyped+ ) where++import qualified Hasql.Decoders as HasqlDecoders+import qualified Hasql.DynamicStatements.Snippet as Snippet+import IHP.ModelSupport (sqlQueryHasql)+import IHP.Prelude++import IHP.TypedSql.Quoter (typedSql)+import IHP.TypedSql.Types (TypedQuery (..))++-- | Run a typed SELECT query and return all result rows.+--+-- Also works with INSERT\/UPDATE\/DELETE ... RETURNING statements+-- that return rows.+--+-- > users <- sqlQueryTyped [typedSql| SELECT name FROM users |]+-- > newIds <- sqlQueryTyped [typedSql| INSERT INTO items (name) VALUES (${name}) RETURNING id |]+sqlQueryTyped :: (?modelContext :: ModelContext) => TypedQuery result -> IO [result]+sqlQueryTyped TypedQuery { tqSnippet, tqResultDecoder } =+ runTypedSqlSession tqSnippet (HasqlDecoders.rowList tqResultDecoder)++-- | Run a typed statement (INSERT\/UPDATE\/DELETE) and return the affected row count.+--+-- Use 'sqlQueryTyped' instead if your statement has a RETURNING clause.+--+-- > rowsAffected <- sqlExecTyped [typedSql| DELETE FROM items WHERE id = ${itemId} |]+sqlExecTyped :: (?modelContext :: ModelContext) => TypedQuery result -> IO Int64+sqlExecTyped TypedQuery { tqSnippet } =+ runTypedSqlSession tqSnippet HasqlDecoders.rowsAffected++runTypedSqlSession :: (?modelContext :: ModelContext) => Snippet.Snippet -> HasqlDecoders.Result result -> IO result+runTypedSqlSession snippet decoder =+ sqlQueryHasql ?modelContext.hasqlPool snippet decoder
+ IHP/TypedSql/Decoders.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module IHP.TypedSql.Decoders+ ( resultDecoderForColumns+ ) where++import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.String.Conversions as CS+import qualified Database.PostgreSQL.LibPQ as PQ+import qualified Hasql.Decoders as HasqlDecoders+import qualified Hasql.Mapping.IsScalar as Mapping+import qualified Language.Haskell.TH as TH+import IHP.Hasql.FromRow as HasqlFromRow+import IHP.ModelSupport.Types (Id' (..))+import IHP.Prelude++import IHP.TypedSql.Metadata (ColumnMeta (..), DescribeColumn (..), PgTypeInfo (..), TableMeta (..))+import IHP.TypedSql.TypeMapping (detectFullTable)++-- | Build a hasql result decoder for the described SQL columns.+-- For full-table selections we reuse FromRowHasql; otherwise we decode a scalar/tuple.+resultDecoderForColumns :: Map.Map PQ.Oid PgTypeInfo -> Map.Map PQ.Oid TableMeta -> Set.Set PQ.Oid -> [DescribeColumn] -> TH.ExpQ+resultDecoderForColumns typeInfo tables joinNullableOids columns = do+ case detectFullTable tables columns of+ Just _ ->+ pure (TH.VarE 'HasqlFromRow.hasqlRowDecoder)+ Nothing -> do+ rowDecoder <- case columns of+ [] -> pure (TH.AppE (TH.VarE 'pure) (TH.ConE '()))+ [column] -> rowDecoderForColumn typeInfo tables joinNullableOids column+ _ -> tupleRowDecoderForColumns typeInfo tables joinNullableOids columns+ pure rowDecoder++tupleRowDecoderForColumns :: Map.Map PQ.Oid PgTypeInfo -> Map.Map PQ.Oid TableMeta -> Set.Set PQ.Oid -> [DescribeColumn] -> TH.ExpQ+tupleRowDecoderForColumns typeInfo tables joinNullableOids columns = do+ columnDecoders <- mapM (rowDecoderForColumn typeInfo tables joinNullableOids) columns+ case columnDecoders of+ [] -> pure (TH.AppE (TH.VarE 'pure) (TH.ConE '()))+ firstDecoder:restDecoders -> do+ let tupleConstructor = TH.ConE (TH.tupleDataName (length columnDecoders))+ let withFirst = TH.AppE (TH.AppE (TH.VarE '(<$>)) tupleConstructor) firstDecoder+ pure (foldl (\acc decoder -> TH.AppE (TH.AppE (TH.VarE '(<*>)) acc) decoder) withFirst restDecoders)++rowDecoderForColumn :: Map.Map PQ.Oid PgTypeInfo -> Map.Map PQ.Oid TableMeta -> Set.Set PQ.Oid -> DescribeColumn -> TH.ExpQ+rowDecoderForColumn typeInfo tables joinNullableOids DescribeColumn { dcType, dcTable, dcAttnum } =+ case (Map.lookup dcTable tables, dcAttnum) of+ (Just TableMeta { tmPrimaryKeys, tmForeignKeys, tmColumns }, Just attnum) ->+ let joinNullable = dcTable `Set.member` joinNullableOids+ nullable = joinNullable || maybe True (not . cmNotNull) (Map.lookup attnum tmColumns)+ isIdColumn = attnum `Set.member` tmPrimaryKeys || attnum `Map.member` tmForeignKeys+ in do+ columnTypeOid <- maybe (failText (missingColumnType attnum dcTable)) (pure . cmTypeOid) (Map.lookup attnum tmColumns)+ if isIdColumn+ then decodeIdColumn typeInfo nullable columnTypeOid+ else decodeColumnByOid typeInfo nullable columnTypeOid+ _ ->+ decodeColumnByOid typeInfo True dcType+ where+ missingColumnType attnum tableOid =+ "typedSql: missing column metadata for attnum " <> show attnum <> " on table oid " <> show tableOid++decodeIdColumn :: Map.Map PQ.Oid PgTypeInfo -> Bool -> PQ.Oid -> TH.ExpQ+decodeIdColumn typeInfo nullable oid = do+ baseDecoder <- decodeColumnByOid typeInfo nullable oid+ if nullable+ then pure (TH.AppE (TH.AppE (TH.VarE 'fmap) (TH.AppE (TH.VarE 'fmap) (TH.ConE 'Id))) baseDecoder)+ else pure (TH.AppE (TH.AppE (TH.VarE 'fmap) (TH.ConE 'Id)) baseDecoder)++decodeColumnByOid :: Map.Map PQ.Oid PgTypeInfo -> Bool -> PQ.Oid -> TH.ExpQ+decodeColumnByOid typeInfo nullable oid =+ case Map.lookup oid typeInfo of+ Nothing -> failText ("typedSql: missing type information for column oid " <> show oid)+ Just pgTypeInfo -> decodeColumnByTypeInfo typeInfo nullable pgTypeInfo++decodeColumnByTypeInfo :: Map.Map PQ.Oid PgTypeInfo -> Bool -> PgTypeInfo -> TH.ExpQ+decodeColumnByTypeInfo typeInfo nullable PgTypeInfo { ptiName, ptiElem } =+ case ptiElem of+ Just elementOid -> decodeArrayColumn typeInfo nullable elementOid+ Nothing -> decodeScalarColumn nullable ptiName++decodeArrayColumn :: Map.Map PQ.Oid PgTypeInfo -> Bool -> PQ.Oid -> TH.ExpQ+decodeArrayColumn typeInfo nullable elementOid =+ case Map.lookup elementOid typeInfo of+ Nothing -> failText ("typedSql: missing array element type for oid " <> show elementOid)+ Just elementType ->+ case ptiName elementType of+ "int2" -> decodeIntLikeArray nullable (TH.VarE 'HasqlDecoders.int2)+ "int4" -> decodeIntLikeArray nullable (TH.VarE 'HasqlDecoders.int4)+ "int8" -> decodeIntLikeArray nullable (TH.VarE 'HasqlDecoders.int8)+ "text" -> decodeSimpleArray nullable (TH.VarE 'HasqlDecoders.text)+ "varchar" -> decodeSimpleArray nullable (TH.VarE 'HasqlDecoders.text)+ "bpchar" -> decodeSimpleArray nullable (TH.VarE 'HasqlDecoders.text)+ "citext" -> decodeSimpleArray nullable (TH.VarE 'HasqlDecoders.text)+ "bool" -> decodeSimpleArray nullable (TH.VarE 'HasqlDecoders.bool)+ "uuid" -> decodeSimpleArray nullable (TH.VarE 'HasqlDecoders.uuid)+ "float4" -> decodeSimpleArray nullable (TH.VarE 'HasqlDecoders.float4)+ "float8" -> decodeSimpleArray nullable (TH.VarE 'HasqlDecoders.float8)+ "numeric" -> decodeSimpleArray nullable (TH.VarE 'HasqlDecoders.numeric)+ "json" -> decodeSimpleArray nullable (TH.VarE 'HasqlDecoders.json)+ "jsonb" -> decodeSimpleArray nullable (TH.VarE 'HasqlDecoders.jsonb)+ "bytea" -> decodeSimpleArray nullable (TH.VarE 'HasqlDecoders.bytea)+ "timestamptz" -> decodeSimpleArray nullable (TH.VarE 'HasqlDecoders.timestamptz)+ "timestamp" -> decodeSimpleArray nullable (TH.VarE 'HasqlDecoders.timestamp)+ "date" -> decodeSimpleArray nullable (TH.VarE 'HasqlDecoders.date)+ "time" -> decodeSimpleArray nullable (TH.VarE 'HasqlDecoders.time)+ _ -> decodeMappingArray nullable++decodeScalarColumn :: Bool -> Text -> TH.ExpQ+decodeScalarColumn nullable typeName =+ case typeName of+ "int2" -> decodeIntLikeScalar nullable (TH.VarE 'HasqlDecoders.int2)+ "int4" -> decodeIntLikeScalar nullable (TH.VarE 'HasqlDecoders.int4)+ "int8" -> decodeIntLikeScalar nullable (TH.VarE 'HasqlDecoders.int8)+ "text" -> decodeSimpleScalar nullable (TH.VarE 'HasqlDecoders.text)+ "varchar" -> decodeSimpleScalar nullable (TH.VarE 'HasqlDecoders.text)+ "bpchar" -> decodeSimpleScalar nullable (TH.VarE 'HasqlDecoders.text)+ "citext" -> decodeSimpleScalar nullable (TH.VarE 'HasqlDecoders.text)+ "bool" -> decodeSimpleScalar nullable (TH.VarE 'HasqlDecoders.bool)+ "uuid" -> decodeSimpleScalar nullable (TH.VarE 'HasqlDecoders.uuid)+ "timestamptz" -> decodeSimpleScalar nullable (TH.VarE 'HasqlDecoders.timestamptz)+ "timestamp" -> decodeSimpleScalar nullable (TH.VarE 'HasqlDecoders.timestamp)+ "date" -> decodeSimpleScalar nullable (TH.VarE 'HasqlDecoders.date)+ "time" -> decodeSimpleScalar nullable (TH.VarE 'HasqlDecoders.time)+ "json" -> decodeSimpleScalar nullable (TH.VarE 'HasqlDecoders.json)+ "jsonb" -> decodeSimpleScalar nullable (TH.VarE 'HasqlDecoders.jsonb)+ "float4" -> decodeSimpleScalar nullable (TH.VarE 'HasqlDecoders.float4)+ "float8" -> decodeSimpleScalar nullable (TH.VarE 'HasqlDecoders.float8)+ "numeric" -> decodeSimpleScalar nullable (TH.VarE 'HasqlDecoders.numeric)+ "bytea" -> decodeSimpleScalar nullable (TH.VarE 'HasqlDecoders.bytea)+ "point" -> decodeMappingScalar nullable+ "polygon" -> decodeMappingScalar nullable+ "inet" -> decodeMappingScalar nullable+ "tsvector" -> decodeMappingScalar nullable+ "interval" -> decodeMappingScalar nullable+ _ -> decodeMappingScalar nullable++decodeSimpleScalar :: Bool -> TH.Exp -> TH.ExpQ+decodeSimpleScalar nullable valueDecoder =+ pure (TH.AppE (TH.VarE 'HasqlDecoders.column) (nullabilityWrapper nullable valueDecoder))++decodeSimpleArray :: Bool -> TH.Exp -> TH.ExpQ+decodeSimpleArray nullable valueDecoder =+ pure+ ( TH.AppE+ (TH.VarE 'HasqlDecoders.column)+ ( nullabilityWrapper+ nullable+ ( TH.AppE+ (TH.VarE 'HasqlDecoders.listArray)+ (TH.AppE (TH.VarE 'HasqlDecoders.nonNullable) valueDecoder)+ )+ )+ )++decodeIntLikeScalar :: Bool -> TH.Exp -> TH.ExpQ+decodeIntLikeScalar nullable baseDecoder =+ if nullable+ then pure+ ( TH.AppE+ (TH.AppE (TH.VarE 'fmap) (TH.AppE (TH.VarE 'fmap) (TH.VarE 'fromIntegral)))+ (TH.AppE (TH.VarE 'HasqlDecoders.column) (nullabilityWrapper True baseDecoder))+ )+ else pure+ ( TH.AppE+ (TH.AppE (TH.VarE 'fmap) (TH.VarE 'fromIntegral))+ (TH.AppE (TH.VarE 'HasqlDecoders.column) (nullabilityWrapper False baseDecoder))+ )++decodeIntLikeArray :: Bool -> TH.Exp -> TH.ExpQ+decodeIntLikeArray nullable baseDecoder =+ if nullable+ then pure+ ( TH.AppE+ (TH.AppE (TH.VarE 'fmap) (TH.AppE (TH.VarE 'fmap) (TH.AppE (TH.VarE 'map) (TH.VarE 'fromIntegral))))+ ( TH.AppE+ (TH.VarE 'HasqlDecoders.column)+ ( nullabilityWrapper True+ ( TH.AppE+ (TH.VarE 'HasqlDecoders.listArray)+ (TH.AppE (TH.VarE 'HasqlDecoders.nonNullable) baseDecoder)+ )+ )+ )+ )+ else pure+ ( TH.AppE+ (TH.AppE (TH.VarE 'fmap) (TH.AppE (TH.VarE 'map) (TH.VarE 'fromIntegral)))+ ( TH.AppE+ (TH.VarE 'HasqlDecoders.column)+ ( nullabilityWrapper False+ ( TH.AppE+ (TH.VarE 'HasqlDecoders.listArray)+ (TH.AppE (TH.VarE 'HasqlDecoders.nonNullable) baseDecoder)+ )+ )+ )+ )++decodeMappingScalar :: Bool -> TH.ExpQ+decodeMappingScalar nullable =+ decodeSimpleScalar nullable (TH.VarE 'Mapping.decoder)++decodeMappingArray :: Bool -> TH.ExpQ+decodeMappingArray nullable =+ decodeSimpleArray nullable (TH.VarE 'Mapping.decoder)++nullabilityWrapper :: Bool -> TH.Exp -> TH.Exp+nullabilityWrapper nullable valueDecoder =+ TH.AppE+ (TH.VarE (if nullable then 'HasqlDecoders.nullable else 'HasqlDecoders.nonNullable))+ valueDecoder++failText :: Text -> TH.Q a+failText = fail . CS.cs
+ IHP/TypedSql/Metadata.hs view
@@ -0,0 +1,362 @@+{-# LANGUAGE NamedFieldPuns #-}++module IHP.TypedSql.Metadata+ ( DescribeResult (..)+ , DescribeColumn (..)+ , ColumnMeta (..)+ , TableMeta (..)+ , PgTypeInfo (..)+ , toOidInt32+ , fromOidInt32+ , describeStatement+ , describeStatementWith+ ) where++import Control.Exception (bracket)+import qualified Data.ByteString as BS+import qualified Data.List as List+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.String.Conversions as CS+import qualified Database.PostgreSQL.LibPQ as PQ+import qualified Hasql.Connection as HasqlConnection+import qualified Hasql.Connection.Settings as HasqlSettings+import qualified Hasql.Decoders as HasqlDecoders+import qualified Hasql.Encoders as HasqlEncoders+import qualified Hasql.Pipeline as HasqlPipeline+import qualified Hasql.Session as HasqlSession+import qualified Hasql.Statement as HasqlStatement+import IHP.FrameworkConfig (defaultDatabaseUrl)+import IHP.Prelude++-- | Result of describing a statement.+-- High-level: this is the central metadata bundle for typedSql inference.+data DescribeResult = DescribeResult+ { drParams :: ![PQ.Oid]+ , drColumns :: ![DescribeColumn]+ , drTables :: !(Map.Map PQ.Oid TableMeta)+ , drTypes :: !(Map.Map PQ.Oid PgTypeInfo)+ }++-- | Metadata for a column in the result set.+-- This drives result type inference and row parser selection.+data DescribeColumn = DescribeColumn+ { dcName :: !BS.ByteString+ , dcType :: !PQ.Oid+ , dcTable :: !PQ.Oid+ , dcAttnum :: !(Maybe Int)+ }++-- | Column details extracted from pg_attribute.+-- These are used to map columns to IHP Id' and nullable types.+data ColumnMeta = ColumnMeta+ { cmAttnum :: !Int+ , cmName :: !Text+ , cmTypeOid :: !PQ.Oid+ , cmNotNull :: !Bool+ }++-- | Table metadata, including columns and key relationships.+-- This is used for table.* detection and key-aware typing.+data TableMeta = TableMeta+ { tmOid :: !PQ.Oid+ , tmName :: !Text+ , tmColumns :: !(Map.Map Int ColumnMeta)+ , tmColumnOrder :: ![Int]+ , tmPrimaryKeys :: !(Set.Set Int)+ , tmForeignKeys :: !(Map.Map Int PQ.Oid)+ }++-- | Postgres type metadata needed for Haskell mapping.+-- Used to convert OIDs to concrete Haskell types.+data PgTypeInfo = PgTypeInfo+ { ptiOid :: !PQ.Oid+ , ptiName :: !Text+ , ptiElem :: !(Maybe PQ.Oid)+ , ptiType :: !Char+ , ptiNamespace :: !(Maybe Text)+ }++-- | Convert libpq Oid to Int32 for Hasql parameter encoding.+toOidInt32 :: PQ.Oid -> Int32+toOidInt32 (PQ.Oid oid) = fromIntegral oid++-- | Convert Hasql-decoded Oid value back to libpq Oid.+fromOidInt32 :: Int32 -> PQ.Oid+fromOidInt32 oid = PQ.Oid (fromIntegral oid)++-- | Describe a statement by asking a real Postgres server.+describeStatement :: BS.ByteString -> IO DescribeResult+describeStatement sql = do+ dbUrl <- defaultDatabaseUrl+ describeStatementWith dbUrl sql++-- | Describe a statement using an explicit database URL.+-- This is the core path for metadata lookup in typedSql.+describeStatementWith :: BS.ByteString -> BS.ByteString -> IO DescribeResult+describeStatementWith dbUrl sql = do+ bracket (PQ.connectdb dbUrl) PQ.finish \conn -> do+ status <- PQ.status conn+ unless (status == PQ.ConnectionOk) do+ err <- PQ.errorMessage conn+ fail ("typedSql: could not connect to the database: " <> CS.cs (fromMaybe "" err)+ <> "\nThe typedSql quasiquoter connects to PostgreSQL at compile time to infer types."+ <> "\nEnsure your development database is running (e.g. devenv up) and DATABASE_URL is set."+ <> "\nUsing: " <> CS.cs dbUrl)++ let statementName = "ihp_typed_sql_stmt"+ _ <- ensureOk "prepare" =<< PQ.prepare conn statementName sql Nothing+ desc <- ensureOk "describe" =<< PQ.describePrepared conn statementName++ paramCount <- PQ.nparams desc+ paramTypes <- mapM (PQ.paramtype desc) [0 .. paramCount - 1]++ columnCount <- PQ.nfields desc+ let PQ.Col columnCountCInt = columnCount+ let columnCountInt = fromIntegral columnCountCInt :: Int+ columns <- mapM (\i -> do+ let colIndex = PQ.Col (fromIntegral i)+ name <- fromMaybe "" <$> PQ.fname desc colIndex+ colType <- PQ.ftype desc colIndex+ tableOid <- PQ.ftable desc colIndex+ attnumRaw <- PQ.ftablecol desc colIndex+ let PQ.Col attnumCInt = attnumRaw+ let attnumInt = fromIntegral attnumCInt :: Int+ let attnum =+ if tableOid == PQ.Oid 0 || attnumInt <= 0+ then Nothing+ else Just attnumInt+ pure DescribeColumn { dcName = name, dcType = colType, dcTable = tableOid, dcAttnum = attnum }+ ) [0 .. columnCountInt - 1]++ let tableOids = Set.fromList (map dcTable columns) |> Set.delete (PQ.Oid 0)+ typeOids = Set.fromList paramTypes <> Set.fromList (map dcType columns)++ tables <- loadTableMeta dbUrl (Set.toList tableOids)+ let referencedOids =+ tables+ |> Map.elems+ |> foldl'+ (\acc TableMeta { tmForeignKeys } ->+ acc <> Set.fromList (Map.elems tmForeignKeys)+ )+ mempty+ let missingRefs = referencedOids `Set.difference` Map.keysSet tables+ extraTables <- loadTableMeta dbUrl (Set.toList missingRefs)+ let tables' = tables <> extraTables+ types <- loadTypeInfo dbUrl (Set.toList typeOids)++ pure DescribeResult { drParams = paramTypes, drColumns = columns, drTables = tables', drTypes = types }++-- | Ensure libpq returned a successful result.+-- Errors here surface as typedSql compile-time failures.+ensureOk :: String -> Maybe PQ.Result -> IO PQ.Result+ensureOk actionName = \case+ Nothing -> fail ("typedSql: " <> actionName <> " returned no result")+ Just res -> do+ status <- PQ.resultStatus res+ case status of+ PQ.CommandOk -> pure res+ PQ.TuplesOk -> pure res+ _ -> do+ msg <- PQ.resultErrorMessage res+ fail ("typedSql: " <> actionName <> " failed: " <> CS.cs (fromMaybe "" msg))++-- | Run a Hasql session for metadata queries (pg_catalog).+-- This keeps metadata lookups on the same hasql stack as typedSql execution.+runHasqlMetadataSession :: BS.ByteString -> HasqlSession.Session a -> IO a+runHasqlMetadataSession dbUrl session = do+ let settings = HasqlSettings.connectionString (CS.cs dbUrl)+ result <- bracket+ (HasqlConnection.acquire settings >>= \case+ Left connectionError ->+ fail (CS.cs ("typedSql: could not connect to database at "+ <> CS.cs dbUrl <> ": " <> tshow connectionError+ <> "\nHint: ensure your development database is running (e.g. devenv up)."))+ Right connection ->+ pure connection+ )+ HasqlConnection.release+ (\connection -> HasqlConnection.use connection session)+ case result of+ Left sessionError ->+ fail (CS.cs ("typedSql: metadata query failed: " <> tshow sessionError))+ Right value ->+ pure value++-- | Encoder for passing OID arrays into pg_catalog queries.+oidArrayParamsEncoder :: HasqlEncoders.Params [Int32]+oidArrayParamsEncoder =+ HasqlEncoders.param+ (HasqlEncoders.nonNullable+ (HasqlEncoders.foldableArray+ (HasqlEncoders.nonNullable HasqlEncoders.oid)+ )+ )++-- | Query to load column metadata for a set of table OIDs.+tableColumnsStatement :: HasqlStatement.Statement [Int32] [(Int32, Text, Int32, Text, Int32, Bool)]+tableColumnsStatement =+ HasqlStatement.preparable+ (mconcat+ [ "SELECT c.oid::int4, c.relname::text, a.attnum::int4, a.attname::text, a.atttypid::int4, a.attnotnull "+ , "FROM pg_class c "+ , "JOIN pg_namespace ns ON ns.oid = c.relnamespace "+ , "JOIN pg_attribute a ON a.attrelid = c.oid "+ , "WHERE c.oid = ANY($1) AND a.attnum > 0 AND NOT a.attisdropped "+ , "ORDER BY c.oid, a.attnum"+ ])+ oidArrayParamsEncoder+ (HasqlDecoders.rowList+ ((,,,,,)+ <$> HasqlDecoders.column (HasqlDecoders.nonNullable HasqlDecoders.int4)+ <*> HasqlDecoders.column (HasqlDecoders.nonNullable HasqlDecoders.text)+ <*> HasqlDecoders.column (HasqlDecoders.nonNullable HasqlDecoders.int4)+ <*> HasqlDecoders.column (HasqlDecoders.nonNullable HasqlDecoders.text)+ <*> HasqlDecoders.column (HasqlDecoders.nonNullable HasqlDecoders.int4)+ <*> HasqlDecoders.column (HasqlDecoders.nonNullable HasqlDecoders.bool)+ ))++-- | Query to load primary key columns for a set of tables.+primaryKeysStatement :: HasqlStatement.Statement [Int32] [(Int32, Int32)]+primaryKeysStatement =+ HasqlStatement.preparable+ "SELECT conrelid::int4, unnest(conkey)::int4 as attnum FROM pg_constraint WHERE contype = 'p' AND conrelid = ANY($1)"+ oidArrayParamsEncoder+ (HasqlDecoders.rowList+ ((,)+ <$> HasqlDecoders.column (HasqlDecoders.nonNullable HasqlDecoders.int4)+ <*> HasqlDecoders.column (HasqlDecoders.nonNullable HasqlDecoders.int4)+ ))++-- | Query to load single-column foreign keys for a set of tables.+foreignKeysStatement :: HasqlStatement.Statement [Int32] [(Int32, Int32, Int32)]+foreignKeysStatement =+ HasqlStatement.preparable+ (mconcat+ [ "SELECT conrelid::int4, conkey[1]::int4 as attnum, confrelid::int4 "+ , "FROM pg_constraint "+ , "WHERE contype = 'f' AND array_length(conkey,1) = 1 AND conrelid = ANY($1)"+ ])+ oidArrayParamsEncoder+ (HasqlDecoders.rowList+ ((,,)+ <$> HasqlDecoders.column (HasqlDecoders.nonNullable HasqlDecoders.int4)+ <*> HasqlDecoders.column (HasqlDecoders.nonNullable HasqlDecoders.int4)+ <*> HasqlDecoders.column (HasqlDecoders.nonNullable HasqlDecoders.int4)+ ))++-- | Query to load type information for a set of type OIDs.+typeInfoStatement :: HasqlStatement.Statement [Int32] [(Int32, Text, Int32, Text, Maybe Text)]+typeInfoStatement =+ HasqlStatement.preparable+ (mconcat+ [ "SELECT oid::int4, typname::text, typelem::int4, typtype::text, typnamespace::regnamespace::text "+ , "FROM pg_type "+ , "WHERE oid = ANY($1)"+ ])+ oidArrayParamsEncoder+ (HasqlDecoders.rowList+ ((,,,,)+ <$> HasqlDecoders.column (HasqlDecoders.nonNullable HasqlDecoders.int4)+ <*> HasqlDecoders.column (HasqlDecoders.nonNullable HasqlDecoders.text)+ <*> HasqlDecoders.column (HasqlDecoders.nonNullable HasqlDecoders.int4)+ <*> HasqlDecoders.column (HasqlDecoders.nonNullable HasqlDecoders.text) -- typtype (NOT NULL in pg_type)+ <*> HasqlDecoders.column (HasqlDecoders.nullable HasqlDecoders.text)+ ))++-- | Load table metadata for all referenced tables.+-- High-level: read pg_catalog to map table/column info for typedSql inference.+loadTableMeta :: BS.ByteString -> [PQ.Oid] -> IO (Map.Map PQ.Oid TableMeta)+loadTableMeta _ [] = pure mempty+loadTableMeta dbUrl tableOids = do+ let tableOidParams = map toOidInt32 tableOids+ (rows, primaryKeys, foreignKeys) <- runHasqlMetadataSession dbUrl $+ HasqlSession.pipeline $+ (,,)+ <$> HasqlPipeline.statement tableOidParams tableColumnsStatement+ <*> HasqlPipeline.statement tableOidParams primaryKeysStatement+ <*> HasqlPipeline.statement tableOidParams foreignKeysStatement++ let pkMap = primaryKeys+ |> foldl' (\acc (relid, attnum) ->+ Map.insertWith Set.union (fromOidInt32 relid) (Set.singleton (fromIntegral attnum)) acc+ ) mempty++ fkMap = foreignKeys+ |> foldl' (\acc (relid, attnum, ref) ->+ Map.insertWith Map.union (fromOidInt32 relid) (Map.singleton (fromIntegral attnum) (fromOidInt32 ref)) acc+ ) mempty++ tableGroups =+ rows+ |> map (\(relid, name, attnum, attname, atttypid, attnotnull) ->+ ( fromOidInt32 relid+ , ColumnMeta+ { cmAttnum = fromIntegral attnum+ , cmName = attname+ , cmTypeOid = fromOidInt32 atttypid+ , cmNotNull = attnotnull+ }+ , name+ )+ )+ |> List.groupBy (\(l, _, _) (r, _, _) -> l == r)++ pure $ tableGroups+ |> foldl'+ (\acc group ->+ case group of+ [] -> acc+ (tableOid, _, tableName):_ ->+ let cols = group+ |> map (\(_, column, _) -> (cmAttnum column, column))+ |> Map.fromList+ order = group |> map (\(_, column, _) -> cmAttnum column)+ pks = Map.findWithDefault mempty tableOid pkMap+ fks = Map.findWithDefault mempty tableOid fkMap+ meta = TableMeta+ { tmOid = tableOid+ , tmName = tableName+ , tmColumns = cols+ , tmColumnOrder = order+ , tmPrimaryKeys = pks+ , tmForeignKeys = fks+ }+ in Map.insert tableOid meta acc+ )+ mempty++-- | Load type information for the given OIDs.+-- High-level: fetch pg_type metadata recursively for arrays.+loadTypeInfo :: BS.ByteString -> [PQ.Oid] -> IO (Map.Map PQ.Oid PgTypeInfo)+loadTypeInfo _ [] = pure mempty+loadTypeInfo dbUrl typeOids = do+ let requested = Set.fromList typeOids+ rows <- runHasqlMetadataSession dbUrl (HasqlSession.statement (map toOidInt32 typeOids) typeInfoStatement)+ let (typeMap, missing) =+ rows+ |> foldl'+ (\(acc, missingAcc) (oid, name, elemOid, typtype, nsp) ->+ let thisOid = fromOidInt32 oid+ elemOid' = if elemOid == 0 then Nothing else Just (fromOidInt32 elemOid)+ nextMissing = case elemOid' of+ Just o | o `Set.notMember` requested -> o : missingAcc+ _ -> missingAcc+ typtypeChar = case CS.cs typtype :: [Char] of+ (c:_) -> c+ [] -> 'b' -- fallback to base type+ in ( Map.insert thisOid PgTypeInfo+ { ptiOid = thisOid+ , ptiName = name+ , ptiElem = elemOid'+ , ptiType = typtypeChar+ , ptiNamespace = nsp+ }+ acc+ , nextMissing+ )+ )+ (mempty, [])+ extras <- loadTypeInfo dbUrl (Set.toList (Set.fromList missing))+ pure (typeMap <> extras)
+ IHP/TypedSql/ParamHints.hs view
@@ -0,0 +1,445 @@+module IHP.TypedSql.ParamHints+ ( ParamHint (..)+ , extractParamHints+ , extractJoinNullableTables+ , parseSql+ , extractParamHintsFromAst+ , extractJoinNullableTablesFromAst+ , resolveParamHintTypes+ ) where++import Data.Foldable (foldMap, toList)+import qualified Data.List as List+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.Text as Text+import qualified Data.String.Conversions as CS+import qualified Database.PostgreSQL.LibPQ as PQ+import qualified Language.Haskell.TH as TH+import IHP.Prelude++import qualified PostgresqlSyntax.Ast as Ast+import qualified PostgresqlSyntax.Parsing as Parsing++import IHP.TypedSql.Metadata (ColumnMeta (..), DescribeColumn (..),+ PgTypeInfo, TableMeta (..))+import IHP.TypedSql.TypeMapping (hsTypeForColumn)++-- | A derived hint about the expected type of a placeholder.+-- The quasiquoter uses this to coerce ${...} to a column-compatible type.+data ParamHint = ParamHint+ { phIndex :: !Int+ , phTable :: !Text+ , phColumn :: !Text+ , phArray :: !Bool+ }+ deriving (Eq, Show)++-- | Parse SQL into an AST. Returns Nothing if parsing fails.+-- Note: postgresql-syntax does not tolerate leading/trailing whitespace,+-- so we strip it before parsing.+parseSql :: String -> Maybe Ast.PreparableStmt+parseSql sql =+ case Parsing.run Parsing.preparableStmt (Text.strip (Text.pack sql)) of+ Left _err -> Nothing+ Right stmt -> Just stmt++-- | Extract parameter hints by parsing SQL and walking the AST.+-- Falls back to empty map if parsing fails.+extractParamHints :: String -> Map.Map Int ParamHint+extractParamHints sql =+ case parseSql sql of+ Nothing -> Map.empty+ Just stmt -> extractParamHintsFromAst stmt++-- | Extract parameter hints from an already-parsed AST.+extractParamHintsFromAst :: Ast.PreparableStmt -> Map.Map Int ParamHint+extractParamHintsFromAst stmt =+ let aliasMap = buildAliasMapFromStmt stmt+ defTable = singleTable aliasMap+ in collectFromStmt aliasMap defTable stmt++-- | Extract table names that are on the nullable side of outer JOINs.+-- LEFT JOIN: right-side tables are nullable.+-- RIGHT JOIN: left-side tables are nullable.+-- FULL [OUTER] JOIN: both sides are nullable.+extractJoinNullableTables :: String -> Set.Set Text+extractJoinNullableTables sql =+ case parseSql sql of+ Nothing -> Set.empty+ Just stmt -> extractJoinNullableTablesFromAst stmt++-- | Extract nullable tables from an already-parsed AST.+extractJoinNullableTablesFromAst :: Ast.PreparableStmt -> Set.Set Text+extractJoinNullableTablesFromAst = nullableTablesFromStmt++nullableTablesFromStmt :: Ast.PreparableStmt -> Set.Set Text+nullableTablesFromStmt = \case+ Ast.SelectPreparableStmt selectStmt -> nullableTablesFromSelectStmt selectStmt+ _ -> Set.empty++nullableTablesFromSelectStmt :: Ast.SelectStmt -> Set.Set Text+nullableTablesFromSelectStmt (Left (Ast.SelectNoParens _with selectClause _sort _limit _lock)) =+ nullableTablesFromSelectClause selectClause+nullableTablesFromSelectStmt (Right _) = Set.empty++nullableTablesFromSelectClause :: Ast.SelectClause -> Set.Set Text+nullableTablesFromSelectClause (Left simpleSelect) = nullableTablesFromSimpleSelect simpleSelect+nullableTablesFromSelectClause (Right _) = Set.empty++nullableTablesFromSimpleSelect :: Ast.SimpleSelect -> Set.Set Text+nullableTablesFromSimpleSelect = \case+ Ast.NormalSimpleSelect _targeting _into maybeFrom _where _group _having _window ->+ case maybeFrom of+ Just fromClause -> foldMap nullableTablesFromTableRef (toList fromClause)+ Nothing -> Set.empty+ Ast.BinSimpleSelect _op left _distinct right ->+ Set.union (nullableTablesFromSelectClause left) (nullableTablesFromSelectClause right)+ _ -> Set.empty++nullableTablesFromTableRef :: Ast.TableRef -> Set.Set Text+nullableTablesFromTableRef = \case+ Ast.JoinTableRef joinedTable _alias -> nullableTablesFromJoinedTable joinedTable+ _ -> Set.empty++nullableTablesFromJoinedTable :: Ast.JoinedTable -> Set.Set Text+nullableTablesFromJoinedTable = \case+ Ast.InParensJoinedTable inner -> nullableTablesFromJoinedTable inner+ Ast.MethJoinedTable meth left right ->+ let nested = Set.union (nullableTablesFromTableRef left) (nullableTablesFromTableRef right)+ in case joinTypeFromMeth meth of+ Just (Ast.LeftJoinType _) -> Set.union nested (tableNamesFromTableRef right)+ Just (Ast.RightJoinType _) -> Set.union nested (tableNamesFromTableRef left)+ Just (Ast.FullJoinType _) -> Set.union nested (Set.union (tableNamesFromTableRef left) (tableNamesFromTableRef right))+ _ -> nested++joinTypeFromMeth :: Ast.JoinMeth -> Maybe Ast.JoinType+joinTypeFromMeth = \case+ Ast.QualJoinMeth maybeJoinType _ -> maybeJoinType+ Ast.NaturalJoinMeth maybeJoinType -> maybeJoinType+ Ast.CrossJoinMeth -> Nothing++-- | Collect all resolved table names from a TableRef.+tableNamesFromTableRef :: Ast.TableRef -> Set.Set Text+tableNamesFromTableRef = Set.fromList . Map.elems . buildAliasMapFromTableRef++-- | Get the text from an Ident.+-- Unquoted identifiers are folded to lowercase (PostgreSQL convention).+-- Quoted identifiers preserve case (they are case-sensitive in PostgreSQL).+identToText :: Ast.Ident -> Text+identToText (Ast.QuotedIdent t) = t+identToText (Ast.UnquotedIdent t) = Text.toLower t++-- | Extract table name from a QualifiedName, ignoring schema prefix.+qualifiedNameToText :: Ast.QualifiedName -> Text+qualifiedNameToText (Ast.SimpleQualifiedName ident) = identToText ident+qualifiedNameToText (Ast.IndirectedQualifiedName _schema indirection) =+ -- schema.table -> take the last attr name+ case toList indirection of+ [] -> identToText _schema+ els -> case List.last els of+ Ast.AttrNameIndirectionEl ident -> identToText ident+ _ -> identToText _schema++-- | If the alias map has exactly one distinct table, return it.+singleTable :: Map.Map Text Text -> Maybe Text+singleTable aliases =+ case Set.toList (Set.fromList (Map.elems aliases)) of+ [table] -> Just table+ _ -> Nothing++----------------------------------------------------------------------+-- Alias map building+----------------------------------------------------------------------++buildAliasMapFromStmt :: Ast.PreparableStmt -> Map.Map Text Text+buildAliasMapFromStmt = \case+ Ast.SelectPreparableStmt selectStmt -> buildAliasMapFromSelectStmt selectStmt+ Ast.UpdatePreparableStmt (Ast.UpdateStmt _with (Ast.RelationExprOptAlias relExpr maybeAlias) _setClauses maybeFrom _where _ret) ->+ let tableName = relationExprName relExpr+ base = Map.singleton tableName tableName+ withAlias = case maybeAlias of+ Just (_, aliasIdent) -> Map.insert (identToText aliasIdent) tableName base+ Nothing -> base+ in case maybeFrom of+ Just fromClause -> Map.union withAlias (buildAliasMapFromFrom fromClause)+ Nothing -> withAlias+ Ast.DeletePreparableStmt (Ast.DeleteStmt _with (Ast.RelationExprOptAlias relExpr maybeAlias) _using _where _ret) ->+ let tableName = relationExprName relExpr+ base = Map.singleton tableName tableName+ in case maybeAlias of+ Just (_, aliasIdent) -> Map.insert (identToText aliasIdent) tableName base+ Nothing -> base+ Ast.InsertPreparableStmt (Ast.InsertStmt _with (Ast.InsertTarget qname _alias) _rest _onConflict _ret) ->+ let tableName = qualifiedNameToText qname+ in Map.singleton tableName tableName+ Ast.CallPreparableStmt _ -> Map.empty++buildAliasMapFromSelectStmt :: Ast.SelectStmt -> Map.Map Text Text+buildAliasMapFromSelectStmt (Left (Ast.SelectNoParens maybeWith selectClause _sort _limit _lock)) =+ let withMap = case maybeWith of+ Just (Ast.WithClause _recursive ctes) -> foldMap buildAliasMapFromCte (toList ctes)+ Nothing -> Map.empty+ in Map.union withMap (buildAliasMapFromSelectClause selectClause)+buildAliasMapFromSelectStmt (Right _parens) = Map.empty++buildAliasMapFromCte :: Ast.CommonTableExpr -> Map.Map Text Text+buildAliasMapFromCte (Ast.CommonTableExpr _name _cols _mat innerStmt) =+ buildAliasMapFromStmt innerStmt++buildAliasMapFromSelectClause :: Ast.SelectClause -> Map.Map Text Text+buildAliasMapFromSelectClause (Left simpleSelect) = buildAliasMapFromSimpleSelect simpleSelect+buildAliasMapFromSelectClause (Right _parens) = Map.empty++buildAliasMapFromSimpleSelect :: Ast.SimpleSelect -> Map.Map Text Text+buildAliasMapFromSimpleSelect = \case+ Ast.NormalSimpleSelect _targeting _into maybeFrom _where _group _having _window ->+ case maybeFrom of+ Just fromClause -> buildAliasMapFromFrom fromClause+ Nothing -> Map.empty+ Ast.BinSimpleSelect _op left _distinct right ->+ Map.union (buildAliasMapFromSelectClause left) (buildAliasMapFromSelectClause right)+ Ast.TableSimpleSelect relExpr ->+ let name = relationExprName relExpr+ in Map.singleton name name+ Ast.ValuesSimpleSelect _ -> Map.empty++buildAliasMapFromFrom :: Ast.FromClause -> Map.Map Text Text+buildAliasMapFromFrom = foldMap buildAliasMapFromTableRef . toList++buildAliasMapFromTableRef :: Ast.TableRef -> Map.Map Text Text+buildAliasMapFromTableRef = \case+ Ast.RelationExprTableRef relExpr maybeAlias _sample ->+ let tableName = relationExprName relExpr+ base = Map.singleton tableName tableName+ in case maybeAlias of+ Just (Ast.AliasClause _asKw aliasIdent _cols) ->+ Map.insert (identToText aliasIdent) tableName base+ Nothing -> base+ Ast.JoinTableRef joinedTable maybeAlias ->+ let joinMap = buildAliasMapFromJoinedTable joinedTable+ in case maybeAlias of+ Just _ -> joinMap -- parenthesized join with alias, just pass through+ Nothing -> joinMap+ Ast.SelectTableRef _lateral _subquery _alias -> Map.empty+ Ast.FuncTableRef _lateral _funcTable _alias -> Map.empty++buildAliasMapFromJoinedTable :: Ast.JoinedTable -> Map.Map Text Text+buildAliasMapFromJoinedTable = \case+ Ast.InParensJoinedTable inner -> buildAliasMapFromJoinedTable inner+ Ast.MethJoinedTable _meth left right ->+ Map.union (buildAliasMapFromTableRef left) (buildAliasMapFromTableRef right)++relationExprName :: Ast.RelationExpr -> Text+relationExprName (Ast.SimpleRelationExpr qname _) = qualifiedNameToText qname+relationExprName (Ast.OnlyRelationExpr qname _) = qualifiedNameToText qname++----------------------------------------------------------------------+-- Parameter hint collection from expressions+----------------------------------------------------------------------++collectFromStmt :: Map.Map Text Text -> Maybe Text -> Ast.PreparableStmt -> Map.Map Int ParamHint+collectFromStmt aliasMap defTable = \case+ Ast.SelectPreparableStmt selectStmt ->+ collectFromSelectStmt aliasMap defTable selectStmt+ Ast.UpdatePreparableStmt (Ast.UpdateStmt _with (Ast.RelationExprOptAlias relExpr _) setClauses _from maybeWhere _ret) ->+ let updateTable = relationExprName relExpr+ setHints = foldMap (collectFromSetClause aliasMap defTable updateTable) (toList setClauses)+ whereHints = case maybeWhere of+ Just (Ast.ExprWhereOrCurrentClause expr) -> collectFromAExpr aliasMap defTable expr+ _ -> Map.empty+ in mergeHintMaps setHints whereHints+ Ast.DeletePreparableStmt (Ast.DeleteStmt _with _rel _using maybeWhere _ret) ->+ case maybeWhere of+ Just (Ast.ExprWhereOrCurrentClause expr) -> collectFromAExpr aliasMap defTable expr+ _ -> Map.empty+ Ast.InsertPreparableStmt (Ast.InsertStmt _with _target _rest maybeOnConflict _ret) ->+ case maybeOnConflict of+ Just (Ast.OnConflict _confExpr (Ast.UpdateOnConflictDo setClauses maybeWhere)) ->+ let insertTable = case _target of+ Ast.InsertTarget qname _ -> qualifiedNameToText qname+ setHints = foldMap (collectFromSetClause aliasMap defTable insertTable) (toList setClauses)+ whereHints = case maybeWhere of+ Just whereExpr -> collectFromAExpr aliasMap defTable whereExpr+ Nothing -> Map.empty+ in mergeHintMaps setHints whereHints+ _ -> Map.empty+ Ast.CallPreparableStmt _ -> Map.empty++collectFromSelectStmt :: Map.Map Text Text -> Maybe Text -> Ast.SelectStmt -> Map.Map Int ParamHint+collectFromSelectStmt aliasMap defTable (Left (Ast.SelectNoParens _with selectClause _sort _limit _lock)) =+ collectFromSelectClause aliasMap defTable selectClause+collectFromSelectStmt _ _ (Right _) = Map.empty++collectFromSelectClause :: Map.Map Text Text -> Maybe Text -> Ast.SelectClause -> Map.Map Int ParamHint+collectFromSelectClause aliasMap defTable (Left simpleSelect) =+ collectFromSimpleSelect aliasMap defTable simpleSelect+collectFromSelectClause _ _ (Right _) = Map.empty++collectFromSimpleSelect :: Map.Map Text Text -> Maybe Text -> Ast.SimpleSelect -> Map.Map Int ParamHint+collectFromSimpleSelect aliasMap defTable = \case+ Ast.NormalSimpleSelect _targeting _into _from maybeWhere _group _having _window ->+ case maybeWhere of+ Just whereExpr -> collectFromAExpr aliasMap defTable whereExpr+ Nothing -> Map.empty+ Ast.BinSimpleSelect _op left _distinct right ->+ mergeHintMaps+ (collectFromSelectClause aliasMap defTable left)+ (collectFromSelectClause aliasMap defTable right)+ _ -> Map.empty++collectFromSetClause :: Map.Map Text Text -> Maybe Text -> Text -> Ast.SetClause -> Map.Map Int ParamHint+collectFromSetClause aliasMap defTable updateTable = \case+ Ast.TargetSetClause (Ast.SetTarget colIdent _indirection) expr ->+ let colName = identToText colIdent+ in case extractParam expr of+ Just paramIndex ->+ Map.singleton paramIndex ParamHint+ { phIndex = paramIndex+ , phTable = updateTable+ , phColumn = colName+ , phArray = False+ }+ Nothing -> Map.empty+ Ast.TargetListSetClause _ _ -> Map.empty++-- | Extract parameter hints from an AExpr, looking for patterns like:+-- column = $N, $N = column, column IN ($N), column = ANY($N)+collectFromAExpr :: Map.Map Text Text -> Maybe Text -> Ast.AExpr -> Map.Map Int ParamHint+collectFromAExpr aliasMap defTable = \case+ -- column = $N or $N = column+ Ast.SymbolicBinOpAExpr left (Ast.MathSymbolicExprBinOp Ast.EqualsMathOp) right ->+ mergeHintMaps+ (matchColEqParam aliasMap defTable left right False)+ (matchColEqParam aliasMap defTable right left False)+ -- AND / OR: recurse both sides+ Ast.AndAExpr left right ->+ mergeHintMaps+ (collectFromAExpr aliasMap defTable left)+ (collectFromAExpr aliasMap defTable right)+ Ast.OrAExpr left right ->+ mergeHintMaps+ (collectFromAExpr aliasMap defTable left)+ (collectFromAExpr aliasMap defTable right)+ -- NOT: recurse+ Ast.NotAExpr inner -> collectFromAExpr aliasMap defTable inner+ -- column IN ($N, ...) - reversable op+ Ast.ReversableOpAExpr colExpr _negated (Ast.InAExprReversableOp (Ast.ExprListInExpr exprs)) ->+ case resolveColumnRef aliasMap defTable colExpr of+ Just (tableName, colName) ->+ foldMap (\expr -> case extractParam expr of+ Just n ->+ Map.singleton n ParamHint+ { phIndex = n+ , phTable = tableName+ , phColumn = colName+ , phArray = True+ }+ Nothing -> Map.empty+ ) (toList exprs)+ Nothing -> Map.empty+ -- column = ANY($N) pattern via SubqueryAExpr+ Ast.SubqueryAExpr colExpr (Ast.AllSubqueryOp (Ast.MathAllOp Ast.EqualsMathOp)) Ast.AnySubType (Right paramExpr) ->+ case resolveColumnRef aliasMap defTable colExpr of+ Just (tableName, colName) ->+ case extractParam paramExpr of+ Just n -> Map.singleton n ParamHint+ { phIndex = n+ , phTable = tableName+ , phColumn = colName+ , phArray = True+ }+ Nothing -> Map.empty+ Nothing -> Map.empty+ -- Parenthesized expression+ Ast.CExprAExpr (Ast.InParensCExpr inner _) -> collectFromAExpr aliasMap defTable inner+ _ -> Map.empty++-- | Try to match: colExpr is a column ref and paramExpr is $N+matchColEqParam :: Map.Map Text Text -> Maybe Text -> Ast.AExpr -> Ast.AExpr -> Bool -> Map.Map Int ParamHint+matchColEqParam aliasMap defTable colExpr paramExpr isArray =+ case (resolveColumnRef aliasMap defTable colExpr, extractParam paramExpr) of+ (Just (tableName, colName), Just n) ->+ Map.singleton n ParamHint+ { phIndex = n+ , phTable = tableName+ , phColumn = colName+ , phArray = isArray+ }+ _ -> Map.empty++-- | Resolve a column reference expression to (table, column).+resolveColumnRef :: Map.Map Text Text -> Maybe Text -> Ast.AExpr -> Maybe (Text, Text)+resolveColumnRef aliasMap defTable = \case+ Ast.CExprAExpr (Ast.ColumnrefCExpr (Ast.Columnref colId maybeIndirection)) ->+ case maybeIndirection of+ -- qualified: tableOrAlias.column+ Just indirection ->+ case toList indirection of+ [Ast.AttrNameIndirectionEl colIdent] ->+ let tableRef = identToText colId+ colName = identToText colIdent+ in case Map.lookup tableRef aliasMap of+ Just tableName -> Just (tableName, colName)+ Nothing -> Nothing+ _ -> Nothing+ -- unqualified: just column name+ Nothing ->+ case defTable of+ Just tableName -> Just (tableName, identToText colId)+ Nothing -> Nothing+ _ -> Nothing++-- | Extract a $N parameter index from an expression.+extractParam :: Ast.AExpr -> Maybe Int+extractParam = \case+ Ast.CExprAExpr (Ast.ParamCExpr n _) -> Just n+ _ -> Nothing++-- | Merge two hint maps. On conflict, the left (earlier) hint wins.+mergeHintMaps :: Map.Map Int ParamHint -> Map.Map Int ParamHint -> Map.Map Int ParamHint+mergeHintMaps = Map.union++----------------------------------------------------------------------+-- Type resolution (unchanged from before)+----------------------------------------------------------------------++-- | Convert parameter hints into concrete Haskell types using table metadata.+-- The quasiquoter uses this to apply per-placeholder type annotations.+resolveParamHintTypes :: Map.Map PQ.Oid TableMeta -> Map.Map PQ.Oid PgTypeInfo -> Map.Map Int ParamHint -> TH.Q (Map.Map Int TH.Type)+resolveParamHintTypes tables typeInfo hints = do+ let tablesByName = tables+ |> Map.toList+ |> mapMaybe (\(oid, table@TableMeta { tmName }) -> Just (tmName, (oid, table)))+ |> Map.fromList+ resolved <- mapM (resolveHint tablesByName) (Map.toList hints)+ pure (Map.fromList (catMaybes resolved))+ where+ resolveHint tablesByName (index, ParamHint { phTable, phColumn, phArray }) = do+ case Map.lookup phTable tablesByName of+ Nothing -> pure Nothing+ Just (tableOid, table@TableMeta { tmColumns }) ->+ case findColumn tmColumns phColumn of+ Nothing -> pure Nothing+ Just (attnum, ColumnMeta { cmTypeOid }) -> do+ baseType <- hsTypeForColumn typeInfo tables Set.empty DescribeColumn+ { dcName = CS.cs phColumn+ , dcType = cmTypeOid+ , dcTable = tableOid+ , dcAttnum = Just attnum+ }+ let stripped = stripMaybeType baseType+ let hintedType = if phArray then TH.AppT TH.ListT stripped else stripped+ pure (Just (index, hintedType))++ findColumn columns columnName =+ columns+ |> Map.toList+ |> List.find (\(_, ColumnMeta { cmName }) -> Text.toLower cmName == Text.toLower columnName)++-- | Strip a top-level Maybe wrapper to get the base column type.+-- Used when parameter hints should be non-nullable inputs.+stripMaybeType :: TH.Type -> TH.Type+stripMaybeType (TH.AppT (TH.ConT maybeName) inner)+ | maybeName == ''Maybe = inner+stripMaybeType other = other
+ IHP/TypedSql/Placeholders.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE TemplateHaskell #-}++module IHP.TypedSql.Placeholders+ ( PlaceholderPlan (..)+ , planPlaceholders+ , parseExpr+ ) where++import qualified Data.String.Conversions as CS+import qualified Language.Haskell.Meta.Parse as HaskellMeta+import qualified Language.Haskell.TH as TH+import IHP.Prelude++-- | Output of placeholder parsing used by the typedSql quasiquoter.+-- It carries the SQL variant for describe, the SQL variant for runtime execution,+-- and the original Haskell placeholder expressions to splice.+data PlaceholderPlan = PlaceholderPlan+ { ppDescribeSql :: !String -- ^ SQL with $1/$2 placeholders for the describe step.+ , ppRuntimeSql :: !String -- ^ SQL with ? placeholders for hasql snippet execution.+ , ppExprs :: ![String] -- ^ Raw Haskell expressions from ${...}.+ }++-- | Replace ${expr} placeholders with PostgreSQL-style $1 for describe and ? for runtime.+-- High-level: turns a templated SQL string into SQL strings plus expr list.+planPlaceholders :: String -> PlaceholderPlan+planPlaceholders = go 1 "" "" [] where+ go _ accDescribe accRuntime exprs [] =+ PlaceholderPlan+ { ppDescribeSql = reverse accDescribe+ , ppRuntimeSql = reverse accRuntime+ , ppExprs = reverse exprs+ }+ go n accDescribe accRuntime exprs ('$':'{':rest) =+ let (expr, after) = breakOnClosing 0 "" rest -- parse until matching }+ in case after of+ [] | not (null rest) -> error "typedSql: unclosed ${ placeholder"+ _ ->+ let describeToken = reverse ('$' : CS.cs (show n))+ in go (n + 1)+ (describeToken <> accDescribe)+ ('\0' : accRuntime)+ (expr : exprs)+ after+ go n accDescribe accRuntime exprs (c:rest) =+ go n (c : accDescribe) (c : accRuntime) exprs rest++ breakOnClosing depth acc [] = (reverse acc, []) -- no closing brace found+ breakOnClosing depth acc ('{':xs) = breakOnClosing (depth + 1) ('{':acc) xs -- nested { increases depth+ breakOnClosing depth acc ('}':xs)+ | depth == 0 = (reverse acc, xs) -- close the current placeholder+ | otherwise = breakOnClosing (depth - 1) ('}':acc) xs -- close a nested brace+ breakOnClosing depth acc (x:xs) = breakOnClosing depth (x:acc) xs -- accumulate placeholder chars++-- | Parse a placeholder expression into TH.+-- Used by typedSql to turn ${...} splices into typed expressions.+parseExpr :: String -> TH.ExpQ+parseExpr exprText =+ case HaskellMeta.parseExp exprText of+ Left err -> fail ("typedSql: failed to parse expression {" <> exprText <> "}: " <> err) -- parse error+ Right expr -> pure expr -- success: return parsed TH expression
+ IHP/TypedSql/Quoter.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++module IHP.TypedSql.Quoter+ ( typedSql+ ) where++import Data.Coerce (coerce)+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.String.Conversions as CS+import qualified Hasql.DynamicStatements.Snippet as Snippet+import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Quote as TH+import IHP.Prelude+import IHP.Hasql.Encoders ()++import IHP.TypedSql.Decoders (resultDecoderForColumns)+import IHP.TypedSql.Metadata (DescribeColumn (..), DescribeResult (..), PgTypeInfo (..), TableMeta (..),+ describeStatement)+import IHP.TypedSql.ParamHints (extractParamHintsFromAst, extractJoinNullableTablesFromAst,+ parseSql, resolveParamHintTypes)+import IHP.TypedSql.Placeholders (PlaceholderPlan (..), parseExpr,+ planPlaceholders)+import IHP.TypedSql.TypeMapping (hsTypeForColumns, hsTypeForParam)+import IHP.TypedSql.Types (TypedQuery (..))++-- | QuasiQuoter entry point for typed SQL.+-- High-level: produces a TH expression that builds a TypedQuery at compile time.+typedSql :: TH.QuasiQuoter+typedSql =+ TH.QuasiQuoter+ { TH.quoteExp = typedSqlExp+ , TH.quotePat = \_ -> fail "typedSql: not supported in patterns"+ , TH.quoteType = \_ -> fail "typedSql: not supported in types"+ , TH.quoteDec = \_ -> fail "typedSql: not supported at top-level"+ }++-- | Build the TH expression for a typed SQL quasiquote.+-- This is the heart of typedSql: parse placeholders, describe SQL, and assemble a TypedQuery.+typedSqlExp :: String -> TH.ExpQ+typedSqlExp rawSql = do+ let PlaceholderPlan { ppDescribeSql, ppRuntimeSql, ppExprs } = planPlaceholders rawSql+ parsedExprs <- mapM parseExpr ppExprs++ describeResult <- TH.runIO $ describeStatement (CS.cs ppDescribeSql)++ let DescribeResult { drParams, drColumns, drTables, drTypes } = describeResult+ when (length drParams /= length parsedExprs) $+ fail (CS.cs ("typedSql: placeholder count mismatch. SQL expects " <> show (length drParams) <> " parameters but found " <> show (length parsedExprs) <> " ${..} expressions."))++ paramTypes <- mapM (hsTypeForParam drTypes) drParams++ let parsedAst = parseSql ppDescribeSql+ when (isNothing parsedAst) do+ TH.reportWarning "typedSql: could not parse SQL for type refinement; parameter hints and LEFT/RIGHT JOIN nullability detection are disabled for this query."+ let paramHints = maybe Map.empty extractParamHintsFromAst parsedAst+ paramHintTypes <- resolveParamHintTypes drTables drTypes paramHints++ let annotatedParams =+ zipWith3+ (\index expr paramTy ->+ let expectedType = fromMaybe paramTy (Map.lookup index paramHintTypes)+ in TH.SigE (TH.AppE (TH.VarE 'coerce) expr) expectedType+ )+ [1..]+ parsedExprs+ paramTypes++ let nullableTableNames = maybe Set.empty extractJoinNullableTablesFromAst parsedAst+ let joinNullableOids = drTables+ |> Map.toList+ |> filter (\(_, TableMeta { tmName }) -> tmName `Set.member` nullableTableNames)+ |> map fst+ |> Set.fromList++ resultType <- hsTypeForColumns drTypes drTables joinNullableOids drColumns++ let isCompositeColumn =+ case drColumns of+ [DescribeColumn { dcType }] ->+ case Map.lookup dcType drTypes of+ Just PgTypeInfo { ptiType = 'c' } -> True+ _ -> False+ _ -> False+ when (length drColumns == 1 && isCompositeColumn) $+ fail+ ("typedSql: composite columns must be expanded (use SELECT table.* "+ <> "or list columns explicitly)")+ resultDecoder <- resultDecoderForColumns drTypes drTables joinNullableOids drColumns+ snippetExpr <- buildSnippetExpression ppRuntimeSql annotatedParams+ let typedQueryExpr =+ TH.AppE+ (TH.AppE+ (TH.ConE 'TypedQuery)+ snippetExpr+ )+ resultDecoder++ pure (TH.SigE typedQueryExpr (TH.AppT (TH.ConT ''TypedQuery) resultType))++buildSnippetExpression :: String -> [TH.Exp] -> TH.ExpQ+buildSnippetExpression sql params = do+ let chunks = splitOnSentinel sql+ when (length chunks /= length params + 1) do+ fail "typedSql: internal error while building hasql snippet"+ let sqlSnippets = map (TH.AppE (TH.VarE 'Snippet.sql) . TH.LitE . TH.StringL) chunks+ let paramSnippets = map (TH.AppE (TH.VarE 'Snippet.param)) params+ let pieces = interleave sqlSnippets paramSnippets+ case pieces of+ [] -> pure (TH.AppE (TH.VarE 'Snippet.sql) (TH.LitE (TH.StringL "")))+ firstPiece:restPieces ->+ pure (foldl (\acc piece -> TH.InfixE (Just acc) (TH.VarE '(<>) ) (Just piece)) firstPiece restPieces)++splitOnSentinel :: String -> [String]+splitOnSentinel input = go "" [] input+ where+ go current acc [] = reverse (reverse current : acc)+ go current acc ('\0':rest) = go "" (reverse current : acc) rest+ go current acc (char:rest) = go (char:current) acc rest++interleave :: [a] -> [a] -> [a]+interleave [] ys = ys+interleave xs [] = xs+interleave (x:xs) (y:ys) = x : y : interleave xs ys
+ IHP/TypedSql/TypeMapping.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE NamedFieldPuns #-}++module IHP.TypedSql.TypeMapping+ ( hsTypeForParam+ , hsTypeForColumns+ , hsTypeForColumn+ , detectFullTable+ ) where++import Control.Monad (guard)+import qualified Data.Aeson as Aeson+import qualified Data.ByteString as BS+import qualified Data.List as List+import qualified Data.Map.Strict as Map+import Data.Scientific (Scientific)+import qualified Data.Set as Set+import qualified Data.String.Conversions as CS+import qualified Database.PostgreSQL.LibPQ as PQ+import qualified Language.Haskell.TH as TH+import IHP.ModelSupport.Types (Id')+import IHP.Prelude+import PostgresqlTypes.Point (Point)+import PostgresqlTypes.Polygon (Polygon)+import PostgresqlTypes.Inet (Inet)+import PostgresqlTypes.Tsvector (Tsvector)+import PostgresqlTypes.Interval (Interval)++import IHP.TypedSql.Metadata (ColumnMeta (..), DescribeColumn (..), PgTypeInfo (..), TableMeta (..))++-- | Build the Haskell type for a parameter, based on its OID.+-- High-level: map a PG type OID into a TH Type.+hsTypeForParam :: Map.Map PQ.Oid PgTypeInfo -> PQ.Oid -> TH.TypeQ+hsTypeForParam typeInfo oid = maybe (fail (CS.cs unknown)) (hsTypeForPg typeInfo False) (Map.lookup oid typeInfo)+ where+ unknown = "typedSql: missing type information for parameter oid " <> show oid++-- | Build the result type for the described columns.+-- High-level: pick a model type for table.* or a tuple type for ad-hoc select lists.+hsTypeForColumns :: Map.Map PQ.Oid PgTypeInfo -> Map.Map PQ.Oid TableMeta -> Set.Set PQ.Oid -> [DescribeColumn] -> TH.TypeQ+hsTypeForColumns typeInfo tables joinNullableOids cols = do+ case detectFullTable tables cols of+ Just tableName ->+ pure (TH.ConT (TH.mkName (CS.cs (tableNameToModelName tableName))))+ Nothing -> do+ hsCols <- mapM (hsTypeForColumn typeInfo tables joinNullableOids) cols+ case hsCols of+ [single] -> pure single+ _ -> pure $ foldl TH.AppT (TH.TupleT (length hsCols)) hsCols++-- | Detect whether the columns represent a full table selection (table.* with all columns in order).+-- High-level: if yes, we can return the model type directly.+detectFullTable :: Map.Map PQ.Oid TableMeta -> [DescribeColumn] -> Maybe Text+detectFullTable tables cols = do+ guard (not (null cols))+ let grouped =+ cols+ |> List.groupBy (\a b -> dcTable a == dcTable b)+ |> mapMaybe (\group -> case List.uncons group of+ Just (first, _) -> Just (dcTable first, group)+ Nothing -> Nothing+ )+ case grouped of+ [(tableOid, colGroup)] | tableOid /= PQ.Oid 0 -> do+ TableMeta { tmColumnOrder } <- Map.lookup tableOid tables+ let attnums = mapMaybe dcAttnum colGroup+ guard (attnums == tmColumnOrder)+ TableMeta { tmName } <- Map.lookup tableOid tables+ pure tmName+ _ -> Nothing++-- | Map a single column into a Haskell type, with key-aware rules.+hsTypeForColumn :: Map.Map PQ.Oid PgTypeInfo -> Map.Map PQ.Oid TableMeta -> Set.Set PQ.Oid -> DescribeColumn -> TH.TypeQ+hsTypeForColumn typeInfo tables joinNullableOids DescribeColumn { dcType, dcTable, dcAttnum } =+ case (Map.lookup dcTable tables, dcAttnum) of+ (Just TableMeta { tmName = tableName, tmPrimaryKeys, tmForeignKeys, tmColumns }, Just attnum) -> do+ let baseType = Map.lookup attnum tmColumns >>= \ColumnMeta { cmTypeOid } -> Map.lookup cmTypeOid typeInfo+ let joinNullable = dcTable `Set.member` joinNullableOids+ let nullable = joinNullable || maybe True (not . cmNotNull) (Map.lookup attnum tmColumns)+ case () of+ _ | attnum `Set.member` tmPrimaryKeys ->+ pure (wrapNull nullable (idType tableName))+ | Just refTable <- Map.lookup attnum tmForeignKeys ->+ case Map.lookup refTable tables of+ Just TableMeta { tmName = refName } ->+ pure (wrapNull nullable (idType refName))+ Nothing ->+ maybe (fail (CS.cs missingType)) (hsTypeForPg typeInfo nullable) baseType+ | otherwise ->+ maybe (fail (CS.cs missingType)) (hsTypeForPg typeInfo nullable) baseType+ where+ missingType = "typedSql: missing type info for column " <> show attnum <> " of table " <> tableName+ _ ->+ maybe (fail (CS.cs ("typedSql: missing type info for column oid " <> show dcType))) (hsTypeForPg typeInfo True) (Map.lookup dcType typeInfo)++-- | Wrap a type in Maybe when nullable.+wrapNull :: Bool -> TH.Type -> TH.Type+wrapNull nullable ty = if nullable then TH.AppT (TH.ConT ''Maybe) ty else ty++-- | Build the Id' type for a table name.+idType :: Text -> TH.Type+idType tableName = TH.AppT (TH.ConT ''Id') (TH.LitT (TH.StrTyLit (CS.cs tableName)))++-- | Map Postgres type metadata to a Haskell type.+-- This is the core mapping used for both parameters and results.+hsTypeForPg :: Map.Map PQ.Oid PgTypeInfo -> Bool -> PgTypeInfo -> TH.TypeQ+hsTypeForPg typeInfo nullable PgTypeInfo { ptiName, ptiElem, ptiType } = do+ base <- case () of+ _ | Just elemOid <- ptiElem -> do+ elemInfo <- maybe (fail (CS.cs ("typedSql: missing array element type for " <> ptiName))) pure (Map.lookup elemOid typeInfo)+ elemTy <- hsTypeForPg typeInfo False elemInfo+ pure (TH.AppT TH.ListT elemTy)+ _ | ptiName `elem` ["int2", "int4"] -> pure (TH.ConT ''Int)+ _ | ptiName == "int8" -> pure (TH.ConT ''Integer)+ _ | ptiName `elem` ["text", "varchar", "bpchar", "citext"] -> pure (TH.ConT ''Text)+ _ | ptiName == "bool" -> pure (TH.ConT ''Bool)+ _ | ptiName == "uuid" -> pure (TH.ConT ''UUID)+ _ | ptiName == "timestamptz" -> pure (TH.ConT ''UTCTime)+ _ | ptiName == "timestamp" -> pure (TH.ConT ''LocalTime)+ _ | ptiName == "date" -> pure (TH.ConT ''Day)+ _ | ptiName == "time" -> pure (TH.ConT ''TimeOfDay)+ _ | ptiName `elem` ["json", "jsonb"] -> pure (TH.ConT ''Aeson.Value)+ _ | ptiName == "bytea" -> pure (TH.ConT ''BS.ByteString)+ _ | ptiName == "float4" -> pure (TH.ConT ''Float)+ _ | ptiName == "float8" -> pure (TH.ConT ''Double)+ _ | ptiName == "numeric" -> pure (TH.ConT ''Scientific)+ _ | ptiName == "point" -> pure (TH.ConT ''Point)+ _ | ptiName == "polygon" -> pure (TH.ConT ''Polygon)+ _ | ptiName == "inet" -> pure (TH.ConT ''Inet)+ _ | ptiName == "tsvector" -> pure (TH.ConT ''Tsvector)+ _ | ptiName == "interval" -> pure (TH.ConT ''Interval)+ _ | ptiType == 'e' ->+ pure (TH.ConT (TH.mkName (CS.cs (tableNameToModelName ptiName))))+ _ | ptiType == 'c' ->+ pure (TH.ConT (TH.mkName (CS.cs (tableNameToModelName ptiName))))+ _ -> fail (CS.cs ("typedSql: unsupported column type '" <> ptiName <> "' (typtype=" <> cs [ptiType] <> "). Consider filing a feature request."))+ pure (wrapNull nullable base)
+ IHP/TypedSql/Types.hs view
@@ -0,0 +1,13 @@+module IHP.TypedSql.Types+ ( TypedQuery (..)+ ) where++import qualified Hasql.Decoders as HasqlDecoders+import qualified Hasql.DynamicStatements.Snippet as Snippet++-- | Prepared query with a custom row parser.+-- High-level: this is the runtime value produced by the typed SQL quasiquoter.+data TypedQuery result = TypedQuery+ { tqSnippet :: !Snippet.Snippet+ , tqResultDecoder :: !(HasqlDecoders.Row result)+ }
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2020 digitally induced GmbH++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ Test/Test/Main.hs view
@@ -0,0 +1,10 @@+module Main where++import Test.Hspec+import IHP.Prelude++import qualified Test.TypedSqlSpec++main :: IO ()+main = hspec do+ Test.TypedSqlSpec.tests
+ Test/Test/TypedSqlSpec.hs view
@@ -0,0 +1,1224 @@+module Test.TypedSqlSpec where++import qualified Control.Exception as Exception+import qualified Data.Set as Set+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import IHP.Log.Types+import IHP.ModelSupport (createModelContext,+ releaseModelContext,+ sqlExecDiscardResult)+import IHP.Prelude+import IHP.TypedSql.ParamHints (parseSql, extractJoinNullableTables)+import System.Directory (doesFileExist,+ getCurrentDirectory)+import System.Environment (getEnvironment, lookupEnv)+import System.FilePath (takeDirectory)+import System.Process (CreateProcess (..), proc,+ readCreateProcessWithExitCode)+import System.IO.Temp (withSystemTempDirectory)+import Test.Hspec+import qualified Prelude++tests :: Spec+tests = do+ describe "TypedSql macro compile-time checks" do+ it "compiles valid typedSql queries with inferred types" do+ requirePostgresTestHook+ withTestModelContext do+ setupSchema+ ghciOutput <- ghciLoadModule compilePassModule+ assertGhciSuccess ghciOutput++ compileFailTest "fails when a scalar parameter has the wrong type"+ (mkTestModule "TypedQuery Text"+ "[typedSql| SELECT name FROM typed_sql_test_items WHERE views = ${(\"not an int\" :: Text)} LIMIT 1 |]")+ []++ compileFailTest "fails when a foreign-key parameter has the wrong type"+ (mkTestModuleWithPK ["typed_sql_test_items", "typed_sql_test_authors"] "TypedQuery Text"+ "[typedSql| SELECT name FROM typed_sql_test_items WHERE author_id = ${(\"not-an-id\" :: Text)} LIMIT 1 |]")+ []++ compileFailTest "fails when an IN parameter has the wrong element type"+ (mkTestModuleWithPK ["typed_sql_test_items", "typed_sql_test_authors"] "TypedQuery Text"+ "let authorIds = [\"one\" :: Text, \"two\" :: Text]\n in [typedSql| SELECT name FROM typed_sql_test_items WHERE author_id IN (${authorIds}) LIMIT 1 |]")+ []++ compileFailTest "fails when a placeholder expression is invalid Haskell"+ (mkTestModule "TypedQuery Text"+ "[typedSql| SELECT name FROM typed_sql_test_items WHERE views = ${(} LIMIT 1 |]")+ ["failed to parse expression"]++ compileFailTest "fails when SQL parameter count does not match ${...} placeholders"+ (mkTestModule "TypedQuery Text"+ "[typedSql| SELECT name FROM typed_sql_test_items WHERE views = $1 LIMIT 1 |]")+ ["placeholder count mismatch"]++ compileFailTest "fails when selecting a single composite value without expansion"+ (mkTestModule "TypedQuery Text"+ "[typedSql| SELECT ROW(name, views)::typed_sql_test_pair FROM typed_sql_test_items LIMIT 1 |]")+ ["composite columns must be expanded"]++ compileFailTest "fails when SQL references an unknown column"+ (mkTestModule "TypedQuery Text"+ "[typedSql| SELECT no_such_column FROM typed_sql_test_items LIMIT 1 |]")+ ["does not exist"]++ compileFailTest "fails when primary-key result type is annotated as UUID instead of Id"+ (mkTestModuleWithPK ["typed_sql_test_items"] "TypedQuery UUID"+ "[typedSql| SELECT id FROM typed_sql_test_items LIMIT 1 |]")+ []++ compileFailTest "fails when nullable column result is annotated as non-Maybe"+ (mkTestModule "TypedQuery Double"+ "[typedSql| SELECT score FROM typed_sql_test_items LIMIT 1 |]")+ []++ compileFailTest "fails when LEFT JOIN nullable side is not annotated as Maybe"+ (mkTestModule "TypedQuery (Text, Text)"+ "[typedSql| SELECT i.name, a.name FROM typed_sql_test_items i LEFT JOIN typed_sql_test_authors a ON a.id = i.author_id LIMIT 1 |]")+ []++ compileFailTest "fails when RIGHT JOIN nullable side is not annotated as Maybe"+ (mkTestModule "TypedQuery (Text, Text)"+ "[typedSql| SELECT i.name, a.name FROM typed_sql_test_items i RIGHT JOIN typed_sql_test_authors a ON a.id = i.author_id ORDER BY a.name LIMIT 1 |]")+ []++ compileFailTest "fails when tuple arity does not match selected columns"+ (mkTestModule "TypedQuery Text"+ "[typedSql| SELECT name, views FROM typed_sql_test_items LIMIT 1 |]")+ []++ compileFailTest "fails when boolean expression result is annotated as Int"+ (mkTestModule "TypedQuery Int"+ "[typedSql| SELECT author_id IS NULL FROM typed_sql_test_items LIMIT 1 |]")+ []++ compileFailTest "fails when boolean expression result is annotated as non-Maybe Bool"+ (mkTestModule "TypedQuery Bool"+ "[typedSql| SELECT author_id IS NULL FROM typed_sql_test_items LIMIT 1 |]")+ []++ compileFailTest "fails when COUNT(*) result is annotated as non-Maybe Integer"+ (mkTestModule "TypedQuery Integer"+ "[typedSql| SELECT COUNT(*) FROM typed_sql_test_items |]")+ []++ compileFailTest "fails when COALESCE expression is annotated as non-Maybe Text"+ (mkTestModule "TypedQuery (Text, Text)"+ "[typedSql| SELECT COALESCE(i.name, '(no-item)'), a.name FROM typed_sql_test_items i RIGHT JOIN typed_sql_test_authors a ON a.id = i.author_id LIMIT 1 |]")+ []++ compileFailTest "fails when literal expression result is annotated as non-Maybe Int"+ (mkTestModule "TypedQuery Int"+ "[typedSql| SELECT 1 |]")+ []++ compileFailTest "fails when arithmetic expression result is annotated as non-Maybe Int"+ (mkTestModule "TypedQuery Int"+ "[typedSql| SELECT views + 1 FROM typed_sql_test_items LIMIT 1 |]")+ []++ compileFailTest "fails when CASE expression result is annotated as non-Maybe Text"+ (mkTestModule "TypedQuery Text"+ "[typedSql| SELECT CASE WHEN views > 5 THEN name ELSE 'low' END FROM typed_sql_test_items LIMIT 1 |]")+ []++ compileFailTest "fails when EXISTS expression result is annotated as non-Maybe Bool"+ (mkTestModule "TypedQuery Bool"+ "[typedSql| SELECT EXISTS(SELECT 1 FROM typed_sql_test_items WHERE views > 7) |]")+ []++ compileFailTest "fails when NULL literal result is annotated as non-Maybe Text"+ (mkTestModule "TypedQuery Text"+ "[typedSql| SELECT NULL::text |]")+ []++ compileFailTest "fails when CTE result is annotated as Maybe Text"+ (mkTestModule "TypedQuery (Maybe Text)"+ "[typedSql| WITH item_names AS (SELECT name FROM typed_sql_test_items WHERE views > 6) SELECT name FROM item_names LIMIT 1 |]")+ []++ compileFailTest "fails when subquery result is annotated as Maybe Text"+ (mkTestModule "TypedQuery (Maybe Text)"+ "[typedSql| SELECT name FROM (SELECT name FROM typed_sql_test_items WHERE views < 6) sub LIMIT 1 |]")+ []++ compileFailTest "fails when UNION result is annotated as non-Maybe Text"+ (mkTestModule "TypedQuery Text"+ "[typedSql| SELECT name FROM typed_sql_test_items WHERE views > 6 UNION ALL SELECT name FROM typed_sql_test_items WHERE views < 6 |]")+ []++ compileFailTest "fails when window function result is annotated as non-Maybe Integer"+ (mkTestModule "TypedQuery Integer"+ "[typedSql| SELECT row_number() OVER (ORDER BY name) FROM typed_sql_test_items LIMIT 1 |]")+ []++ compileFailTest "fails when grouped COUNT(*) result is annotated as non-Maybe Integer"+ (mkTestModule "TypedQuery (Text, Integer)"+ "[typedSql| SELECT name, COUNT(*) FROM typed_sql_test_items GROUP BY name ORDER BY name LIMIT 1 |]")+ []++ compileFailTest "fails when array literal result is annotated as non-Maybe [Text]"+ (mkTestModule "TypedQuery [Text]"+ "[typedSql| SELECT ARRAY['x','y']::text[] |]")+ []++ compileFailTest "fails when NULLIF expression result is annotated as non-Maybe Text"+ (mkTestModule "TypedQuery Text"+ "[typedSql| SELECT NULLIF(name, 'First') FROM typed_sql_test_items LIMIT 1 |]")+ []++ describe "TypedSql macro compile-time success" do+ compilePassTest "primary key inferred as Id'"+ (mkTestModuleWithPK ["typed_sql_test_items"] "TypedQuery (Id' \"typed_sql_test_items\")"+ "[typedSql| SELECT id FROM typed_sql_test_items LIMIT 1 |]")++ compilePassTest "nullable column inferred as Maybe"+ (mkTestModule "TypedQuery (Maybe Double)"+ "[typedSql| SELECT score FROM typed_sql_test_items LIMIT 1 |]")++ compilePassTest "LEFT JOIN right side inferred as Maybe"+ (mkTestModule "TypedQuery (Text, Maybe Text)"+ "[typedSql| SELECT i.name, a.name FROM typed_sql_test_items i LEFT JOIN typed_sql_test_authors a ON a.id = i.author_id LIMIT 1 |]")++ compilePassTest "RIGHT JOIN left side inferred as Maybe"+ (mkTestModule "TypedQuery (Maybe Text, Text)"+ "[typedSql| SELECT i.name, a.name FROM typed_sql_test_items i RIGHT JOIN typed_sql_test_authors a ON a.id = i.author_id ORDER BY a.name LIMIT 1 |]")++ compilePassTest "tuple arity matches selected columns"+ (mkTestModule "TypedQuery (Text, Int)"+ "[typedSql| SELECT name, views FROM typed_sql_test_items LIMIT 1 |]")++ compilePassTest "boolean expression inferred as Maybe Bool"+ (mkTestModule "TypedQuery (Maybe Bool)"+ "[typedSql| SELECT author_id IS NULL FROM typed_sql_test_items LIMIT 1 |]")++ compilePassTest "COUNT(*) inferred as Maybe Integer"+ (mkTestModule "TypedQuery (Maybe Integer)"+ "[typedSql| SELECT COUNT(*) FROM typed_sql_test_items |]")++ compilePassTest "COALESCE in RIGHT JOIN inferred as Maybe"+ (mkTestModule "TypedQuery (Maybe Text, Text)"+ "[typedSql| SELECT COALESCE(i.name, '(no-item)'), a.name FROM typed_sql_test_items i RIGHT JOIN typed_sql_test_authors a ON a.id = i.author_id LIMIT 1 |]")++ compilePassTest "literal expression inferred as Maybe Int"+ (mkTestModule "TypedQuery (Maybe Int)"+ "[typedSql| SELECT 1 |]")++ compilePassTest "arithmetic expression inferred as Maybe Int"+ (mkTestModule "TypedQuery (Maybe Int)"+ "[typedSql| SELECT views + 1 FROM typed_sql_test_items LIMIT 1 |]")++ compilePassTest "CASE expression inferred as Maybe Text"+ (mkTestModule "TypedQuery (Maybe Text)"+ "[typedSql| SELECT CASE WHEN views > 5 THEN name ELSE 'low' END FROM typed_sql_test_items LIMIT 1 |]")++ compilePassTest "EXISTS expression inferred as Maybe Bool"+ (mkTestModule "TypedQuery (Maybe Bool)"+ "[typedSql| SELECT EXISTS(SELECT 1 FROM typed_sql_test_items WHERE views > 7) |]")++ compilePassTest "NULL literal inferred as Maybe Text"+ (mkTestModule "TypedQuery (Maybe Text)"+ "[typedSql| SELECT NULL::text |]")++ compilePassTest "CTE preserves column type"+ (mkTestModule "TypedQuery Text"+ "[typedSql| WITH item_names AS (SELECT name FROM typed_sql_test_items WHERE views > 6) SELECT name FROM item_names LIMIT 1 |]")++ compilePassTest "subquery preserves column type"+ (mkTestModule "TypedQuery Text"+ "[typedSql| SELECT name FROM (SELECT name FROM typed_sql_test_items WHERE views < 6) sub LIMIT 1 |]")++ compilePassTest "UNION inferred as Maybe"+ (mkTestModule "TypedQuery (Maybe Text)"+ "[typedSql| SELECT name FROM typed_sql_test_items WHERE views > 6 UNION ALL SELECT name FROM typed_sql_test_items WHERE views < 6 |]")++ compilePassTest "window function inferred as Maybe Integer"+ (mkTestModule "TypedQuery (Maybe Integer)"+ "[typedSql| SELECT row_number() OVER (ORDER BY name) FROM typed_sql_test_items LIMIT 1 |]")++ compilePassTest "grouped COUNT(*) inferred as (Text, Maybe Integer)"+ (mkTestModule "TypedQuery (Text, Maybe Integer)"+ "[typedSql| SELECT name, COUNT(*) FROM typed_sql_test_items GROUP BY name ORDER BY name LIMIT 1 |]")++ compilePassTest "array literal inferred as Maybe [Text]"+ (mkTestModule "TypedQuery (Maybe [Text])"+ "[typedSql| SELECT ARRAY['x','y']::text[] |]")++ compilePassTest "NULLIF inferred as Maybe Text"+ (mkTestModule "TypedQuery (Maybe Text)"+ "[typedSql| SELECT NULLIF(name, 'First') FROM typed_sql_test_items LIMIT 1 |]")++ compilePassTest "scalar parameter accepts correct type"+ (mkTestModule "TypedQuery Text"+ "[typedSql| SELECT name FROM typed_sql_test_items WHERE views = ${(5 :: Int)} LIMIT 1 |]")++ compilePassTest "foreign-key parameter accepts Id' type"+ (mkTestModuleWithPK ["typed_sql_test_items", "typed_sql_test_authors"] "TypedQuery Text"+ "let authorId = (\"00000000-0000-0000-0000-000000000001\" :: Id' \"typed_sql_test_authors\")\n in [typedSql| SELECT name FROM typed_sql_test_items WHERE author_id = ${authorId} LIMIT 1 |]")++ compilePassTest "INNER JOIN columns are non-Maybe"+ (mkTestModule "TypedQuery (Text, Text)"+ "[typedSql| SELECT i.name, a.name FROM typed_sql_test_items i INNER JOIN typed_sql_test_authors a ON a.id = i.author_id LIMIT 1 |]")++ describe "TypedSql macro runtime execution" do+ runtimeTest "executes typedSql queries end-to-end via ghci" runtimeModule+ runtimeTest "UPDATE and DELETE with parameters" runtimeUpdateDeleteModule+ runtimeTest "empty results and edge cases" runtimeEdgeCasesModule+ runtimeTest "additional column types (smallint, bigint, numeric, bytea, bool, timestamptz, date, jsonb)" runtimeExtraTypesModule++ describe "TypedSql SQL parser (pure, no postgres)" do+ it "parseSql succeeds on simple SELECT" do+ parseSql "SELECT 1" `shouldSatisfy` isJust++ it "parseSql handles leading/trailing whitespace from quasiquoter" do+ parseSql " SELECT 1 " `shouldSatisfy` isJust++ it "extractJoinNullableTables detects LEFT JOIN nullable table" do+ let sql = " SELECT i.name, a.name FROM items i LEFT JOIN authors a ON a.id = i.aid LIMIT 1 "+ extractJoinNullableTables sql `shouldBe` Set.fromList ["authors"]++ it "extractJoinNullableTables detects RIGHT JOIN nullable table" do+ let sql = " SELECT i.name, a.name FROM items i RIGHT JOIN authors a ON a.id = i.aid LIMIT 1 "+ extractJoinNullableTables sql `shouldBe` Set.fromList ["items"]++ it "extractJoinNullableTables detects FULL JOIN nullable tables" do+ let sql = "SELECT i.name, a.name FROM items i FULL JOIN authors a ON a.id = i.aid"+ extractJoinNullableTables sql `shouldBe` Set.fromList ["items", "authors"]++ it "extractJoinNullableTables returns empty for INNER JOIN" do+ let sql = " SELECT i.name, a.name FROM items i INNER JOIN authors a ON a.id = i.aid "+ extractJoinNullableTables sql `shouldBe` Set.empty++ it "extractJoinNullableTables returns empty for plain FROM" do+ let sql = " SELECT name FROM items LIMIT 1 "+ extractJoinNullableTables sql `shouldBe` Set.empty++-- Test helpers ---------------------------------------------------------------++requirePostgresTestHook :: IO ()+requirePostgresTestHook = do+ maybePgHost <- lookupEnv "PGHOST"+ when (isNothing maybePgHost) do+ pendingWith "requires postgresqlTestHook / withTestPostgres (PGHOST is not set)"++withTestModelContext :: ((?modelContext :: ModelContext) => IO a) -> IO a+withTestModelContext action = do+ logger <- newLogger def { level = Warn }+ databaseUrl <- cs . fromMaybe "" <$> lookupEnv "DATABASE_URL"+ modelContext <- createModelContext databaseUrl logger+ let ?modelContext = modelContext+ action `Exception.finally` releaseModelContext modelContext++setupSchema :: (?modelContext :: ModelContext) => IO ()+setupSchema = do+ -- Use sqlExecDiscardResult for DDL (DROP/CREATE) since they have no rows-affected count+ sqlExecDiscardResult "DROP TABLE IF EXISTS typed_sql_test_extras" ()+ sqlExecDiscardResult "DROP TABLE IF EXISTS typed_sql_test_items" ()+ sqlExecDiscardResult "DROP TABLE IF EXISTS typed_sql_test_authors" ()+ sqlExecDiscardResult "DROP TYPE IF EXISTS typed_sql_test_pair" ()++ sqlExecDiscardResult "CREATE TYPE typed_sql_test_pair AS (name TEXT, views INT)" ()++ sqlExecDiscardResult+ "CREATE TABLE typed_sql_test_authors (id UUID PRIMARY KEY, name TEXT NOT NULL)"+ ()++ sqlExecDiscardResult+ "CREATE TABLE typed_sql_test_items (id UUID PRIMARY KEY, author_id UUID REFERENCES typed_sql_test_authors(id), name TEXT NOT NULL, views INT NOT NULL, score DOUBLE PRECISION, tags TEXT[] NOT NULL DEFAULT '{}')"+ ()++ sqlExecDiscardResult+ "INSERT INTO typed_sql_test_authors (id, name) VALUES ('00000000-0000-0000-0000-000000000001'::uuid, 'Alice')"+ ()++ sqlExecDiscardResult+ "INSERT INTO typed_sql_test_authors (id, name) VALUES ('00000000-0000-0000-0000-000000000002'::uuid, 'Bob')"+ ()++ sqlExecDiscardResult+ "INSERT INTO typed_sql_test_items (id, author_id, name, views, score, tags) VALUES ('10000000-0000-0000-0000-000000000001'::uuid, '00000000-0000-0000-0000-000000000001'::uuid, 'First', 5, 1.5, ARRAY['red', 'blue'])"+ ()++ sqlExecDiscardResult+ "INSERT INTO typed_sql_test_items (id, author_id, name, views, score, tags) VALUES ('10000000-0000-0000-0000-000000000002'::uuid, '00000000-0000-0000-0000-000000000001'::uuid, 'Second', 8, NULL, ARRAY['green'])"+ ()++ sqlExecDiscardResult+ "CREATE TABLE typed_sql_test_extras (id UUID PRIMARY KEY, small_count SMALLINT NOT NULL DEFAULT 0, big_count BIGINT NOT NULL DEFAULT 0, amount NUMERIC, payload BYTEA, metadata JSONB, created_at TIMESTAMPTZ NOT NULL DEFAULT '2025-06-15 12:00:00+00', due_date DATE, active BOOLEAN NOT NULL DEFAULT TRUE)"+ ()++ sqlExecDiscardResult+ "INSERT INTO typed_sql_test_extras (id, small_count, big_count, amount, payload, metadata, created_at, due_date, active) VALUES ('20000000-0000-0000-0000-000000000001'::uuid, 7, 1000000000, 99.95, '\\xDEADBEEF', '{\"key\": \"value\"}', '2025-06-15 12:00:00+00', '2025-06-15', true)"+ ()++ pure ()++-- GHCi infrastructure --------------------------------------------------------++ghciLoadModule :: Text -> IO Text+ghciLoadModule source =+ ghciRun source [":set -fno-code"] []++ghciRunModule :: Text -> IO Text+ghciRunModule source =+ ghciRun source [] ["main"]++ghciRun :: Text -> [Text] -> [Text] -> IO Text+ghciRun source preLoadCommands postLoadCommands =+ withSystemTempDirectory "typed-sql-ghci" \tempDir -> do+ packageRoot <- findIhpPackageRoot+ let repoRoot = takeDirectory packageRoot+ useRepoGhci <- doesFileExist (repoRoot </> ".ghci")+ env <- ghciEnvironment++ let modulePath = tempDir </> "TypedSqlCase.hs"+ Text.writeFile modulePath source++ let commands =+ ghciDefaultExtensionCommands+ <> preLoadCommands+ <> [":l " <> tshow modulePath]+ <> postLoadCommands+ <> [":quit"]++ let ghciArgs =+ if useRepoGhci+ then ["-v0"]+ else ["-ignore-dot-ghci", "-v0", "-i" <> packageRoot]++ let process = (proc "ghci" ghciArgs)+ { cwd = Just (if useRepoGhci then repoRoot else packageRoot)+ , env = Just env+ }++ (_exitCode, stdOut, stdErr) <- readCreateProcessWithExitCode process (cs (Text.unlines commands))+ pure (cs stdOut <> cs stdErr)++ghciDefaultExtensionCommands :: [Text]+ghciDefaultExtensionCommands =+ map (":set " <>)+ [ "-XGHC2021"+ , "-XNoImplicitPrelude"+ , "-XImplicitParams"+ , "-XOverloadedStrings"+ , "-XDisambiguateRecordFields"+ , "-XDuplicateRecordFields"+ , "-XOverloadedLabels"+ , "-XDataKinds"+ , "-XQuasiQuotes"+ , "-XTypeFamilies"+ , "-XPackageImports"+ , "-XRecordWildCards"+ , "-XDefaultSignatures"+ , "-XFunctionalDependencies"+ , "-XPartialTypeSignatures"+ , "-XBlockArguments"+ , "-XLambdaCase"+ , "-XTemplateHaskell"+ , "-XOverloadedRecordDot"+ , "-XDeepSubsumption"+ , "-XExplicitNamespaces"+ ]++findIhpPackageRoot :: IO FilePath+findIhpPackageRoot = do+ currentDirectory <- getCurrentDirectory++ let inPackageRoot = currentDirectory </> "IHP" </> "TypedSql.hs"+ inPackageExists <- doesFileExist inPackageRoot+ if inPackageExists+ then pure currentDirectory+ else do+ let fromRepoRoot = currentDirectory </> "ihp-typed-sql" </> "IHP" </> "TypedSql.hs"+ fromRepoExists <- doesFileExist fromRepoRoot+ if fromRepoExists+ then pure (currentDirectory </> "ihp-typed-sql")+ else fail "TypedSqlSpec: could not locate ihp-typed-sql package root"++ghciEnvironment :: IO [(String, String)]+ghciEnvironment = do+ baseEnvironment <- getEnvironment++ -- Prefer an existing DATABASE_URL (e.g. set by withTestPostgres in nix)+ existingDatabaseUrl <- lookupEnv "DATABASE_URL"++ let databaseUrl = case existingDatabaseUrl of+ Just url | not (null url) -> url+ _ ->+ let pgHost = fromMaybe "" (lookup "PGHOST" baseEnvironment)+ pgDatabase = fromMaybe "" (lookup "PGDATABASE" baseEnvironment)+ pgUser = fromMaybe "" (lookup "PGUSER" baseEnvironment)+ pgPort = lookup "PGPORT" baseEnvironment+ parts =+ [ "host=" <> pgHost+ , "dbname=" <> pgDatabase+ , "user=" <> pgUser+ ] <> case pgPort of+ Just port | not (null port) -> ["port=" <> port]+ _ -> []+ in Prelude.unwords parts++ let overrides :: [(String, String)]+ overrides =+ [ ("DATABASE_URL", databaseUrl)+ ]++ pure (applyEnvironmentOverrides overrides baseEnvironment)++applyEnvironmentOverrides :: [(String, String)] -> [(String, String)] -> [(String, String)]+applyEnvironmentOverrides overrides base =+ overrides <> filter (\(name, _) -> name `notElem` map fst overrides) base++-- Assertion helpers ----------------------------------------------------------++assertGhciSuccess :: Text -> IO ()+assertGhciSuccess output =+ when (containsCompileError output) do+ expectationFailure ("expected ghci load/run to succeed, but got:\n" <> cs output)++assertGhciFailure :: Text -> [Text] -> IO ()+assertGhciFailure output expectedFragments = do+ when (not (containsCompileError output)) do+ expectationFailure ("expected ghci load to fail, but got:\n" <> cs output)++ forM_ expectedFragments \fragment ->+ when (not (Text.toLower fragment `Text.isInfixOf` Text.toLower output)) do+ expectationFailure+ ( "expected ghci output to contain fragment: "+ <> cs fragment+ <> "\nactual output:\n"+ <> cs output+ )++containsCompileError :: Text -> Bool+containsCompileError output =+ let lower = Text.toLower output+ in " error:" `Text.isInfixOf` lower+ || "\nerror:" `Text.isInfixOf` lower++shouldContainText :: Text -> Text -> Expectation+shouldContainText haystack needle =+ when (not (needle `Text.isInfixOf` haystack)) do+ expectationFailure+ ( "expected text output to contain: "+ <> cs needle+ <> "\nactual output:\n"+ <> cs haystack+ )++-- Module generators ----------------------------------------------------------++-- | Spec helper: compile-pass test with shared boilerplate.+compilePassTest :: Text -> Text -> SpecWith ()+compilePassTest description moduleText =+ it (cs description) do+ requirePostgresTestHook+ withTestModelContext do+ setupSchema+ ghciOutput <- ghciLoadModule moduleText+ assertGhciSuccess ghciOutput++-- | Spec helper: compile-fail test with shared boilerplate.+compileFailTest :: Text -> Text -> [Text] -> SpecWith ()+compileFailTest description moduleText expectedFragments =+ it (cs description) do+ requirePostgresTestHook+ withTestModelContext do+ setupSchema+ ghciOutput <- ghciLoadModule moduleText+ assertGhciFailure ghciOutput expectedFragments++-- | Spec helper: runtime test with shared boilerplate.+runtimeTest :: Text -> Text -> SpecWith ()+runtimeTest description moduleText =+ it (cs description) do+ requirePostgresTestHook+ withTestModelContext do+ setupSchema+ ghciOutput <- ghciRunModule moduleText+ assertGhciSuccess ghciOutput+ ghciOutput `shouldContainText` "RUNTIME_OK"++-- | Build a test module from a type signature and body expression.+-- Used for both compile-pass and compile-fail tests.+mkTestModule :: Text -> Text -> Text+mkTestModule typeSig body = Text.unlines+ [ "{-# LANGUAGE NoImplicitPrelude #-}"+ , "{-# LANGUAGE OverloadedStrings #-}"+ , "{-# LANGUAGE QuasiQuotes #-}"+ , "module TypedSqlCase where"+ , ""+ , "import IHP.Prelude"+ , "import IHP.TypedSql (TypedQuery, typedSql)"+ , ""+ , "query :: " <> typeSig+ , "query = " <> body+ ]++-- | Build a test module that also needs PrimaryKey type instances.+mkTestModuleWithPK :: [Text] -> Text -> Text -> Text+mkTestModuleWithPK pkTables typeSig body = Text.unlines $+ [ "{-# LANGUAGE DataKinds #-}"+ , "{-# LANGUAGE NoImplicitPrelude #-}"+ , "{-# LANGUAGE OverloadedStrings #-}"+ , "{-# LANGUAGE QuasiQuotes #-}"+ , "{-# LANGUAGE TypeFamilies #-}"+ , "module TypedSqlCase where"+ , ""+ , "import IHP.Prelude"+ , "import IHP.ModelSupport (Id'(..), PrimaryKey)"+ , "import IHP.TypedSql (TypedQuery, typedSql)"+ , ""+ ]+ <> map (\t -> "type instance PrimaryKey \"" <> t <> "\" = UUID") pkTables+ <>+ [ ""+ , "query :: " <> typeSig+ , "query = " <> body+ ]++-- Test modules ---------------------------------------------------------------++compilePassModule :: Text+compilePassModule = Text.unlines+ [ "{-# LANGUAGE DataKinds #-}"+ , "{-# LANGUAGE NoImplicitPrelude #-}"+ , "{-# LANGUAGE OverloadedStrings #-}"+ , "{-# LANGUAGE QuasiQuotes #-}"+ , "{-# LANGUAGE TypeApplications #-}"+ , "{-# LANGUAGE TypeFamilies #-}"+ , "module TypedSqlCompilePass where"+ , ""+ , "import IHP.Prelude"+ , "import IHP.ModelSupport (Id'(..), PrimaryKey)"+ , "import IHP.Hasql.FromRow (FromRowHasql (..))"+ , "import IHP.TypedSql (TypedQuery, typedSql)"+ , "import qualified Hasql.Decoders as HasqlDecoders"+ , ""+ , "type instance PrimaryKey \"typed_sql_test_items\" = UUID"+ , "type instance PrimaryKey \"typed_sql_test_authors\" = UUID"+ , ""+ , "data TypedSqlTestItem = TypedSqlTestItem"+ , " { typedSqlTestItemId :: Id' \"typed_sql_test_items\""+ , " , typedSqlTestItemAuthorId :: Maybe (Id' \"typed_sql_test_authors\")"+ , " , typedSqlTestItemName :: Text"+ , " , typedSqlTestItemViews :: Int"+ , " , typedSqlTestItemScore :: Maybe Double"+ , " , typedSqlTestItemTags :: [Text]"+ , " } deriving (Eq, Show)"+ , ""+ , "instance FromRowHasql TypedSqlTestItem where"+ , " hasqlRowDecoder ="+ , " TypedSqlTestItem"+ , " <$> (fmap Id (HasqlDecoders.column (HasqlDecoders.nonNullable HasqlDecoders.uuid)))"+ , " <*> (fmap (fmap Id) (HasqlDecoders.column (HasqlDecoders.nullable HasqlDecoders.uuid)))"+ , " <*> HasqlDecoders.column (HasqlDecoders.nonNullable HasqlDecoders.text)"+ , " <*> (fmap fromIntegral (HasqlDecoders.column (HasqlDecoders.nonNullable HasqlDecoders.int4)))"+ , " <*> HasqlDecoders.column (HasqlDecoders.nullable HasqlDecoders.float8)"+ , " <*> HasqlDecoders.column (HasqlDecoders.nonNullable (HasqlDecoders.listArray (HasqlDecoders.nonNullable HasqlDecoders.text)))"+ , ""+ , "qName :: TypedQuery Text"+ , "qName = [typedSql| SELECT name FROM typed_sql_test_items LIMIT 1 |]"+ , ""+ , "qAllFields :: TypedQuery TypedSqlTestItem"+ , "qAllFields = [typedSql| SELECT typed_sql_test_items.* FROM typed_sql_test_items LIMIT 1 |]"+ , ""+ , "qAllFieldsAlias :: TypedQuery TypedSqlTestItem"+ , "qAllFieldsAlias = [typedSql| SELECT i.* FROM typed_sql_test_items i JOIN typed_sql_test_authors a ON a.id = i.author_id LIMIT 1 |]"+ , ""+ , "qPrimaryKey :: TypedQuery (Id' \"typed_sql_test_items\")"+ , "qPrimaryKey = [typedSql| SELECT id FROM typed_sql_test_items LIMIT 1 |]"+ , ""+ , "qForeignKey :: TypedQuery (Maybe (Id' \"typed_sql_test_authors\"))"+ , "qForeignKey = [typedSql| SELECT author_id FROM typed_sql_test_items LIMIT 1 |]"+ , ""+ , "qNullable :: TypedQuery (Maybe Double)"+ , "qNullable = [typedSql| SELECT score FROM typed_sql_test_items LIMIT 1 |]"+ , ""+ , "qArray :: TypedQuery [Text]"+ , "qArray = [typedSql| SELECT tags FROM typed_sql_test_items LIMIT 1 |]"+ , ""+ , "qTuple :: TypedQuery (Id' \"typed_sql_test_items\", Text, Int)"+ , "qTuple = [typedSql| SELECT id, name, views FROM typed_sql_test_items LIMIT 1 |]"+ , ""+ , "qEqParam :: TypedQuery Text"+ , "qEqParam = [typedSql| SELECT name FROM typed_sql_test_items WHERE views = ${5 :: Int} LIMIT 1 |]"+ , ""+ , "qForeignKeyParamHint :: TypedQuery Text"+ , "qForeignKeyParamHint ="+ , " let authorId = (\"00000000-0000-0000-0000-000000000001\" :: Id' \"typed_sql_test_authors\")"+ , " in [typedSql| SELECT name FROM typed_sql_test_items WHERE author_id = ${authorId} LIMIT 1 |]"+ , ""+ , "qInParamHint :: TypedQuery Text"+ , "qInParamHint ="+ , " let authorIds = [ (\"00000000-0000-0000-0000-000000000001\" :: Id' \"typed_sql_test_authors\") ]"+ , " in [typedSql| SELECT name FROM typed_sql_test_items WHERE author_id IN (${authorIds}) LIMIT 1 |]"+ , ""+ , "qAnyParamHint :: TypedQuery Text"+ , "qAnyParamHint ="+ , " let itemIds ="+ , " [ (\"10000000-0000-0000-0000-000000000001\" :: Id' \"typed_sql_test_items\")"+ , " , (\"10000000-0000-0000-0000-000000000002\" :: Id' \"typed_sql_test_items\")"+ , " ]"+ , " in [typedSql| SELECT name FROM typed_sql_test_items WHERE id = ANY(${itemIds}) ORDER BY name LIMIT 1 |]"+ , ""+ , "qCompositeExpanded :: TypedQuery (Maybe Text, Maybe Int)"+ , "qCompositeExpanded = [typedSql| SELECT (ROW(name, views)::typed_sql_test_pair).* FROM typed_sql_test_items LIMIT 1 |]"+ , ""+ , "qBoolExpr :: TypedQuery (Maybe Bool)"+ , "qBoolExpr = [typedSql| SELECT author_id IS NULL FROM typed_sql_test_items LIMIT 1 |]"+ , ""+ , "qCountExpr :: TypedQuery (Maybe Integer)"+ , "qCountExpr = [typedSql| SELECT COUNT(*) FROM typed_sql_test_items |]"+ , ""+ , "qLiteralInt :: TypedQuery (Maybe Int)"+ , "qLiteralInt = [typedSql| SELECT 1 |]"+ , ""+ , "qArithmeticExpr :: TypedQuery (Maybe Int)"+ , "qArithmeticExpr = [typedSql| SELECT views + 1 FROM typed_sql_test_items LIMIT 1 |]"+ , ""+ , "qCaseExpr :: TypedQuery (Maybe Text)"+ , "qCaseExpr = [typedSql| SELECT CASE WHEN views > 5 THEN name ELSE 'low' END FROM typed_sql_test_items LIMIT 1 |]"+ , ""+ , "qExistsExpr :: TypedQuery (Maybe Bool)"+ , "qExistsExpr = [typedSql| SELECT EXISTS(SELECT 1 FROM typed_sql_test_items WHERE views > 7) |]"+ , ""+ , "qNullLiteral :: TypedQuery (Maybe Text)"+ , "qNullLiteral = [typedSql| SELECT NULL::text |]"+ , ""+ , "qCte :: TypedQuery Text"+ , "qCte = [typedSql| WITH item_names AS (SELECT name FROM typed_sql_test_items WHERE views > 6) SELECT name FROM item_names LIMIT 1 |]"+ , ""+ , "qSubquery :: TypedQuery Text"+ , "qSubquery = [typedSql| SELECT name FROM (SELECT name FROM typed_sql_test_items WHERE views < 6) sub LIMIT 1 |]"+ , ""+ , "qUnion :: TypedQuery (Maybe Text)"+ , "qUnion = [typedSql| SELECT name FROM typed_sql_test_items WHERE views > 6 UNION ALL SELECT name FROM typed_sql_test_items WHERE views < 6 |]"+ , ""+ , "qWindow :: TypedQuery (Maybe Integer)"+ , "qWindow = [typedSql| SELECT row_number() OVER (ORDER BY name) FROM typed_sql_test_items LIMIT 1 |]"+ , ""+ , "qGroupedCount :: TypedQuery (Text, Maybe Integer)"+ , "qGroupedCount = [typedSql| SELECT name, COUNT(*) FROM typed_sql_test_items GROUP BY name ORDER BY name LIMIT 1 |]"+ , ""+ , "qArrayLiteral :: TypedQuery (Maybe [Text])"+ , "qArrayLiteral = [typedSql| SELECT ARRAY['x','y']::text[] |]"+ , ""+ , "qNullIfExpr :: TypedQuery (Maybe Text)"+ , "qNullIfExpr = [typedSql| SELECT NULLIF(name, 'First') FROM typed_sql_test_items LIMIT 1 |]"+ , ""+ , "qSchemaQualified :: TypedQuery Text"+ , "qSchemaQualified = [typedSql| SELECT name FROM public.typed_sql_test_items LIMIT 1 |]"+ , ""+ , "qQuotedIdentifiers :: TypedQuery Text"+ , "qQuotedIdentifiers = [typedSql| SELECT \"name\" FROM \"typed_sql_test_items\" LIMIT 1 |]"+ , ""+ , "qInnerJoin :: TypedQuery (Text, Text)"+ , "qInnerJoin = [typedSql| SELECT i.name, a.name FROM typed_sql_test_items i INNER JOIN typed_sql_test_authors a ON a.id = i.author_id LIMIT 1 |]"+ , ""+ , "qLeftJoin :: TypedQuery (Text, Maybe Text)"+ , "qLeftJoin = [typedSql| SELECT i.name, a.name FROM typed_sql_test_items i LEFT JOIN typed_sql_test_authors a ON a.id = i.author_id LIMIT 1 |]"+ , ""+ , "qRightJoin :: TypedQuery (Maybe Text, Text)"+ , "qRightJoin = [typedSql| SELECT i.name, a.name FROM typed_sql_test_items i RIGHT JOIN typed_sql_test_authors a ON a.id = i.author_id LIMIT 1 |]"+ , ""+ , "qRightJoinCoalesced :: TypedQuery (Maybe Text, Text)"+ , "qRightJoinCoalesced = [typedSql| SELECT COALESCE(i.name, '(no-item)'), a.name FROM typed_sql_test_items i RIGHT JOIN typed_sql_test_authors a ON a.id = i.author_id LIMIT 1 |]"+ ]++runtimeModule :: Text+runtimeModule = Text.unlines+ [ "{-# LANGUAGE DataKinds #-}"+ , "{-# LANGUAGE ImplicitParams #-}"+ , "{-# LANGUAGE NoImplicitPrelude #-}"+ , "{-# LANGUAGE OverloadedStrings #-}"+ , "{-# LANGUAGE QuasiQuotes #-}"+ , "{-# LANGUAGE TypeFamilies #-}"+ , "module Main where"+ , ""+ , "import qualified Control.Exception as Exception"+ , "import IHP.Prelude"+ , "import IHP.Log.Types"+ , "import IHP.ModelSupport (Id'(..), ModelContext, PrimaryKey, createModelContext, releaseModelContext)"+ , "import IHP.Hasql.FromRow (FromRowHasql (..))"+ , "import IHP.TypedSql (sqlExecTyped, sqlQueryTyped, typedSql)"+ , "import qualified Hasql.Decoders as HasqlDecoders"+ , "import System.Environment (lookupEnv)"+ , ""+ , "type instance PrimaryKey \"typed_sql_test_items\" = UUID"+ , "type instance PrimaryKey \"typed_sql_test_authors\" = UUID"+ , ""+ , "data TypedSqlTestItem = TypedSqlTestItem"+ , " { typedSqlTestItemId :: Id' \"typed_sql_test_items\""+ , " , typedSqlTestItemAuthorId :: Maybe (Id' \"typed_sql_test_authors\")"+ , " , typedSqlTestItemName :: Text"+ , " , typedSqlTestItemViews :: Int"+ , " , typedSqlTestItemScore :: Maybe Double"+ , " , typedSqlTestItemTags :: [Text]"+ , " } deriving (Eq, Show)"+ , ""+ , "instance FromRowHasql TypedSqlTestItem where"+ , " hasqlRowDecoder ="+ , " TypedSqlTestItem"+ , " <$> (fmap Id (HasqlDecoders.column (HasqlDecoders.nonNullable HasqlDecoders.uuid)))"+ , " <*> (fmap (fmap Id) (HasqlDecoders.column (HasqlDecoders.nullable HasqlDecoders.uuid)))"+ , " <*> HasqlDecoders.column (HasqlDecoders.nonNullable HasqlDecoders.text)"+ , " <*> (fmap fromIntegral (HasqlDecoders.column (HasqlDecoders.nonNullable HasqlDecoders.int4)))"+ , " <*> HasqlDecoders.column (HasqlDecoders.nullable HasqlDecoders.float8)"+ , " <*> HasqlDecoders.column (HasqlDecoders.nonNullable (HasqlDecoders.listArray (HasqlDecoders.nonNullable HasqlDecoders.text)))"+ , ""+ , "main :: IO ()"+ , "main = do"+ , " logger <- newLogger def { level = Warn }"+ , " databaseUrl <- cs . fromMaybe \"\" <$> lookupEnv \"DATABASE_URL\""+ , " modelContext <- createModelContext databaseUrl logger"+ , " let ?modelContext = modelContext"+ , " flip Exception.finally (releaseModelContext modelContext) do"+ , " let authorId = (\"00000000-0000-0000-0000-000000000001\" :: UUID)"+ , " let itemId1 = (\"10000000-0000-0000-0000-000000000001\" :: UUID)"+ , " let itemId2 = (\"10000000-0000-0000-0000-000000000002\" :: UUID)"+ , ""+ , " _ <- sqlExecTyped [typedSql| DELETE FROM typed_sql_test_items |]"+ , ""+ , " _ <- sqlExecTyped [typedSql|"+ , " INSERT INTO typed_sql_test_items (id, author_id, name, views, score, tags)"+ , " VALUES (${itemId1}, ${authorId}, ${(\"First\" :: Text)}, ${5 :: Int}, ${(1.5 :: Double)}, ${([\"red\", \"blue\"] :: [Text])})"+ , " |]"+ , ""+ , " _ <- sqlExecTyped [typedSql|"+ , " INSERT INTO typed_sql_test_items (id, author_id, name, views, score, tags)"+ , " VALUES (${itemId2}, ${authorId}, ${(\"Second\" :: Text)}, ${8 :: Int}, ${(2.0 :: Double)}, ${([\"green\"] :: [Text])})"+ , " |]"+ , ""+ , " names <- sqlQueryTyped [typedSql|"+ , " SELECT name FROM typed_sql_test_items"+ , " WHERE views > ${3 :: Int}"+ , " ORDER BY name"+ , " |]"+ , ""+ , " when ((names :: [Text]) /= [\"First\", \"Second\"]) do"+ , " error (\"unexpected names from typedSql: \" <> show names)"+ , ""+ , " namesViaTypedSql <- sqlQueryTyped [typedSql|"+ , " SELECT name FROM typed_sql_test_items"+ , " WHERE views >= ${5 :: Int}"+ , " ORDER BY name"+ , " |]"+ , ""+ , " when ((namesViaTypedSql :: [Text]) /= [\"First\", \"Second\"]) do"+ , " error (\"unexpected names from typedSql second query: \" <> show namesViaTypedSql)"+ , ""+ , " allItems <- sqlQueryTyped [typedSql|"+ , " SELECT typed_sql_test_items.*"+ , " FROM typed_sql_test_items"+ , " ORDER BY name"+ , " |]"+ , ""+ , " let expectedItems ="+ , " [ TypedSqlTestItem (Id itemId1) (Just (Id authorId)) \"First\" 5 (Just 1.5) [\"red\", \"blue\"]"+ , " , TypedSqlTestItem (Id itemId2) (Just (Id authorId)) \"Second\" 8 (Just 2.0) [\"green\"]"+ , " ]"+ , " when ((allItems :: [TypedSqlTestItem]) /= expectedItems) do"+ , " error (\"unexpected rows from table.* query: \" <> show allItems)"+ , ""+ , " boolExprRows <- sqlQueryTyped [typedSql|"+ , " SELECT author_id IS NULL"+ , " FROM typed_sql_test_items"+ , " ORDER BY name"+ , " |]"+ , ""+ , " when ((boolExprRows :: [Maybe Bool]) /= [Just False, Just False]) do"+ , " error (\"unexpected rows from bool expression query: \" <> show boolExprRows)"+ , ""+ , " countRows <- sqlQueryTyped [typedSql| SELECT COUNT(*) FROM typed_sql_test_items |]"+ , ""+ , " when ((countRows :: [Maybe Integer]) /= [Just 2]) do"+ , " error (\"unexpected rows from count query: \" <> show countRows)"+ , ""+ , " literalRows <- sqlQueryTyped [typedSql| SELECT 1 |]"+ , ""+ , " when ((literalRows :: [Maybe Int]) /= [Just 1]) do"+ , " error (\"unexpected rows from literal query: \" <> show literalRows)"+ , ""+ , " arithmeticRows <- sqlQueryTyped [typedSql|"+ , " SELECT views + 1 FROM typed_sql_test_items"+ , " ORDER BY name"+ , " |]"+ , ""+ , " when ((arithmeticRows :: [Maybe Int]) /= [Just 6, Just 9]) do"+ , " error (\"unexpected rows from arithmetic query: \" <> show arithmeticRows)"+ , ""+ , " caseRows <- sqlQueryTyped [typedSql|"+ , " SELECT CASE WHEN views > 5 THEN name ELSE 'low' END"+ , " FROM typed_sql_test_items"+ , " ORDER BY name"+ , " |]"+ , ""+ , " when ((caseRows :: [Maybe Text]) /= [Just \"low\", Just \"Second\"]) do"+ , " error (\"unexpected rows from CASE query: \" <> show caseRows)"+ , ""+ , " existsRows <- sqlQueryTyped [typedSql| SELECT EXISTS(SELECT 1 FROM typed_sql_test_items WHERE views > 7) |]"+ , ""+ , " when ((existsRows :: [Maybe Bool]) /= [Just True]) do"+ , " error (\"unexpected rows from EXISTS query: \" <> show existsRows)"+ , ""+ , " nullLiteralRows <- sqlQueryTyped [typedSql| SELECT NULL::text |]"+ , ""+ , " when ((nullLiteralRows :: [Maybe Text]) /= [Nothing]) do"+ , " error (\"unexpected rows from NULL literal query: \" <> show nullLiteralRows)"+ , ""+ , " cteRows <- sqlQueryTyped [typedSql|"+ , " WITH item_names AS (SELECT name FROM typed_sql_test_items WHERE views > 6)"+ , " SELECT name FROM item_names ORDER BY name"+ , " |]"+ , ""+ , " when ((cteRows :: [Text]) /= [\"Second\"]) do"+ , " error (\"unexpected rows from CTE query: \" <> show cteRows)"+ , ""+ , " subqueryRows <- sqlQueryTyped [typedSql|"+ , " SELECT name FROM (SELECT name FROM typed_sql_test_items WHERE views < 6) sub"+ , " ORDER BY name"+ , " |]"+ , ""+ , " when ((subqueryRows :: [Text]) /= [\"First\"]) do"+ , " error (\"unexpected rows from subquery: \" <> show subqueryRows)"+ , ""+ , " unionRows <- sqlQueryTyped [typedSql|"+ , " SELECT name FROM typed_sql_test_items WHERE views > 6"+ , " UNION ALL"+ , " SELECT name FROM typed_sql_test_items WHERE views < 6"+ , " ORDER BY name"+ , " |]"+ , ""+ , " when ((unionRows :: [Maybe Text]) /= [Just \"First\", Just \"Second\"]) do"+ , " error (\"unexpected rows from UNION: \" <> show unionRows)"+ , ""+ , " windowRows <- sqlQueryTyped [typedSql|"+ , " SELECT row_number() OVER (ORDER BY name)"+ , " FROM typed_sql_test_items"+ , " ORDER BY name"+ , " |]"+ , ""+ , " when ((windowRows :: [Maybe Integer]) /= [Just 1, Just 2]) do"+ , " error (\"unexpected rows from window function: \" <> show windowRows)"+ , ""+ , " groupedCountRows <- sqlQueryTyped [typedSql|"+ , " SELECT name, COUNT(*)"+ , " FROM typed_sql_test_items"+ , " GROUP BY name"+ , " ORDER BY name"+ , " |]"+ , ""+ , " when ((groupedCountRows :: [(Text, Maybe Integer)]) /= [(\"First\", Just 1), (\"Second\", Just 1)]) do"+ , " error (\"unexpected rows from grouped count: \" <> show groupedCountRows)"+ , ""+ , " arrayLiteralRows <- sqlQueryTyped [typedSql| SELECT ARRAY['x','y']::text[] |]"+ , ""+ , " when ((arrayLiteralRows :: [Maybe [Text]]) /= [Just [\"x\", \"y\"]]) do"+ , " error (\"unexpected rows from array literal: \" <> show arrayLiteralRows)"+ , ""+ , " nullIfRows <- sqlQueryTyped [typedSql|"+ , " SELECT NULLIF(name, 'First')"+ , " FROM typed_sql_test_items"+ , " ORDER BY name"+ , " |]"+ , ""+ , " when ((nullIfRows :: [Maybe Text]) /= [Nothing, Just \"Second\"]) do"+ , " error (\"unexpected rows from NULLIF: \" <> show nullIfRows)"+ , ""+ , " innerJoinRows <- sqlQueryTyped [typedSql|"+ , " SELECT i.name, a.name"+ , " FROM typed_sql_test_items i"+ , " INNER JOIN typed_sql_test_authors a ON a.id = i.author_id"+ , " ORDER BY i.name"+ , " |]"+ , ""+ , " when ((innerJoinRows :: [(Text, Text)]) /= [(\"First\", \"Alice\"), (\"Second\", \"Alice\")]) do"+ , " error (\"unexpected rows from inner join: \" <> show innerJoinRows)"+ , ""+ , " leftJoinRows <- sqlQueryTyped [typedSql|"+ , " SELECT i.name, a.name"+ , " FROM typed_sql_test_items i"+ , " LEFT JOIN typed_sql_test_authors a ON a.id = i.author_id"+ , " ORDER BY i.name"+ , " |]"+ , ""+ , " when ((leftJoinRows :: [(Text, Maybe Text)]) /= [(\"First\", Just \"Alice\"), (\"Second\", Just \"Alice\")]) do"+ , " error (\"unexpected rows from left join: \" <> show leftJoinRows)"+ , ""+ , " rightJoinRows <- sqlQueryTyped [typedSql|"+ , " SELECT i.name, a.name"+ , " FROM typed_sql_test_items i"+ , " RIGHT JOIN typed_sql_test_authors a ON a.id = i.author_id"+ , " WHERE i.id IS NOT NULL"+ , " ORDER BY a.name, i.name"+ , " |]"+ , ""+ , " when ((rightJoinRows :: [(Maybe Text, Text)]) /= [(Just \"First\", \"Alice\"), (Just \"Second\", \"Alice\")]) do"+ , " error (\"unexpected rows from right join: \" <> show rightJoinRows)"+ , ""+ , " rightJoinCoalescedRows <- sqlQueryTyped [typedSql|"+ , " SELECT COALESCE(i.name, '(no-item)'), a.name"+ , " FROM typed_sql_test_items i"+ , " RIGHT JOIN typed_sql_test_authors a ON a.id = i.author_id"+ , " ORDER BY a.name, i.name NULLS LAST"+ , " |]"+ , ""+ , " when ((rightJoinCoalescedRows :: [(Maybe Text, Text)]) /= [(Just \"First\", \"Alice\"), (Just \"Second\", \"Alice\"), (Just \"(no-item)\", \"Bob\")]) do"+ , " error (\"unexpected rows from right join with COALESCE: \" <> show rightJoinCoalescedRows)"+ , ""+ , " putStrLn \"RUNTIME_OK\""+ ]++runtimeUpdateDeleteModule :: Text+runtimeUpdateDeleteModule = Text.unlines+ [ "{-# LANGUAGE DataKinds #-}"+ , "{-# LANGUAGE ImplicitParams #-}"+ , "{-# LANGUAGE NoImplicitPrelude #-}"+ , "{-# LANGUAGE OverloadedStrings #-}"+ , "{-# LANGUAGE QuasiQuotes #-}"+ , "{-# LANGUAGE TypeFamilies #-}"+ , "module Main where"+ , ""+ , "import qualified Control.Exception as Exception"+ , "import IHP.Prelude"+ , "import IHP.Log.Types"+ , "import IHP.ModelSupport (Id'(..), ModelContext, PrimaryKey, createModelContext, releaseModelContext)"+ , "import IHP.TypedSql (sqlExecTyped, sqlQueryTyped, typedSql)"+ , "import System.Environment (lookupEnv)"+ , ""+ , "type instance PrimaryKey \"typed_sql_test_items\" = UUID"+ , "type instance PrimaryKey \"typed_sql_test_authors\" = UUID"+ , ""+ , "assertTest :: Text -> Bool -> IO ()"+ , "assertTest name True = putStrLn (\"PASS: \" <> name)"+ , "assertTest name False = error (\"FAIL: \" <> name)"+ , ""+ , "main :: IO ()"+ , "main = do"+ , " logger <- newLogger def { level = Warn }"+ , " databaseUrl <- cs . fromMaybe \"\" <$> lookupEnv \"DATABASE_URL\""+ , " modelContext <- createModelContext databaseUrl logger"+ , " let ?modelContext = modelContext"+ , " flip Exception.finally (releaseModelContext modelContext) do"+ , " let itemId1 = (\"10000000-0000-0000-0000-000000000001\" :: UUID)"+ , " let itemId2 = (\"10000000-0000-0000-0000-000000000002\" :: UUID)"+ , " let authorId = (\"00000000-0000-0000-0000-000000000001\" :: UUID)"+ , ""+ , " -- Clean slate"+ , " _ <- sqlExecTyped [typedSql| DELETE FROM typed_sql_test_items |]"+ , ""+ , " -- Insert two rows"+ , " _ <- sqlExecTyped [typedSql|"+ , " INSERT INTO typed_sql_test_items (id, author_id, name, views, score, tags)"+ , " VALUES (${itemId1}, ${authorId}, ${(\"First\" :: Text)}, ${5 :: Int}, ${(1.5 :: Double)}, ${([\"red\", \"blue\"] :: [Text])})"+ , " |]"+ , " _ <- sqlExecTyped [typedSql|"+ , " INSERT INTO typed_sql_test_items (id, author_id, name, views, score, tags)"+ , " VALUES (${itemId2}, ${authorId}, ${(\"Second\" :: Text)}, ${8 :: Int}, ${(2.0 :: Double)}, ${([\"green\"] :: [Text])})"+ , " |]"+ , ""+ , " -- UPDATE single column"+ , " rowsUpdated <- sqlExecTyped [typedSql|"+ , " UPDATE typed_sql_test_items SET views = ${10 :: Int} WHERE id = ${itemId1}"+ , " |]"+ , " assertTest \"UPDATE single column rows affected\" (rowsUpdated == 1)"+ , ""+ , " viewsAfter <- sqlQueryTyped [typedSql| SELECT views FROM typed_sql_test_items WHERE id = ${itemId1} |]"+ , " assertTest \"UPDATE single column value\" ((viewsAfter :: [Int]) == [10])"+ , ""+ , " -- UPDATE multiple columns"+ , " rowsUpdated2 <- sqlExecTyped [typedSql|"+ , " UPDATE typed_sql_test_items SET name = ${(\"Updated\" :: Text)}, views = ${99 :: Int} WHERE id = ${itemId2}"+ , " |]"+ , " assertTest \"UPDATE multiple columns rows affected\" (rowsUpdated2 == 1)"+ , ""+ , " updated <- sqlQueryTyped [typedSql| SELECT name, views FROM typed_sql_test_items WHERE id = ${itemId2} |]"+ , " assertTest \"UPDATE multiple columns values\" ((updated :: [(Text, Int)]) == [(\"Updated\", 99)])"+ , ""+ , " -- UPDATE with no matching rows"+ , " noMatch <- sqlExecTyped [typedSql|"+ , " UPDATE typed_sql_test_items SET views = ${0 :: Int} WHERE name = ${(\"NoSuchItem\" :: Text)}"+ , " |]"+ , " assertTest \"UPDATE no matching rows\" (noMatch == 0)"+ , ""+ , " -- DELETE with WHERE"+ , " rowsDeleted <- sqlExecTyped [typedSql|"+ , " DELETE FROM typed_sql_test_items WHERE id = ${itemId1}"+ , " |]"+ , " assertTest \"DELETE WHERE rows affected\" (rowsDeleted == 1)"+ , ""+ , " remaining <- sqlQueryTyped [typedSql| SELECT name FROM typed_sql_test_items ORDER BY name |]"+ , " assertTest \"DELETE WHERE remaining rows\" ((remaining :: [Text]) == [\"Updated\"])"+ , ""+ , " -- DELETE all remaining"+ , " rowsDeletedAll <- sqlExecTyped [typedSql| DELETE FROM typed_sql_test_items |]"+ , " assertTest \"DELETE all rows affected\" (rowsDeletedAll == 1)"+ , ""+ , " putStrLn \"RUNTIME_OK\""+ ]++runtimeEdgeCasesModule :: Text+runtimeEdgeCasesModule = Text.unlines+ [ "{-# LANGUAGE DataKinds #-}"+ , "{-# LANGUAGE ImplicitParams #-}"+ , "{-# LANGUAGE NoImplicitPrelude #-}"+ , "{-# LANGUAGE OverloadedStrings #-}"+ , "{-# LANGUAGE QuasiQuotes #-}"+ , "{-# LANGUAGE TypeFamilies #-}"+ , "module Main where"+ , ""+ , "import qualified Control.Exception as Exception"+ , "import IHP.Prelude"+ , "import IHP.Log.Types"+ , "import IHP.ModelSupport (Id'(..), ModelContext, PrimaryKey, createModelContext, releaseModelContext)"+ , "import IHP.TypedSql (sqlExecTyped, sqlQueryTyped, typedSql)"+ , "import System.Environment (lookupEnv)"+ , ""+ , "type instance PrimaryKey \"typed_sql_test_items\" = UUID"+ , "type instance PrimaryKey \"typed_sql_test_authors\" = UUID"+ , ""+ , "assertTest :: Text -> Bool -> IO ()"+ , "assertTest name True = putStrLn (\"PASS: \" <> name)"+ , "assertTest name False = error (\"FAIL: \" <> name)"+ , ""+ , "main :: IO ()"+ , "main = do"+ , " logger <- newLogger def { level = Warn }"+ , " databaseUrl <- cs . fromMaybe \"\" <$> lookupEnv \"DATABASE_URL\""+ , " modelContext <- createModelContext databaseUrl logger"+ , " let ?modelContext = modelContext"+ , " flip Exception.finally (releaseModelContext modelContext) do"+ , " let authorId = (\"00000000-0000-0000-0000-000000000001\" :: UUID)"+ , " let itemId1 = (\"10000000-0000-0000-0000-000000000001\" :: UUID)"+ , " let itemId2 = (\"10000000-0000-0000-0000-000000000002\" :: UUID)"+ , ""+ , " -- Empty result set (delete all items first)"+ , " _ <- sqlExecTyped [typedSql| DELETE FROM typed_sql_test_items |]"+ , ""+ , " emptyRows <- sqlQueryTyped [typedSql| SELECT name FROM typed_sql_test_items ORDER BY name |]"+ , " assertTest \"empty result set\" ((emptyRows :: [Text]) == [])"+ , ""+ , " -- COUNT on empty table"+ , " countEmpty <- sqlQueryTyped [typedSql| SELECT COUNT(*) FROM typed_sql_test_items |]"+ , " assertTest \"COUNT on empty table\" ((countEmpty :: [Maybe Integer]) == [Just 0])"+ , ""+ , " -- Re-insert rows for further tests"+ , " _ <- sqlExecTyped [typedSql|"+ , " INSERT INTO typed_sql_test_items (id, author_id, name, views, score, tags)"+ , " VALUES (${itemId1}, ${authorId}, ${(\"First\" :: Text)}, ${5 :: Int}, ${(1.5 :: Double)}, ${([\"red\", \"blue\"] :: [Text])})"+ , " |]"+ , " _ <- sqlExecTyped [typedSql|"+ , " INSERT INTO typed_sql_test_items (id, author_id, name, views, score, tags)"+ , " VALUES (${itemId2}, ${authorId}, ${(\"Second\" :: Text)}, ${8 :: Int}, ${(2.0 :: Double)}, ${([\"green\"] :: [Text])})"+ , " |]"+ , ""+ , " -- 5-tuple select"+ , " fiveTuple <- sqlQueryTyped [typedSql|"+ , " SELECT name, views, score, author_id IS NULL, tags"+ , " FROM typed_sql_test_items"+ , " WHERE id = ${itemId1}"+ , " |]"+ , " assertTest \"5-tuple select\" ((fiveTuple :: [(Text, Int, Maybe Double, Maybe Bool, [Text])]) == [(\"First\", 5, Just 1.5, Just False, [\"red\", \"blue\"])])"+ , ""+ , " -- Multi-param WHERE with AND"+ , " andRows <- sqlQueryTyped [typedSql|"+ , " SELECT name FROM typed_sql_test_items"+ , " WHERE views > ${3 :: Int} AND views < ${7 :: Int}"+ , " ORDER BY name"+ , " |]"+ , " assertTest \"multi-param WHERE AND\" ((andRows :: [Text]) == [\"First\"])"+ , ""+ , " -- Multi-param WHERE with OR"+ , " orRows <- sqlQueryTyped [typedSql|"+ , " SELECT name FROM typed_sql_test_items"+ , " WHERE name = ${(\"First\" :: Text)} OR name = ${(\"Second\" :: Text)}"+ , " ORDER BY name"+ , " |]"+ , " assertTest \"multi-param WHERE OR\" ((orRows :: [Text]) == [\"First\", \"Second\"])"+ , ""+ , " putStrLn \"RUNTIME_OK\""+ ]++runtimeExtraTypesModule :: Text+runtimeExtraTypesModule = Text.unlines+ [ "{-# LANGUAGE DataKinds #-}"+ , "{-# LANGUAGE ImplicitParams #-}"+ , "{-# LANGUAGE NoImplicitPrelude #-}"+ , "{-# LANGUAGE OverloadedStrings #-}"+ , "{-# LANGUAGE QuasiQuotes #-}"+ , "{-# LANGUAGE TypeFamilies #-}"+ , "module Main where"+ , ""+ , "import qualified Control.Exception as Exception"+ , "import IHP.Prelude"+ , "import IHP.Log.Types"+ , "import IHP.ModelSupport (ModelContext, PrimaryKey, createModelContext, releaseModelContext)"+ , "import IHP.TypedSql (sqlQueryTyped, typedSql)"+ , "import Data.Time (UTCTime, Day, parseTimeM, defaultTimeLocale)"+ , "import Data.Scientific (Scientific)"+ , "import qualified Data.Aeson as Aeson"+ , "import qualified Data.ByteString as BS"+ , "import System.Environment (lookupEnv)"+ , ""+ , "type instance PrimaryKey \"typed_sql_test_extras\" = UUID"+ , ""+ , "assertTest :: Text -> Bool -> IO ()"+ , "assertTest name True = putStrLn (\"PASS: \" <> name)"+ , "assertTest name False = error (\"FAIL: \" <> name)"+ , ""+ , "main :: IO ()"+ , "main = do"+ , " logger <- newLogger def { level = Warn }"+ , " databaseUrl <- cs . fromMaybe \"\" <$> lookupEnv \"DATABASE_URL\""+ , " modelContext <- createModelContext databaseUrl logger"+ , " let ?modelContext = modelContext"+ , " flip Exception.finally (releaseModelContext modelContext) do"+ , ""+ , " -- smallint -> Int"+ , " smallRows <- sqlQueryTyped [typedSql| SELECT small_count FROM typed_sql_test_extras LIMIT 1 |]"+ , " assertTest \"smallint -> Int\" ((smallRows :: [Int]) == [7])"+ , ""+ , " -- bigint -> Integer"+ , " bigRows <- sqlQueryTyped [typedSql| SELECT big_count FROM typed_sql_test_extras LIMIT 1 |]"+ , " assertTest \"bigint -> Integer\" ((bigRows :: [Integer]) == [1000000000])"+ , ""+ , " -- numeric -> Scientific"+ , " numericRows <- sqlQueryTyped [typedSql| SELECT amount FROM typed_sql_test_extras LIMIT 1 |]"+ , " assertTest \"numeric -> Scientific\" ((numericRows :: [Maybe Scientific]) == [Just 99.95])"+ , ""+ , " -- bytea -> ByteString"+ , " byteaRows <- sqlQueryTyped [typedSql| SELECT payload FROM typed_sql_test_extras LIMIT 1 |]"+ , " assertTest \"bytea -> ByteString\" ((byteaRows :: [Maybe BS.ByteString]) == [Just (BS.pack [0xDE, 0xAD, 0xBE, 0xEF])])"+ , ""+ , " -- bool -> Bool"+ , " boolRows <- sqlQueryTyped [typedSql| SELECT active FROM typed_sql_test_extras LIMIT 1 |]"+ , " assertTest \"bool -> Bool\" ((boolRows :: [Bool]) == [True])"+ , ""+ , " -- timestamptz -> UTCTime"+ , " tsRows <- sqlQueryTyped [typedSql| SELECT created_at FROM typed_sql_test_extras LIMIT 1 |]"+ , " let Just expectedTime = parseTimeM True defaultTimeLocale \"%Y-%m-%d %H:%M:%S%Z\" \"2025-06-15 12:00:00UTC\" :: Maybe UTCTime"+ , " assertTest \"timestamptz -> UTCTime\" ((tsRows :: [UTCTime]) == [expectedTime])"+ , ""+ , " -- date -> Day"+ , " dateRows <- sqlQueryTyped [typedSql| SELECT due_date FROM typed_sql_test_extras LIMIT 1 |]"+ , " let Just expectedDate = parseTimeM True defaultTimeLocale \"%Y-%m-%d\" \"2025-06-15\" :: Maybe Day"+ , " assertTest \"date -> Day\" ((dateRows :: [Maybe Day]) == [Just expectedDate])"+ , ""+ , " -- jsonb -> Aeson.Value"+ , " jsonRows <- sqlQueryTyped [typedSql| SELECT metadata FROM typed_sql_test_extras LIMIT 1 |]"+ , " let expectedJson = Aeson.object [(\"key\", Aeson.String \"value\")]"+ , " assertTest \"jsonb -> Aeson.Value\" ((jsonRows :: [Maybe Aeson.Value]) == [Just expectedJson])"+ , ""+ , " -- multi-type tuple"+ , " tupleRows <- sqlQueryTyped [typedSql|"+ , " SELECT small_count, big_count, active"+ , " FROM typed_sql_test_extras LIMIT 1"+ , " |]"+ , " assertTest \"multi-type tuple\" ((tupleRows :: [(Int, Integer, Bool)]) == [(7, 1000000000, True)])"+ , ""+ , " putStrLn \"RUNTIME_OK\""+ ]
+ changelog.md view
@@ -0,0 +1,15 @@+# Changelog for `ihp-typed-sql`++## v1.5.0++- Improve error messages and developer experience+- Fix LEFT/RIGHT JOIN nullability detection+- Preserve case for quoted identifiers in SQL parser+- Replace hand-rolled SQL tokenizer with `postgresql-syntax` parser+- Fix int2 decoder bug and connection leaks+- Add granular runtime integration tests+- Remove bootstrap mode++## v1.4.0++- Initial release as a standalone package
+ ihp-typed-sql.cabal view
@@ -0,0 +1,97 @@+cabal-version: 2.2+name: ihp-typed-sql+version: 1.5.0+synopsis: Compile-time typed SQL quasiquoter for IHP+description: A quasiquoter that infers Haskell types from PostgreSQL at compile time.+license: MIT+license-file: LICENSE+author: digitally induced GmbH+maintainer: hello@digitallyinduced.com+homepage: https://ihp.digitallyinduced.com/+bug-reports: https://github.com/digitallyinduced/ihp/issues+copyright: (c) digitally induced GmbH+category: Web, IHP+stability: Experimental+build-type: Simple+extra-source-files: changelog.md++common shared-properties+ default-language: GHC2021+ default-extensions:+ OverloadedStrings+ , NoImplicitPrelude+ , ImplicitParams+ , DisambiguateRecordFields+ , DuplicateRecordFields+ , OverloadedLabels+ , DataKinds+ , QuasiQuotes+ , TypeFamilies+ , PackageImports+ , RecordWildCards+ , DefaultSignatures+ , FunctionalDependencies+ , PartialTypeSignatures+ , BlockArguments+ , LambdaCase+ , TemplateHaskell+ , OverloadedRecordDot+ , DeepSubsumption+ ghc-options: -Werror=incomplete-patterns -Werror=unused-imports++library+ import: shared-properties+ hs-source-dirs: .+ exposed-modules:+ IHP.TypedSql+ IHP.TypedSql.Types+ IHP.TypedSql.Quoter+ IHP.TypedSql.Placeholders+ IHP.TypedSql.ParamHints+ IHP.TypedSql.Metadata+ IHP.TypedSql.TypeMapping+ IHP.TypedSql.Decoders+ build-depends:+ base >= 4.17.0 && < 4.22+ , ihp+ , aeson+ , bytestring+ , containers+ , hasql+ , hasql-dynamic-statements+ , hasql-mapping+ , hasql-pool+ , haskell-src-meta+ , postgresql-syntax >= 0.4 && < 0.5+ , postgresql-types+ , postgresql-libpq+ , scientific+ , string-conversions+ , template-haskell+ , text++source-repository head+ type: git+ location: https://github.com/digitallyinduced/ihp++test-suite tests+ import: shared-properties+ type: exitcode-stdio-1.0+ main-is: Test/Main.hs+ hs-source-dirs: Test+ ghc-options: -threaded+ build-depends:+ base >= 4.17.0 && < 4.22+ , ihp+ , ihp-log+ , ihp-typed-sql+ , containers+ , directory+ , filepath+ , hspec+ , process+ , string-conversions+ , temporary+ , text+ other-modules:+ Test.TypedSqlSpec