mirror of
https://github.com/nikita-volkov/hasql.git
synced 2024-11-22 10:05:27 +03:00
Format
This commit is contained in:
nikita-volkov
github-actions[bot]
parent
8c2aacc464
commit
55dc24bbd5
@ -25,7 +25,7 @@ main =
|
||||
sessionBench "manySmallResults" sessionWithManySmallResults
|
||||
]
|
||||
where
|
||||
sessionBench :: NFData a => String -> B.Session a -> Benchmark
|
||||
sessionBench :: (NFData a) => String -> B.Session a -> Benchmark
|
||||
sessionBench name session =
|
||||
bench name (nfIO (fmap (either (error "") id) (B.run session connection)))
|
||||
|
||||
|
||||
@ -306,7 +306,7 @@ refine fn (Value v) = Value (Value.Value (\b -> A.refine fn (Value.run v b)))
|
||||
-- x = hstore 'replicateM'
|
||||
-- @
|
||||
{-# INLINEABLE hstore #-}
|
||||
hstore :: (forall m. Monad m => Int -> m (Text, Maybe Text) -> m a) -> Value a
|
||||
hstore :: (forall m. (Monad m) => Int -> m (Text, Maybe Text) -> m a) -> Value a
|
||||
hstore replicateM = Value (Value.decoder (const (A.hstore replicateM A.text_strict A.text_strict)))
|
||||
|
||||
-- |
|
||||
@ -348,7 +348,7 @@ listArray = array . dimension replicateM . element
|
||||
-- Please notice that in case of multidimensional arrays nesting 'vectorArray' decoder
|
||||
-- won't work. You have to explicitly construct the array decoder using 'array'.
|
||||
{-# INLINE vectorArray #-}
|
||||
vectorArray :: GenericVector.Vector vector element => NullableOrNot Value element -> Value (vector element)
|
||||
vectorArray :: (GenericVector.Vector vector element) => NullableOrNot Value element -> Value (vector element)
|
||||
vectorArray = array . dimension GenericVector.replicateM . element
|
||||
|
||||
-- |
|
||||
@ -383,7 +383,7 @@ newtype Array a = Array (Array.Array a)
|
||||
--
|
||||
-- * A decoder of its components, which can be either another 'dimension' or 'element'.
|
||||
{-# INLINEABLE dimension #-}
|
||||
dimension :: (forall m. Monad m => Int -> m a -> m b) -> Array a -> Array b
|
||||
dimension :: (forall m. (Monad m) => Int -> m a -> m b) -> Array a -> Array b
|
||||
dimension replicateM (Array imp) = Array (Array.dimension replicateM imp)
|
||||
|
||||
-- |
|
||||
|
||||
@ -13,7 +13,7 @@ run (Array imp) env =
|
||||
A.array (runReaderT imp env)
|
||||
|
||||
{-# INLINE dimension #-}
|
||||
dimension :: (forall m. Monad m => Int -> m a -> m b) -> Array a -> Array b
|
||||
dimension :: (forall m. (Monad m) => Int -> m a -> m b) -> Array a -> Array b
|
||||
dimension replicateM (Array imp) =
|
||||
Array $ ReaderT $ \env -> A.dimensionArray replicateM (runReaderT imp env)
|
||||
|
||||
|
||||
@ -34,10 +34,12 @@ rowsAffected =
|
||||
checkExecStatus $ \case
|
||||
LibPQ.CommandOk -> True
|
||||
_ -> False
|
||||
Result $
|
||||
ReaderT $ \(_, result) ->
|
||||
ExceptT $
|
||||
LibPQ.cmdTuples result & fmap cmdTuplesReader
|
||||
Result
|
||||
$ ReaderT
|
||||
$ \(_, result) ->
|
||||
ExceptT
|
||||
$ LibPQ.cmdTuples result
|
||||
& fmap cmdTuplesReader
|
||||
where
|
||||
cmdTuplesReader =
|
||||
notNothing >=> notEmpty >=> decimal
|
||||
@ -49,8 +51,8 @@ rowsAffected =
|
||||
then Left (UnexpectedResult "Empty bytes")
|
||||
else Right bytes
|
||||
decimal bytes =
|
||||
mapLeft (\m -> UnexpectedResult ("Decimal parsing failure: " <> fromString m)) $
|
||||
Attoparsec.parseOnly (Attoparsec.decimal <* Attoparsec.endOfInput) bytes
|
||||
mapLeft (\m -> UnexpectedResult ("Decimal parsing failure: " <> fromString m))
|
||||
$ Attoparsec.parseOnly (Attoparsec.decimal <* Attoparsec.endOfInput) bytes
|
||||
|
||||
{-# INLINE checkExecStatus #-}
|
||||
checkExecStatus :: (LibPQ.ExecStatus -> Bool) -> Result ()
|
||||
@ -69,14 +71,15 @@ checkExecStatus predicate =
|
||||
{-# INLINE serverError #-}
|
||||
serverError :: Result ()
|
||||
serverError =
|
||||
Result $
|
||||
ReaderT $ \(_, result) -> ExceptT $ do
|
||||
Result
|
||||
$ ReaderT
|
||||
$ \(_, result) -> ExceptT $ do
|
||||
code <-
|
||||
fmap fold $
|
||||
LibPQ.resultErrorField result LibPQ.DiagSqlstate
|
||||
fmap fold
|
||||
$ LibPQ.resultErrorField result LibPQ.DiagSqlstate
|
||||
message <-
|
||||
fmap fold $
|
||||
LibPQ.resultErrorField result LibPQ.DiagMessagePrimary
|
||||
fmap fold
|
||||
$ LibPQ.resultErrorField result LibPQ.DiagMessagePrimary
|
||||
detail <-
|
||||
LibPQ.resultErrorField result LibPQ.DiagMessageDetail
|
||||
hint <-
|
||||
@ -99,8 +102,9 @@ maybe rowDec =
|
||||
checkExecStatus $ \case
|
||||
LibPQ.TuplesOk -> True
|
||||
_ -> False
|
||||
Result $
|
||||
ReaderT $ \(integerDatetimes, result) -> ExceptT $ do
|
||||
Result
|
||||
$ ReaderT
|
||||
$ \(integerDatetimes, result) -> ExceptT $ do
|
||||
maxRows <- LibPQ.ntuples result
|
||||
case maxRows of
|
||||
0 -> return (Right Nothing)
|
||||
@ -122,8 +126,9 @@ single rowDec =
|
||||
checkExecStatus $ \case
|
||||
LibPQ.TuplesOk -> True
|
||||
_ -> False
|
||||
Result $
|
||||
ReaderT $ \(integerDatetimes, result) -> ExceptT $ do
|
||||
Result
|
||||
$ ReaderT
|
||||
$ \(integerDatetimes, result) -> ExceptT $ do
|
||||
maxRows <- LibPQ.ntuples result
|
||||
case maxRows of
|
||||
1 -> do
|
||||
@ -144,8 +149,9 @@ vector rowDec =
|
||||
checkExecStatus $ \case
|
||||
LibPQ.TuplesOk -> True
|
||||
_ -> False
|
||||
Result $
|
||||
ReaderT $ \(integerDatetimes, result) -> ExceptT $ do
|
||||
Result
|
||||
$ ReaderT
|
||||
$ \(integerDatetimes, result) -> ExceptT $ do
|
||||
maxRows <- LibPQ.ntuples result
|
||||
maxCols <- LibPQ.nfields result
|
||||
mvector <- MutableVector.unsafeNew (rowToInt maxRows)
|
||||
@ -172,10 +178,11 @@ foldl step init rowDec =
|
||||
checkExecStatus $ \case
|
||||
LibPQ.TuplesOk -> True
|
||||
_ -> False
|
||||
Result $
|
||||
ReaderT $ \(integerDatetimes, result) ->
|
||||
ExceptT $
|
||||
{-# SCC "traversal" #-}
|
||||
Result
|
||||
$ ReaderT
|
||||
$ \(integerDatetimes, result) ->
|
||||
ExceptT
|
||||
$ {-# SCC "traversal" #-}
|
||||
do
|
||||
maxRows <- LibPQ.ntuples result
|
||||
maxCols <- LibPQ.nfields result
|
||||
@ -203,8 +210,9 @@ foldr step init rowDec =
|
||||
checkExecStatus $ \case
|
||||
LibPQ.TuplesOk -> True
|
||||
_ -> False
|
||||
Result $
|
||||
ReaderT $ \(integerDatetimes, result) -> ExceptT $ do
|
||||
Result
|
||||
$ ReaderT
|
||||
$ \(integerDatetimes, result) -> ExceptT $ do
|
||||
maxRows <- LibPQ.ntuples result
|
||||
maxCols <- LibPQ.nfields result
|
||||
accRef <- newIORef init
|
||||
|
||||
@ -29,18 +29,20 @@ run (Results stack) env =
|
||||
{-# INLINE clientError #-}
|
||||
clientError :: Results a
|
||||
clientError =
|
||||
Results $
|
||||
ReaderT $ \(_, connection) ->
|
||||
ExceptT $
|
||||
fmap (Left . ClientError) (LibPQ.errorMessage connection)
|
||||
Results
|
||||
$ ReaderT
|
||||
$ \(_, connection) ->
|
||||
ExceptT
|
||||
$ fmap (Left . ClientError) (LibPQ.errorMessage connection)
|
||||
|
||||
-- |
|
||||
-- Parse a single result.
|
||||
{-# INLINE single #-}
|
||||
single :: Result.Result a -> Results a
|
||||
single resultDec =
|
||||
Results $
|
||||
ReaderT $ \(integerDatetimes, connection) -> ExceptT $ do
|
||||
Results
|
||||
$ ReaderT
|
||||
$ \(integerDatetimes, connection) -> ExceptT $ do
|
||||
resultMaybe <- LibPQ.getResult connection
|
||||
case resultMaybe of
|
||||
Just result ->
|
||||
@ -53,8 +55,9 @@ single resultDec =
|
||||
{-# INLINE getResult #-}
|
||||
getResult :: Results LibPQ.Result
|
||||
getResult =
|
||||
Results $
|
||||
ReaderT $ \(_, connection) -> ExceptT $ do
|
||||
Results
|
||||
$ ReaderT
|
||||
$ \(_, connection) -> ExceptT $ do
|
||||
resultMaybe <- LibPQ.getResult connection
|
||||
case resultMaybe of
|
||||
Just result -> pure (Right result)
|
||||
@ -85,7 +88,8 @@ dropRemainders =
|
||||
ExceptT $ fmap (mapLeft ResultError) $ Result.run Result.noResult (integerDatetimes, result)
|
||||
|
||||
refine :: (a -> Either Text b) -> Results a -> Results b
|
||||
refine refiner results = Results $
|
||||
ReaderT $ \env -> ExceptT $ do
|
||||
refine refiner results = Results
|
||||
$ ReaderT
|
||||
$ \env -> ExceptT $ do
|
||||
resultEither <- run results env
|
||||
return $ resultEither >>= mapLeft (ResultError . UnexpectedResult) . refiner
|
||||
|
||||
@ -41,21 +41,22 @@ error x =
|
||||
value :: Value.Value a -> Row (Maybe a)
|
||||
value valueDec =
|
||||
{-# SCC "value" #-}
|
||||
Row $
|
||||
ReaderT $ \(Env result row columnsAmount integerDatetimes columnRef) -> ExceptT $ do
|
||||
Row
|
||||
$ ReaderT
|
||||
$ \(Env result row columnsAmount integerDatetimes columnRef) -> ExceptT $ do
|
||||
col <- readIORef columnRef
|
||||
writeIORef columnRef (succ col)
|
||||
if col < columnsAmount
|
||||
then do
|
||||
valueMaybe <- {-# SCC "getvalue'" #-} LibPQ.getvalue' result row col
|
||||
pure $
|
||||
case valueMaybe of
|
||||
pure
|
||||
$ case valueMaybe of
|
||||
Nothing ->
|
||||
Right Nothing
|
||||
Just value ->
|
||||
fmap Just $
|
||||
mapLeft ValueError $
|
||||
{-# SCC "decode" #-} A.valueParser (Value.run valueDec integerDatetimes) value
|
||||
fmap Just
|
||||
$ mapLeft ValueError
|
||||
$ {-# SCC "decode" #-} A.valueParser (Value.run valueDec integerDatetimes) value
|
||||
else pure (Left EndOfInput)
|
||||
|
||||
-- |
|
||||
|
||||
@ -330,7 +330,7 @@ composite (Composite encode print) =
|
||||
-- Please notice that in case of multidimensional arrays nesting 'foldableArray' encoder
|
||||
-- won't work. You have to explicitly construct the array encoder using 'array'.
|
||||
{-# INLINE foldableArray #-}
|
||||
foldableArray :: Foldable foldable => NullableOrNot Value element -> Value (foldable element)
|
||||
foldableArray :: (Foldable foldable) => NullableOrNot Value element -> Value (foldable element)
|
||||
foldableArray = array . dimension foldl' . element
|
||||
|
||||
-- * Array
|
||||
|
||||
@ -19,8 +19,9 @@ value =
|
||||
|
||||
nullableValue :: C.Value a -> Params (Maybe a)
|
||||
nullableValue (C.Value valueOID arrayOID encode render) =
|
||||
Params $
|
||||
Op $ \input ->
|
||||
Params
|
||||
$ Op
|
||||
$ \input ->
|
||||
let D.OID _ pqOid format =
|
||||
valueOID
|
||||
encoder env =
|
||||
|
||||
@ -19,6 +19,6 @@ unsafePTI pti =
|
||||
Value (PTI.ptiOID pti) (fromMaybe (error "No array OID") (PTI.ptiArrayOID pti))
|
||||
|
||||
{-# INLINE unsafePTIWithShow #-}
|
||||
unsafePTIWithShow :: Show a => PTI.PTI -> (Bool -> a -> B.Encoding) -> Value a
|
||||
unsafePTIWithShow :: (Show a) => PTI.PTI -> (Bool -> a -> B.Encoding) -> Value a
|
||||
unsafePTIWithShow pti encode =
|
||||
unsafePTI pti encode (C.string . show)
|
||||
|
||||
@ -39,24 +39,24 @@ data CommandError
|
||||
data ResultError
|
||||
= -- | An error reported by the DB.
|
||||
ServerError
|
||||
ByteString
|
||||
-- ^ __Code__. The SQLSTATE code for the error. It's recommended to use
|
||||
-- | __Code__. The SQLSTATE code for the error. It's recommended to use
|
||||
-- <http://hackage.haskell.org/package/postgresql-error-codes
|
||||
-- the "postgresql-error-codes" package> to work with those.
|
||||
ByteString
|
||||
-- ^ __Message__. The primary human-readable error message(typically one
|
||||
-- | __Message__. The primary human-readable error message(typically one
|
||||
-- line). Always present.
|
||||
(Maybe ByteString)
|
||||
-- ^ __Details__. An optional secondary error message carrying more
|
||||
ByteString
|
||||
-- | __Details__. An optional secondary error message carrying more
|
||||
-- detail about the problem. Might run to multiple lines.
|
||||
(Maybe ByteString)
|
||||
-- ^ __Hint__. An optional suggestion on what to do about the problem.
|
||||
-- | __Hint__. An optional suggestion on what to do about the problem.
|
||||
-- This is intended to differ from detail in that it offers advice
|
||||
-- (potentially inappropriate) rather than hard facts. Might run to
|
||||
-- multiple lines.
|
||||
(Maybe Int)
|
||||
-- ^ __Position__. Error cursor position as an index into the original
|
||||
(Maybe ByteString)
|
||||
-- | __Position__. Error cursor position as an index into the original
|
||||
-- statement string. Positions are measured in characters not bytes.
|
||||
(Maybe Int)
|
||||
| -- |
|
||||
-- The database returned an unexpected result.
|
||||
-- Indicates an improper statement or a schema mismatch.
|
||||
|
||||
@ -117,12 +117,12 @@ type TextBuilder =
|
||||
Data.Text.Lazy.Builder.Builder
|
||||
|
||||
{-# INLINE forMToZero_ #-}
|
||||
forMToZero_ :: Applicative m => Int -> (Int -> m a) -> m ()
|
||||
forMToZero_ :: (Applicative m) => Int -> (Int -> m a) -> m ()
|
||||
forMToZero_ !startN f =
|
||||
($ pred startN) $ fix $ \loop !n -> if n >= 0 then f n *> loop (pred n) else pure ()
|
||||
|
||||
{-# INLINE forMFromZero_ #-}
|
||||
forMFromZero_ :: Applicative m => Int -> (Int -> m a) -> m ()
|
||||
forMFromZero_ :: (Applicative m) => Int -> (Int -> m a) -> m ()
|
||||
forMFromZero_ !endN f =
|
||||
($ 0) $ fix $ \loop !n -> if n < endN then f n *> loop (succ n) else pure ()
|
||||
|
||||
|
||||
@ -22,8 +22,8 @@ newtype Session a
|
||||
-- Executes a bunch of commands on the provided connection.
|
||||
run :: Session a -> Connection.Connection -> IO (Either QueryError a)
|
||||
run (Session impl) connection =
|
||||
runExceptT $
|
||||
runReaderT impl connection
|
||||
runExceptT
|
||||
$ runReaderT impl connection
|
||||
|
||||
-- |
|
||||
-- Possibly a multi-statement query,
|
||||
@ -31,14 +31,16 @@ run (Session impl) connection =
|
||||
-- nor can any results of it be collected.
|
||||
sql :: ByteString -> Session ()
|
||||
sql sql =
|
||||
Session $
|
||||
ReaderT $ \(Connection.Connection pqConnectionRef integerDatetimes registry) ->
|
||||
ExceptT $
|
||||
fmap (mapLeft (QueryError sql [])) $
|
||||
withMVar pqConnectionRef $ \pqConnection -> do
|
||||
r1 <- IO.sendNonparametricStatement pqConnection sql
|
||||
r2 <- IO.getResults pqConnection integerDatetimes decoder
|
||||
return $ r1 *> r2
|
||||
Session
|
||||
$ ReaderT
|
||||
$ \(Connection.Connection pqConnectionRef integerDatetimes registry) ->
|
||||
ExceptT
|
||||
$ fmap (mapLeft (QueryError sql []))
|
||||
$ withMVar pqConnectionRef
|
||||
$ \pqConnection -> do
|
||||
r1 <- IO.sendNonparametricStatement pqConnection sql
|
||||
r2 <- IO.getResults pqConnection integerDatetimes decoder
|
||||
return $ r1 *> r2
|
||||
where
|
||||
decoder =
|
||||
Decoders.Results.single Decoders.Result.noResult
|
||||
@ -47,14 +49,16 @@ sql sql =
|
||||
-- Parameters and a specification of a parametric single-statement query to apply them to.
|
||||
statement :: params -> Statement.Statement params result -> Session result
|
||||
statement input (Statement.Statement template (Encoders.Params paramsEncoder) decoder preparable) =
|
||||
Session $
|
||||
ReaderT $ \(Connection.Connection pqConnectionRef integerDatetimes registry) ->
|
||||
ExceptT $
|
||||
fmap (mapLeft (QueryError template inputReps)) $
|
||||
withMVar pqConnectionRef $ \pqConnection -> do
|
||||
r1 <- IO.sendParametricStatement pqConnection integerDatetimes registry template paramsEncoder preparable input
|
||||
r2 <- IO.getResults pqConnection integerDatetimes (unsafeCoerce decoder)
|
||||
return $ r1 *> r2
|
||||
Session
|
||||
$ ReaderT
|
||||
$ \(Connection.Connection pqConnectionRef integerDatetimes registry) ->
|
||||
ExceptT
|
||||
$ fmap (mapLeft (QueryError template inputReps))
|
||||
$ withMVar pqConnectionRef
|
||||
$ \pqConnection -> do
|
||||
r1 <- IO.sendParametricStatement pqConnection integerDatetimes registry template paramsEncoder preparable input
|
||||
r2 <- IO.getResults pqConnection integerDatetimes (unsafeCoerce decoder)
|
||||
return $ r1 *> r2
|
||||
where
|
||||
inputReps =
|
||||
let Encoders.Params.Params (Op encoderOp) = paramsEncoder
|
||||
|
||||
@ -16,19 +16,24 @@ type Settings =
|
||||
{-# INLINE settings #-}
|
||||
settings :: ByteString -> Word16 -> ByteString -> ByteString -> ByteString -> Settings
|
||||
settings host port user password database =
|
||||
BL.toStrict $
|
||||
BB.toLazyByteString $
|
||||
mconcat $
|
||||
intersperse (BB.char7 ' ') $
|
||||
catMaybes $
|
||||
[ mappend (BB.string7 "host=") . BB.byteString
|
||||
<$> mfilter (not . B.null) (pure host),
|
||||
mappend (BB.string7 "port=") . BB.word16Dec
|
||||
<$> mfilter (/= 0) (pure port),
|
||||
mappend (BB.string7 "user=") . BB.byteString
|
||||
<$> mfilter (not . B.null) (pure user),
|
||||
mappend (BB.string7 "password=") . BB.byteString
|
||||
<$> mfilter (not . B.null) (pure password),
|
||||
mappend (BB.string7 "dbname=") . BB.byteString
|
||||
<$> mfilter (not . B.null) (pure database)
|
||||
]
|
||||
BL.toStrict
|
||||
$ BB.toLazyByteString
|
||||
$ mconcat
|
||||
$ intersperse (BB.char7 ' ')
|
||||
$ catMaybes
|
||||
$ [ mappend (BB.string7 "host=")
|
||||
. BB.byteString
|
||||
<$> mfilter (not . B.null) (pure host),
|
||||
mappend (BB.string7 "port=")
|
||||
. BB.word16Dec
|
||||
<$> mfilter (/= 0) (pure port),
|
||||
mappend (BB.string7 "user=")
|
||||
. BB.byteString
|
||||
<$> mfilter (not . B.null) (pure user),
|
||||
mappend (BB.string7 "password=")
|
||||
. BB.byteString
|
||||
<$> mfilter (not . B.null) (pure password),
|
||||
mappend (BB.string7 "dbname=")
|
||||
. BB.byteString
|
||||
<$> mfilter (not . B.null) (pure database)
|
||||
]
|
||||
|
||||
863
tasty/Main.hs
863
tasty/Main.hs
@ -20,141 +20,147 @@ main =
|
||||
defaultMain tree
|
||||
|
||||
tree =
|
||||
localOption (NumThreads 1) $
|
||||
testGroup
|
||||
localOption (NumThreads 1)
|
||||
$ testGroup
|
||||
"All tests"
|
||||
[ testGroup "Roundtrips" $
|
||||
let roundtrip encoder decoder input =
|
||||
let session =
|
||||
let statement = Statement.Statement "select $1" encoder decoder True
|
||||
in Session.statement input statement
|
||||
in unsafePerformIO $ do
|
||||
x <- Connection.with (Session.run session)
|
||||
return (Right (Right input) === x)
|
||||
in [ testProperty "Array" $
|
||||
let encoder = Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8)))))
|
||||
decoder = Decoders.singleRow (Decoders.column (Decoders.nonNullable (Decoders.array (Decoders.dimension replicateM (Decoders.element (Decoders.nonNullable Decoders.int8))))))
|
||||
in roundtrip encoder decoder,
|
||||
testProperty "2D Array" $
|
||||
let encoder = Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8))))))
|
||||
decoder = Decoders.singleRow (Decoders.column (Decoders.nonNullable (Decoders.array (Decoders.dimension replicateM (Decoders.dimension replicateM (Decoders.element (Decoders.nonNullable Decoders.int8)))))))
|
||||
in \list -> list /= [] ==> roundtrip encoder decoder (replicate 3 list)
|
||||
],
|
||||
testCase "Failed query" $
|
||||
let statement =
|
||||
Statement.Statement "select true where 1 = any ($1) and $2" encoder decoder True
|
||||
where
|
||||
encoder =
|
||||
contrazip2
|
||||
(Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8))))))
|
||||
(Encoders.param (Encoders.nonNullable (Encoders.text)))
|
||||
decoder =
|
||||
fmap (maybe False (const True)) (Decoders.rowMaybe ((Decoders.column . Decoders.nonNullable) Decoders.bool))
|
||||
session =
|
||||
Session.statement ([3, 7], "a") statement
|
||||
in do
|
||||
x <- Connection.with (Session.run session)
|
||||
assertBool (show x) $ case x of
|
||||
Right (Left (Session.QueryError "select true where 1 = any ($1) and $2" ["[3, 7]", "\"a\""] _)) -> True
|
||||
_ -> False,
|
||||
testCase "IN simulation" $
|
||||
let statement =
|
||||
Statement.Statement "select true where 1 = any ($1)" encoder decoder True
|
||||
where
|
||||
encoder =
|
||||
Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8)))))
|
||||
decoder =
|
||||
fmap (maybe False (const True)) (Decoders.rowMaybe ((Decoders.column . Decoders.nonNullable) Decoders.bool))
|
||||
session =
|
||||
do
|
||||
result1 <- Session.statement [1, 2] statement
|
||||
result2 <- Session.statement [2, 3] statement
|
||||
return (result1, result2)
|
||||
in do
|
||||
x <- Connection.with (Session.run session)
|
||||
assertEqual (show x) (Right (Right (True, False))) x,
|
||||
testCase "NOT IN simulation" $
|
||||
let statement =
|
||||
Statement.Statement "select true where 3 <> all ($1)" encoder decoder True
|
||||
where
|
||||
encoder =
|
||||
Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8)))))
|
||||
decoder =
|
||||
fmap (maybe False (const True)) (Decoders.rowMaybe ((Decoders.column . Decoders.nonNullable) Decoders.bool))
|
||||
session =
|
||||
do
|
||||
result1 <- Session.statement [1, 2] statement
|
||||
result2 <- Session.statement [2, 3] statement
|
||||
return (result1, result2)
|
||||
in do
|
||||
x <- Connection.with (Session.run session)
|
||||
assertEqual (show x) (Right (Right (True, False))) x,
|
||||
testCase "Composite decoding" $
|
||||
let statement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"select (1, true)"
|
||||
encoder =
|
||||
mempty
|
||||
decoder =
|
||||
Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.composite ((,) <$> (Decoders.field . Decoders.nonNullable) Decoders.int8 <*> (Decoders.field . Decoders.nonNullable) Decoders.bool)))
|
||||
session =
|
||||
Session.statement () statement
|
||||
in do
|
||||
x <- Connection.with (Session.run session)
|
||||
assertEqual (show x) (Right (Right (1, True))) x,
|
||||
testCase "Complex composite decoding" $
|
||||
let statement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"select (1, true) as entity1, ('hello', 3) as entity2"
|
||||
encoder =
|
||||
mempty
|
||||
decoder =
|
||||
Decoders.singleRow $
|
||||
(,) <$> (Decoders.column . Decoders.nonNullable) entity1 <*> (Decoders.column . Decoders.nonNullable) entity2
|
||||
where
|
||||
entity1 =
|
||||
Decoders.composite $
|
||||
(,) <$> (Decoders.field . Decoders.nonNullable) Decoders.int8 <*> (Decoders.field . Decoders.nonNullable) Decoders.bool
|
||||
entity2 =
|
||||
Decoders.composite $
|
||||
(,) <$> (Decoders.field . Decoders.nonNullable) Decoders.text <*> (Decoders.field . Decoders.nonNullable) Decoders.int8
|
||||
session =
|
||||
Session.statement () statement
|
||||
in do
|
||||
x <- Connection.with (Session.run session)
|
||||
assertEqual (show x) (Right (Right ((1, True), ("hello", 3)))) x,
|
||||
testGroup "unknownEnum" $
|
||||
[ testCase "" $ do
|
||||
res <- DSL.session $ do
|
||||
let statement =
|
||||
Statement.Statement sql mempty Decoders.noResult True
|
||||
[ testGroup "Roundtrips"
|
||||
$ let roundtrip encoder decoder input =
|
||||
let session =
|
||||
let statement = Statement.Statement "select $1" encoder decoder True
|
||||
in Session.statement input statement
|
||||
in unsafePerformIO $ do
|
||||
x <- Connection.with (Session.run session)
|
||||
return (Right (Right input) === x)
|
||||
in [ testProperty "Array"
|
||||
$ let encoder = Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8)))))
|
||||
decoder = Decoders.singleRow (Decoders.column (Decoders.nonNullable (Decoders.array (Decoders.dimension replicateM (Decoders.element (Decoders.nonNullable Decoders.int8))))))
|
||||
in roundtrip encoder decoder,
|
||||
testProperty "2D Array"
|
||||
$ let encoder = Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8))))))
|
||||
decoder = Decoders.singleRow (Decoders.column (Decoders.nonNullable (Decoders.array (Decoders.dimension replicateM (Decoders.dimension replicateM (Decoders.element (Decoders.nonNullable Decoders.int8)))))))
|
||||
in \list -> list /= [] ==> roundtrip encoder decoder (replicate 3 list)
|
||||
],
|
||||
testCase "Failed query"
|
||||
$ let statement =
|
||||
Statement.Statement "select true where 1 = any ($1) and $2" encoder decoder True
|
||||
where
|
||||
encoder =
|
||||
contrazip2
|
||||
(Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8))))))
|
||||
(Encoders.param (Encoders.nonNullable (Encoders.text)))
|
||||
decoder =
|
||||
fmap (maybe False (const True)) (Decoders.rowMaybe ((Decoders.column . Decoders.nonNullable) Decoders.bool))
|
||||
session =
|
||||
Session.statement ([3, 7], "a") statement
|
||||
in do
|
||||
x <- Connection.with (Session.run session)
|
||||
assertBool (show x) $ case x of
|
||||
Right (Left (Session.QueryError "select true where 1 = any ($1) and $2" ["[3, 7]", "\"a\""] _)) -> True
|
||||
_ -> False,
|
||||
testCase "IN simulation"
|
||||
$ let statement =
|
||||
Statement.Statement "select true where 1 = any ($1)" encoder decoder True
|
||||
where
|
||||
encoder =
|
||||
Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8)))))
|
||||
decoder =
|
||||
fmap (maybe False (const True)) (Decoders.rowMaybe ((Decoders.column . Decoders.nonNullable) Decoders.bool))
|
||||
session =
|
||||
do
|
||||
result1 <- Session.statement [1, 2] statement
|
||||
result2 <- Session.statement [2, 3] statement
|
||||
return (result1, result2)
|
||||
in do
|
||||
x <- Connection.with (Session.run session)
|
||||
assertEqual (show x) (Right (Right (True, False))) x,
|
||||
testCase "NOT IN simulation"
|
||||
$ let statement =
|
||||
Statement.Statement "select true where 3 <> all ($1)" encoder decoder True
|
||||
where
|
||||
encoder =
|
||||
Encoders.param (Encoders.nonNullable (Encoders.array (Encoders.dimension foldl' (Encoders.element (Encoders.nonNullable Encoders.int8)))))
|
||||
decoder =
|
||||
fmap (maybe False (const True)) (Decoders.rowMaybe ((Decoders.column . Decoders.nonNullable) Decoders.bool))
|
||||
session =
|
||||
do
|
||||
result1 <- Session.statement [1, 2] statement
|
||||
result2 <- Session.statement [2, 3] statement
|
||||
return (result1, result2)
|
||||
in do
|
||||
x <- Connection.with (Session.run session)
|
||||
assertEqual (show x) (Right (Right (True, False))) x,
|
||||
testCase "Composite decoding"
|
||||
$ let statement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"select (1, true)"
|
||||
encoder =
|
||||
mempty
|
||||
decoder =
|
||||
Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.composite ((,) <$> (Decoders.field . Decoders.nonNullable) Decoders.int8 <*> (Decoders.field . Decoders.nonNullable) Decoders.bool)))
|
||||
session =
|
||||
Session.statement () statement
|
||||
in do
|
||||
x <- Connection.with (Session.run session)
|
||||
assertEqual (show x) (Right (Right (1, True))) x,
|
||||
testCase "Complex composite decoding"
|
||||
$ let statement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"select (1, true) as entity1, ('hello', 3) as entity2"
|
||||
encoder =
|
||||
mempty
|
||||
decoder =
|
||||
Decoders.singleRow
|
||||
$ (,)
|
||||
<$> (Decoders.column . Decoders.nonNullable) entity1
|
||||
<*> (Decoders.column . Decoders.nonNullable) entity2
|
||||
where
|
||||
sql =
|
||||
"drop type if exists mood"
|
||||
in DSL.statement () statement
|
||||
let statement =
|
||||
Statement.Statement sql mempty Decoders.noResult True
|
||||
where
|
||||
sql =
|
||||
"create type mood as enum ('sad', 'ok', 'happy')"
|
||||
in DSL.statement () statement
|
||||
let statement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"select $1"
|
||||
decoder =
|
||||
(Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.enum (Just . id))))
|
||||
encoder =
|
||||
Encoders.param (Encoders.nonNullable (Encoders.unknownEnum id))
|
||||
in DSL.statement "ok" statement
|
||||
entity1 =
|
||||
Decoders.composite
|
||||
$ (,)
|
||||
<$> (Decoders.field . Decoders.nonNullable) Decoders.int8
|
||||
<*> (Decoders.field . Decoders.nonNullable) Decoders.bool
|
||||
entity2 =
|
||||
Decoders.composite
|
||||
$ (,)
|
||||
<$> (Decoders.field . Decoders.nonNullable) Decoders.text
|
||||
<*> (Decoders.field . Decoders.nonNullable) Decoders.int8
|
||||
session =
|
||||
Session.statement () statement
|
||||
in do
|
||||
x <- Connection.with (Session.run session)
|
||||
assertEqual (show x) (Right (Right ((1, True), ("hello", 3)))) x,
|
||||
testGroup "unknownEnum"
|
||||
$ [ testCase "" $ do
|
||||
res <- DSL.session $ do
|
||||
let statement =
|
||||
Statement.Statement sql mempty Decoders.noResult True
|
||||
where
|
||||
sql =
|
||||
"drop type if exists mood"
|
||||
in DSL.statement () statement
|
||||
let statement =
|
||||
Statement.Statement sql mempty Decoders.noResult True
|
||||
where
|
||||
sql =
|
||||
"create type mood as enum ('sad', 'ok', 'happy')"
|
||||
in DSL.statement () statement
|
||||
let statement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"select $1"
|
||||
decoder =
|
||||
(Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.enum (Just . id))))
|
||||
encoder =
|
||||
Encoders.param (Encoders.nonNullable (Encoders.unknownEnum id))
|
||||
in DSL.statement "ok" statement
|
||||
|
||||
assertEqual "" (Right "ok") res
|
||||
],
|
||||
assertEqual "" (Right "ok") res
|
||||
],
|
||||
testCase "Composite encoding" $ do
|
||||
let value =
|
||||
(123, 456, 789, "abc")
|
||||
@ -165,15 +171,18 @@ tree =
|
||||
sql =
|
||||
"select $1 :: pg_enum"
|
||||
encoder =
|
||||
Encoders.param . Encoders.nonNullable . Encoders.composite . mconcat $
|
||||
[ contramap (\(a, _, _, _) -> a) . Encoders.field . Encoders.nonNullable $ Encoders.oid,
|
||||
contramap (\(_, a, _, _) -> a) . Encoders.field . Encoders.nonNullable $ Encoders.oid,
|
||||
contramap (\(_, _, a, _) -> a) . Encoders.field . Encoders.nonNullable $ Encoders.float4,
|
||||
contramap (\(_, _, _, a) -> a) . Encoders.field . Encoders.nonNullable $ Encoders.name
|
||||
]
|
||||
Encoders.param
|
||||
. Encoders.nonNullable
|
||||
. Encoders.composite
|
||||
. mconcat
|
||||
$ [ contramap (\(a, _, _, _) -> a) . Encoders.field . Encoders.nonNullable $ Encoders.oid,
|
||||
contramap (\(_, a, _, _) -> a) . Encoders.field . Encoders.nonNullable $ Encoders.oid,
|
||||
contramap (\(_, _, a, _) -> a) . Encoders.field . Encoders.nonNullable $ Encoders.float4,
|
||||
contramap (\(_, _, _, a) -> a) . Encoders.field . Encoders.nonNullable $ Encoders.name
|
||||
]
|
||||
decoder =
|
||||
Decoders.singleRow $
|
||||
(Decoders.column . Decoders.nonNullable . Decoders.composite)
|
||||
Decoders.singleRow
|
||||
$ (Decoders.column . Decoders.nonNullable . Decoders.composite)
|
||||
( (,,,)
|
||||
<$> (Decoders.field . Decoders.nonNullable) Decoders.int4
|
||||
<*> (Decoders.field . Decoders.nonNullable) Decoders.int4
|
||||
@ -182,270 +191,270 @@ tree =
|
||||
)
|
||||
in Connection.with $ Session.run $ Session.statement value statement
|
||||
assertEqual "" (Right (Right value)) res,
|
||||
testCase "Empty array" $
|
||||
let io =
|
||||
do
|
||||
x <- Connection.with (Session.run session)
|
||||
assertEqual (show x) (Right (Right [])) x
|
||||
where
|
||||
session =
|
||||
Session.statement () statement
|
||||
where
|
||||
statement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"select array[]::int8[]"
|
||||
encoder =
|
||||
mempty
|
||||
decoder =
|
||||
Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.array (Decoders.dimension replicateM (Decoders.element (Decoders.nonNullable Decoders.int8)))))
|
||||
in io,
|
||||
testCase "Failing prepared statements" $
|
||||
let io =
|
||||
Connection.with (Session.run session)
|
||||
>>= (assertBool <$> show <*> resultTest)
|
||||
where
|
||||
resultTest =
|
||||
\case
|
||||
Right (Left (Session.QueryError _ _ (Session.ResultError (Session.ServerError "26000" _ _ _ _)))) -> False
|
||||
_ -> True
|
||||
session =
|
||||
catchError session (const (pure ())) *> session
|
||||
where
|
||||
session =
|
||||
Session.statement () statement
|
||||
where
|
||||
statement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"absurd"
|
||||
encoder =
|
||||
mempty
|
||||
decoder =
|
||||
Decoders.noResult
|
||||
in io,
|
||||
testCase "Prepared statements after error" $
|
||||
let io =
|
||||
Connection.with (Session.run session)
|
||||
>>= \x -> assertBool (show x) (either (const False) isRight x)
|
||||
where
|
||||
session =
|
||||
try *> fail *> try
|
||||
where
|
||||
try =
|
||||
Session.statement 1 statement
|
||||
where
|
||||
statement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"select $1 :: int8"
|
||||
encoder =
|
||||
Encoders.param (Encoders.nonNullable (Encoders.int8))
|
||||
decoder =
|
||||
Decoders.singleRow $ (Decoders.column . Decoders.nonNullable) Decoders.int8
|
||||
fail =
|
||||
catchError (Session.sql "absurd") (const (pure ()))
|
||||
in io,
|
||||
testCase "\"in progress after error\" bugfix" $
|
||||
let sumStatement :: Statement.Statement (Int64, Int64) Int64
|
||||
sumStatement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"select ($1 + $2)"
|
||||
encoder =
|
||||
contramap fst (Encoders.param (Encoders.nonNullable (Encoders.int8)))
|
||||
<> contramap snd (Encoders.param (Encoders.nonNullable (Encoders.int8)))
|
||||
decoder =
|
||||
Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int8)
|
||||
sumSession :: Session.Session Int64
|
||||
sumSession =
|
||||
Session.sql "begin" *> Session.statement (1, 1) sumStatement <* Session.sql "end"
|
||||
errorSession :: Session.Session ()
|
||||
errorSession =
|
||||
Session.sql "asldfjsldk"
|
||||
io =
|
||||
Connection.with $ \c -> do
|
||||
Session.run errorSession c
|
||||
Session.run sumSession c
|
||||
in io >>= \x -> assertBool (show x) (either (const False) isRight x),
|
||||
testCase "\"another command is already in progress\" bugfix" $
|
||||
let sumStatement :: Statement.Statement (Int64, Int64) Int64
|
||||
sumStatement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"select ($1 + $2)"
|
||||
encoder =
|
||||
contramap fst (Encoders.param (Encoders.nonNullable (Encoders.int8)))
|
||||
<> contramap snd (Encoders.param (Encoders.nonNullable (Encoders.int8)))
|
||||
decoder =
|
||||
Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int8)
|
||||
session :: Session.Session Int64
|
||||
session =
|
||||
do
|
||||
Session.sql "begin;"
|
||||
s <- Session.statement (1, 1) sumStatement
|
||||
Session.sql "end;"
|
||||
return s
|
||||
in DSL.session session >>= \x -> assertEqual (show x) (Right 2) x,
|
||||
testCase "Executing the same query twice" $
|
||||
pure (),
|
||||
testCase "Interval Encoding" $
|
||||
let actualIO =
|
||||
DSL.session $ do
|
||||
let statement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"select $1 = interval '10 seconds'"
|
||||
decoder =
|
||||
(Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.bool)))
|
||||
encoder =
|
||||
Encoders.param (Encoders.nonNullable (Encoders.interval))
|
||||
in DSL.statement (10 :: DiffTime) statement
|
||||
in actualIO >>= \x -> assertEqual (show x) (Right True) x,
|
||||
testCase "Interval Decoding" $
|
||||
let actualIO =
|
||||
DSL.session $ do
|
||||
let statement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"select interval '10 seconds'"
|
||||
decoder =
|
||||
(Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.interval)))
|
||||
encoder =
|
||||
Encoders.noParams
|
||||
in DSL.statement () statement
|
||||
in actualIO >>= \x -> assertEqual (show x) (Right (10 :: DiffTime)) x,
|
||||
testCase "Interval Encoding/Decoding" $
|
||||
let actualIO =
|
||||
DSL.session $ do
|
||||
let statement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"select $1"
|
||||
decoder =
|
||||
(Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.interval)))
|
||||
encoder =
|
||||
Encoders.param (Encoders.nonNullable (Encoders.interval))
|
||||
in DSL.statement (10 :: DiffTime) statement
|
||||
in actualIO >>= \x -> assertEqual (show x) (Right (10 :: DiffTime)) x,
|
||||
testCase "Unknown" $
|
||||
let actualIO =
|
||||
DSL.session $ do
|
||||
let statement =
|
||||
Statement.Statement sql mempty Decoders.noResult True
|
||||
where
|
||||
sql =
|
||||
"drop type if exists mood"
|
||||
in DSL.statement () statement
|
||||
let statement =
|
||||
Statement.Statement sql mempty Decoders.noResult True
|
||||
where
|
||||
sql =
|
||||
"create type mood as enum ('sad', 'ok', 'happy')"
|
||||
in DSL.statement () statement
|
||||
let statement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"select $1 = ('ok' :: mood)"
|
||||
decoder =
|
||||
(Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.bool)))
|
||||
encoder =
|
||||
Encoders.param (Encoders.nonNullable (Encoders.unknown))
|
||||
in DSL.statement "ok" statement
|
||||
in actualIO >>= assertEqual "" (Right True),
|
||||
testCase "Textual Unknown" $
|
||||
let actualIO =
|
||||
DSL.session $ do
|
||||
let statement =
|
||||
Statement.Statement sql mempty Decoders.noResult True
|
||||
where
|
||||
sql =
|
||||
"create or replace function overloaded(a int, b int) returns int as $$ select a + b $$ language sql;"
|
||||
in DSL.statement () statement
|
||||
let statement =
|
||||
Statement.Statement sql mempty Decoders.noResult True
|
||||
where
|
||||
sql =
|
||||
"create or replace function overloaded(a text, b text, c text) returns text as $$ select a || b || c $$ language sql;"
|
||||
in DSL.statement () statement
|
||||
let statement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"select overloaded($1, $2) || overloaded($3, $4, $5)"
|
||||
decoder =
|
||||
(Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.text)))
|
||||
encoder =
|
||||
contramany (Encoders.param (Encoders.nonNullable (Encoders.unknown)))
|
||||
in DSL.statement ["1", "2", "4", "5", "6"] statement
|
||||
in actualIO >>= assertEqual "" (Right "3456"),
|
||||
testCase "Enum" $
|
||||
let actualIO =
|
||||
DSL.session $ do
|
||||
let statement =
|
||||
Statement.Statement sql mempty Decoders.noResult True
|
||||
where
|
||||
sql =
|
||||
"drop type if exists mood"
|
||||
in DSL.statement () statement
|
||||
let statement =
|
||||
Statement.Statement sql mempty Decoders.noResult True
|
||||
where
|
||||
sql =
|
||||
"create type mood as enum ('sad', 'ok', 'happy')"
|
||||
in DSL.statement () statement
|
||||
let statement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"select ($1 :: mood)"
|
||||
decoder =
|
||||
(Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.enum (Just . id))))
|
||||
encoder =
|
||||
Encoders.param (Encoders.nonNullable ((Encoders.enum id)))
|
||||
in DSL.statement "ok" statement
|
||||
in actualIO >>= assertEqual "" (Right "ok"),
|
||||
testCase "The same prepared statement used on different types" $
|
||||
let actualIO =
|
||||
DSL.session $ do
|
||||
let effect1 =
|
||||
DSL.statement "ok" statement
|
||||
where
|
||||
statement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"select $1"
|
||||
encoder =
|
||||
Encoders.param (Encoders.nonNullable (Encoders.text))
|
||||
decoder =
|
||||
(Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.text)))
|
||||
effect2 =
|
||||
DSL.statement 1 statement
|
||||
where
|
||||
statement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"select $1"
|
||||
encoder =
|
||||
Encoders.param (Encoders.nonNullable (Encoders.int8))
|
||||
decoder =
|
||||
(Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int8))
|
||||
in (,) <$> effect1 <*> effect2
|
||||
in actualIO >>= assertEqual "" (Right ("ok", 1)),
|
||||
testCase "Affected rows counting" $
|
||||
replicateM_ 13 $
|
||||
let actualIO =
|
||||
testCase "Empty array"
|
||||
$ let io =
|
||||
do
|
||||
x <- Connection.with (Session.run session)
|
||||
assertEqual (show x) (Right (Right [])) x
|
||||
where
|
||||
session =
|
||||
Session.statement () statement
|
||||
where
|
||||
statement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"select array[]::int8[]"
|
||||
encoder =
|
||||
mempty
|
||||
decoder =
|
||||
Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.array (Decoders.dimension replicateM (Decoders.element (Decoders.nonNullable Decoders.int8)))))
|
||||
in io,
|
||||
testCase "Failing prepared statements"
|
||||
$ let io =
|
||||
Connection.with (Session.run session)
|
||||
>>= (assertBool <$> show <*> resultTest)
|
||||
where
|
||||
resultTest =
|
||||
\case
|
||||
Right (Left (Session.QueryError _ _ (Session.ResultError (Session.ServerError "26000" _ _ _ _)))) -> False
|
||||
_ -> True
|
||||
session =
|
||||
catchError session (const (pure ())) *> session
|
||||
where
|
||||
session =
|
||||
Session.statement () statement
|
||||
where
|
||||
statement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"absurd"
|
||||
encoder =
|
||||
mempty
|
||||
decoder =
|
||||
Decoders.noResult
|
||||
in io,
|
||||
testCase "Prepared statements after error"
|
||||
$ let io =
|
||||
Connection.with (Session.run session)
|
||||
>>= \x -> assertBool (show x) (either (const False) isRight x)
|
||||
where
|
||||
session =
|
||||
try *> fail *> try
|
||||
where
|
||||
try =
|
||||
Session.statement 1 statement
|
||||
where
|
||||
statement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"select $1 :: int8"
|
||||
encoder =
|
||||
Encoders.param (Encoders.nonNullable (Encoders.int8))
|
||||
decoder =
|
||||
Decoders.singleRow $ (Decoders.column . Decoders.nonNullable) Decoders.int8
|
||||
fail =
|
||||
catchError (Session.sql "absurd") (const (pure ()))
|
||||
in io,
|
||||
testCase "\"in progress after error\" bugfix"
|
||||
$ let sumStatement :: Statement.Statement (Int64, Int64) Int64
|
||||
sumStatement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"select ($1 + $2)"
|
||||
encoder =
|
||||
contramap fst (Encoders.param (Encoders.nonNullable (Encoders.int8)))
|
||||
<> contramap snd (Encoders.param (Encoders.nonNullable (Encoders.int8)))
|
||||
decoder =
|
||||
Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int8)
|
||||
sumSession :: Session.Session Int64
|
||||
sumSession =
|
||||
Session.sql "begin" *> Session.statement (1, 1) sumStatement <* Session.sql "end"
|
||||
errorSession :: Session.Session ()
|
||||
errorSession =
|
||||
Session.sql "asldfjsldk"
|
||||
io =
|
||||
Connection.with $ \c -> do
|
||||
Session.run errorSession c
|
||||
Session.run sumSession c
|
||||
in io >>= \x -> assertBool (show x) (either (const False) isRight x),
|
||||
testCase "\"another command is already in progress\" bugfix"
|
||||
$ let sumStatement :: Statement.Statement (Int64, Int64) Int64
|
||||
sumStatement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"select ($1 + $2)"
|
||||
encoder =
|
||||
contramap fst (Encoders.param (Encoders.nonNullable (Encoders.int8)))
|
||||
<> contramap snd (Encoders.param (Encoders.nonNullable (Encoders.int8)))
|
||||
decoder =
|
||||
Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int8)
|
||||
session :: Session.Session Int64
|
||||
session =
|
||||
do
|
||||
Session.sql "begin;"
|
||||
s <- Session.statement (1, 1) sumStatement
|
||||
Session.sql "end;"
|
||||
return s
|
||||
in DSL.session session >>= \x -> assertEqual (show x) (Right 2) x,
|
||||
testCase "Executing the same query twice"
|
||||
$ pure (),
|
||||
testCase "Interval Encoding"
|
||||
$ let actualIO =
|
||||
DSL.session $ do
|
||||
let statement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"select $1 = interval '10 seconds'"
|
||||
decoder =
|
||||
(Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.bool)))
|
||||
encoder =
|
||||
Encoders.param (Encoders.nonNullable (Encoders.interval))
|
||||
in DSL.statement (10 :: DiffTime) statement
|
||||
in actualIO >>= \x -> assertEqual (show x) (Right True) x,
|
||||
testCase "Interval Decoding"
|
||||
$ let actualIO =
|
||||
DSL.session $ do
|
||||
let statement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"select interval '10 seconds'"
|
||||
decoder =
|
||||
(Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.interval)))
|
||||
encoder =
|
||||
Encoders.noParams
|
||||
in DSL.statement () statement
|
||||
in actualIO >>= \x -> assertEqual (show x) (Right (10 :: DiffTime)) x,
|
||||
testCase "Interval Encoding/Decoding"
|
||||
$ let actualIO =
|
||||
DSL.session $ do
|
||||
let statement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"select $1"
|
||||
decoder =
|
||||
(Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.interval)))
|
||||
encoder =
|
||||
Encoders.param (Encoders.nonNullable (Encoders.interval))
|
||||
in DSL.statement (10 :: DiffTime) statement
|
||||
in actualIO >>= \x -> assertEqual (show x) (Right (10 :: DiffTime)) x,
|
||||
testCase "Unknown"
|
||||
$ let actualIO =
|
||||
DSL.session $ do
|
||||
let statement =
|
||||
Statement.Statement sql mempty Decoders.noResult True
|
||||
where
|
||||
sql =
|
||||
"drop type if exists mood"
|
||||
in DSL.statement () statement
|
||||
let statement =
|
||||
Statement.Statement sql mempty Decoders.noResult True
|
||||
where
|
||||
sql =
|
||||
"create type mood as enum ('sad', 'ok', 'happy')"
|
||||
in DSL.statement () statement
|
||||
let statement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"select $1 = ('ok' :: mood)"
|
||||
decoder =
|
||||
(Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.bool)))
|
||||
encoder =
|
||||
Encoders.param (Encoders.nonNullable (Encoders.unknown))
|
||||
in DSL.statement "ok" statement
|
||||
in actualIO >>= assertEqual "" (Right True),
|
||||
testCase "Textual Unknown"
|
||||
$ let actualIO =
|
||||
DSL.session $ do
|
||||
let statement =
|
||||
Statement.Statement sql mempty Decoders.noResult True
|
||||
where
|
||||
sql =
|
||||
"create or replace function overloaded(a int, b int) returns int as $$ select a + b $$ language sql;"
|
||||
in DSL.statement () statement
|
||||
let statement =
|
||||
Statement.Statement sql mempty Decoders.noResult True
|
||||
where
|
||||
sql =
|
||||
"create or replace function overloaded(a text, b text, c text) returns text as $$ select a || b || c $$ language sql;"
|
||||
in DSL.statement () statement
|
||||
let statement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"select overloaded($1, $2) || overloaded($3, $4, $5)"
|
||||
decoder =
|
||||
(Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.text)))
|
||||
encoder =
|
||||
contramany (Encoders.param (Encoders.nonNullable (Encoders.unknown)))
|
||||
in DSL.statement ["1", "2", "4", "5", "6"] statement
|
||||
in actualIO >>= assertEqual "" (Right "3456"),
|
||||
testCase "Enum"
|
||||
$ let actualIO =
|
||||
DSL.session $ do
|
||||
let statement =
|
||||
Statement.Statement sql mempty Decoders.noResult True
|
||||
where
|
||||
sql =
|
||||
"drop type if exists mood"
|
||||
in DSL.statement () statement
|
||||
let statement =
|
||||
Statement.Statement sql mempty Decoders.noResult True
|
||||
where
|
||||
sql =
|
||||
"create type mood as enum ('sad', 'ok', 'happy')"
|
||||
in DSL.statement () statement
|
||||
let statement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"select ($1 :: mood)"
|
||||
decoder =
|
||||
(Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.enum (Just . id))))
|
||||
encoder =
|
||||
Encoders.param (Encoders.nonNullable ((Encoders.enum id)))
|
||||
in DSL.statement "ok" statement
|
||||
in actualIO >>= assertEqual "" (Right "ok"),
|
||||
testCase "The same prepared statement used on different types"
|
||||
$ let actualIO =
|
||||
DSL.session $ do
|
||||
let effect1 =
|
||||
DSL.statement "ok" statement
|
||||
where
|
||||
statement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"select $1"
|
||||
encoder =
|
||||
Encoders.param (Encoders.nonNullable (Encoders.text))
|
||||
decoder =
|
||||
(Decoders.singleRow ((Decoders.column . Decoders.nonNullable) (Decoders.text)))
|
||||
effect2 =
|
||||
DSL.statement 1 statement
|
||||
where
|
||||
statement =
|
||||
Statement.Statement sql encoder decoder True
|
||||
where
|
||||
sql =
|
||||
"select $1"
|
||||
encoder =
|
||||
Encoders.param (Encoders.nonNullable (Encoders.int8))
|
||||
decoder =
|
||||
(Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int8))
|
||||
in (,) <$> effect1 <*> effect2
|
||||
in actualIO >>= assertEqual "" (Right ("ok", 1)),
|
||||
testCase "Affected rows counting"
|
||||
$ replicateM_ 13
|
||||
$ let actualIO =
|
||||
DSL.session $ do
|
||||
dropTable
|
||||
createTable
|
||||
@ -453,17 +462,17 @@ tree =
|
||||
deleteRows <* dropTable
|
||||
where
|
||||
dropTable =
|
||||
DSL.statement () $
|
||||
Statements.plain $
|
||||
"drop table if exists a"
|
||||
DSL.statement ()
|
||||
$ Statements.plain
|
||||
$ "drop table if exists a"
|
||||
createTable =
|
||||
DSL.statement () $
|
||||
Statements.plain $
|
||||
"create table a (id bigserial not null, name varchar not null, primary key (id))"
|
||||
DSL.statement ()
|
||||
$ Statements.plain
|
||||
$ "create table a (id bigserial not null, name varchar not null, primary key (id))"
|
||||
insertRow =
|
||||
DSL.statement () $
|
||||
Statements.plain $
|
||||
"insert into a (name) values ('a')"
|
||||
DSL.statement ()
|
||||
$ Statements.plain
|
||||
$ "insert into a (name) values ('a')"
|
||||
deleteRows =
|
||||
DSL.statement () $ Statement.Statement sql mempty decoder False
|
||||
where
|
||||
@ -472,18 +481,18 @@ tree =
|
||||
decoder =
|
||||
Decoders.rowsAffected
|
||||
in actualIO >>= assertEqual "" (Right 100),
|
||||
testCase "Result of an auto-incremented column" $
|
||||
let actualIO =
|
||||
DSL.session $ do
|
||||
DSL.statement () $ Statements.plain $ "drop table if exists a"
|
||||
DSL.statement () $ Statements.plain $ "create table a (id serial not null, v char not null, primary key (id))"
|
||||
id1 <- DSL.statement () $ Statement.Statement "insert into a (v) values ('a') returning id" mempty (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int4)) False
|
||||
id2 <- DSL.statement () $ Statement.Statement "insert into a (v) values ('b') returning id" mempty (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int4)) False
|
||||
DSL.statement () $ Statements.plain $ "drop table if exists a"
|
||||
pure (id1, id2)
|
||||
in assertEqual "" (Right (1, 2)) =<< actualIO,
|
||||
testCase "List decoding" $
|
||||
let actualIO =
|
||||
DSL.session $ DSL.statement () $ Statements.selectList
|
||||
in assertEqual "" (Right [(1, 2), (3, 4), (5, 6)]) =<< actualIO
|
||||
testCase "Result of an auto-incremented column"
|
||||
$ let actualIO =
|
||||
DSL.session $ do
|
||||
DSL.statement () $ Statements.plain $ "drop table if exists a"
|
||||
DSL.statement () $ Statements.plain $ "create table a (id serial not null, v char not null, primary key (id))"
|
||||
id1 <- DSL.statement () $ Statement.Statement "insert into a (v) values ('a') returning id" mempty (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int4)) False
|
||||
id2 <- DSL.statement () $ Statement.Statement "insert into a (v) values ('b') returning id" mempty (Decoders.singleRow ((Decoders.column . Decoders.nonNullable) Decoders.int4)) False
|
||||
DSL.statement () $ Statements.plain $ "drop table if exists a"
|
||||
pure (id1, id2)
|
||||
in assertEqual "" (Right (1, 2)) =<< actualIO,
|
||||
testCase "List decoding"
|
||||
$ let actualIO =
|
||||
DSL.session $ DSL.statement () $ Statements.selectList
|
||||
in assertEqual "" (Right [(1, 2), (3, 4), (5, 6)]) =<< actualIO
|
||||
]
|
||||
|
||||
@ -38,8 +38,8 @@ session session =
|
||||
password = ""
|
||||
database = "postgres"
|
||||
use connection =
|
||||
ExceptT $
|
||||
fmap (mapLeft SessionError) $
|
||||
Hasql.Session.run session connection
|
||||
ExceptT
|
||||
$ fmap (mapLeft SessionError)
|
||||
$ Hasql.Session.run session connection
|
||||
release connection =
|
||||
lift $ HC.release connection
|
||||
|
||||
@ -12,15 +12,18 @@ plain sql =
|
||||
|
||||
dropType :: ByteString -> HQ.Statement () ()
|
||||
dropType name =
|
||||
plain $
|
||||
"drop type if exists " <> name
|
||||
plain
|
||||
$ "drop type if exists "
|
||||
<> name
|
||||
|
||||
createEnum :: ByteString -> [ByteString] -> HQ.Statement () ()
|
||||
createEnum name values =
|
||||
plain $
|
||||
"create type " <> name <> " as enum ("
|
||||
<> mconcat (intersperse ", " (map (\x -> "'" <> x <> "'") values))
|
||||
<> ")"
|
||||
plain
|
||||
$ "create type "
|
||||
<> name
|
||||
<> " as enum ("
|
||||
<> mconcat (intersperse ", " (map (\x -> "'" <> x <> "'") values))
|
||||
<> ")"
|
||||
|
||||
selectList :: HQ.Statement () ([] (Int64, Int64))
|
||||
selectList =
|
||||
|
||||
@ -15,9 +15,9 @@ main =
|
||||
(,) <$> acquire <*> acquire
|
||||
where
|
||||
acquire =
|
||||
join $
|
||||
fmap (either (fail . show) return) $
|
||||
Hasql.Connection.acquire connectionSettings
|
||||
join
|
||||
$ fmap (either (fail . show) return)
|
||||
$ Hasql.Connection.acquire connectionSettings
|
||||
where
|
||||
connectionSettings =
|
||||
Hasql.Connection.settings "localhost" 5432 "postgres" "" "postgres"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user