mirror of
https://github.com/circuithub/rel8.git
synced 2024-09-11 16:05:41 +03:00
Implement schema typechecker
This closes #274 and #186, allowing the generation of CREATE TABLE statements from a TableSchema, as well as checking a TableSchema against a database to determine if the tables are defined correctly in the database to be read from/written to by rel8. It also adds tests for the creation and type checking of tables, to ensure they succeed/fail in appropriate cases. Co-authored-by: David Kraeutmann <kane@kane.cx>
This commit is contained in:
Abigail Gooding
parent
9580b6ffb3
commit
a23cd8227a
@ -29,6 +29,7 @@ library
|
||||
, bytestring
|
||||
, case-insensitive
|
||||
, comonad
|
||||
, containers
|
||||
, contravariant
|
||||
, data-textual
|
||||
, hasql ^>= 1.6.1.2
|
||||
@ -65,6 +66,7 @@ library
|
||||
Rel8.Expr.Num
|
||||
Rel8.Expr.Text
|
||||
Rel8.Expr.Time
|
||||
Rel8.Table.Verify
|
||||
Rel8.Tabulate
|
||||
|
||||
other-modules:
|
||||
@ -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
|
||||
|
||||
642
src/Rel8/Table/Verify.hs
Normal file
642
src/Rel8/Table/Verify.hs
Normal file
@ -0,0 +1,642 @@
|
||||
|
||||
{-# 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 Control.Monad
|
||||
import Data.Bits (shiftR, (.&.))
|
||||
import Data.Either (lefts)
|
||||
import Data.Function
|
||||
import Data.Functor ((<&>))
|
||||
import Data.Functor.Const
|
||||
import Data.Functor.Contravariant ( (>$<) )
|
||||
import Data.Int ( Int16, Int64 )
|
||||
import qualified Data.List as L
|
||||
import Data.List.NonEmpty ( NonEmpty((:|)) )
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Data.Maybe (isJust, mapMaybe)
|
||||
import Data.Text ( Text )
|
||||
import qualified Data.Text as T
|
||||
import GHC.Generics
|
||||
import Prelude hiding ( filter )
|
||||
import qualified Prelude as P
|
||||
|
||||
-- containers
|
||||
import qualified Data.Map as M
|
||||
|
||||
-- hasql
|
||||
import Hasql.Connection
|
||||
import qualified Hasql.Statement as HS
|
||||
|
||||
-- rel8
|
||||
import Rel8 -- not importing this seems to cause a type error???
|
||||
import Rel8.Column ( Column )
|
||||
import Rel8.Column.List ( HList )
|
||||
import Rel8.Expr ( Expr )
|
||||
import Rel8.Generic.Rel8able (GFromExprs, Rel8able)
|
||||
import Rel8.Query ( Query )
|
||||
import Rel8.Schema.HTable
|
||||
import Rel8.Schema.Name ( Name(Name) )
|
||||
import Rel8.Schema.Null hiding (nullable)
|
||||
import qualified Rel8.Schema.Null as Null
|
||||
import qualified Rel8.Statement.Run as RSR
|
||||
import Rel8.Schema.Table ( TableSchema(..) )
|
||||
import Rel8.Schema.Spec
|
||||
import Rel8.Schema.Result ( Result )
|
||||
import Rel8.Schema.QualifiedName ( QualifiedName(..) )
|
||||
import Rel8.Table ( Columns )
|
||||
import Rel8.Table.List ( ListTable )
|
||||
import Rel8.Table.Serialize ( ToExprs )
|
||||
import Rel8.Type ( DBType(..) )
|
||||
import Rel8.Type.Eq ( DBEq )
|
||||
import Rel8.Type.Name ( TypeName(..) )
|
||||
|
||||
-- these
|
||||
import Data.These
|
||||
|
||||
|
||||
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
|
||||
, atttypmod :: 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
|
||||
, typnamespace :: Column f Oid
|
||||
}
|
||||
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
|
||||
, namespace :: PGNamespace 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)
|
||||
|
||||
namespace <-
|
||||
each pgnamespace
|
||||
>>= filter (\PGNamespace{ oid = nsoid } -> nsoid ==. typ.typnamespace)
|
||||
|
||||
|
||||
|
||||
return Attribute{ attribute, typ, namespace }
|
||||
|
||||
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 " <> 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
|
||||
|
||||
-- |@'checkedShowCreateTable'@ 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 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 -> TypeInfo -> TypeInfo -> Maybe ColumnError
|
||||
checkTypeEquality env db hs
|
||||
| Prelude.and [sameDims, sameMods, toName db == toName hs || castExists]
|
||||
= Nothing
|
||||
| otherwise
|
||||
= Just BidirectionalCastDoesNotExist
|
||||
where
|
||||
castExists = Prelude.and
|
||||
[ (toName db, toName hs) `elem` env.casts
|
||||
, (toName hs, toName db) `elem` env.casts
|
||||
]
|
||||
|
||||
sameMods, sameDims :: Bool
|
||||
sameMods = db.typeName.modifiers == hs.typeName.modifiers
|
||||
sameDims = db.typeName.arrayDepth == hs.typeName.arrayDepth
|
||||
|
||||
sameName = equalName db.typeName.name hs.typeName.name
|
||||
|
||||
toName :: TypeInfo -> String
|
||||
toName typeInfo = case typeInfo.typeName.name of
|
||||
QualifiedName name _ -> L.dropWhile (=='_') name
|
||||
|
||||
equalName :: QualifiedName -> QualifiedName -> Bool
|
||||
equalName (QualifiedName a (Just b)) (QualifiedName a' (Just b'))
|
||||
= L.dropWhile (=='_') a == L.dropWhile (=='_') a' && b == b'
|
||||
equalName (QualifiedName a _) (QualifiedName a' _)
|
||||
= dropWhile (=='_') a == dropWhile (=='_') a'
|
||||
|
||||
-- check types for a single table
|
||||
compareTypes
|
||||
:: CheckEnv
|
||||
-> M.Map String (Attribute Result)
|
||||
-> M.Map String TypeInfo
|
||||
-> [ColumnInfo]
|
||||
compareTypes env attrMap typeMap = fmap (uncurry go) $ M.assocs (disjointUnion attrMap typeMap)
|
||||
where
|
||||
go :: String -> These (Attribute Result) TypeInfo -> ColumnInfo
|
||||
go name (These a b) = ColumnInfo
|
||||
{ name = name
|
||||
, dbType = Just $ fromAttribute a
|
||||
, hsType = Just $ b
|
||||
, error = checkTypeEquality env (fromAttribute a) b
|
||||
}
|
||||
go name (This a) = ColumnInfo
|
||||
{ name = name
|
||||
, dbType = Just $ fromAttribute a
|
||||
, hsType = Nothing
|
||||
, error =
|
||||
if a.attribute.attnotnull
|
||||
then Just DbTypeIsNotNullButNotPresentInHsType
|
||||
else Nothing
|
||||
}
|
||||
go name (That b) = ColumnInfo
|
||||
{ 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)
|
||||
(Just $ T.unpack attr.namespace.nspname)
|
||||
, modifiers = toModifier
|
||||
(T.dropWhile (=='_') attr.typ.typname)
|
||||
attr.attribute.atttypmod
|
||||
, arrayDepth = fromIntegral attr.attribute.attndims
|
||||
}
|
||||
}
|
||||
|
||||
toModifier :: Text -> Int64 -> [String]
|
||||
toModifier "bpchar" (-1) = []
|
||||
toModifier "bpchar" n = [show (n - 4)]
|
||||
toModifier "numeric" (-1) = []
|
||||
toModifier "numeric" n = [show $ (n - 4) `shiftR` 16, show $ (n - 4) .&. 65535]
|
||||
toModifier _ _ = []
|
||||
|
||||
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 :: [TableInfo] -> Text
|
||||
pShowErrors = T.intercalate "\n\n" . fmap go
|
||||
where
|
||||
go :: TableInfo -> Text
|
||||
go (TableInfo {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}) = mconcat
|
||||
[ "Table "
|
||||
, T.pack (show name)
|
||||
, " has multiple columns with the same name. This is an error with the Haskell code generating an impossible schema, rather than an error in your current setup of the database itself. 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 new 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 TableInfo
|
||||
= TableInfo
|
||||
{ tableExists :: Bool
|
||||
, name :: String
|
||||
, columns :: [ColumnInfo]
|
||||
}
|
||||
| DuplicateNames
|
||||
{ name :: String
|
||||
, duplicates :: M.Map String (NonEmpty.NonEmpty TypeInfo)
|
||||
}
|
||||
deriving (Show)
|
||||
data ColumnInfo = ColumnInfo
|
||||
{ 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 = concat
|
||||
[ name
|
||||
, if Prelude.null modifiers then "" else "(" <> L.intercalate "," modifiers <> ")"
|
||||
, concat (replicate (fromIntegral typeInfo.typeName.arrayDepth) "[]")
|
||||
, if typeInfo.isNull then "" else " NOT NULL"
|
||||
]
|
||||
where
|
||||
name = case typeInfo.typeName.name of
|
||||
QualifiedName a Nothing -> show (dropWhile (=='_') a)
|
||||
QualifiedName a (Just b) -> show b <> "." <> show (dropWhile (=='_') a)
|
||||
|
||||
modifiers :: [String]
|
||||
modifiers = typeInfo.typeName.modifiers
|
||||
|
||||
|
||||
verifySchema :: Rel8able k => CheckEnv -> TableSchema (k Name) -> TableInfo
|
||||
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 = TableInfo
|
||||
{ tableExists = False
|
||||
, name = schema.name.name
|
||||
, columns = compareTypes env mempty typeMap
|
||||
}
|
||||
go typeMap (Just attrs) = TableInfo
|
||||
{ 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 :: [TableInfo] -> Maybe [TableInfo]
|
||||
filterErrors tables = case mapMaybe go tables of
|
||||
[] -> Nothing
|
||||
xs -> Just xs
|
||||
where
|
||||
go :: TableInfo -> Maybe TableInfo
|
||||
go TableInfo {..} = case P.filter (\cd -> isJust cd.error) columns of
|
||||
[] -> if tableExists then Nothing else Just $ TableInfo { name , tableExists , columns = [] }
|
||||
xs -> Just $ TableInfo { name , tableExists , columns = xs }
|
||||
go DuplicateNames {..} = Just (DuplicateNames {..})
|
||||
|
||||
|
||||
112
tests/Main.hs
112
tests/Main.hs
@ -13,6 +13,8 @@
|
||||
{-# language StandaloneDeriving #-}
|
||||
{-# language TypeApplications #-}
|
||||
|
||||
{-# language PartialTypeSignatures #-}
|
||||
|
||||
module Main
|
||||
( main
|
||||
)
|
||||
@ -37,6 +39,7 @@ import GHC.Generics ( Generic )
|
||||
import Prelude hiding (truncate)
|
||||
|
||||
-- bytestring
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString.Lazy
|
||||
|
||||
-- case-insensitive
|
||||
@ -52,10 +55,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, failure, property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )
|
||||
import qualified Hedgehog.Gen as Gen
|
||||
import qualified Hedgehog.Range as Range
|
||||
|
||||
@ -69,6 +73,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 )
|
||||
@ -139,10 +145,9 @@ tests =
|
||||
, testSelectArray getTestDatabase
|
||||
, testNestedMaybeTable getTestDatabase
|
||||
, testEvaluate getTestDatabase
|
||||
, testShowCreateTable getTestDatabase
|
||||
]
|
||||
|
||||
where
|
||||
|
||||
startTestDatabase = do
|
||||
db <- TmpPostgres.start >>= either throwIO return
|
||||
|
||||
@ -163,6 +168,107 @@ 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
|
||||
, testCharMismatch getTestDatabase
|
||||
, testNumericMismatch getTestDatabase
|
||||
]
|
||||
where
|
||||
-- confirms that the type checker works correctly for numeric modifiers
|
||||
testNumericMismatch = databasePropertyTest "numeric mismatch" \transaction -> transaction do
|
||||
lift $ Hasql.sql $ "create table \"tableNumeric\" ( foo numeric(1000, 4) not null );"
|
||||
typeErrors <- lift $ statement () $ Verify.getSchemaErrors
|
||||
[Verify.SomeTableSchema Rel8able.tableNumeric]
|
||||
case typeErrors of
|
||||
Nothing -> failure
|
||||
Just _ -> pure ()
|
||||
lift $ Hasql.sql $ "alter table \"tableNumeric\" alter column foo set data type numeric(1000, 2);"
|
||||
typeErrors <- lift $ statement () $ Verify.getSchemaErrors
|
||||
[Verify.SomeTableSchema Rel8able.tableNumeric]
|
||||
case typeErrors of
|
||||
Nothing -> pure ()
|
||||
Just _ -> failure
|
||||
|
||||
-- tests that the type checker works correctly for bpchar modifiers
|
||||
testCharMismatch = databasePropertyTest "bpchar mismatch" \transaction -> transaction do
|
||||
lift $ Hasql.sql $ "create table \"tableChar\" ( foo bpchar(2) not null );"
|
||||
typeErrors <- lift $ statement () $ Verify.getSchemaErrors
|
||||
[Verify.SomeTableSchema Rel8able.tableChar]
|
||||
case typeErrors of
|
||||
Nothing -> failure
|
||||
Just _ -> pure ()
|
||||
lift $ Hasql.sql $ "alter table \"tableChar\" alter column foo set data type bpchar(1);"
|
||||
typeErrors <- lift $ statement () $ Verify.getSchemaErrors
|
||||
[Verify.SomeTableSchema Rel8able.tableChar]
|
||||
case typeErrors of
|
||||
Nothing -> pure ()
|
||||
Just a -> do
|
||||
annotate (unpack a)
|
||||
failure
|
||||
|
||||
-- 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 ())
|
||||
|
||||
@ -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,107 @@ 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
|
||||
|
||||
|
||||
data TableNumeric f = TableNumeric
|
||||
{ foo :: Column f (Fixed E2)
|
||||
} deriving stock (Generic)
|
||||
deriving anyclass instance Rel8able TableNumeric
|
||||
deriving stock instance f ~ Result => Show (TableNumeric f)
|
||||
deriving stock instance f ~ Result => Eq (TableNumeric f)
|
||||
|
||||
tableNumeric :: TableSchema (TableNumeric Name)
|
||||
tableNumeric = makeSchema "tableNumeric"
|
||||
|
||||
|
||||
data TableChar f = TableChar
|
||||
{ foo :: Column f Char
|
||||
} deriving stock (Generic)
|
||||
deriving anyclass instance Rel8able TableChar
|
||||
deriving stock instance f ~ Result => Show (TableChar f)
|
||||
deriving stock instance f ~ Result => Eq (TableChar f)
|
||||
|
||||
tableChar :: TableSchema (TableChar Name)
|
||||
tableChar = makeSchema "tableChar"
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user