generated from tpl/purs
212 lines
7.2 KiB
Haskell
212 lines
7.2 KiB
Haskell
module Test.Data.Postgres where
|
|
|
|
import Prelude
|
|
|
|
import Control.Monad.Gen (chooseInt, elements, oneOf)
|
|
import Control.Parallel (parTraverse_)
|
|
import Data.Array (intercalate)
|
|
import Data.Array as Array
|
|
import Data.Array.NonEmpty as Array.NonEmpty
|
|
import Data.DateTime (DateTime(..), canonicalDate)
|
|
import Data.DateTime.Instant as Instant
|
|
import Data.Enum (toEnum)
|
|
import Data.Foldable (fold)
|
|
import Data.Identity (Identity)
|
|
import Data.Int as Int
|
|
import Data.Maybe (Maybe(..), fromJust, maybe)
|
|
import Data.Newtype (class Newtype, unwrap, wrap)
|
|
import Data.Number (abs) as Number
|
|
import Data.Postgres (class Rep)
|
|
import Data.Postgres.Query.Builder as Q
|
|
import Data.Postgres.Raw (Raw, jsNull)
|
|
import Data.Postgres.Raw as Raw
|
|
import Data.Postgres.Result (class FromRow)
|
|
import Data.RFC3339String as DateTime.ISO
|
|
import Data.String as String
|
|
import Data.Time (Time(..))
|
|
import Data.Traversable (for, sequence)
|
|
import Data.Tuple.Nested ((/\))
|
|
import Effect (Effect)
|
|
import Effect.Aff (Aff)
|
|
import Effect.Aff.Postgres.Client (exec, query)
|
|
import Effect.Class (liftEffect)
|
|
import Effect.Postgres.Client (Client)
|
|
import Effect.Unsafe (unsafePerformEffect)
|
|
import Foreign (Foreign, unsafeToForeign)
|
|
import Foreign.Object as Object
|
|
import JS.BigInt (BigInt)
|
|
import JS.BigInt as BigInt
|
|
import Node.Buffer (Buffer)
|
|
import Node.Buffer as Buffer
|
|
import Partial.Unsafe (unsafePartial)
|
|
import Simple.JSON (writeJSON)
|
|
import Test.Common (withClient, withPoolClient)
|
|
import Test.QuickCheck (class Arbitrary, arbitrary, randomSeed)
|
|
import Test.QuickCheck.Gen (sample, vectorOf)
|
|
import Test.Spec (Spec, SpecT, around, describe, it, parallel)
|
|
import Test.Spec.Assertions (fail)
|
|
|
|
foreign import readBigInt64BE :: Buffer -> Effect BigInt
|
|
foreign import dbg :: forall a. a -> Effect Unit
|
|
|
|
newtype GenSmallInt = GenSmallInt Int
|
|
|
|
derive instance Newtype GenSmallInt _
|
|
instance Arbitrary GenSmallInt where
|
|
arbitrary = wrap <$> chooseInt (-32768) 32767
|
|
|
|
newtype GenDateTime = GenDateTime DateTime
|
|
|
|
derive instance Newtype GenDateTime _
|
|
instance Arbitrary GenDateTime where
|
|
arbitrary = do
|
|
yr <- chooseInt 1970 2100
|
|
mo <- chooseInt 1 12
|
|
dy <- chooseInt 1 28
|
|
hr <- chooseInt 0 23
|
|
mn <- chooseInt 0 59
|
|
sc <- chooseInt 0 59
|
|
ms <- chooseInt 0 999
|
|
let
|
|
date = unsafePartial fromJust $ Just canonicalDate <*> toEnum yr <*> toEnum mo <*> toEnum dy
|
|
time = unsafePartial fromJust $ Just Time <*> toEnum hr <*> toEnum mn <*> toEnum sc <*> toEnum ms
|
|
pure $ wrap $ DateTime date time
|
|
|
|
newtype GenString = GenString String
|
|
|
|
derive instance Newtype GenString _
|
|
instance Arbitrary GenString where
|
|
arbitrary = do
|
|
let chars = unsafePartial fromJust $ Array.NonEmpty.fromArray $ String.split (wrap "") "abcdefghijklmnopqrstuvwxyz01234567890 _-=><|\\/"
|
|
len <- chooseInt 0 100
|
|
chars' <- vectorOf len (elements chars)
|
|
pure $ wrap $ fold chars'
|
|
|
|
newtype GenSmallFloat = GenSmallFloat Number
|
|
|
|
derive instance Newtype GenSmallFloat _
|
|
instance Arbitrary GenSmallFloat where
|
|
arbitrary = do
|
|
let byte = chooseInt 0 7
|
|
bytes <- sequence $ Array.replicate 4 byte
|
|
pure
|
|
$ wrap
|
|
$ unsafePerformEffect do
|
|
buf <- Buffer.fromArray bytes
|
|
Buffer.read Buffer.FloatBE 0 buf
|
|
|
|
newtype GenBigInt = GenBigInt BigInt
|
|
|
|
derive instance Newtype GenBigInt _
|
|
|
|
instance Arbitrary GenBigInt where
|
|
arbitrary = do
|
|
let byte = chooseInt 0 7
|
|
bytes <- sequence $ Array.replicate 8 byte
|
|
let
|
|
bigint = unsafePerformEffect do
|
|
buf <- Buffer.fromArray bytes
|
|
readBigInt64BE buf
|
|
pure $ wrap bigint
|
|
|
|
newtype GenJSON = GenJSON Foreign
|
|
|
|
derive instance Newtype GenJSON _
|
|
|
|
instance Arbitrary GenJSON where
|
|
arbitrary =
|
|
let
|
|
json _ = map wrap $ oneOf' [ prim, array unit, obj unit ]
|
|
oneOf' = oneOf <<< unsafePartial fromJust <<< Array.NonEmpty.fromArray
|
|
elements' = elements <<< unsafePartial fromJust <<< Array.NonEmpty.fromArray
|
|
prim = oneOf'
|
|
[ pure $ unsafeToForeign jsNull
|
|
, unsafeToForeign <$> arbitrary @Number
|
|
, unsafeToForeign <$> arbitrary @String
|
|
]
|
|
array _ = map unsafeToForeign $ vectorOf 3 prim
|
|
obj _ = do
|
|
keys <- vectorOf 3 (elements' [ "foo", "bar", "baz", "quux", "duck", "dog", "cat", "cow" ])
|
|
kvs <- for keys \k -> (k /\ _) <$> prim
|
|
pure $ unsafeToForeign $ Object.fromFoldable kvs
|
|
in
|
|
json unit
|
|
|
|
asRaw :: forall a. a -> Raw
|
|
asRaw = Raw.unsafeFromForeign <<< unsafeToForeign
|
|
|
|
type PursType = String
|
|
type SQLType = String
|
|
type FromArbitrary x a = x -> a
|
|
type IsEqual a = a -> a -> Boolean
|
|
|
|
class (Show a, FromRow a, Rep a) <= Checkable a
|
|
|
|
instance (Show a, FromRow a, Rep a) => Checkable a
|
|
|
|
spec :: Spec Unit
|
|
spec =
|
|
let
|
|
check
|
|
:: forall @a @x
|
|
. Checkable a
|
|
=> Arbitrary x
|
|
=> { purs :: String
|
|
, sql :: String
|
|
, fromArb :: x -> a
|
|
, isEq :: a -> a -> Boolean
|
|
}
|
|
-> SpecT Aff Client Identity Unit
|
|
check { purs, sql, fromArb, isEq } =
|
|
it (purs <> " <> " <> sql) \c -> do
|
|
let
|
|
tab =
|
|
String.replace (wrap " ") (wrap "_")
|
|
$ String.replace (wrap "[") (wrap "")
|
|
$ String.replace (wrap "]") (wrap "")
|
|
$ sql <> "_is_" <> String.toLower purs
|
|
createtab =
|
|
intercalate "\n"
|
|
[ "create temp table " <> tab
|
|
, " ( val " <> sql
|
|
, " );"
|
|
]
|
|
ser x =
|
|
Q.build do
|
|
x' <- Q.param $ fromArb x
|
|
let val = x' <> " :: " <> sql
|
|
pure $ "insert into " <> tab <> " values (" <> val <> ")"
|
|
de x =
|
|
Q.build do
|
|
x' <- Q.param $ fromArb x
|
|
let val = x' <> " :: " <> sql
|
|
pure $ "select " <> val
|
|
void $ exec createtab c
|
|
seed <- liftEffect randomSeed
|
|
let xs = sample seed 10 (arbitrary @x)
|
|
flip parTraverse_ xs
|
|
\x -> do
|
|
void $ exec (ser x) c
|
|
res <- query (de x) c
|
|
let
|
|
exp = fromArb x
|
|
act = unsafePartial fromJust $ Array.head res
|
|
when (not $ isEq exp act) $ fail $ "expected " <> show exp <> " to equal " <> show act
|
|
in
|
|
around withPoolClient
|
|
$ describe "Data.Postgres"
|
|
$ do
|
|
check @Int @GenSmallInt { purs: "Int", sql: "int2", fromArb: unwrap, isEq: eq }
|
|
check @Int { purs: "Int", sql: "int4", fromArb: identity, isEq: eq }
|
|
check @String @GenString { purs: "String", sql: "text", fromArb: unwrap, isEq: eq }
|
|
check @Boolean { purs: "Boolean", sql: "bool", fromArb: identity, isEq: eq }
|
|
check @Number @GenSmallFloat { purs: "Number", sql: "float4", fromArb: unwrap, isEq: \a b -> Number.abs (a - b) <= 0.0001 }
|
|
check @Number { purs: "Number", sql: "float8", fromArb: identity, isEq: eq }
|
|
check @BigInt @GenBigInt { purs: "BigInt", sql: "int8", fromArb: unwrap, isEq: eq }
|
|
check @DateTime @GenDateTime { purs: "DateTime", sql: "timestamptz", fromArb: unwrap, isEq: eq }
|
|
|
|
check @(Maybe String) @(Maybe GenString) { purs: "Maybe String", sql: "text", fromArb: map unwrap, isEq: eq }
|
|
check @(Array String) @(Array GenString) { purs: "Array String", sql: "text[]", fromArb: map unwrap, isEq: eq }
|
|
|
|
check @String @GenJSON { purs: "JSON", sql: "json", fromArb: writeJSON <<< unwrap, isEq: eq }
|