diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for poseidon + +## 0.1.0.0 -- 2019-09-22 + +* First version. Released on an unsuspecting world. diff --git a/Data/Poseidon.hs b/Data/Poseidon.hs new file mode 100644 --- /dev/null +++ b/Data/Poseidon.hs @@ -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' diff --git a/Database/Poseidon.hs b/Database/Poseidon.hs new file mode 100644 --- /dev/null +++ b/Database/Poseidon.hs @@ -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" diff --git a/Database/Poseidon/Internal.hs b/Database/Poseidon/Internal.hs new file mode 100644 --- /dev/null +++ b/Database/Poseidon/Internal.hs @@ -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 +-- * - standard varlena header word +-- * - number of dimensions of the array +-- * - offset to stored data, or 0 if no nulls bitmap +-- * - element type OID +-- * - length of each array axis (C array of int) +-- * - lower boundary of each dimension (C array of int) +-- * - bitmap showing locations of nulls (OPTIONAL) +-- * - 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' diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/poseidon.cabal b/poseidon.cabal new file mode 100644 --- /dev/null +++ b/poseidon.cabal @@ -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 diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -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)