diff --git a/IHP/TypedSql.hs b/IHP/TypedSql.hs new file mode 100644 --- /dev/null +++ b/IHP/TypedSql.hs @@ -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 diff --git a/IHP/TypedSql/Decoders.hs b/IHP/TypedSql/Decoders.hs new file mode 100644 --- /dev/null +++ b/IHP/TypedSql/Decoders.hs @@ -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 diff --git a/IHP/TypedSql/Metadata.hs b/IHP/TypedSql/Metadata.hs new file mode 100644 --- /dev/null +++ b/IHP/TypedSql/Metadata.hs @@ -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) diff --git a/IHP/TypedSql/ParamHints.hs b/IHP/TypedSql/ParamHints.hs new file mode 100644 --- /dev/null +++ b/IHP/TypedSql/ParamHints.hs @@ -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 diff --git a/IHP/TypedSql/Placeholders.hs b/IHP/TypedSql/Placeholders.hs new file mode 100644 --- /dev/null +++ b/IHP/TypedSql/Placeholders.hs @@ -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 diff --git a/IHP/TypedSql/Quoter.hs b/IHP/TypedSql/Quoter.hs new file mode 100644 --- /dev/null +++ b/IHP/TypedSql/Quoter.hs @@ -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 diff --git a/IHP/TypedSql/TypeMapping.hs b/IHP/TypedSql/TypeMapping.hs new file mode 100644 --- /dev/null +++ b/IHP/TypedSql/TypeMapping.hs @@ -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) diff --git a/IHP/TypedSql/Types.hs b/IHP/TypedSql/Types.hs new file mode 100644 --- /dev/null +++ b/IHP/TypedSql/Types.hs @@ -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) + } diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Test/Test/Main.hs b/Test/Test/Main.hs new file mode 100644 --- /dev/null +++ b/Test/Test/Main.hs @@ -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 diff --git a/Test/Test/TypedSqlSpec.hs b/Test/Test/TypedSqlSpec.hs new file mode 100644 --- /dev/null +++ b/Test/Test/TypedSqlSpec.hs @@ -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\"" + ] diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -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 diff --git a/ihp-typed-sql.cabal b/ihp-typed-sql.cabal new file mode 100644 --- /dev/null +++ b/ihp-typed-sql.cabal @@ -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