preql-0.2: test/Test/Wire.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module Test.Wire where
import Preql.Effect
import Preql.QuasiQuoter.Raw.TH (sql)
import Preql.Wire
import Control.Exception (Exception, bracket_, throwIO)
import Control.Monad
import Data.ByteString (ByteString)
import Data.Either
import Data.Int
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Time (Day, TimeOfDay, UTCTime, TimeZone)
#if MIN_VERSION_time(1,9,0)
import Data.Time.Format.ISO8601 (iso8601ParseM)
#else
import Data.Time.Format (parseTimeM, defaultTimeLocale, iso8601DateFormat, ParseTime)
#endif
import Data.Text.Encoding (encodeUtf8)
import Data.Vector (Vector)
import System.Environment (lookupEnv)
import Test.Tasty
import Test.Tasty.HUnit
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.UUID as UUID
import qualified Database.PostgreSQL.LibPQ as PQ
import qualified Preql.Wire.Query as W
wire :: TestTree
wire = withResource initDB PQ.finish $ \db -> testGroup "wire" $
let
inTransaction desc body = testCase desc $
bracket_ (query_ "BEGIN TRANSACTION" ()) (query_ "ROLLBACK" ()) body
query :: (ToSql p, FromSql r) => Query -> p -> IO (Either QueryError (Vector r))
query q p = db >>= \conn -> W.query conn q p
query_ :: (ToSql p) => Query -> p -> IO ()
query_ q p = db >>= \conn -> W.query_ conn q p >>= either throwIO pure
assertQuery :: (FromSql r, Eq r, Show r) => Vector r -> Query -> IO ()
assertQuery expected q = assertEqual "" (Right expected) =<< query q () in
[ testGroup "decoders"
[ inTransaction "decode True" $
assertQuery [True] "SELECT true"
, inTransaction "decode False" $
assertQuery [False] "SELECT false"
, inTransaction "decode Int64 literal" $
assertQuery [2^32 :: Int64] "SELECT (2^32)::int8"
, inTransaction "decode Int32 literal" $
assertQuery [2^16 :: Int32] "SELECT (2^16)::int4"
, inTransaction "decode Int16 literal" $
assertQuery [2^8 :: Int16] "SELECT (2^8)::int2"
, inTransaction "decode Float literal" $
assertQuery [2**32 :: Float] "SELECT (2^32)::float4"
, inTransaction "decode Double literal" $
assertQuery [2**32 :: Double] "SELECT (2^32)::float8"
-- , inTransaction "decode Char literal" $
-- assertQuery ['x'] "SELECT 'x'::char"
, inTransaction "decode String literal" $
assertQuery ["foo" :: String] "SELECT 'foo'::text"
, inTransaction "decode Text literal" $
assertQuery ["foo" :: Text] "SELECT 'foo'::text"
, inTransaction "decode lazy Text literal" $
assertQuery ["foo" :: TL.Text] "SELECT 'foo'::text"
, inTransaction "decode byte array literal" $
assertQuery ["foo" :: ByteString] "SELECT 'foo'::bytea"
, inTransaction "decode UTCTime literal" $ do
time <- iso8601ParseM "2020-03-19T21:43:00Z"
assertQuery [time :: UTCTime] "SELECT '2020-03-19T21:43:00Z'::timestamptz"
, inTransaction "decode Day literal" $ do
time <- iso8601ParseM "2020-03-19"
assertQuery [time :: Day] "SELECT '2020-03-19'::date"
, inTransaction "decode time literal" $ do
time <- iso8601ParseM "21:43:00"
assertQuery [time :: TimeOfDay] "SELECT '21:43:00Z'::time"
, inTransaction "decode TimeTZ literal" $ do
time <- iso8601ParseM "21:43:00"
zone <- iso8601ParseM "+05:00"
assertQuery [TimeTZ time zone] "SELECT '21:43:00+05:00'::timetz"
, inTransaction "decode UUID literal" $
assertQuery [UUID.fromWords 0x01234567 0x89abcdef 0x01234567 0x89abcdef] "SELECT '01234567-89ab-cdef-0123-456789abcdef'::uuid"
]
, testGroup "encoders"
[ inTransaction "encode True" $ do
query_ "INSERT INTO encoder_tests (b) VALUES ($1)" True
assertQuery [True] "SELECT b FROM encoder_tests WHERE b is not null"
, inTransaction "encode Int64" $ do
let v = 12345 :: Int64
query_ "INSERT INTO encoder_tests (i64) VALUES ($1)" v
assertQuery [v] "SELECT i64 FROM encoder_tests WHERE i64 is not null"
, inTransaction "encode Int32" $ do
let v = 12345 :: Int32
query_ "INSERT INTO encoder_tests (i32) VALUES ($1)" v
assertQuery [v] "SELECT i32 FROM encoder_tests WHERE i32 is not null"
, inTransaction "encode Int16" $ do
let v = 12345 :: Int16
query_ "INSERT INTO encoder_tests (i16) VALUES ($1)" v
assertQuery [v] "SELECT i16 FROM encoder_tests WHERE i16 is not null"
, inTransaction "encode Float" $ do
let v = 12345.678 :: Float
query_ "INSERT INTO encoder_tests (f) VALUES ($1)" v
assertQuery [v] "SELECT f FROM encoder_tests WHERE f is not null"
, inTransaction "encode Double" $ do
let v = 12345.678 :: Double
query_ "INSERT INTO encoder_tests (d) VALUES ($1)" v
assertQuery [v] "SELECT d FROM encoder_tests WHERE d is not null"
, inTransaction "encode strict Text" $ do
let v = "foo" :: Text
query_ "INSERT INTO encoder_tests (t) VALUES ($1)" v
assertQuery [v] "SELECT t FROM encoder_tests WHERE t is not null"
, inTransaction "encode lazy Text" $ do
let v = "foo" :: TL.Text
query_ "INSERT INTO encoder_tests (t) VALUES ($1)" v
assertQuery [v] "SELECT t FROM encoder_tests WHERE t is not null"
, inTransaction "encode String" $ do
let v = "foo" :: String
query_ "INSERT INTO encoder_tests (t) VALUES ($1)" v
assertQuery [v] "SELECT t FROM encoder_tests WHERE t is not null"
, inTransaction "encode UTCTime" $ do
v :: UTCTime <- iso8601ParseM "2020-03-19T21:43:00Z"
query_ "INSERT INTO encoder_tests (ts) VALUES ($1)" v
assertQuery [v] "SELECT ts FROM encoder_tests WHERE ts is not null"
, inTransaction "encode Day" $ do
v :: Day <- iso8601ParseM "2020-03-19"
query_ "INSERT INTO encoder_tests (day) VALUES ($1)" v
assertQuery [v] "SELECT day FROM encoder_tests WHERE day is not null"
, inTransaction "encode TimeOfDay" $ do
v :: TimeOfDay <- iso8601ParseM "21:43:00"
query_ "INSERT INTO encoder_tests (time) VALUES ($1)" v
assertQuery [v] "SELECT time FROM encoder_tests WHERE time is not null"
, inTransaction "encode TimeTZ" $ do
v <- TimeTZ <$> iso8601ParseM "21:43:00" <*> iso8601ParseM "+05:00"
query_ "INSERT INTO encoder_tests (ttz) VALUES ($1)" v
assertQuery [v] "SELECT ttz FROM encoder_tests WHERE ttz is not null"
, inTransaction "encode UUID" $ do
let v = UUID.fromWords 0x01234567 0x89abcdef 0x01234567 0x89abcdef
query_ "INSERT INTO encoder_tests (u) VALUES ($1)" v
assertQuery [v] "SELECT u FROM encoder_tests WHERE u is not null"
]
, testGroup "parameters & expressions"
[ inTransaction "schema type mismatch causes runtime error" $
assertBool "" . isLeft =<< query @() @Int32 "SELECT 2.5" ()
, inTransaction "ignore later columns" $
assertEqual "" (Right [2]) =<< query @() @Int32 "SELECT 2, 3" ()
, inTransaction "parse a pair" $
assertEqual "" (Right [(2, 3)]) =<< query @() @(Int32, Int32) "SELECT 2, 3" ()
, inTransaction "add Int32 parameters" $
assertEqual "" (Right [3]) =<< query @(Int32, Int32) @Int32 "SELECT $1 + $2" (1, 2)
, inTransaction "add Int64 parameters" $
assertEqual "" (Right [3]) =<< query @(Int64, Int64) @Int64 "SELECT $1 + $2" (1, 2)
, inTransaction "add Float32 parameters" $
assertEqual "" (Right [3]) =<< query @(Float, Float) @Float "SELECT $1 + $2" (1, 2)
, inTransaction "add Float64 parameters" $
assertEqual "" (Right [3]) =<< query @(Double, Double) @Double "SELECT $1 + $2" (1, 2)
, inTransaction "add 3 Int32 parameters" $
assertEqual "" (Right [6]) =<< query @(Int32, Int32, Int32) @Int32 "SELECT $1 + $2 + $3" (1, 2, 3)
]
, testGroup "TH-derived instances"
[ inTransaction "FromSql 4-tuple" $
assertQuery [(1 :: Int64, 2 :: Int64, 3 :: Int64, 4 :: Int64)] "SELECT 1::int8, 2::int8, 3::int8, 4::int8 "
, inTransaction "ToSql 4-tuple" $ do
let v = (True, 2 :: Int16, 3 :: Int32, 4 :: Int64)
query_ "INSERT INTO encoder_tests (b, i16, i32, i64) VALUES ($1, $2, $3, $4)" v
assertQuery [v] "SELECT b, i16, i32, i64 FROM encoder_tests"
]
]
initDB :: HasCallStack => IO PQ.Connection
initDB = do
conn <- PQ.connectdb =<< connectionString
status <- PQ.status conn
unless (status == PQ.ConnectionOk) (throwIO =<< badConnection conn)
void $ W.query_ conn "DROP TABLE IF EXISTS encoder_tests" ()
void $ W.query_ conn "CREATE TABLE encoder_tests (b boolean, i16 int2, i32 int4, i64 int8, f float4, d float8, t text, by bytea, ts timestamptz, day date, time time, ttz timetz, u uuid)" ()
return conn
connectionString :: IO ByteString
connectionString = do
m_dbname <- lookupEnv "PREQL_TESTS_DB"
let dbname = case m_dbname of
Just s -> encodeUtf8 (T.pack s)
Nothing -> "preql_tests"
return $ "dbname=" <> dbname
data BadConnection = BadConnection
{ status :: PQ.ConnStatus
, errorMessage :: ByteString
, host :: ByteString
, port :: ByteString
, user :: ByteString
} deriving (Show)
instance Exception BadConnection
badConnection :: PQ.Connection -> IO BadConnection
badConnection c = do
status <- PQ.status c
errorMessage <- fromMaybe "" <$> PQ.errorMessage c
host <- fromMaybe "" <$> PQ.host c
port <- fromMaybe "" <$> PQ.port c
user <- fromMaybe "" <$> PQ.user c
return BadConnection {..}
#if !MIN_VERSION_time(1,9,0)
class ParseTime8601 t where
iso8601ParseM :: Monad m => String -> m t
instance ParseTime8601 UTCTime where
iso8601ParseM = parseTimeM False defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%SZ"))
instance ParseTime8601 Day where
iso8601ParseM = parseTimeM False defaultTimeLocale (iso8601DateFormat Nothing)
instance ParseTime8601 TimeOfDay where
iso8601ParseM = parseTimeM False defaultTimeLocale "%H:%M:%S"
instance ParseTime8601 TimeZone where
iso8601ParseM = parseTimeM False defaultTimeLocale "%z"
#endif