poseidon (empty) → 0.1.0.0
raw patch · 8 files changed
+694/−0 lines, 8 filesdep +QuickCheckdep +aesondep +asyncsetup-changed
Dependencies added: QuickCheck, aeson, async, base, binary, binary-bits, bytestring, generics-eot, hspec, poseidon, postgresql-libpq, random, scientific, text, time, unordered-containers, uuid
Files
- CHANGELOG.md +5/−0
- Data/Poseidon.hs +113/−0
- Database/Poseidon.hs +237/−0
- Database/Poseidon/Internal.hs +109/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- poseidon.cabal +122/−0
- tests/Tests.hs +76/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for poseidon++## 0.1.0.0 -- 2019-09-22++* First version. Released on an unsuspecting world.
+ Data/Poseidon.hs view
@@ -0,0 +1,113 @@+-----------------------------------------------------------------------------+-- |+-- Module : Database.Poseidon+-- Copyright : (c) 2019 Florian Grignon+-- License : BSD3+--+-- Maintainer : grignon.florian@gmail.com+-- Stability : experimental+--+-- This library provide a Simple and Extensible access to PostgreSQL.+--+-- Simple: Poseidon runs a SQL query and returns a set of custom datatype.+-- **It is not an ORM.**+--+-- Extensible: As a user of the library, you can map your custom PostgreSQL+-- type to your Haskell datatype easily, in a pluggable way (e.g. if you're+-- using postgis, you will be most likely interested by poseidon-postgis,+-- that maps GeoJSON WKT to GeospatialGeometry).+--+-----------------------------------------------------------------------------+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Poseidon where+++import GHC.Generics++import Data.Text+import Data.UUID+import Data.Time+import Data.Aeson as A+import Data.ByteString as B+import Data.ByteString.Lazy as BSL+++newtype PGText = PGText Text+ deriving (Generic, Show)++toText :: PGText -> Text+toText pgText = case pgText of+ PGText text' -> text'++newtype PGBool = PGBool Bool+ deriving (Generic, Show)++toBool :: PGBool -> Bool+toBool pgBool = case pgBool of+ PGBool value' -> value'++newtype PGTimestamp = PGTimestamp UTCTime+ deriving (Generic, Show)++toUTCTime :: PGTimestamp -> UTCTime+toUTCTime pgTimestamp = case pgTimestamp of+ PGTimestamp value' -> value'++newtype PGUUID = PGUUID UUID+ deriving (Generic, Show)++toUUID :: PGUUID -> UUID+toUUID pgUUID = case pgUUID of+ PGUUID uuid' -> uuid'++newtype PGJsonValue = PGJsonValue A.Value+ deriving (Generic, Show)++toValue :: PGJsonValue -> A.Value+toValue pgJsonValue = case pgJsonValue of+ PGJsonValue value' -> value'++newtype PGInteger = PGInteger Integer+ deriving (Generic, Show)++toInteger :: PGInteger -> Integer+toInteger pgInteger = case pgInteger of+ PGInteger integer' -> integer'++newtype PGDouble = PGDouble Double+ deriving (Generic, Show)++toDouble :: PGDouble -> Double+toDouble pgDouble = case pgDouble of+ PGDouble integer' -> integer'++newtype PGDecimal = PGDecimal Float+ deriving (Generic, Show)++toDecimal :: PGDecimal -> Float+toDecimal pgDecimal = case pgDecimal of+ PGDecimal value' -> value'++newtype PGByteString = PGByteString B.ByteString+ deriving (Generic, Show)++toByteString :: PGByteString -> B.ByteString+toByteString pgByteString = case pgByteString of+ PGByteString value' -> value'++newtype PGLazyByteString = PGLazyByteString BSL.ByteString+ deriving (Generic, Show)++toLazyByteString :: PGLazyByteString -> BSL.ByteString+toLazyByteString pgLazyByteString = case pgLazyByteString of+ PGLazyByteString value' -> value'
+ Database/Poseidon.hs view
@@ -0,0 +1,237 @@+-----------------------------------------------------------------------------+-- |+-- Module : Database.Poseidon+-- Copyright : (c) 2019 Florian Grignon+-- License : BSD3+--+-- Maintainer : grignon.florian@gmail.com+-- Stability : experimental+--+-- This library provide a Simple and Extensible access to PostgreSQL.+--+-- Simple: Poseidon runs a SQL query and returns a set of custom datatype.+-- **It is not an ORM.**+--+-- Extensible: As a user of the library, you can map your custom PostgreSQL+-- type to your Haskell datatype easily, in a pluggable way (e.g. if you're+-- using postgis, you will be most likely interested by poseidon-postgis,+-- that maps GeoJSON WKT to GeospatialGeometry).+--+-----------------------------------------------------------------------------+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}++module Database.Poseidon where++import Prelude++import Generics.Eot++import Control.Concurrent.Async++import Foreign.C.Types+import Control.Exception+import Data.Maybe (fromMaybe)+import Database.Poseidon.Internal+import Data.Poseidon()++import Data.Binary+import Data.Binary.Get+import Data.UUID+import Data.Time+import Data.Aeson as A hiding (Result)+import Data.Text hiding (splitAt)+import Data.Text.Encoding (encodeUtf8, decodeUtf8)+import Database.PostgreSQL.LibPQ+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as B+ ( ByteString(..) )++newtype ExceptionText = ExceptionText Text+ deriving (Show, Eq)+instance Exception ExceptionText++data ExceptionPostgreSQL = ExceptionPGUniqueViolation+ | ExceptionPGJWTMalformed+ | ExceptionPGJWTInvalid+ | ExceptionPGUnknown+ deriving (Show, Eq)+instance Exception ExceptionPostgreSQL++queryFromText :: (HasEot a, EotDeserialize (Eot a)) => Connection -> Text -> [Maybe (Oid, B.ByteString, Format)] -> IO [a]+queryFromText conn sqlQuery params = do+ mresult <- execParams conn (encodeUtf8 sqlQuery) params Binary + case mresult of+ Just result -> do+ rStatus <- resultStatus result+ case rStatus of+ TuplesOk -> do+ (Row nbRows) <- ntuples result+ let rows = [0..(nbRows-1)]+ mapConcurrently (\k -> genericDeserialize result k 0) rows+ FatalError -> do+ diagSqlstate <- resultErrorField result DiagSqlstate++ diagSeverity <- resultErrorField result DiagSeverity+ putStrLn $ ("DiagSeverity : " <> (show diagSeverity))+ diagMessagePrimary <- resultErrorField result DiagMessagePrimary+ putStrLn $ ("DiagMessagePrimary : " <> (show diagMessagePrimary))+ diagMessageDetail <- resultErrorField result DiagMessageDetail+ putStrLn $ ("DiagMessageDetail : " <> (show diagMessageDetail))+ diagMessageHint <- resultErrorField result DiagMessageHint+ putStrLn $ ("DiagMessageHint : " <> (show diagMessageHint))+ diagStatementPosition <- resultErrorField result DiagStatementPosition+ putStrLn $ ("DiagStatementPosition : " <> (show diagStatementPosition))+ diagInternalPosition <- resultErrorField result DiagInternalPosition+ putStrLn $ ("DiagInternalPosition : " <> (show diagInternalPosition))+ diagInternalQuery <- resultErrorField result DiagInternalQuery+ putStrLn $ ("DiagInternalQuery : " <> (show diagInternalQuery))+ diagContext <- resultErrorField result DiagContext+ putStrLn $ ("DiagContext : " <> (show diagContext))+ diagSourceFile <- resultErrorField result DiagSourceFile+ putStrLn $ ("DiagSourceFile : " <> (show diagSourceFile))+ diagSourceLine <- resultErrorField result DiagSourceLine+ putStrLn $ ("DiagSourceLine : " <> (show diagSourceLine))+ diagSourceFunction <- resultErrorField result DiagSourceFunction+ putStrLn $ ("DiagSourceFunction : " <> (show diagSourceFunction))+ putStrLn $ ("DiagSqlstate : " <> (show diagSqlstate))++ case diagSqlstate of+ Just sqlStateBS -> do+ let sqlState = show sqlStateBS :: [Char]+ case sqlState of+ -- https://www.postgresql.org/docs/current/errcodes-appendix.html+ "\"23505\"" -> throw ExceptionPGUniqueViolation+ "\"P1002\"" -> throw ExceptionPGJWTMalformed+ "\"P1003\"" -> throw ExceptionPGJWTInvalid+ _ -> throw $ ExceptionPGUnknown+ Nothing -> throw $ ExceptionText "Cant retrieve the PostgreSQL error field SqlState"+ otherStatus -> do+ putStrLn $ ("PG Status : " <> (show otherStatus))+ throw $ ExceptionText "Wrong PostgreSQL result status, please check"+ Nothing -> throw $ ExceptionText "Didnt receive a PostgreSQL result"+++class EotDeserialize eot where+ eotDeserialize :: Result -> CInt -> CInt -> IO eot++instance (EotDeserialize this, EotDeserialize next) => EotDeserialize (Either this next) where++ eotDeserialize res row _ = Left <$> eotDeserialize res row 0+++instance (Deserialize x, EotDeserialize xs) => EotDeserialize (x, xs) where+ -- eotDeserialize :: (Result, CInt, CInt) -> IO eot+ eotDeserialize res row col = do+ firstField <- deserialize res row col+ nextFields <- eotDeserialize res row (succ col)+ pure ( firstField, nextFields )++instance EotDeserialize Void where+ eotDeserialize _ _ _ = error "invalid input"++instance EotDeserialize () where+ eotDeserialize _ _ _ = mempty++getBSValue :: Result -> CInt -> CInt -> IO (Maybe BSL.ByteString)+getBSValue res row col = do+ mValueBS <- getvalue res (Row row) (Col col)+ case mValueBS of+ Just valueBS' -> pure $ Just (BSL.fromStrict valueBS')+ Nothing -> pure $ Nothing++class Deserialize a where+ deserialize :: Result -> CInt -> CInt -> IO a++-- All base datatype we can deserialize+instance Deserialize BSL.ByteString where+ deserialize res row col = do+ bs <- (fromMaybe mempty) <$> getBSValue res row col+ pure $ bs++instance Deserialize BS.ByteString where+ deserialize res row col = do+ bs <- (fromMaybe mempty) <$> getBSValue res row col+ pure $ BSL.toStrict bs++instance Deserialize Integer where+ deserialize res row col = do+ bs <- (fromMaybe mempty) <$> getBSValue res row col+ pure $ fromIntegral . runGet getInt16be $ bs++instance Deserialize Float where+ deserialize res row col = do+ bs <- (fromMaybe mempty) <$> getBSValue res row col+ pure $ runGet getFloatbe bs++instance Deserialize Double where+ deserialize res row col = do+ bs <- (fromMaybe mempty) <$> getBSValue res row col+ pure $ runGet getDoublebe bs++instance Deserialize Text where+ deserialize res row col = do+ bs <- (fromMaybe mempty) <$> getBSValue res row col+ pure $ decodeUtf8 . BSL.toStrict $ bs++instance Deserialize UTCTime where+ deserialize res row col = do+ bs <- (fromMaybe mempty) <$> getBSValue res row col+ let (relDays, relSeconds) = runGet getDate bs+ pure $ UTCTime (ModifiedJulianDay relDays) (secondsToDiffTime relSeconds)++instance Deserialize (Maybe Text) where+ deserialize res row col = (decodeUtf8 . BSL.toStrict <$>) <$> getBSValue res row col++instance Deserialize UUID where+ deserialize res row col = do+ bs <- (fromMaybe mempty) <$> getBSValue res row col+ let mValue = fromByteString bs+ case mValue of+ Just value' -> pure value'+ Nothing -> error "Impossible to decode expected UUID"++getPGBool :: Get Bool+getPGBool = do+ w <- getWord8+ return $ (fromIntegral w :: Integer) /= 0++instance Deserialize Bool where+ deserialize res row col = do+ bs <- (fromMaybe mempty) <$> getBSValue res row col+ pure $ runGet getPGBool bs++instance Deserialize (Maybe Bool) where+ deserialize res row col = (runGet getPGBool <$>) <$> getBSValue res row col++instance Deserialize [Text] where+ deserialize res row col = do+ bs <- (fromMaybe mempty) <$> getBSValue res row col+ let pgArray = runGet getPGArray bs+ let words8 = fmap pgArrayDataData $ pgArrayData pgArray+ pure $ (decodeUtf8 . BS.pack) <$> words8++instance Deserialize () where+ deserialize _ _ _ = pure ()++genericDeserialize :: (HasEot a, EotDeserialize (Eot a)) => Result -> CInt -> CInt -> IO a+genericDeserialize res row col = do+ resrow <- eotDeserialize res row col+ pure $ fromEot resrow++instance Deserialize A.Value where+ deserialize res row col = do+ bs <- (fromMaybe mempty) <$> getBSValue res row col+ let mValue = A.decode bs :: Maybe A.Value+ case mValue of+ Just value' -> pure $ value'+ Nothing -> error "Impossible to decode JSON"
+ Database/Poseidon/Internal.hs view
@@ -0,0 +1,109 @@+module Database.Poseidon.Internal where++import Data.Binary+import Data.Binary.Get+import Data.Int++getRemainingWord8 :: Get [Word8]+getRemainingWord8 = do+ bempty <- isEmpty+ if bempty+ then return []+ else do current <- getWord8+ remainingWords <- getRemainingWord8+ return (current:remainingWords)++getDate :: Get (Integer, Integer)+getDate = do+ totalSeconds <- Data.Binary.get :: Get Int64+ let relDays = (totalSeconds `div` 86400000000) + 51544+ let relSeconds = (totalSeconds `mod` 86400000000) `div` 1000000+ pure(fromIntegral relDays, fromIntegral relSeconds)+++data PGRange = PGRange+ { pgH :: !Word8+ , pgLengthStart :: !Word32+ , pgRangeStartData :: ![Word8]+ , pgLengthStop :: !Word32+ , pgRangeStopData :: ![Word8]+ } deriving (Show)++getPGRange :: Get PGRange+getPGRange = do+ pgH' <- getWord8 -- get the first byte+ pgLengthStart' <- getWord32be+ pgRangeStartData' <- getNbPGArrayData pgLengthStart'+ pgLengthStop' <- getWord32be+ pgRangeStopData' <- getNbPGArrayData pgLengthStop'++ pure $! PGRange pgH' pgLengthStart' pgRangeStartData' pgLengthStop' pgRangeStopData'++-- Please refer to the documentation of array.h in postgresql repository+-- https://doxygen.postgresql.org/array_8h_source.html+-- * <vl_len_> - standard varlena header word+-- * <ndim> - number of dimensions of the array+-- * <dataoffset> - offset to stored data, or 0 if no nulls bitmap+-- * <elemtype> - element type OID+-- * <dimensions> - length of each array axis (C array of int)+-- * <lower bnds> - lower boundary of each dimension (C array of int)+-- * <null bitmap> - bitmap showing locations of nulls (OPTIONAL)+-- * <actual data> - whatever is the stored data+data PGArray = PGArray+ { pgArrayVl_len_ :: !Word32+ , pgArrayNbDim :: !Word16+ , pgArrayDataOffset :: !Word32+ , pgArrayElemType :: !Word16+ , pgArrayDimensions :: !Word32+ , pgArrayLowerBound :: !Word32+ , pgArrayData :: ![PGArrayData]+ } deriving (Show)++data PGArrayData = PGArrayData+ { pgArrayDataLength :: !Word32+ , pgArrayDataData :: ![Word8]+ } deriving (Show)++getNb16PGArrayData :: Word16 -> Get [Word8]+getNb16PGArrayData 0 = pure []+getNb16PGArrayData nbWords = do+ currentWord <- getWord8+ remainingWords <- getNb16PGArrayData (nbWords - 1)+ pure (currentWord:remainingWords)++getNbPGArrayData :: Word32 -> Get [Word8]+getNbPGArrayData 0 = pure []+getNbPGArrayData nbWords = do+ currentWord <- getWord8+ remainingWords <- getNbPGArrayData (nbWords - 1)+ pure (currentWord:remainingWords)++getPGArrayData :: Get PGArrayData+getPGArrayData = do+ textLength <- getWord32be+ pgWord8' <- getNbPGArrayData textLength+ pure $ PGArrayData textLength pgWord8'++getPGArrayDataList :: Get [PGArrayData]+getPGArrayDataList = do+ bempty <- isEmpty+ if bempty+ then pure []+ else do pgArrayData' <- getPGArrayData+ pgArrayDatas' <- getPGArrayDataList+ pure (pgArrayData':pgArrayDatas')++getPGArray :: Get PGArray+getPGArray = do+ vl_len_' <- getWord32be+ nbDim' <- getWord16be+ dataOffset' <- getWord32be+ elemType' <- getWord16be+ dimensions' <- getWord32be+ lowerBound' <- getWord32be++ -- A text is represented by the length of the next words+ -- then appended the text+ pgArrayData' <- getPGArrayDataList++ pure $! PGArray vl_len_' nbDim' dataOffset' elemType' dimensions' lowerBound' pgArrayData'
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019, Florian Grignon++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Florian Grignon nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ poseidon.cabal view
@@ -0,0 +1,122 @@+cabal-version: 2.4++-- Initial package description 'poseidon.cabal' generated by 'cabal init'.+-- For further documentation, see http://haskell.org/cabal/users-guide/++-- The name of the package.+name: poseidon++-- The package version. See the Haskell package versioning policy (PVP)+-- for standards guiding when and how versions should be incremented.+-- https://pvp.haskell.org+-- PVP summary: +-+------- breaking API changes+-- | | +----- non-breaking API additions+-- | | | +--- code changes with no API change+version: 0.1.0.0++-- A short (one-line) description of the package.+synopsis: Simple extensible library to run SQL file against PostgreSQL database.++-- A longer description of the package.+description:+ Poseidon provides a Simple and Extensible access to PostgreSQL.+ .+ Simple: Poseidon runs a SQL query and returns a set of custom datatype.+ **It is not an ORM.**+ .+ Extensible: As a user of the library, you can map your custom PostgreSQL+ type to your Haskell datatype easily, in a pluggable way (e.g. if you're+ using postgis, you will be most likely interested by poseidon-postgis,+ that maps GeoJSON WKT to GeospatialGeometry).++-- URL for the project homepage or repository.+homepage: https://github.com/FlogFr/poseidon++-- A URL where users can report bugs.+bug-reports: https://github.com/FlogFr/poseidon/issues++-- The license under which the package is released.+license: BSD-3-Clause++-- The file containing the license text.+license-file: LICENSE++-- The package author(s).+author: Florian Grignon++-- An email address to which users can send suggestions, bug reports, and+-- patches.+maintainer: grignon.florian@gmail.com++-- A copyright notice.+-- copyright:++category: Database++-- Extra files to be distributed with the package, such as examples or a+-- README.+extra-source-files: CHANGELOG.md+++library+ -- Modules exported by the library.+ exposed-modules:+ Data.Poseidon+ Database.Poseidon++ -- Modules included in this library but not exported.+ other-modules:+ Database.Poseidon.Internal++ -- LANGUAGE extensions used by modules in this package.+ -- other-extensions:++ ghc-options: -Wall++ -- Other library packages from which modules are imported.+ build-depends:+ async >=2.2.2 && <2.3+ , aeson >=1.4.5.0 && <1.5+ , base >=4.12.0.0 && <5+ , binary >=0.8.6.0 && <0.9+ , binary-bits >=0.5 && <0.6+ , bytestring >=0.10.8.2 && <0.11+ , generics-eot >=0.4 && <0.5+ , postgresql-libpq >=0.9.4 && <0.10+ , random >=1.1 && <1.2+ , scientific >=0.3.6.2 && <0.4+ , text >=1.2 && <1.3+ , time >=1.9 && <1.10+ , unordered-containers >=0.2.10.0 && <0.3+ , uuid >=1.3 && <1.14++ -- Directories containing source files.+ hs-source-dirs: .++ -- Base language which the package is written in.+ default-language: Haskell2010++test-suite tests+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: tests+ main-is: Tests.hs+ ghc-options: -Wall -threaded -rtsopts++ build-depends:+ aeson >=1.4.5.0 && <1.5+ , bytestring >=0.10.8.2 && <0.11+ , base >=4.12.0.0 && <5+ , hspec >=2.7.1 && <2.8+ , QuickCheck >= 2.10.0.1 && < 2.14+ , poseidon+ , text >=1.2 && <1.3+ , time >=1.9 && <1.10+ , scientific >=0.3.6.2 && <0.4+ , postgresql-libpq >=0.9.4 && <0.10+ , unordered-containers >=0.2.10.0 && <0.3+ , uuid >=1.3 && <1.14++source-repository head+ type: git+ location: git://github.com/FlogFr/poseidon.git
+ tests/Tests.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}++module Main (main) where++import Prelude+import GHC.Generics++import Data.Aeson as A+import Data.List ((!!))+import Database.PostgreSQL.LibPQ+import Data.Poseidon+import Database.Poseidon++import Test.Hspec+import Data.Scientific+import Data.Time+import qualified Data.UUID as U+import Data.HashMap.Strict+import Data.ByteString as B+import Data.ByteString.Lazy as BSL+import Data.Text hiding (head)+import Data.Text.Encoding (encodeUtf8)++data User = User {+ first_name :: Text+ , is_admin :: Bool+ } deriving (Generic, Eq, Show)++data UserDetails = UserDetails {+ age :: Integer+ , extra_values :: Value+ } deriving (Generic, Eq, Show)++main :: IO ()+main = do+ conn <- connectdb . encodeUtf8 $ "service=test"+ hspec $ do+ describe "Single Value Deserialization tests" $ do+ it "Single Value Text deserialization" $ do+ dataResult <- queryFromText conn "SELECT CAST('Florian :)' AS TEXT);" mempty :: IO [PGText]+ let resultExpected = "Florian :)"+ resultExpected `shouldBe` (toText $ dataResult!!0)+ it "Single Value Bool deserialization" $ do+ dataResult <- queryFromText conn "SELECT CAST('t' AS BOOL);" mempty :: IO [PGBool]+ let resultExpected = True+ resultExpected `shouldBe` (toBool $ dataResult!!0)+ it "Single Value Timestamp With TZ deserialization" $ do+ dataResult <- queryFromText conn "SELECT CAST('2019-09-24 02:04:23+1' AS TIMESTAMPTZ);" mempty :: IO [PGTimestamp]+ let resultExpected = UTCTime (ModifiedJulianDay 58750) (secondsToDiffTime 3863)+ resultExpected `shouldBe` (toUTCTime $ dataResult!!0)+ it "Single Value UUID deserialization" $ do+ dataResult <- queryFromText conn "SELECT CAST('0cfa19ce-eed9-42f8-87b2-64f97dc27770' AS UUID);" mempty :: IO [PGUUID]+ let resultExpected = U.fromString "0cfa19ce-eed9-42f8-87b2-64f97dc27770"+ resultExpected `shouldBe` (Just (toUUID $ dataResult!!0))+ it "Single Value JSON deserialization" $ do+ jsonResult <- queryFromText conn "SELECT '{\"username\": \"florian728\", \"age\": 28}'::JSON ;" mempty :: IO [PGJsonValue]+ let resultExpected = A.Object . fromList $ [("username", "florian728"), ("age", A.Number ( read "28" :: Scientific ) )]+ resultExpected `shouldBe` (toValue $ jsonResult!!0)+ it "Single Value Strict Binary deserialization" $ do+ jsonResult <- queryFromText conn "SELECT CAST(E'\\120\\121' AS BYTEA) ;" mempty :: IO [PGByteString]+ let resultExpected = B.pack [80, 81]+ resultExpected `shouldBe` (toByteString $ jsonResult!!0)+ it "Single Value Lazy Binary deserialization" $ do+ jsonResult <- queryFromText conn "SELECT CAST(E'\\120\\121' AS BYTEA) ;" mempty :: IO [PGLazyByteString]+ let resultExpected = BSL.pack [80, 81]+ resultExpected `shouldBe` (toLazyByteString $ jsonResult!!0)+ describe "User Datatype Deserialization tests" $ do+ it "Full User deserialization" $ do+ dataResult <- queryFromText conn "SELECT CAST('Florian :)' AS TEXT), CAST('t' AS BOOL);" mempty :: IO [User]+ let resultExpected = User "Florian :)" True+ resultExpected `shouldBe` (dataResult!!0)+ it "Full UserDetails deserialization" $ do+ dataResult <- queryFromText conn "SELECT CAST(28 AS SMALLINT), CAST('{\"paid_user\": true, \"registered_at\": \"2019-08-27\"}' AS JSON);" mempty :: IO [UserDetails]+ let resultExpected = UserDetails 28 (A.Object . fromList $ [("paid_user", A.Bool True), ("registered_at", "2019-08-27")])+ resultExpected `shouldBe` (dataResult!!0)