From 32f9f321e4a97201559d4dede7d8d22a0e289474 Mon Sep 17 00:00:00 2001 From: Abigail Gooding Date: Thu, 1 Aug 2024 17:22:46 -0700 Subject: [PATCH] Implement schema typechecker This closes #274 and #186, allowing the generation of CREATE TABLE statements from a TableSchema, as well as testing the table's schema in the database against the schema implied by the TableSchema type. Co-authored-by: David Kraeutmann --- rel8.cabal | 7 +- src/Rel8/Table/Verify.hs | 599 ++++++++++++++++++++++++++++ tests/Main.hs | 78 +++- tests/Rel8/Generic/Rel8able/Test.hs | 334 +++++++++++++++- 4 files changed, 1011 insertions(+), 7 deletions(-) create mode 100644 src/Rel8/Table/Verify.hs diff --git a/rel8.cabal b/rel8.cabal index 39b37893..731adba3 100644 --- a/rel8.cabal +++ b/rel8.cabal @@ -30,6 +30,7 @@ library , case-insensitive , comonad , contravariant + , containers , data-textual , hasql ^>= 1.6.1.2 , network-ip @@ -66,6 +67,7 @@ library Rel8.Expr.Text Rel8.Expr.Time Rel8.Tabulate + Rel8.Table.Verify other-modules: Rel8.Aggregate @@ -238,7 +240,8 @@ library test-suite tests type: exitcode-stdio-1.0 build-depends: - base + aeson + , base , bytestring , case-insensitive , containers @@ -253,10 +256,12 @@ test-suite tests , tasty , tasty-hedgehog , text + , these , time , tmp-postgres ^>=1.34.1.0 , transformers , uuid + , vector other-modules: Rel8.Generic.Rel8able.Test diff --git a/src/Rel8/Table/Verify.hs b/src/Rel8/Table/Verify.hs new file mode 100644 index 00000000..4e2834ad --- /dev/null +++ b/src/Rel8/Table/Verify.hs @@ -0,0 +1,599 @@ + +{-# language BlockArguments #-} +{-# language LambdaCase #-} +{-# language RecordWildCards #-} +{-# language RankNTypes #-} +{-# language DuplicateRecordFields #-} +{-# language DerivingStrategies #-} +{-# language OverloadedRecordDot #-} +{-# language TypeApplications #-} +{-# language NamedFieldPuns #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneDeriving #-} +{-# language DeriveAnyClass #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language DeriveGeneric #-} +{-# language GeneralizedNewtypeDeriving #-} +{-# language OverloadedStrings #-} +{-# language GADTs #-} + +module Rel8.Table.Verify + ( getSchemaErrors + , SomeTableSchema(..) + , showCreateTable + , checkedShowCreateTable + ) where + +-- base +import Prelude hiding ( filter ) +import qualified Prelude as P +import Data.These +import Control.Monad +import Data.Function +import Data.Functor ((<&>)) +import Data.Maybe (isJust, mapMaybe) +import qualified Data.List as L + +-- hasql +import Hasql.Connection +import qualified Hasql.Statement as HS + +import Data.Either (lefts) +import Data.Functor.Contravariant ( (>$<) ) +import Data.Int ( Int16, Int64 ) +import Data.Text ( Text ) +import qualified Data.Text as T +import GHC.Generics +import Data.List.NonEmpty ( NonEmpty((:|)) ) +import qualified Data.List.NonEmpty as NonEmpty + +-- containers +import qualified Data.Map as M + +-- rel8 +import Rel8 -- not importing this seems to cause a type error??? +import Rel8.Schema.Null hiding (nullable) +import Rel8.Generic.Rel8able (GFromExprs, Rel8able) +import qualified Rel8.Schema.Null as Null +import Rel8.Schema.Table ( TableSchema(..) ) +import qualified Rel8.Statement.Run as RSR +import Rel8.Schema.Name ( Name(Name) ) +import Rel8.Expr ( Expr ) +import Rel8.Table ( Columns ) +import Rel8.Schema.Spec +import Rel8.Schema.Result ( Result ) +import Rel8.Schema.QualifiedName ( QualifiedName(..) ) +import Rel8.Query ( Query ) +import Rel8.Column ( Column ) +import Rel8.Type.Eq ( DBEq ) +import Rel8.Type ( DBType(..) ) +import Rel8.Table.List ( ListTable ) +import Rel8.Column.List ( HList ) +import Data.Functor.Const +import Rel8.Schema.HTable +import Rel8.Type.Name ( TypeName(..) ) +import Rel8.Table.Serialize ( ToExprs ) + + +data Relkind + = OrdinaryTable + | Index + | Sequence + | ToastTable + | View + | MaterializedView + | CompositeType + | ForeignTable + | PartitionedTable + | PartitionedIndex + deriving stock (Show) + deriving anyclass (DBEq) + +instance DBType Relkind where + typeInformation = parseTypeInformation parser printer typeInformation + where + parser = \case + "r" -> pure OrdinaryTable + "i" -> pure Index + "S" -> pure Sequence + "t" -> pure ToastTable + "v" -> pure View + "m" -> pure MaterializedView + "c" -> pure CompositeType + "f" -> pure ForeignTable + "p" -> pure PartitionedTable + "I" -> pure PartitionedIndex + (x :: Text) -> Left $ "Unknown relkind: " ++ show x + + printer = \case + OrdinaryTable -> "r" + Index -> "i" + Sequence -> "S" + ToastTable -> "t" + View -> "v" + MaterializedView -> "m" + CompositeType -> "c" + ForeignTable -> "f" + PartitionedTable -> "p" + PartitionedIndex -> "I" + +newtype Oid = Oid Int64 + deriving newtype (DBType, DBEq, Show) + +data PGClass f = PGClass + { oid :: Column f Oid + , relname :: Column f Text + , relkind :: Column f Relkind + , relnamespace :: Column f Oid + } + deriving stock (Generic) + deriving anyclass (Rel8able) + +deriving stock instance Show (PGClass Result) + +pgclass :: TableSchema (PGClass Name) +pgclass = TableSchema + { name = QualifiedName "pg_class" (Just "pg_catalog") + , columns = namesFromLabelsWith NonEmpty.last + } + +data PGAttribute f = PGAttribute + { attrelid :: Column f Oid + , attname :: Column f Text + , atttypid :: Column f Oid + , attnum :: Column f Int64 + , attnotnull :: Column f Bool + , attndims :: Column f Int16 + } + deriving stock (Generic) + deriving anyclass (Rel8able) + +deriving stock instance Show (PGAttribute Result) + +pgattribute :: TableSchema (PGAttribute Name) +pgattribute = TableSchema + { name = QualifiedName "pg_attribute" (Just "pg_catalog") + , columns = namesFromLabelsWith NonEmpty.last + } + +data PGType f = PGType + { oid :: Column f Oid + , typname :: Column f Text + } + deriving stock (Generic) + deriving anyclass (Rel8able) + +deriving stock instance Show (PGType Result) + +pgtype :: TableSchema (PGType Name) +pgtype = TableSchema + { name = QualifiedName "pg_type" (Just "pg_catalog") + , columns = namesFromLabelsWith NonEmpty.last + } + +data PGNamespace f = PGNamespace + { oid :: Column f Oid + , nspname :: Column f Text + } + deriving stock (Generic) + deriving anyclass (Rel8able) + +deriving stock instance Show (PGNamespace Result) + +pgnamespace :: TableSchema (PGNamespace Name) +pgnamespace = TableSchema + { name = QualifiedName "pg_namespace" (Just "pg_catalog") + , columns = namesFromLabelsWith NonEmpty.last + } + +data PGCast f = PGCast + { oid :: Column f Oid + , castsource :: Column f Oid + , casttarget :: Column f Oid + , castfunc :: Column f Oid + , castcontext :: Column f Text -- Char + , castmethod :: Column f Char + } + deriving stock (Generic) + deriving anyclass (Rel8able) + +deriving stock instance Show (PGCast Result) + +pgcast :: TableSchema (PGCast Name) +pgcast = TableSchema + { name = QualifiedName "pg_cast" (Just "pg_catalog") + , columns = namesFromLabelsWith NonEmpty.last + } + +data PGTable f = PGTable + { name :: Column f Text + , columns :: HList f (Attribute f) + } + deriving stock (Generic) + deriving anyclass (Rel8able) + +deriving stock instance Show (PGTable Result) + +data Attribute f = Attribute + { attribute :: PGAttribute f + , typ :: PGType f + } + deriving stock (Generic) + deriving anyclass (Rel8able) + +deriving stock instance Show (Attribute Result) + +data Cast f = Cast + { source :: PGType f + , target :: PGType f + , context :: Column f Text -- Char + } + deriving stock (Generic) + deriving anyclass (Rel8able) + +deriving stock instance Show (Cast Result) + +fetchTables :: Query (ListTable Expr (PGTable Expr)) +fetchTables = many do + PGClass{ oid = tableOid, relname } <- orderBy (relname >$< asc) do + each pgclass + >>= filter ((lit OrdinaryTable ==.) . relkind) + + columns <- many do + attribute@PGAttribute{ atttypid } <- + each pgattribute + >>= filter ((tableOid ==.) . attrelid) + >>= filter ((>. 0) . attnum) + + typ <- + each pgtype + >>= filter (\PGType{ oid = typoid } -> atttypid ==. typoid) + + return Attribute{ attribute, typ } + + return PGTable + { name = relname + , .. + } + +fetchCasts :: Query (ListTable Expr (Cast Expr)) +fetchCasts = many do + PGCast {castsource, casttarget, castcontext} <- each pgcast + src <- each pgtype >>= filter (\PGType { oid = typoid } -> typoid ==. castsource) + tgt <- each pgtype >>= filter (\PGType { oid = typoid } -> typoid ==. casttarget) + return Cast { source = src, target = tgt, context = castcontext } + + +data CheckEnv = CheckEnv + { schemaMap :: M.Map String [Attribute Result] -- map of schemas to attributes + , casts :: [(String, String)] -- list of implicit casts + } deriving (Show) + + +nullableToBool :: Nullity a -> Bool +nullableToBool Null = True +nullableToBool NotNull = False + + +attrsToMap :: [Attribute Result] -> M.Map String (Attribute Result) +attrsToMap = foldMap (\attr -> M.singleton (T.unpack $ attr.attribute.attname) attr) + + +data TypeInfo = TypeInfo + { label :: [String] + , isNull :: Bool + , typeName :: TypeName + } +instance Show TypeInfo where + show = showTypeInfo + + +-- @'schemaToTypeMap'@ takes a schema and returns a map of database column names +-- to the type information associated with the column. It is possible (though +-- undesirable) to write a schema which has multiple columns with the same name, +-- so a list of results are returned for each key. +schemaToTypeMap :: forall k. Rel8able k => k Name -> M.Map String (NonEmpty.NonEmpty TypeInfo) +schemaToTypeMap cols = go . uncurry zip . getConst $ + htabulateA @(Columns (k Name)) $ \field -> + case (hfield hspecs field, hfield (toColumns cols) field) of + (Spec {..}, Name name) -> Const ([name], [ + TypeInfo { label = labels + , isNull = nullableToBool nullity + , typeName = info.typeName}]) + where + go :: [(String, TypeInfo)] -> M.Map String (NonEmpty.NonEmpty TypeInfo) + go = M.fromListWith (<>) . (fmap . fmap) pure + +-- A checked version of @schemaToTypeMap@, which returns a list of columns with +-- duplicate names if any such columns are present. Otherwise it returns the +-- type map with no duplicates. +checkedSchemaToTypeMap :: Rel8able k + => k Name + -> Either (M.Map String (NonEmpty.NonEmpty TypeInfo)) (M.Map String TypeInfo) +checkedSchemaToTypeMap cols = + let typeMap = schemaToTypeMap cols + duplicates = M.filter (\col -> length col > 1) typeMap + in if length duplicates > 0 + then Left duplicates + else Right (typeMap & M.mapMaybe \case + a :| [] -> Just a + _ -> Nothing) + + +showCreateTable_helper :: String -> M.Map String TypeInfo -> String +showCreateTable_helper name typeMap = "CREATE TABLE IF NOT EXISTS " <> show name <> " (" + ++ L.intercalate "," (fmap go $ M.assocs typeMap) + ++ "\n);" + where + go :: (String, TypeInfo) -> String + go (name, typeInfo) = "\n " ++ show name ++ " " ++ showTypeInfo typeInfo + + +-- |@'showCreateTable'@ shows an example CREATE TABLE statement for the table. +-- This does not show relationships like primary or foreign keys, but can still +-- be useful to see what types @rel8@ will expect of the underlying database. +-- +-- In the event multiple columns have the same name, this will fail silently. To +-- handle that case, see @'checkedShowCreateTable'@ +showCreateTable :: Rel8able k => TableSchema (k Name) -> String +showCreateTable schema = showCreateTable_helper schema.name.name $ fmap NonEmpty.head $ schemaToTypeMap schema.columns + + +-- |@'safeShowCreateTable'@ shows an example CREATE TABLE statement for the table. +-- This does not show relationships like primary or foreign keys, but can still +-- be useful to see what types rel8 will expect of the underlying database +-- table. +-- +-- In the event multiple columns have the same name, this will return a map of +-- names to the labels identifying the column. +checkedShowCreateTable :: Rel8able k => TableSchema (k Name) -> Either (M.Map String (NonEmpty [String])) String +checkedShowCreateTable schema = case checkedSchemaToTypeMap schema.columns of + Left e -> Left $ (fmap . fmap) (\typ -> typ.label) e + Right a -> Right $ showCreateTable_helper schema.name.name a + + +-- implicit casts are ok as long as they're bidirectional +checkTypeEquality :: CheckEnv -> Attribute Result -> TypeInfo -> Maybe ColumnError +checkTypeEquality env attr ty + | attrTyName == tyTyName && attrDims == tyDims = Nothing + | (attrTyName, tyTyName) `elem` env.casts && (tyTyName, attrTyName) `elem` env.casts + && attrDims == tyDims + = Nothing + | otherwise = Just BidirectionalCastDoesNotExist + where + attrTyName = dropWhile (=='_') $ T.unpack attr.typ.typname + attrDims = fromIntegral attr.attribute.attndims + tyTyName = case ty.typeName.name of + QualifiedName a _ -> dropWhile (=='_') a + tyDims = fromIntegral ty.typeName.arrayDepth + + +-- check types for a single table +compareTypes + :: CheckEnv + -> M.Map String (Attribute Result) + -> M.Map String TypeInfo + -> [ColumnDiff] +compareTypes env attrMap typeMap = fmap (uncurry go) $ M.assocs (disjointUnion attrMap typeMap) + where + go :: String -> These (Attribute Result) TypeInfo -> ColumnDiff + go name (These a b) = ColumnDiff + { name = name + , dbType = Just $ fromAttribute a + , hsType = Just $ b + , error = checkTypeEquality env a b + } + go name (This a) = ColumnDiff + { name = name + , dbType = Just $ fromAttribute a + , hsType = Nothing + , error = + if a.attribute.attnotnull + then Just DbTypeIsNotNullButNotPresentInHsType + else Nothing + } + go name (That b) = ColumnDiff + { name = name + , dbType = Nothing + , hsType = Just $ b + , error = Just HsTypeIsPresentButNotPresentInDbType + } + + fromAttribute :: Attribute Result -> TypeInfo + fromAttribute attr = TypeInfo + { label = [T.unpack attr.attribute.attname] + , isNull = not attr.attribute.attnotnull + , typeName = TypeName + { name = QualifiedName (T.unpack attr.typ.typname) Nothing + , modifiers = [] + , arrayDepth = fromIntegral attr.attribute.attndims + } + } + + disjointUnion :: Ord k => M.Map k a -> M.Map k b -> M.Map k (These a b) + disjointUnion a b = M.unionWith go (fmap This a) (fmap That b) + where + go :: These a b -> These a b -> These a b + go (This a) (That b) = These a b + go _ _ = undefined + + +-- |@pShowTable@ is a helper function which takes a grid of text and prints it +-- as a table, with padding so that cells are lined in columns, and a bordered +-- header for the first row +pShowTable :: [[Text]] -> Text +pShowTable xs + = T.intercalate "\n" + $ addHeaderBorder + $ fmap (T.intercalate " | ") + $ L.transpose + $ zip lengths xs' <&> \(n, column) -> column <&> \cell -> T.justifyLeft n ' ' cell + where + addHeaderBorder :: [Text] -> [Text] + addHeaderBorder [] = [] + addHeaderBorder (x : xs) = x : T.replicate (T.length x) "-" : xs + + xs' :: [[Text]] + xs' = L.transpose xs + + lengths :: [Int] + lengths = fmap (maximum . fmap T.length) $ xs' + + +pShowErrors :: [TableDiff] -> Text +pShowErrors = T.intercalate "\n\n" . fmap go + where + go :: TableDiff -> Text + go (TableDiff {tableExists, name, columns}) = "Table: " <> T.pack name + <> if not tableExists then " does not exist\n" else "\n" + <> pShowTable (["Column Name", "Implied DB type", "Current DB type", "Error"] : (columns <&> \column -> + [ T.pack $ column.name + , T.pack $ maybe "" showTypeInfo column.hsType + , T.pack $ maybe "" showTypeInfo column.dbType + , T.pack $ maybe "" show column.error + ])) + go (DuplicateNames {name, duplicates}) = "Table " <> T.pack name <> " has multiple columns with the same name. Using 'namesFromLabels' can ensure each column has unique names, which is the easiest way to prevent this, but may require changing names in your database to match the generated names." + <> pShowTable (["DB name", "Haskell label"] : (M.assocs duplicates <&> \(name, typs) -> + [ T.pack name + , T.intercalate " " $ fmap (\typ -> T.intercalate "/" $ fmap T.pack typ.label) $ NonEmpty.toList typs + ])) + + +data TableDiff + = TableDiff + { tableExists :: Bool + , name :: String + , columns :: [ColumnDiff] + } + | DuplicateNames + { name :: String + , duplicates :: M.Map String (NonEmpty.NonEmpty TypeInfo) + } + deriving (Show) +data ColumnDiff = ColumnDiff + { name :: String + , hsType :: Maybe TypeInfo + , dbType :: Maybe TypeInfo + , error :: Maybe ColumnError + } deriving (Show) +data ColumnError + = DbTypeIsNotNullButNotPresentInHsType + | HsTypeIsPresentButNotPresentInDbType + | BidirectionalCastDoesNotExist + deriving (Show) + + +showTypeInfo :: TypeInfo -> String +showTypeInfo typeInfo = name + <> concat (replicate (fromIntegral typeInfo.typeName.arrayDepth) "[]") + <> if typeInfo.isNull then "" else " NOT NULL" + where + name = case typeInfo.typeName.name of + QualifiedName a _ -> dropWhile (=='_') a + + +verifySchema :: Rel8able k => CheckEnv -> TableSchema (k Name) -> TableDiff +verifySchema env schema = case checkedSchemaToTypeMap schema.columns of + Left dups -> DuplicateNames schema.name.name dups + Right typeMap -> go typeMap maybeTable + where + maybeTable = M.lookup schema.name.name env.schemaMap + go typeMap Nothing = TableDiff + { tableExists = False + , name = schema.name.name + , columns = compareTypes env mempty typeMap + } + go typeMap (Just attrs) = TableDiff + { tableExists = True + , name = schema.name.name + , columns = compareTypes env (attrsToMap attrs) typeMap + } + + +fetchCheckEnv :: HS.Statement () CheckEnv +fetchCheckEnv = fetchSchema <&> \(tbls, casts) -> + let tblMap = foldMap (\PGTable {..} -> M.singleton (T.unpack name) columns) tbls + castMap = map (\Cast {..} -> (T.unpack source.typname, T.unpack target.typname)) $ L.filter (\Cast {context} -> context == "i") casts + in CheckEnv tblMap castMap + where + fetchSchema :: HS.Statement () ([PGTable Result], [Cast Result]) + fetchSchema = run1 $ select $ liftA2 (,) fetchTables fetchCasts + + +-- |@'SomeTableSchema'@ is used to allow the collection of a variety of different +-- @TableSchema@s under a single type, like: +-- +-- @ +-- userTable :: TableSchema (User Name) +-- orderTable :: TableSchema (Order Name) +-- +-- tables :: [SomeTableSchema] +-- tables = [SomeTableSchema userTable, SomeTable orderTable] +-- @ +-- +-- This is used by @'schemaErrors'@ to more conveniently group every table an +-- application relies on together, for typechecking the postgresql schemas +-- together in a single batch. +data SomeTableSchema where + -- The ToExpr constraint isn't used here, but can be used to read from the + -- SomeTableSchema, which can be useful to combine the type checking with more + -- thorough value-level checking of the validity of existing rows in the + -- table. + SomeTableSchema + :: (ToExprs (k Expr) (GFromExprs k), Rel8able k) + => TableSchema (k Name) -> SomeTableSchema + +-- |@'getSchemaErrors'@ checks whether the provided schemas have correct postgresql +-- column names and types to allow reading and writing from their equivalent Haskell +-- types, returning a list of errors if that is not the case. The function does not +-- crash on an encountered bug, instead leaving it to the caller to decide how +-- to respond. A schema is valid if: +-- +-- 1. for every existing field, the types match +-- 2. all non-nullable columns are present in the hs type +-- 3. no nonexistent columns are present in the hs type +-- 4. no two columns in the same schema share the same name +-- +-- It's still possible for a valid schema to allow invalid data, for instance, +-- if using an ADT, which can introduce restrictions on which values are allowed +-- for the column representing the tag, and introduce restrictions on which +-- columns are non-null depending on the value of the tag. However, if the +-- schema is valid rel8 shouldn't be able to write invalid data to the table. +-- +-- However, it is possible for migrations to cause valid data to become invalid, +-- in ways not detectable by this function, if the migration code changes the +-- schema correctly but doesn't handle the value-level constraints correctly, so +-- it is a good idea to both read from the tables and check the schema for errors +-- in a transaction during the migration. This former will catch value-level +-- bugs, while the latter will help ensure the schema is set up correctly to +-- be able to insert new data. +-- +-- This function does nothing to check that the conflict target of an @Upsert@ +-- are valid for the schema, nor can it prevent invalid uses of @unsafeDefault@. +-- However, it should be enough to catch the most likely errors. +getSchemaErrors :: [SomeTableSchema] -> HS.Statement () (Maybe Text) +getSchemaErrors someTables = fmap collectErrors fetchCheckEnv + where + collectErrors :: CheckEnv -> Maybe Text + collectErrors env + = fmap pShowErrors + . filterErrors + . fmap \case + SomeTableSchema t -> verifySchema env t + $ someTables + + -- removes each column which is valid for use by rel8, as well as each table + -- which contains only valid columns + filterErrors :: [TableDiff] -> Maybe [TableDiff] + filterErrors tables = case mapMaybe go tables of + [] -> Nothing + xs -> Just xs + where + go :: TableDiff -> Maybe TableDiff + go TableDiff {..} = case P.filter (\cd -> isJust cd.error) columns of + [] -> if tableExists then Nothing else Just $ TableDiff { name , tableExists , columns = [] } + xs -> Just $ TableDiff { name , tableExists , columns = xs } + go DuplicateNames {..} = Just (DuplicateNames {..}) + + diff --git a/tests/Main.hs b/tests/Main.hs index 9020a840..62cf22ca 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -13,6 +13,8 @@ {-# language StandaloneDeriving #-} {-# language TypeApplications #-} +{-# language PartialTypeSignatures #-} + module Main ( main ) @@ -36,7 +38,10 @@ import Data.Word (Word32, Word8) import GHC.Generics ( Generic ) import Prelude hiding (truncate) +import Debug.Trace + -- bytestring +import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy -- case-insensitive @@ -52,10 +57,11 @@ import Hasql.Session ( sql, run ) -- hasql-transaction import Hasql.Transaction ( Transaction, condemn, statement ) +import qualified Hasql.Transaction as Hasql import qualified Hasql.Transaction.Sessions as Hasql -- hedgehog -import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen ) +import Hedgehog ( annotate, footnote, failure, property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen ) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range @@ -69,6 +75,8 @@ import Data.DoubleWord (Word128(..)) -- rel8 import Rel8 ( Result ) import qualified Rel8 +import qualified Rel8.Generic.Rel8able.Test as Rel8able +import qualified Rel8.Table.Verify as Verify -- scientific import Data.Scientific ( Scientific ) @@ -138,10 +146,9 @@ tests = , testSelectArray getTestDatabase , testNestedMaybeTable getTestDatabase , testEvaluate getTestDatabase + , testShowCreateTable getTestDatabase ] - where - startTestDatabase = do db <- TmpPostgres.start >>= either throwIO return @@ -162,6 +169,71 @@ connect :: TmpPostgres.DB -> IO Connection connect = acquire . TmpPostgres.toConnectionString >=> either (maybe empty (fail . unpack . decodeUtf8)) pure +testShowCreateTable :: IO TmpPostgres.DB -> TestTree +testShowCreateTable getTestDatabase = testGroup "CREATE TABLE" + [ testTypeChecker "tableTest" Rel8able.tableTest Rel8able.genTableTest getTestDatabase + , testTypeChecker "tablePair" Rel8able.tablePair Rel8able.genTablePair getTestDatabase + , testTypeChecker "tableMaybe" Rel8able.tableMaybe Rel8able.genTableMaybe getTestDatabase + , testTypeChecker "tableEither" Rel8able.tableEither Rel8able.genTableEither getTestDatabase + , testTypeChecker "tableThese" Rel8able.tableThese Rel8able.genTableThese getTestDatabase + , testTypeChecker "tableList" Rel8able.tableList Rel8able.genTableList getTestDatabase + , testTypeChecker "tableNest" Rel8able.tableNest Rel8able.genTableNest getTestDatabase + , testTypeChecker "nonRecord" Rel8able.nonRecord Rel8able.genNonRecord getTestDatabase + , testTypeChecker "tableProduct" Rel8able.tableProduct Rel8able.genTableProduct getTestDatabase + , testTypeChecker "tableType" Rel8able.tableType Rel8able.genTableType getTestDatabase + , testWrongTable getTestDatabase + , testDuplicateTable getTestDatabase + ] + where + -- confirms that the type checker fails when no type errors are present in a + -- table with duplicate column names + testDuplicateTable = databasePropertyTest "duplicate columns" \transaction -> transaction do + lift $ Hasql.sql $ B.pack $ Verify.showCreateTable Rel8able.tableDuplicate + typeErrors <- lift $ statement () $ Verify.getSchemaErrors [Verify.SomeTableSchema Rel8able.tableDuplicate] + case typeErrors of + Nothing -> failure + Just _ -> pure () + + -- confirms that the type checker fails if the types mismatch + testWrongTable = databasePropertyTest "type mismatch" \transaction -> transaction do + lift $ Hasql.sql $ B.pack $ Verify.showCreateTable Rel8able.tableType + typeErrors <- lift $ statement () $ Verify.getSchemaErrors [Verify.SomeTableSchema Rel8able.badTableType] + case typeErrors of + Nothing -> failure + Just _ -> pure () + + testTypeChecker :: + ( Show (k Result), Rel8.Rel8able k, Rel8.Selects (k Rel8.Name) (k Rel8.Expr) + , Rel8.Serializable (k Rel8.Expr) (k Rel8.Result)) + => TestName -> Rel8.TableSchema (k Rel8.Name) -> Gen (k Result) -> IO TmpPostgres.DB -> TestTree + testTypeChecker testName tableSchema genRows = databasePropertyTest testName \transaction -> do + rows <- forAll $ Gen.list (Range.linear 0 10) genRows + + transaction do + lift $ Hasql.sql $ B.pack $ Verify.showCreateTable tableSchema + typeErrors <- lift $ statement () $ Verify.getSchemaErrors [Verify.SomeTableSchema tableSchema] + case typeErrors of + Nothing -> pure () + Just typ -> do + annotate (unpack typ) + failure + + selected <- lift do + statement () $ Rel8.run_ $ Rel8.insert Rel8.Insert + { into = tableSchema + , rows = Rel8.values $ map Rel8.lit rows + , onConflict = Rel8.DoNothing + , returning = Rel8.NoReturning + } + statement () $ Rel8.run $ Rel8.select do + Rel8.each tableSchema + + -- not every type we use this with has an ord instance, and we're + -- primarily checking the type checker here, not the parser/printer, + -- so we this is only here as one additional check + length selected === length rows + + databasePropertyTest :: TestName -> ((TestT Transaction () -> PropertyT IO ()) -> PropertyT IO ()) diff --git a/tests/Rel8/Generic/Rel8able/Test.hs b/tests/Rel8/Generic/Rel8able/Test.hs index 7a8fc87c..8df7c796 100644 --- a/tests/Rel8/Generic/Rel8able/Test.hs +++ b/tests/Rel8/Generic/Rel8able/Test.hs @@ -1,3 +1,4 @@ +{-# language ScopedTypeVariables #-} {-# language DataKinds #-} {-# language DeriveAnyClass #-} {-# language DeriveGeneric #-} @@ -5,9 +6,13 @@ {-# language DuplicateRecordFields #-} {-# language FlexibleInstances #-} {-# language MultiParamTypeClasses #-} +{-# language OverloadedStrings #-} +{-# language StandaloneDeriving #-} {-# language StandaloneKindSignatures #-} +{-# language TypeApplications #-} {-# language TypeFamilies #-} {-# language TypeOperators #-} +{-# language RecordWildCards #-} {-# language UndecidableInstances #-} {-# options_ghc -O0 #-} @@ -17,15 +22,89 @@ module Rel8.Generic.Rel8able.Test ) where +-- aeson +import Data.Aeson ( Value(..) ) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.KeyMap as Aeson + -- base +import Data.Fixed ( Fixed ( MkFixed ), E2 ) +import Data.Int ( Int16, Int32, Int64 ) +import Data.Functor.Identity ( Identity(..) ) +import qualified Data.List.NonEmpty as NonEmpty import GHC.Generics ( Generic ) import Prelude +import Control.Applicative ( liftA3 ) + +-- bytestring +import Data.ByteString ( ByteString ) +import qualified Data.ByteString.Lazy as LB + +-- case-insensitive +import Data.CaseInsensitive ( CI ) +import qualified Data.CaseInsensitive as CI + +-- containers +import qualified Data.Map as Map + +-- hedgehog +import qualified Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +-- network-ip +import qualified Network.IP.Addr as IP -- rel8 import Rel8 +-- scientific +import Data.Scientific ( Scientific, fromFloatDigits ) + +-- time +import Data.Time.Calendar (Day) +import Data.Time.Clock (UTCTime(..), secondsToDiffTime, secondsToNominalDiffTime) +import Data.Time.LocalTime + ( CalendarDiffTime (CalendarDiffTime) + , LocalTime(..) + , TimeOfDay(..) + ) + -- text import Data.Text ( Text ) +import qualified Data.Text.Lazy as LT + +-- these +import Data.These + +-- uuid +import Data.UUID ( UUID ) +import qualified Data.UUID as UUID + +-- vector +import Data.Vector ( Vector ) +import qualified Data.Vector as Vector + + +makeSchema :: forall f. Rel8able f => QualifiedName -> TableSchema (f Name) +makeSchema name = TableSchema + { name = name + , columns = namesFromLabels @(f Name) + } + + +data TableDuplicate f = TableDuplicate + { foo :: TablePair f + , bar :: TablePair f + } + deriving stock Generic + deriving anyclass Rel8able + +tableDuplicate :: TableSchema (TableDuplicate Name) +tableDuplicate = TableSchema + { name = "tableDuplicate" + , columns = namesFromLabelsWith NonEmpty.last + } data TableTest f = TableTest @@ -34,6 +113,15 @@ data TableTest f = TableTest } deriving stock Generic deriving anyclass Rel8able +deriving stock instance f ~ Result => Show (TableTest f) +deriving stock instance f ~ Result => Eq (TableTest f) +deriving stock instance f ~ Result => Ord (TableTest f) + +tableTest :: TableSchema (TableTest Name) +tableTest = makeSchema "tableTest" + +genTableTest :: Hedgehog.MonadGen m => m (TableTest Result) +genTableTest = TableTest <$> Gen.bool <*> Gen.maybe Gen.bool data TablePair f = TablePair @@ -42,6 +130,17 @@ data TablePair f = TablePair } deriving stock Generic deriving anyclass Rel8able +deriving stock instance f ~ Result => Show (TablePair f) +deriving stock instance f ~ Result => Eq (TablePair f) +deriving stock instance f ~ Result => Ord (TablePair f) + +tablePair :: TableSchema (TablePair Name) +tablePair = makeSchema "tablePair" + +genTablePair :: Hedgehog.MonadGen m => m (TablePair Result) +genTablePair = TablePair + <$> Gen.bool + <*> liftA2 (,) (Gen.text (Range.linear 0 10) Gen.alphaNum) (Gen.text (Range.linear 0 10) Gen.alphaNum) data TableMaybe f = TableMaybe @@ -50,6 +149,17 @@ data TableMaybe f = TableMaybe } deriving stock Generic deriving anyclass Rel8able +deriving stock instance f ~ Result => Show (TableMaybe f) +deriving stock instance f ~ Result => Eq (TableMaybe f) +deriving stock instance f ~ Result => Ord (TableMaybe f) + +tableMaybe :: TableSchema (TableMaybe Name) +tableMaybe = makeSchema "tableMaybe" + +genTableMaybe :: Hedgehog.MonadGen m => m (TableMaybe Result) +genTableMaybe = TableMaybe + <$> Gen.list (Range.linear 0 10) (Gen.maybe Gen.bool) + <*> Gen.maybe (liftA2 (,) genTablePair genTablePair) data TableEither f = TableEither @@ -58,6 +168,17 @@ data TableEither f = TableEither } deriving stock Generic deriving anyclass Rel8able +deriving stock instance f ~ Result => Show (TableEither f) +deriving stock instance f ~ Result => Eq (TableEither f) +deriving stock instance f ~ Result => Ord (TableEither f) + +tableEither :: TableSchema (TableEither Name) +tableEither = makeSchema "tableEither" + +genTableEither :: Hedgehog.MonadGen m => m (TableEither Result) +genTableEither = TableEither + <$> Gen.bool + <*> Gen.either (Gen.maybe $ liftA2 (,) genTablePair genTablePair) Gen.alphaNum data TableThese f = TableThese @@ -66,6 +187,21 @@ data TableThese f = TableThese } deriving stock Generic deriving anyclass Rel8able +deriving stock instance f ~ Result => Show (TableThese f) +deriving stock instance f ~ Result => Eq (TableThese f) +deriving stock instance f ~ Result => Ord (TableThese f) + +tableThese :: TableSchema (TableThese Name) +tableThese = makeSchema "tableThese" + +genTableThese :: Hedgehog.MonadGen m => m (TableThese Result) +genTableThese = TableThese + <$> Gen.bool + <*> Gen.choice + [ This <$> genTableMaybe + , That <$> genTableEither + , These <$> genTableMaybe <*> genTableEither + ] data TableList f = TableList @@ -74,6 +210,17 @@ data TableList f = TableList } deriving stock Generic deriving anyclass Rel8able +deriving stock instance f ~ Result => Show (TableList f) +deriving stock instance f ~ Result => Eq (TableList f) +deriving stock instance f ~ Result => Ord (TableList f) + +tableList :: TableSchema (TableList Name) +tableList = makeSchema "tableList" + +genTableList :: Hedgehog.MonadGen m => m (TableList Result) +genTableList = TableList + <$> Gen.bool + <*> Gen.list (Range.linear 0 10) genTableThese data TableNonEmpty f = TableNonEmpty @@ -82,6 +229,17 @@ data TableNonEmpty f = TableNonEmpty } deriving stock Generic deriving anyclass Rel8able +deriving stock instance f ~ Result => Show (TableNonEmpty f) +deriving stock instance f ~ Result => Eq (TableNonEmpty f) +deriving stock instance f ~ Result => Ord (TableNonEmpty f) + +tableNonEmpty :: TableSchema (TableNonEmpty Name) +tableNonEmpty = makeSchema "tableNonEmpty" + +genTableNonEmpty :: Hedgehog.MonadGen m => m (TableNonEmpty Result) +genTableNonEmpty = TableNonEmpty + <$> Gen.bool + <*> Gen.nonEmpty (Range.linear 0 10) (liftA2 (,) genTableList genTableMaybe) data TableNest f = TableNest @@ -90,24 +248,41 @@ data TableNest f = TableNest } deriving stock Generic deriving anyclass Rel8able +deriving stock instance f ~ Result => Show (TableNest f) +deriving stock instance f ~ Result => Eq (TableNest f) +deriving stock instance f ~ Result => Ord (TableNest f) + +tableNest :: TableSchema (TableNest Name) +tableNest = makeSchema "tableNest" + +genTableNest :: Hedgehog.MonadGen m => m (TableNest Result) +genTableNest = TableNest + <$> Gen.bool + <*> Gen.list (Range.linear 0 10) (Gen.maybe genTablePair) data S3Object = S3Object { bucketName :: Text , objectKey :: Text } - deriving stock Generic + deriving stock (Generic, Show, Eq, Ord) instance x ~ HKD S3Object Expr => ToExprs x S3Object data HKDSum = HKDSumA Text | HKDSumB Bool Char | HKDSumC - deriving stock Generic + deriving stock (Generic, Show, Eq, Ord) instance x ~ HKD HKDSum Expr => ToExprs x HKDSum +genHKDSum :: Hedgehog.MonadGen m => m HKDSum +genHKDSum = Gen.choice + [ HKDSumA <$> Gen.text (Range.linear 0 10) Gen.alpha + , HKDSumB <$> Gen.bool <*> Gen.alpha + , pure HKDSumC + ] data HKDTest f = HKDTest { s3Object :: Lift f S3Object @@ -115,7 +290,14 @@ data HKDTest f = HKDTest } deriving stock Generic deriving anyclass Rel8able +deriving stock instance f ~ Result => Show (HKDTest f) +deriving stock instance f ~ Result => Eq (HKDTest f) +deriving stock instance f ~ Result => Ord (HKDTest f) +genHKDTest :: Hedgehog.MonadGen m => m (HKDTest Result) +genHKDTest = HKDTest + <$> liftA2 S3Object (Gen.text (Range.linear 0 10) Gen.alpha) (Gen.text (Range.linear 0 10) Gen.alpha) + <*> genHKDSum data NonRecord f = NonRecord (Column f Bool) @@ -130,6 +312,25 @@ data NonRecord f = NonRecord (Column f Char) deriving stock Generic deriving anyclass Rel8able +deriving stock instance f ~ Result => Show (NonRecord f) +deriving stock instance f ~ Result => Eq (NonRecord f) +deriving stock instance f ~ Result => Ord (NonRecord f) + +nonRecord :: TableSchema (NonRecord Name) +nonRecord = makeSchema "nonRecord" + +genNonRecord :: Hedgehog.MonadGen m => m (NonRecord Result) +genNonRecord = NonRecord + <$> Gen.bool + <*> Gen.alpha + <*> Gen.alpha + <*> Gen.alpha + <*> Gen.alpha + <*> Gen.alpha + <*> Gen.alpha + <*> Gen.alpha + <*> Gen.alpha + <*> Gen.alpha data TableSum f @@ -137,6 +338,17 @@ data TableSum f | TableSumB | TableSumC (Column f Text) deriving stock Generic +deriving stock instance f ~ Result => Show (TableSum f) +deriving stock instance f ~ Result => Eq (TableSum f) +deriving stock instance f ~ Result => Ord (TableSum f) + + +genTableSum :: Hedgehog.MonadGen m => m (HADT Result TableSum) +genTableSum = Gen.choice + [ TableSumA <$> Gen.bool <*> Gen.text (Range.linear 0 10) Gen.alpha + , pure TableSumB + , TableSumC <$> Gen.text (Range.linear 0 10) Gen.alpha + ] data BarbieSum f @@ -144,6 +356,17 @@ data BarbieSum f | BarbieSumB | BarbieSumC (f Text) deriving stock Generic +deriving stock instance f ~ Result => Show (BarbieSum f) +deriving stock instance f ~ Result => Eq (BarbieSum f) +deriving stock instance f ~ Result => Ord (BarbieSum f) + + +genBarbieSum :: Hedgehog.MonadGen m => m (BarbieSum Result) +genBarbieSum = Gen.choice + [ BarbieSumA <$> fmap Identity Gen.bool <*> fmap Identity (Gen.text (Range.linear 0 10) Gen.alpha) + , pure BarbieSumB + , BarbieSumC <$> fmap Identity (Gen.text (Range.linear 0 10) Gen.alpha) + ] data TableProduct f = TableProduct @@ -153,7 +376,31 @@ data TableProduct f = TableProduct } deriving stock Generic deriving anyclass Rel8able - +deriving stock instance f ~ Result => Show (TableProduct f) +deriving stock instance f ~ Result => Eq (TableProduct f) +deriving stock instance f ~ Result => Ord (TableProduct f) + +tableProduct :: TableSchema (TableProduct Name) +tableProduct = makeSchema "tableProduct" + +genTableProduct :: Hedgehog.MonadGen m => m (TableProduct Result) +genTableProduct = TableProduct + <$> genBarbieSum + <*> genTableList + <*> Gen.list (Range.linear 0 10) (liftA3 (,,) genTableSum genHKDSum genHKDTest) + +-- tableProduct :: TableProduct Name +-- tableProduct = makeSchema "tableProduct" + +-- genTableProduct :: Hedgehog.MonadGen m => m (TableProduct Result) +-- genTableProduct = TableProduct +-- <$> Gen.choice +-- [ BarbieSumA <$> Gen.bool <*> Gen.text (Range.linear 0 10) Gen.alpha +-- , BarbieSumB +-- , BarbieSumC <$> Gen.text (Range.linear 0 10) Gen.alpha +-- ] +-- <*> genTableList +-- <*> Gen.list (Range.linear 0 10) (liftA3 (,,) genTableSum) data TableTestB f = TableTestB { foo :: f Bool @@ -187,3 +434,84 @@ data Nest t u f = Nest } deriving stock Generic deriving anyclass Rel8able + + +data TableType f = TableType + { bool :: Column f Bool + , char :: Column f Char + , int16 :: Column f Int16 + , int32 :: Column f Int32 + , int64 :: Column f Int64 + , float :: Column f Float + , double :: Column f Double + , scientific :: Column f Scientific + , fixed :: Column f (Fixed E2) + , utctime :: Column f UTCTime + , day :: Column f Day + , localtime :: Column f LocalTime + , timeofday :: Column f TimeOfDay + , calendardifftime :: Column f CalendarDiffTime + , text :: Column f Text + , lazytext :: Column f LT.Text + , citext :: Column f (CI Text) + , cilazytext :: Column f (CI LT.Text) + , bytestring :: Column f ByteString + , lazybytestring :: Column f LB.ByteString + , uuid :: Column f UUID + , value :: Column f Value + , netaddr :: Column f (IP.NetAddr IP.IP) + } deriving stock (Generic) +deriving anyclass instance Rel8able TableType +deriving stock instance f ~ Result => Show (TableType f) +deriving stock instance f ~ Result => Eq (TableType f) +-- deriving stock instance f ~ Result => Ord (TableType f) + +tableType :: TableSchema (TableType Name) +tableType = makeSchema "tableType" + +badTableType :: TableSchema (TableProduct Name) +badTableType = makeSchema "tableType" + +genTableType :: Hedgehog.MonadGen m => m (TableType Result) +genTableType = do + bool <- Gen.bool + char <- Gen.alpha + int16 <- Gen.int16 range + int32 <- Gen.int32 range + int64 <- Gen.int64 range + float <- Gen.float linearFrac + double <- Gen.double linearFrac + scientific <- fromFloatDigits <$> Gen.realFloat linearFrac + utctime <- UTCTime <$> (toEnum <$> Gen.integral range) <*> fmap secondsToDiffTime (Gen.integral range) + day <- toEnum <$> Gen.integral range + localtime <- LocalTime <$> (toEnum <$> Gen.integral range) <*> timeOfDay + timeofday <- timeOfDay + text <- Gen.text range Gen.alpha + lazytext <- LT.fromStrict <$> Gen.text range Gen.alpha + citext <- CI.mk <$> Gen.text range Gen.alpha + cilazytext <- CI.mk <$> LT.fromStrict <$> Gen.text range Gen.alpha + bytestring <- Gen.bytes range + lazybytestring <- LB.fromStrict <$> Gen.bytes range + uuid <- UUID.fromWords <$> Gen.word32 range <*> Gen.word32 range <*> Gen.word32 range <*> Gen.word32 range + fixed <- MkFixed <$> Gen.integral range + value <- Gen.choice + [ Object <$> Aeson.fromMapText <$> Map.fromList <$> Gen.list range (liftA2 (,) (Gen.text range Gen.alpha) (pure Null)) + , Array <$> Vector.fromList <$> Gen.list range (pure Null) + , String <$> Gen.text range Gen.alpha + , Number <$> fromFloatDigits <$> Gen.realFloat linearFrac + , Bool <$> Gen.bool + , pure Null + ] + netaddr <- IP.netAddr <$> Gen.choice [IP.IPv4 <$> IP.IP4 <$> Gen.word32 range, IP.IPv6 <$> IP.IP6 <$> Gen.integral range] <*> Gen.word8 range + calendardifftime <- CalendarDiffTime <$> Gen.integral range <*> (secondsToNominalDiffTime <$> Gen.realFrac_ linearFrac) + pure TableType {..} + where + timeOfDay :: Hedgehog.MonadGen m => m TimeOfDay + timeOfDay = TimeOfDay <$> Gen.integral range <*> Gen.integral range <*> Gen.realFrac_ linearFrac + + range :: Integral a => Range.Range a + range = Range.linear 0 10 + + linearFrac :: (Fractional a, Ord a) => Range.Range a + linearFrac = Range.linearFrac 0 10 +