diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,13 @@ # Changelog +## 0.5.2.0 + +Statements with `$1.$field` param fields are checked, by `hasql-check-hie` +and the plugin alike: `hasql-check` 0.5.2.0, which this now requires, +records their slots' Postgres types reduced; see its changelog. The tests +compile them to `.hie` files and check them with `hasql-check --inferred`, +under a `kronor-syntax` flag to set with `hasql-check`'s. + ## 0.5.1.0 `hasql-check-hie` identified an inferred quote by its `Params` dictionary, diff --git a/hasql-check-ghc.cabal b/hasql-check-ghc.cabal --- a/hasql-check-ghc.cabal +++ b/hasql-check-ghc.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hasql-check-ghc -version: 0.5.1.0 +version: 0.5.2.0 synopsis: Check inferred hasql statements with what GHC knows of their types @@ -43,6 +43,14 @@ manual: True default: False +flag kronor-syntax + description: + Also test the statements only hasql-check's kronor-syntax flag accepts, + such as $1.$field param fields. Set it with hasql-check's. + + manual: True + default: False + common warnings default-language: GHC2021 default-extensions: @@ -69,7 +77,7 @@ , base >=4.21 && <4.23 , bytestring >=0.11 && <0.13 , ghc >=9.12 && <9.15 - , hasql-check >=0.5 && <0.6 + , hasql-check >=0.5.2 && <0.6 , text >=2.0 && <2.2 executable hasql-check-hie @@ -96,14 +104,15 @@ , base >=4.21 && <4.23 , hasql-check-ghc --- Compiles fixture modules with the plugin, against a throwaway PostgreSQL --- server: initdb, pg_ctl and psql must be on PATH, and cabal must write the --- package environment the compiler finds the plugin through. +-- Compiles fixture modules with the plugin, or to .hie files that +-- hasql-check-hie and hasql-check --inferred check, against a throwaway +-- PostgreSQL server: initdb, pg_ctl and psql must be on PATH, and cabal must +-- write the package environment the compiler finds the plugin through. test-suite hasql-check-plugin-test - import: warnings - type: exitcode-stdio-1.0 - main-is: Plugin.hs - hs-source-dirs: test + import: warnings + type: exitcode-stdio-1.0 + main-is: Plugin.hs + hs-source-dirs: test build-depends: , base >=4.21 && <4.23 , directory >=1.3 && <1.4 @@ -111,3 +120,10 @@ , hasql-check-ghc , process >=1.6 && <1.7 , temporary >=1.3 && <1.4 + + build-tool-depends: + , hasql-check:hasql-check + , hasql-check-ghc:hasql-check-hie + + if flag(kronor-syntax) + cpp-options: -DKRONOR_SYNTAX diff --git a/test/Plugin.hs b/test/Plugin.hs --- a/test/Plugin.hs +++ b/test/Plugin.hs @@ -1,5 +1,10 @@ +{-# LANGUAGE CPP #-} + -- | The plugin, as GHC runs it: each case compiles a fixture module with --- @-fplugin=Hasql.Check.Plugin@, against a throwaway PostgreSQL server. +-- @-fplugin=Hasql.Check.Plugin@, against a throwaway PostgreSQL server. Or +-- hasql-check-hie, as a sandboxed build runs it: the case compiles the +-- module to a .hie file, which hasql-check-hie reads and hasql-check +-- --inferred checks against the same server. -- -- GHC finds the plugin and its dependencies through the package environment -- cabal writes (@write-ghc-environment-files: always@ in cabal.project), and @@ -34,6 +39,7 @@ data Case = Case { caseName :: String + , via :: Via , before :: [Database] -- ^ Compilations of the same module, in the same directory, first. , database :: Database @@ -46,10 +52,16 @@ data Database = TestDatabase | NoDatabase | Unreachable +-- | Which of the two checks the statements: the compiler plugin, or +-- hasql-check --inferred on what hasql-check-hie read from the .hie file. +data Via = Plugin | Hie + + cases :: [Case] cases = [ Case "checks nothing when no database is set" + Plugin [] NoDatabase [] @@ -57,6 +69,7 @@ \(code, out) -> code == ExitSuccess && not ("hasql-check:" `isInfixOf` out) , Case "accepts a statement that fits the schema" + Plugin [] TestDatabase [] @@ -64,6 +77,7 @@ \(code, _) -> code == ExitSuccess , Case "fails at the quote on a statement that does not prepare" + Plugin [] TestDatabase [] @@ -74,6 +88,7 @@ && "column \"nope\" does not exist" `isInfixOf` out , Case "fails on a column read through a conversion that can fail" + Plugin [] TestDatabase [] @@ -81,6 +96,7 @@ \(code, out) -> code /= ExitSuccess && "column 1 (email) is text, but is read as" `isInfixOf` out , Case "fails on an enum read without a label the database has" + Plugin [] TestDatabase [] @@ -102,6 +118,7 @@ \(code, out) -> code /= ExitSuccess && "which cannot read labels payment_state has: REFUNDED" `isInfixOf` out , Case "warns about a nullable column read without a Maybe, without failing" + Plugin [] TestDatabase [("HASQL_CHECK_NULLABILITY", "1")] @@ -112,6 +129,7 @@ && "warning: hasql-check: column 1 (nickname) is not a Maybe in Haskell" `isInfixOf` out , Case "checks the statement GHC compiled, after CPP, not the file" + Plugin [] TestDatabase [] @@ -130,6 +148,7 @@ \(code, out) -> code /= ExitSuccess && "column \"nope\" does not exist" `isInfixOf` out , Case "checks a module compiled before without a database once one is set" + Plugin [NoDatabase] TestDatabase [] @@ -137,14 +156,132 @@ \(code, out) -> code /= ExitSuccess && "column \"nope\" does not exist" `isInfixOf` out , Case "does not fail the build when the database cannot be reached" + Plugin [] Unreachable [] (fixture "Statement Int64 Text" "select nope from customer where id = $1") \(code, out) -> code == ExitSuccess && "hasql-check: not checking statements" `isInfixOf` out + , Case + "checks a statement from its .hie file" + Hie + [] + TestDatabase + [] + (fixture "Statement Int64 Int64" "select email from customer where id = $1") + \(code, out) -> + code /= ExitSuccess + && "Error in Fixture.hs:11:5" `isInfixOf` out + && "column 1 (email) is text, but is read as GHC.Internal.Int.Int64" `isInfixOf` out ] + <> fieldCases +-- | Statements with $1.$field param fields, which only hasql-check's +-- kronor-syntax flag accepts. Each slot's type is the type of the field it +-- sends, which GHC only knows once it has solved the field's HasField. +fieldCases :: [Case] +#ifdef KRONOR_SYNTAX +fieldCases = + [ Case + "recovers the types of a record parameter's fields from a .hie file" + Hie + [] + TestDatabase + [] + (discrepancy "Maybe Int64" "Bool") + \(code, out) -> + code == ExitSuccess + && ( concat + [ "\"params\":[" + , param "Data.Text.Internal.Text" "text" False + , "," + , param "Data.UUID.Types.Internal.UUID" "uuid" True + , "," + , param "GHC.Internal.Int.Int64" "int8" True + , "," + , param "Data.Text.Internal.Text" "text" True + , "],\"row\":[" + , param "GHC.Internal.Types.Bool" "bool" False + , "]" + ] + ) + `isInfixOf` out + , Case + "reports a record parameter's field sent as the wrong type, from a .hie file" + Hie + [] + TestDatabase + [] + (discrepancy "Maybe Text" "Bool") + \(code, out) -> code /= ExitSuccess && "function record_discrepancy(text, uuid, text, text) does not exist" `isInfixOf` out + , Case + "reports a column read as the wrong type, with a record parameter, from a .hie file" + Hie + [] + TestDatabase + [] + (discrepancy "Maybe Int64" "Int64") + \(code, out) -> code /= ExitSuccess && "column 1 (record_discrepancy) is boolean, but is read as GHC.Internal.Int.Int64" `isInfixOf` out + , Case + "accepts a statement with a record parameter that fits the schema" + Plugin + [] + TestDatabase + [] + (discrepancy "Maybe Int64" "Bool") + \(code, _) -> code == ExitSuccess + , Case + "fails on a column read as the wrong type, with a record parameter" + Plugin + [] + TestDatabase + [] + (discrepancy "Maybe Int64" "Int64") + \(code, out) -> code /= ExitSuccess && "column 1 (record_discrepancy) is boolean, but is read as GHC.Internal.Int.Int64" `isInfixOf` out + ] + where + param type' postgres nullable = + concat ["{\"type\":\"", type', "\",\"postgres\":\"", postgres, "\",\"labels\":[],\"nullable\":", if nullable then "true" else "false", "}"] + + +{- | A module with one statement that sends the fields of a record, given +the type of its amount field and the type of the row: record_discrepancy +takes an int8 amount and returns a boolean. + +The fork's parser wants white space after a field, before a comma or a +closing parenthesis, so the fields are written one a line. +-} +discrepancy :: String -> String -> String +discrepancy amount row = + unlines + [ "{-# LANGUAGE DataKinds, QuasiQuotes #-}" + , "module Fixture where" + , "" + , "import Data.Int (Int64)" + , "import Data.Text (Text)" + , "import Data.UUID (UUID)" + , "import Hasql.Check.Inferred.TH" + , "import Hasql.Statement (Statement)" + , "" + , "data Discrepancy = Discrepancy {kind :: Text, orderId :: Maybe UUID, amount :: " <> amount <> ", note :: Maybe Text}" + , "" + , "s :: Statement Discrepancy " <> row + , "s =" + , " [singletonStatement|" + , " select record_discrepancy(" + , " $1.$kind" + , " , $1.$orderId" + , " , $1.$amount" + , " , $1.$note" + , " )" + , " |]" + ] +#else +fieldCases = [] +#endif + + -- | A module with one statement, of the given type, on line 11. fixture :: String -> String -> String fixture type' sql = @@ -179,8 +316,28 @@ readCreateProcessWithExitCode (proc compiler ["-package-env", env, "-fno-code", "-fwrite-interface", "-fplugin=Hasql.Check.Plugin", "Fixture.hs"]){Process.cwd = Just dir, Process.env = Just procEnv} "" - mapM_ compile c.before - (code, out, err) <- compile c.database + (code, out, err) <- case c.via of + Plugin -> do + mapM_ compile c.before + compile c.database + Hie -> do + (built, buildOut, buildErr) <- + readCreateProcessWithExitCode + (proc compiler ["-package-env", env, "-fno-code", "-fwrite-ide-info", "-hiedir", ".", "Fixture.hs"]){Process.cwd = Just dir} + "" + if built /= ExitSuccess + then pure (built, buildOut, buildErr) + else do + (read', quotes, readErr) <- readCreateProcessWithExitCode (proc "hasql-check-hie" ["Fixture.hie"]){Process.cwd = Just dir} "" + writeFile (dir "statements.jsonl") quotes + if read' /= ExitSuccess + then pure (read', quotes, readErr) + else do + (checked, checkOut, checkErr) <- + readCreateProcessWithExitCode + (proc "hasql-check" ["--database", conn, "--inferred", "statements.jsonl"]){Process.cwd = Just dir} + "" + pure (checked, quotes <> checkOut, readErr <> checkErr) let ok = c.expect (code, out <> err) unless ok (putStrLn (c.caseName <> ":\n" <> show code <> "\n" <> out <> err)) pure ok @@ -243,6 +400,6 @@ [ conn , "--quiet" , "--command" - , "create table customer (id int8 primary key, email text not null, nickname text); create type payment_state as enum ('PENDING', 'PAID', 'REFUNDED'); create table payment (id int8 primary key, state payment_state not null)" + , "create table customer (id int8 primary key, email text not null, nickname text); create type payment_state as enum ('PENDING', 'PAID', 'REFUNDED'); create table payment (id int8 primary key, state payment_state not null); create function record_discrepancy(text, uuid, int8, text) returns boolean language sql as 'select true'" ] action conn