diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,8 @@ +# Changelog + +## 0.5.0.0 + +Initial release, alongside `hasql-check` 0.5.0.0: `Hasql.Check.Plugin`, a GHC +plugin that checks the statements of `Hasql.Check.Inferred.TH` against a +database while their module compiles, and `hasql-check-hie`, which reads their +types from GHC's `.hie` files for `hasql-check --inferred`. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +BSD 3-Clause License + +Copyright (c) 2021-2026, Kronor + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,50 @@ +# hasql-check-ghc + +The GHC half of [hasql-check](https://hackage.haskell.org/package/hasql-check). + +`Hasql.Check.Inferred.TH`'s quoters take no annotations: a statement's +parameter and result types come from the Haskell type it is used at. GHC only +knows those types once it has type-checked the module, which is after the +quoter ran, so this package gets them from GHC itself: + +- **`Hasql.Check.Plugin`**, a GHC plugin that checks each statement against a + database while its module compiles. Add it to the package that holds the + statements: + + ``` + build-depends: hasql-check-ghc + ghc-options: -fplugin=Hasql.Check.Plugin + ``` + + and set `HASQL_CHECK_DATABASE_URL`. A statement that does not fit the schema + is then a compile error at its quote. Without the variable nothing is + checked; if the database cannot be reached the plugin says so once and the + build carries on. + +- **`hasql-check-hie`**, which reads the same types out of the `.hie` files GHC + writes with `-fwrite-ide-info`, for `hasql-check --inferred`: + + ``` + $ cabal build --ghc-options='-fwrite-ide-info -hiedir=.hie' + $ hasql-check-hie $(find .hie -name '*.hie') > statements.jsonl + $ hasql-check --inferred statements.jsonl --nullability --types + ``` + + It needs no database, so it can run inside a sandboxed build, such as a Nix + derivation, with only the checking step outside it. + +Both use GHC's own library, whose internals change with each release, so this +package supports the series it has been built against — currently **GHC 9.12 +and 9.14**. Build it with the GHC the checked project is built with. + +The full documentation, including everything the checks report, is in the +[main README](https://github.com/kronor-io/hasql-check#readme). + +## Development + +`cabal test` compiles fixture modules with GHC itself, against a throwaway +PostgreSQL server, so `initdb`, `pg_ctl` and `psql` must be on `PATH`. The +compiler finds the plugin through the package environment cabal writes +(`write-ghc-environment-files: always`, in the project's `cabal.project`), so +run the tests from a checkout of the whole repository rather than from this +directory's sdist. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,136 @@ +-- | +-- Module : Main +-- Copyright : (c) 2026 Kronor.io +-- +-- License : BSD-3-Clause +-- Maintainer : lorenzo@kronor.io +-- Stability : experimental +-- Portability : GHC +-- +-- Print, for every quote of "Hasql.Check.Inferred.TH" in the given .hie +-- files, the types GHC instantiated its statement at, one JSON object a line: +-- +-- > {"file":"src/Shop.hs","line":14,"column":11,"quoter":"maybeStatement", +-- > "sql":"...","params":[{"type":"GHC.Internal.Int.Int64","nullable":false}], +-- > "row":[...]} +-- +-- for @hasql-check --inferred@. The quote's own span holds the nodes of the +-- code it generated, typed where it is used, even when the statement is an +-- argument with no signature of its own. @row@ is null for a statement +-- returning no rows. +-- +-- The .hie format changes with each GHC release: build this with the GHC the +-- project is built with. +module Main where + +import Control.Monad (unless) +import Data.Char (ord) +import Data.List (intercalate) +import Data.Map qualified as Map +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import GHC.Data.FastString (getLexicalFastString, unpackFS) +import GHC.Iface.Ext.Binary (HieFileResult (..), readHieFile) +import GHC.Iface.Ext.Types +import GHC.Iface.Ext.Utils (recoverFullType) +import GHC.Iface.Type (IfaceTyCon (..), IfaceTyLit (..)) +import GHC.Types.Name (Name, nameModule_maybe, nameOccName) +import GHC.Types.Name.Cache (initNameCache) +import GHC.Types.Name.Occurrence (occNameString) +import GHC.Types.SrcLoc (srcSpanEndCol, srcSpanEndLine, srcSpanStartCol, srcSpanStartLine) +import GHC.Unit.Module (moduleName, moduleNameString) +import Hasql.Check.Ghc.Source (Column (..), Quote (..), Statement (..), Ty (..), statementAt) +import System.Environment (getArgs) +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) +import Text.Printf (printf) + + +main :: IO () +main = do + files <- getArgs + nc <- initNameCache 'z' [] + errors <- concat <$> mapM (dump nc) files + mapM_ (hPutStrLn stderr) errors + unless (null errors) exitFailure + where + dump nc path = do + result <- readHieFile nc path + let hf = hie_file_result result + toTy = convert . flip recoverFullType (hie_types hf) + found = Map.fromListWith (flip (<>)) [(s, [t]) | (s, t) <- concatMap (collect toTy) (Map.elems (getAsts (hie_asts hf)))] + source = lines (Text.unpack (Text.decodeUtf8Lenient (hie_hs_src hf))) + concat + <$> mapM + ( \(s, here) -> + -- The enclosing declarations hold the same dictionaries, + -- but only the quote's own span starts after "[quoter|". + case statementAt source (srcSpanStartLine s, srcSpanStartCol s) (srcSpanEndLine s, srcSpanEndCol s) here of + Nothing -> pure [] + Just (Right statement) -> [] <$ putStrLn (output (hie_hs_file hf) statement) + Just (Left err) -> pure [hie_hs_file hf <> ":" <> show (srcSpanStartLine s) <> ":" <> show (srcSpanStartCol s) <> ": " <> err] + ) + (Map.toList found) + + collect toTy node = + -- The dictionaries the generated code passes are identifiers of the + -- quote's node, typed by the instance GHC chose. + let infos = Map.elems (getSourcedNodeInfo (sourcedNodeInfo node)) + here = + [(nodeSpan node, toTy t) | info <- infos, t <- nodeType info] + <> [(nodeSpan node, toTy t) | info <- infos, (Right _, details) <- Map.toList (nodeIdentifiers info), Just t <- [identType details]] + in here <> concatMap (collect toTy) (nodeChildren node) + + +-- | One statement's line of output. +output :: FilePath -> Statement -> String +output file statement = + object + [ ("file", string file) + , ("line", show statement.line) + , ("column", show statement.quote.column) + , ("quoter", string statement.quote.quoter) + , ("sql", string statement.quote.body) + , ("params", columns statement.params) + , ("row", maybe "null" columns statement.row) + ] + where + columns cs = "[" <> intercalate "," (map column cs) <> "]" + column c = + object + [ ("type", string c.haskellType) + , ("postgres", string c.postgres) + , ("labels", "[" <> intercalate "," (map string c.labels) <> "]") + , ("nullable", if c.nullable then "true" else "false") + ] + + +convert :: HieTypeFix -> Ty +convert (Roll t) = case t of + HTyConApp tc (HieArgs args) -> uncurry Con (names (ifaceTyConName tc)) [convert a | (True, a) <- args] + HQualTy _ b -> convert b + HForAllTy _ b -> convert b + HCastTy a -> convert a + HLitTy (IfaceStrTyLit s) -> Lit (unpackFS (getLexicalFastString s)) + HLitTy (IfaceNumTyLit n) -> OtherLit (show n) + HLitTy (IfaceCharTyLit c) -> OtherLit (show c) + _ -> Var + where + names :: Name -> (String, String) + names n = (maybe "" (moduleNameString . moduleName) (nameModule_maybe n), occNameString (nameOccName n)) + + +object :: [(String, String)] -> String +object fields = "{" <> intercalate "," [string k <> ":" <> v | (k, v) <- fields] <> "}" + + +string :: String -> String +string s = "\"" <> concatMap escape s <> "\"" + where + escape = \case + '"' -> "\\\"" + '\\' -> "\\\\" + '\n' -> "\\n" + '\t' -> "\\t" + c | ord c < 0x20 -> printf "\\u%04x" (ord c) + c -> [c] diff --git a/hasql-check-ghc.cabal b/hasql-check-ghc.cabal new file mode 100644 --- /dev/null +++ b/hasql-check-ghc.cabal @@ -0,0 +1,113 @@ +cabal-version: 3.0 +name: hasql-check-ghc +version: 0.5.0.0 +synopsis: + Check inferred hasql statements with what GHC knows of their types + +description: + The types of a statement of Hasql.Check.Inferred.TH are only known once GHC + has type-checked its module. This package gets them from GHC in two ways: + . + * Hasql.Check.Plugin, a GHC plugin that checks the statements against a + database while their module compiles, making a statement that does not + fit the schema a compile error at its quote. + . + * hasql-check-hie, which reads them from the .hie files GHC writes with + -fwrite-ide-info, for hasql-check --inferred. It needs no database, so it + can run inside a sandboxed build. + . + Both depend on GHC's own library: build them with the GHC the checked + project is built with. + +category: Database, Development +homepage: https://github.com/kronor-io/hasql-check +bug-reports: https://github.com/kronor-io/hasql-check/issues +license: BSD-3-Clause +license-file: LICENSE +author: Pranay Sashank, Jose Lorenzo Rodriguez +maintainer: lorenzo@kronor.io, pranay.sashank@kronor.io +copyright: 2026 Kronor +build-type: Simple +tested-with: GHC ==9.12.4 || ==9.14.1 +extra-doc-files: + ChangeLog.md + README.md + +source-repository head + type: git + location: https://github.com/kronor-io/hasql-check + subdir: ghc + +flag lint + description: lint + manual: True + default: False + +common warnings + default-language: GHC2021 + default-extensions: + BlockArguments + DerivingStrategies + LambdaCase + OverloadedRecordDot + + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + + if flag(lint) + ghc-options: -Werror + +library + import: warnings + exposed-modules: + Hasql.Check.Ghc.Source + Hasql.Check.Plugin + + hs-source-dirs: src + build-depends: + , base >=4.21 && <4.23 + , bytestring >=0.11 && <0.13 + , ghc >=9.12 && <9.15 + , hasql-check >=0.5 && <0.6 + , text >=2.0 && <2.2 + +executable hasql-check-hie + import: warnings + main-is: Main.hs + hs-source-dirs: app + + -- 9.14 deprecates initNameCache in favour of a newNameCache that takes no + -- arguments and does not exist in 9.12. Drop this with 9.12. + ghc-options: -Wno-deprecations + build-depends: + , base >=4.21 && <4.23 + , containers >=0.6 && <0.9 + , ghc >=9.12 && <9.15 + , hasql-check-ghc + , text >=2.0 && <2.2 + +test-suite hasql-check-ghc-test + import: warnings + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + build-depends: + , 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. +test-suite hasql-check-plugin-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 + , filepath >=1.4 && <1.6 + , hasql-check-ghc + , process >=1.6 && <1.7 + , temporary >=1.3 && <1.4 diff --git a/src/Hasql/Check/Ghc/Source.hs b/src/Hasql/Check/Ghc/Source.hs new file mode 100644 --- /dev/null +++ b/src/Hasql/Check/Ghc/Source.hs @@ -0,0 +1,267 @@ +-- | +-- Module : Hasql.Check.Ghc.Source +-- Copyright : (c) 2026 Kronor.io +-- +-- License : BSD-3-Clause +-- Maintainer : lorenzo@kronor.io +-- Stability : experimental +-- Portability : GHC +-- +-- A statement of "Hasql.Check.Inferred.TH", from what GHC knows of it: its +-- quote, found in its source from the span GHC gives the code it generated, +-- and its types, from the dictionaries that code is passed. Whether GHC's +-- types come from a @.hie@ file or a compiler plugin, they are read here. +-- +-- GHC counts columns from 1, and a tab as reaching the next tab stop, every 8 +-- columns; the source text counts characters. +module Hasql.Check.Ghc.Source ( + -- * Statements + Statement (..), + Column (..), + statementAt, + statementOf, + typeName, + + -- * Quotes + Quote (..), + quoteAt, + Types (..), + typesOf, + Ty (..), + ground, + columnTypes, + symbols, + labelLists, + charIndex, + ghcColumn, +) where + +import Data.Char (isAlphaNum, isDigit) +import Data.List (intercalate) + + +data Quote = Quote + { column :: Int + -- ^ GHC's column of the quote's opening bracket. + , quoter :: String + , body :: String + } + deriving stock (Eq, Show) + + +-- | The quote a span covers, given the source's lines and the span's start +-- and end, as GHC's line and column. The span starts right after +-- @[quoter|@ and ends right after @|]@; any other span is not a quote's. +quoteAt :: [String] -> (Int, Int) -> (Int, Int) -> Maybe Quote +quoteAt source (startLine, startColumn) (endLine, endColumn) = do + first <- line startLine + final <- line endLine + let start = charIndex first startColumn + end = charIndex final endColumn - 2 + opening = take (start - 1) first + bracket = lastIndex '[' opening + name = drop (bracket + 1) opening + if start >= 1 + && take 1 (drop (start - 1) first) == "|" + && bracket >= 0 + && not (null name) + && all (\c -> isAlphaNum c || c `elem` ("._'" :: String)) name + then + Just + Quote + { column = ghcColumn first bracket + , quoter = name + , body = + if startLine == endLine + then take (end - start) (drop start first) + else + intercalate "\n" $ + [drop start first] + <> [l | n <- [startLine + 1 .. endLine - 1], Just l <- [line n]] + <> [take end final] + } + else Nothing + where + line n + | n >= 1, l : _ <- drop (n - 1) source = Just l + | otherwise = Nothing + lastIndex c s = case [i | (i, x) <- zip [0 ..] s, x == c] of + [] -> -1 + is -> last is + + +-- | What the dictionaries in a quote's span say about its statement's types. +data Types t + = -- | Not a statement of Hasql.Check.Inferred.TH. + NotInferred + | -- | Its types are only known where it is used, and may differ from one + -- use to the next. + Unresolved + | -- | Its parameter type, and its row type unless it returns no rows. + Resolved t (Maybe t) + deriving stock (Eq, Show) + + +-- | The statement's types, given which types are concrete, and the types of +-- the quote's Params and Row dictionaries. +typesOf :: (t -> Bool) -> [t] -> [t] -> Types t +typesOf concrete params rows = case (filter concrete params, filter concrete rows) of + _ | null params -> NotInferred + ([], _) -> Unresolved + (_, []) | not (null rows) -> Unresolved + (p : _, r) -> Resolved p (case r of x : _ -> Just x; [] -> Nothing) + + +-- | The index in a line of the character at a GHC column. +charIndex :: String -> Int -> Int +charIndex = go 0 1 + where + go i c rest target + | c >= target = i + | x : xs <- rest = go (i + 1) (advance c x) xs target + | otherwise = i + + +-- | GHC's column of the character at an index in a line. +ghcColumn :: String -> Int -> Int +ghcColumn s i = foldl advance 1 (take i s) + + +advance :: Int -> Char -> Int +advance c = \case + '\t' -> ((c - 1) `div` 8 + 1) * 8 + 1 + _ -> c + 1 + + +-- | A type: a constructor applied to its visible arguments, by module and +-- name; a string literal, which names a Postgres type or label; another +-- literal; or something not concrete. +data Ty = Con String String [Ty] | Lit String | OtherLit String | Var + deriving stock (Eq, Show) + + +-- | Whether a type is concrete. +ground :: Ty -> Bool +ground = \case + Var -> False + Lit _ -> True + OtherLit _ -> True + Con _ _ args -> all ground args + + +-- | A parameter or row type's columns, each with whether it is a 'Maybe': +-- a tuple's elements, none for unit as parameters, or the type itself. +columnTypes :: Bool -> Ty -> [(Ty, Bool)] +columnTypes isParams t = map column (split t) + where + split = \case + Con m "Unit" [] | isParams, m `elem` tupleModules -> [] + Con m name args | m `elem` tupleModules, isTuple name -> args + other -> [other] + column = \case + Con m "Maybe" [inner] | m `elem` maybeModules -> (inner, True) + other -> (other, False) + + +-- | Where GHC defines tuples and unit, and Maybe: a type of the same name +-- elsewhere, a newtype TupleId say, is a type of its own. +tupleModules, maybeModules :: [String] +tupleModules = ["GHC.Tuple", "GHC.Tuple.Prim"] +maybeModules = ["GHC.Internal.Maybe", "GHC.Maybe"] + + +isTuple :: String -> Bool +isTuple name = case splitAt 5 name of + ("Tuple", n) -> not (null n) && all isDigit n + _ -> False + + +-- * Statements + + +-- | A statement, with what the checker needs of it. +data Statement = Statement + { line :: Int + , quote :: Quote + , params :: [Column] + , row :: Maybe [Column] + -- ^ Nothing for a statement that returns no rows. + } + + +-- | A parameter or result column. +data Column = Column + { haskellType :: String + , postgres :: String + , labels :: [String] + -- ^ The enum's labels, if it is one. + , nullable :: Bool + } + + +-- | The statement whose generated code has the given span, given the source +-- lines and the types of the dictionaries the code is passed there: nothing +-- if the span is not a quote of these quoters, an error if its types are not +-- concrete there. +statementAt :: [String] -> (Int, Int) -> (Int, Int) -> [Ty] -> Maybe (Either String Statement) +statementAt source start@(line', _) end here = do + q <- quoteAt source start end + statementOf line' q here + + +-- | The statement of a quote on a line, given the types of the dictionaries +-- its generated code is passed: nothing if it is not a quote of these +-- quoters, an error if its types are not concrete there. +statementOf :: Int -> Quote -> [Ty] -> Maybe (Either String Statement) +statementOf line' q here = + case typesOf ground params' rows of + NotInferred -> Nothing + Resolved p r + | Just names <- first paramNames + , Just labels' <- first paramLabels + , Just row' <- traverse (\r' -> (r',,) <$> first columnNames <*> first columnLabels) r -> + Just (Right (Statement line' q (columns True (p, names, labels')) (columns False <$> row'))) + _ -> + Just + ( Left + "the statement's types are not known where it is written, so it cannot be checked; give its binding a concrete type, such as Statement Int64 Text" + ) + where + params' = [p | Con "Hasql.Check.Inferred" "Params" [p] <- here] + rows = [r | Con "Hasql.Check.Inferred" "Row" [r] <- here] + paramNames = [ns | Con "Hasql.Check.Inferred" "PostgresParams" [l] <- here, Just ns <- [symbols l]] + columnNames = [ns | Con "Hasql.Check.Inferred" "PostgresColumns" [l] <- here, Just ns <- [symbols l]] + paramLabels = [ls | Con "Hasql.Check.Inferred" "PostgresParamLabels" [l] <- here, Just ls <- [labelLists l]] + columnLabels = [ls | Con "Hasql.Check.Inferred" "PostgresColumnLabels" [l] <- here, Just ls <- [labelLists l]] + first = \case + x : _ -> Just x + [] -> Nothing + columns isParams (t, names, labels') = + zipWith3 (\(c, nullable') postgres' ls -> Column (typeName c) postgres' ls nullable') (columnTypes isParams t) names labels' + + +-- | A type as Haskell would write it, qualified. +typeName :: Ty -> String +typeName = \case + Con m n args -> unwords ((if null m then n else m <> "." <> n) : map (parenthesised . typeName) args) + Lit s -> show s + OtherLit s -> s + Var -> "?" + where + parenthesised name = if ' ' `elem` name then concat ["(", name, ")"] else name + + +-- | A type-level list of strings. +symbols :: Ty -> Maybe [String] +symbols = \case + Con _ ":" [Lit s, rest] -> (s :) <$> symbols rest + Con _ "[]" [] -> Just [] + _ -> Nothing + + +-- | A type-level list of lists of strings. +labelLists :: Ty -> Maybe [[String]] +labelLists = \case + Con _ ":" [l, rest] -> (:) <$> symbols l <*> labelLists rest + Con _ "[]" [] -> Just [] + _ -> Nothing diff --git a/src/Hasql/Check/Plugin.hs b/src/Hasql/Check/Plugin.hs new file mode 100644 --- /dev/null +++ b/src/Hasql/Check/Plugin.hs @@ -0,0 +1,193 @@ +-- | +-- Module : Hasql.Check.Plugin +-- Copyright : (c) 2026 Kronor.io +-- +-- License : BSD-3-Clause +-- Maintainer : lorenzo@kronor.io +-- Stability : experimental +-- Portability : GHC +-- +-- A GHC plugin that checks the statements of "Hasql.Check.Inferred.TH" +-- against a database while their module compiles, as "Hasql.Check.TH" does +-- for hasql-th's: once GHC has type-checked the module, the types each +-- statement is used at are known, and the plugin checks it as +-- @hasql-check --inferred@ would. A statement that does not fit the schema +-- is a compile error at its quote. +-- +-- > {-# OPTIONS_GHC -fplugin=Hasql.Check.Plugin #-} +-- +-- or @ghc-options: -fplugin=Hasql.Check.Plugin@ for a whole package, which +-- depends on @hasql-check-ghc@. It is configured as "Hasql.Check.TH" is, by +-- @HASQL_CHECK_DATABASE_URL@ and the rest (see "Hasql.Check.Compile"); with +-- no database set, it checks nothing. +module Hasql.Check.Plugin (plugin) where + +import Control.Monad (forM_, unless) +import Control.Monad.IO.Class (liftIO) +import Data.Data (Data, cast, gmapQ) +import Data.Maybe (catMaybes) +import Data.Text qualified as Text +import GHC.Core.TyCo.Rep (Type) +import GHC.Core.TyCon (tyConName) +import GHC.Core.Type (filterOutInvisibleTypes, isCharLitTy, isNumLitTy, isStrLitTy, splitTyConApp_maybe) +import GHC.Core.Utils (exprType) +import GHC.Data.FastString (unpackFS) +import GHC.Driver.Plugins (Plugin (..), PluginRecompile (..), defaultPlugin, keepRenamedSource) +import GHC.Hs +import GHC.Tc.Errors.Types (TcRnMessage (..)) +import GHC.Tc.Types (TcGblEnv (..), TcM) +import GHC.Tc.Types.Evidence (EvTerm (..), HsWrapper (..)) +import GHC.Tc.Utils.Monad (addErrAt, updTcRef) +import GHC.Types.Error (mkPlainError, mkSimpleUnknownDiagnostic, noHints) +import GHC.Types.Name (getOccString, nameModule_maybe) +import GHC.Types.SrcLoc +import GHC.Types.Var (varName) +import GHC.Unit.Module (moduleName) +import GHC.Utils.Fingerprint (fingerprintString) +import GHC.Utils.Outputable (empty, nest, text, vcat) +import Hasql.Check.Compile (Config (..), Session (..), readConfig, reportUnavailable, warning, warnings, withSession) +import Hasql.Check.Finding (Rule (..)) +import Hasql.Check.Ghc.Source (Column (..), Quote (..), Statement (..), Ty (..), statementOf) +import Hasql.Check.Inferred.Quote (Inferred (Inferred), checkInferred) +import Hasql.Check.Inferred.Quote qualified as Quote + + +plugin :: Plugin +plugin = + defaultPlugin + { -- The quotes as GHC read them, after CPP and from an editor's buffer. + renamedResultAction = keepRenamedSource + , typeCheckResultAction = \_ _ env -> env <$ check env + , pluginRecompile = \_ -> recompile <$> readConfig + } + + +-- | A module is checked again when what it was checked with changes, as a +-- different database; a change of schema rechecks only the modules with +-- statements, which depend on the schema file. +recompile :: Config -> PluginRecompile +recompile config = + MaybeRecompile (fingerprintString (show (config.databaseUrl, config.schemaFile, config.nullability, config.types, config.baseline))) + + +check :: TcGblEnv -> TcM () +check env = do + config <- liftIO readConfig + forM_ config.databaseUrl \url -> do + -- A module with a statement depends on the schema, so that a change + -- of schema rechecks it, as for "Hasql.Check.TH"'s quoters, and on + -- the baseline its warnings are settled against. + let found = statements (tcg_binds env) + quotes = quasiQuotes (tcg_rn_decls env) + unless (null found) (forM_ (catMaybes [config.schemaFile, config.baseline]) \file -> updTcRef (tcg_dependent_files env) (file :)) + forM_ found \(s, passed) -> + forM_ (quoteAround quotes s) \(line, q) -> + case statementOf line q (map fromType passed) of + Nothing -> pure () + Just (Left err) -> failAt s err + Just (Right statement) -> checkStatement config url s statement + + +checkStatement :: Config -> String -> RealSrcSpan -> Statement -> TcM () +checkStatement config url s statement = do + let file = unpackFS (srcSpanFile s) + inferred = toInferred file statement + rules = [Nullable | config.nullability, Just _ <- [statement.row]] <> [Narrowing | config.types] + outcome <- liftIO $ withSession config url (not (null rules)) \session -> + checkInferred session.connection (snd <$> session.catalogue) (Nullable `elem` rules) (Narrowing `elem` rules) inferred + case outcome of + Left why -> liftIO (reportUnavailable why) + Right (Left err) -> failAt s ("hasql-check: the statement does not fit HASQL_CHECK_DATABASE_URL's schema:\n" <> err) + Right (Right (found, fingerprint)) -> liftIO do + messages <- warnings config rules file statement.line fingerprint found + forM_ messages (warning file (statement.line, statement.quote.column)) + + +-- | The statement as @hasql-check --inferred@ reads it. +toInferred :: FilePath -> Statement -> Inferred +toInferred file statement = + Inferred + file + statement.line + statement.quote.column + (Text.pack statement.quote.quoter) + (Text.pack statement.quote.body) + (map column statement.params) + (map column <$> statement.row) + where + column c = Quote.Column (Text.pack c.haskellType) (Text.pack c.postgres) (map Text.pack c.labels) c.nullable + + +failAt :: RealSrcSpan -> String -> TcM () +failAt s message = + addErrAt (RealSrcSpan s mempty) (TcRnUnknownMessage (mkSimpleUnknownDiagnostic (mkPlainError noHints layout))) + where + -- GHC's layout: the first line, and the rest under it. + layout = case filter (not . null) (lines message) of + first : rest -> vcat [text first, nest 2 (vcat (map text rest))] + [] -> empty + + +-- * The statements in a type-checked module + + +-- | The quasi-quotes of a renamed module, with their spans and the line each +-- starts on. +quasiQuotes :: Data a => a -> [(RealSrcSpan, Quote)] +quasiQuotes x = here <> concat (gmapQ quasiQuotes x) + where + here = case cast x of + Just (L l (HsUntypedSplice _ (HsQuasiQuote _ quoter (L _ body))) :: LHsExpr GhcRn) + | RealSrcSpan s _ <- locA l -> + [(s, Quote (srcSpanStartCol s) (getOccString quoter) (unpackFS body))] + _ -> [] + + +-- | The innermost quote whose span holds the given span - that of the code it +-- was spliced into - with the line it starts on. +quoteAround :: [(RealSrcSpan, Quote)] -> RealSrcSpan -> Maybe (Int, Quote) +quoteAround quotes s = + case [(srcSpanStartLine o, q) | (o, q) <- around, all (\(o', _) -> o' `containsSpan` o) around] of + found : _ -> Just found + [] -> Nothing + where + around = filter (\(o, _) -> o `containsSpan` s) quotes + + +-- | Each use of 'Hasql.Check.Inferred.statement' or +-- 'Hasql.Check.Inferred.resultless' - each quote - with its span and the +-- types of the dictionaries it is passed: GHC has worked out the types it is +-- used at. +statements :: Data a => a -> [(RealSrcSpan, [Type])] +statements x = here <> concat (gmapQ statements x) + where + here = case cast x of + Just (L l (XExpr (WrapExpr w (HsVar _ (L _ v)))) :: LHsExpr GhcTc) + | getOccString v `elem` ["statement", "resultless"] + , Just m <- nameModule_maybe (varName v) + , moduleNameString (moduleName m) == "Hasql.Check.Inferred" + , RealSrcSpan s _ <- locA l -> + [(s, dictionaries w)] + _ -> [] + + +dictionaries :: HsWrapper -> [Type] +dictionaries = \case + WpCompose a b -> dictionaries a <> dictionaries b + WpEvApp (EvExpr e) -> [exprType e] + _ -> [] + + +-- | A type, as "Hasql.Check.Ghc.Source" reads it. +fromType :: Type -> Ty +fromType t + | Just s <- isStrLitTy t = Lit (unpackFS s) + | Just n <- isNumLitTy t = OtherLit (show n) + | Just c <- isCharLitTy t = OtherLit (show c) + | Just (tc, args) <- splitTyConApp_maybe t = + let name = tyConName tc + in Con + (maybe "" (moduleNameString . moduleName) (nameModule_maybe name)) + (getOccString name) + (map fromType (filterOutInvisibleTypes tc args)) + | otherwise = Var diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,85 @@ +module Main where + +import Control.Monad (unless) +import Hasql.Check.Ghc.Source +import System.Exit (exitFailure) + + +-- | Each case: the source, the span GHC gives the quote's generated code, and +-- the quote. The columns are worked out by hand from GHC's rule that a tab +-- reaches the next of columns 9, 17, 25, ... +-- +-- In "t =\t[singletonStatement| select 1 |]" the tab reaches column 9: '[' +-- is at 9, the quoter at 10-27, '|' at 28, the body at 29-38, "|]" at 39-40. +-- In "\tb|]", 'b' is at 9 and "|]" at 10-11. +cases :: [(String, [String], (Int, Int), (Int, Int), Maybe Quote)] +cases = + [ ("no tabs", ["f = [q|x|]"], (1, 8), (1, 11), Just (Quote 5 "q" "x")) + , ("a tab before the quote", ["t =\t[singletonStatement| select 1 |]"], (1, 29), (1, 41), Just (Quote 9 "singletonStatement" " select 1 ")) + , ("a tab inside a multiline quote", ["f = [q|a", "\tb|]"], (1, 8), (2, 12), Just (Quote 5 "q" "a\n\tb")) + , ("a span that is not a quote's", ["f = g x"], (1, 5), (1, 8), Nothing) + ] + + +-- | The types of a quote, from its dictionaries' types; here a type is +-- concrete unless it is "?". +typeCases :: [(String, [String], [String], Types String)] +typeCases = + [ ("concrete", ["Int64"], ["Text"], Resolved "Int64" (Just "Text")) + , ("no rows", ["Int64"], [], Resolved "Int64" Nothing) + , ("a polymorphic statement", ["?"], ["?"], Unresolved) + , ("a polymorphic row", ["Int64"], ["?"], Unresolved) + , ("not a statement of these quoters", [], [], NotInferred) + ] + + +-- | A row type's columns: the oracle is the type itself. +columnCases :: [(String, Ty, [(Ty, Bool)])] +columnCases = + [ ("a tuple", Con "GHC.Tuple" "Tuple2" [int64, maybe' text], [(int64, False), (text, True)]) + , ("a newtype named like a tuple", tupleId, [(tupleId, False)]) + , ("a type with a number in it", amount, [(amount, False)]) + , ("a Maybe of another module", otherMaybe, [(otherMaybe, False)]) + ] + where + int64 = Con "GHC.Internal.Int" "Int64" [] + text = Con "Data.Text.Internal" "Text" [] + maybe' a = Con "GHC.Internal.Maybe" "Maybe" [a] + tupleId = Con "Shop" "TupleId" [] + amount = Con "Shop" "Amount" [OtherLit "2"] + otherMaybe = Con "Shop" "Maybe" [int64] + + +main :: IO () +main = do + columnFailures <- + traverse + ( \(name, t, expected) -> do + let found = columnTypes False t + unless (found == expected) $ + putStrLn (name <> ": expected " <> show expected <> ", found " <> show found) + pure (found /= expected) + ) + columnCases + unless (ground (Con "Shop" "Amount" [OtherLit "2"])) $ putStrLn "a type with a number in it is not concrete" + typeFailures <- + traverse + ( \(name, params, rows, expected) -> do + let found = typesOf (/= "?") params rows + unless (found == expected) $ + putStrLn (name <> ": expected " <> show expected <> ", found " <> show found) + pure (found /= expected) + ) + typeCases + failures <- + traverse + ( \(name, source, start, end, expected) -> do + let found = quoteAt source start end + unless (found == expected) $ + putStrLn (name <> ": expected " <> show expected <> ", found " <> show found) + pure (found /= expected) + ) + cases + if or (failures <> typeFailures <> columnFailures) || not (ground (Con "Shop" "Amount" [OtherLit "2"])) + then exitFailure + else putStrLn (show (length cases + length typeCases + length columnCases + 1) <> " passed") diff --git a/test/Plugin.hs b/test/Plugin.hs new file mode 100644 --- /dev/null +++ b/test/Plugin.hs @@ -0,0 +1,248 @@ +-- | The plugin, as GHC runs it: each case compiles a fixture module with +-- @-fplugin=Hasql.Check.Plugin@, against a throwaway PostgreSQL server. +-- +-- GHC finds the plugin and its dependencies through the package environment +-- cabal writes (@write-ghc-environment-files: always@ in cabal.project), and +-- must be the GHC that built them: @ghc-@, or @$GHC@. +module Main where + +import Control.Exception (bracket_) +import Control.Monad (unless, when) +import Data.List (isInfixOf, isPrefixOf) +import Data.Maybe (isNothing) +import Data.Version (showVersion) +import System.Directory (findExecutable, getCurrentDirectory, listDirectory) +import System.Environment (getEnvironment, lookupEnv) +import System.Exit (ExitCode (..), exitFailure) +import System.FilePath (takeDirectory, ()) +import System.IO.Temp (withSystemTempDirectory) +import System.Info (fullCompilerVersion) +import System.Process (callProcess, proc, readCreateProcessWithExitCode, readProcess) +import System.Process qualified as Process + + +main :: IO () +main = do + env <- environmentFile + compiler <- ghc + withPostgres \conn -> do + failures <- traverse (run compiler env conn) cases + let failed = [name | (name, False) <- zip (map caseName cases) failures] + mapM_ (putStrLn . ("failed: " <>)) failed + if null failed then putStrLn (show (length cases) <> " passed") else exitFailure + + +data Case = Case + { caseName :: String + , before :: [Database] + -- ^ Compilations of the same module, in the same directory, first. + , database :: Database + , extraEnv :: [(String, String)] + , source :: String + , expect :: (ExitCode, String) -> Bool + } + + +data Database = TestDatabase | NoDatabase | Unreachable + + +cases :: [Case] +cases = + [ Case + "checks nothing when no database is set" + [] + NoDatabase + [] + (fixture "Statement Int64 Text" "select nope from customer where id = $1") + \(code, out) -> code == ExitSuccess && not ("hasql-check:" `isInfixOf` out) + , Case + "accepts a statement that fits the schema" + [] + TestDatabase + [] + (fixture "Statement Int64 (Maybe Text)" "select nickname from customer where id = $1") + \(code, _) -> code == ExitSuccess + , Case + "fails at the quote on a statement that does not prepare" + [] + TestDatabase + [] + (fixture "Statement Int64 Text" "select nope from customer where id = $1") + \(code, out) -> + code /= ExitSuccess + && "Fixture.hs:11:" `isInfixOf` out + && "column \"nope\" does not exist" `isInfixOf` out + , Case + "fails on a column read through a conversion that can fail" + [] + TestDatabase + [] + (fixture "Statement Int64 Int64" "select email from customer where id = $1") + \(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" + [] + TestDatabase + [] + ( unlines + [ "{-# LANGUAGE DataKinds, DerivingVia, QuasiQuotes, UndecidableInstances #-}" + , "module Fixture where" + , "import Data.Int (Int64)" + , "import GHC.Generics (Generic)" + , "import Hasql.Check.Inferred (PgEnum (..), Value)" + , "import Hasql.Check.Inferred.TH" + , "import Hasql.Statement (Statement)" + , "data State = PENDING | PAID" + , " deriving stock (Generic)" + , " deriving (Value) via PgEnum \"payment_state\" State" + , "s :: Statement Int64 State" + , "s = [singletonStatement| select state from payment where id = $1 |]" + ] + ) + \(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" + [] + TestDatabase + [("HASQL_CHECK_NULLABILITY", "1")] + (fixture "Statement Int64 Text" "select nickname from customer where id = $1") + \(code, out) -> + code == ExitSuccess + && "Fixture.hs:11:" `isInfixOf` out + && "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" + [] + TestDatabase + [] + ( unlines + [ "{-# LANGUAGE CPP, QuasiQuotes #-}" + , "module Fixture where" + , "import Data.Int (Int64)" + , "import Data.Text (Text)" + , "import Hasql.Check.Inferred.TH" + , "import Hasql.Statement (Statement)" + , "#define FIELD nope" + , "s :: Statement Int64 Text" + , "s = [singletonStatement| select FIELD from customer where id = $1 |]" + ] + ) + \(code, out) -> code /= ExitSuccess && "column \"nope\" does not exist" `isInfixOf` out + , Case + "checks a module compiled before without a database once one is set" + [NoDatabase] + TestDatabase + [] + (fixture "Statement Int64 Text" "select nope from customer where id = $1") + \(code, out) -> code /= ExitSuccess && "column \"nope\" does not exist" `isInfixOf` out + , Case + "does not fail the build when the database cannot be reached" + [] + Unreachable + [] + (fixture "Statement Int64 Text" "select nope from customer where id = $1") + \(code, out) -> code == ExitSuccess && "hasql-check: not checking statements" `isInfixOf` out + ] + + +-- | A module with one statement, of the given type, on line 11. +fixture :: String -> String -> String +fixture type' sql = + unlines + [ "{-# LANGUAGE QuasiQuotes #-}" + , "module Fixture where" + , "" + , "import Data.Int (Int64)" + , "import Data.Text (Text)" + , "import Hasql.Check.Inferred.TH" + , "import Hasql.Statement (Statement)" + , "" + , "" + , "s :: " <> type' + , "s = [singletonStatement| " <> sql <> " |]" + ] + + +run :: FilePath -> FilePath -> String -> Case -> IO Bool +run compiler env conn c = + withSystemTempDirectory "hasql-check-plugin" \dir -> do + writeFile (dir "Fixture.hs") c.source + inherited <- getEnvironment + let compile db = do + let database = case db of + TestDatabase -> [("HASQL_CHECK_DATABASE_URL", conn)] + NoDatabase -> [] + Unreachable -> [("HASQL_CHECK_DATABASE_URL", "host=/nonexistent")] + ours = database <> c.extraEnv + procEnv = ours <> filter (not . ("HASQL_CHECK_" `isPrefixOf`) . fst) inherited + -- Interfaces written, so that a later compilation can reuse them. + 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 + let ok = c.expect (code, out <> err) + unless ok (putStrLn (c.caseName <> ":\n" <> show code <> "\n" <> out <> err)) + pure ok + + +-- | The package environment cabal wrote, in this directory or one above. +-- Cabal writes it once a command has run, after the tests of a first +-- @cabal test@: then it is written here, by building the plugin. +environmentFile :: IO FilePath +environmentFile = + find >>= \case + Just file -> pure file + Nothing -> do + callProcess "cabal" ["build", "-v0", "--write-ghc-environment-files=always", "hasql-check-ghc:lib:hasql-check-ghc"] + find >>= \case + Just file -> pure file + Nothing -> do + putStrLn "no .ghc.environment file: set write-ghc-environment-files: always in cabal.project" + exitFailure + where + find = getCurrentDirectory >>= go + go dir = do + found <- filter (".ghc.environment." `isPrefixOf`) <$> listDirectory dir + case found of + file : _ -> pure (Just (dir file)) + [] + | takeDirectory dir == dir -> pure Nothing + | otherwise -> go (takeDirectory dir) + + +-- | The GHC that built the plugin. +ghc :: IO FilePath +ghc = + lookupEnv "GHC" >>= \case + Just path -> pure path + Nothing -> do + let versioned = "ghc-" <> showVersion fullCompilerVersion + found <- findExecutable versioned + pure (maybe "ghc" (const versioned) found) + + +-- | A connection string for a throwaway server, reachable only over a socket +-- in a temporary directory. +withPostgres :: (String -> IO ()) -> IO () +withPostgres action = + withSystemTempDirectory "hasql-check-plugin-db" \dir -> do + initdb <- findExecutable "initdb" + when (isNothing initdb) do + putStrLn "initdb is not on PATH; the plugin tests need a PostgreSQL installation" + exitFailure + let dataDir = dir "data" + conn = "host=" <> dir <> " port=5432 user=postgres dbname=postgres" + _ <- readProcess "initdb" ["--pgdata", dataDir, "--username", "postgres", "--auth", "trust", "--no-sync"] "" + bracket_ + (callProcess "pg_ctl" ["--pgdata", dataDir, "--log", dir "postgres.log", "--options", "-k " <> dir <> " -c listen_addresses=''", "--wait", "--silent", "start"]) + (callProcess "pg_ctl" ["--pgdata", dataDir, "--mode", "immediate", "--silent", "stop"]) + do + callProcess + "psql" + [ 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)" + ] + action conn