hpqtypes 1.7.0.0 → 1.8.0.0

raw patch · 19 files changed

+315/−239 lines, 19 filesdep +uuid-typesdep ~aesondep ~asyncdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: uuid-types

Dependency ranges changed: aeson, async, base, containers, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• examples/Catalog.hs +5/−5
• hpqtypes.cabal +24/−22
• libpqtypes/src/libpqtypes.h +13/−1
• libpqtypes/src/misc.c +11/−26
• src/Database/PostgreSQL/PQTypes/Format.hs +4/−0
• src/Database/PostgreSQL/PQTypes/FromSQL.hs +6/−0
• src/Database/PostgreSQL/PQTypes/Internal/C/Types.hsc +72/−40
• src/Database/PostgreSQL/PQTypes/Internal/Connection.hs +19/−19
• src/Database/PostgreSQL/PQTypes/Internal/Error.hs +61/−61
• src/Database/PostgreSQL/PQTypes/Internal/Exception.hs +6/−6
• src/Database/PostgreSQL/PQTypes/Internal/Notification.hsc +8/−8
• src/Database/PostgreSQL/PQTypes/Internal/QueryResult.hs +5/−5
• src/Database/PostgreSQL/PQTypes/Internal/State.hs +12/−12
• src/Database/PostgreSQL/PQTypes/Interval.hsc +9/−9
• src/Database/PostgreSQL/PQTypes/ToSQL.hs +7/−0
• src/Database/PostgreSQL/PQTypes/Transaction/Settings.hs +21/−22
• test/Main.hs +20/−3
• test/Test/QuickCheck/Arbitrary/Instances.hs +8/−0

@@ -1,3 +1,7 @@+# hpqtypes-1.8.0.0 (2019-10-31)+* Implement `UUID` format ([#17](https://github.com/scrive/hpqtypes/pull/17)).+* Support GHC 8.8.+ # hpqtypes-1.7.0.0 (2019-05-21) * Remove the `Default` instances for `ConnectionSettings` and   `TransactionSettings`; use `defaultConnectionSettings` and

@@ -33,11 +33,11 @@ ----------------------------------------  -- | Representation of a book.-data Book = Book {-  bookID       :: Int64-, bookName     :: String-, bookYear     :: Int32-} deriving (Read, Show)+data Book = Book+  { bookID       :: Int64+  , bookName     :: String+  , bookYear     :: Int32+  } deriving (Read, Show)  -- | Intermediate representation of 'Book'. type instance CompositeRow Book = (Int64, String, Int32)

@@ -1,5 +1,5 @@ name:                hpqtypes-version:             1.7.0.0+version:             1.8.0.0 synopsis:            Haskell bindings to libpqtypes  description:         Efficient and easy-to-use bindings to (slightly modified)@@ -38,8 +38,8 @@ copyright:           Scrive AB category:            Database build-type:          Custom-cabal-version:       1.18-tested-with:         GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5+cabal-version:       1.24+tested-with:         GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.1   extra-source-files: README.md@@ -70,8 +70,8 @@                   , libpqtypes/src/libpqtypes.h  custom-setup-  setup-depends: base >= 4.9 && < 4.13,-                 Cabal >= 1.24 && < 2.5,+  setup-depends: base  >= 4.9  && < 4.14,+                 Cabal >= 1.24 && < 3.1,                  directory,                  filepath @@ -123,23 +123,24 @@                      , Database.PostgreSQL.PQTypes.Internal.C.Interface                      , Database.PostgreSQL.PQTypes.Internal.C.Get -  build-depends:       base >= 4.9 && < 4.13-                     , text >= 0.11-                     , aeson >= 0.6.2.0-                     , async >= 2.1.1.1-                     , bytestring >= 0.9-                     , semigroups >= 0.16-                     , time >= 1.4-                     , vector >= 0.10+  build-depends:       base              >= 4.9     && < 4.14+                     , text              >= 0.11    && < 1.3+                     , aeson             >= 1.0     && < 1.5+                     , async             >= 2.1.1.1 && < 2.3+                     , bytestring        >= 0.9+                     , semigroups        >= 0.16+                     , time              >= 1.4+                     , vector            >= 0.10                      , transformers-base >= 0.4-                     , monad-control >= 0.3-                     , lifted-base >= 0.2-                     , resource-pool >= 0.2-                     , mtl >= 2.1-                     , transformers >= 0.2.2-                     , containers >= 0.4.0.0-                     , exceptions >= 0.6-                     , text-show >= 2+                     , monad-control     >= 0.3+                     , lifted-base       >= 0.2+                     , resource-pool     >= 0.2+                     , mtl               >= 2.1+                     , transformers      >= 0.2.2+                     , containers        >= 0.5.0.0+                     , exceptions        >= 0.6+                     , text-show         >= 2+                     , uuid-types        >= 1.0.3   && < 1.1    hs-source-dirs:    src @@ -206,7 +207,7 @@                      Test.QuickCheck.Compat                      Test.QuickCheck.Arbitrary.Instances   build-depends:       hpqtypes-                     , base >= 4.9 && < 4.13+                     , base >= 4.9 && < 4.14                      , HUnit >= 1.2                      , QuickCheck >= 2.5                      , aeson >= 0.6.2.0@@ -225,6 +226,7 @@                      , transformers-base >= 0.4                      , unordered-containers                      , vector+                     , uuid-types    default-language:  Haskell2010   default-extensions: BangPatterns

@@ -148,7 +148,19 @@ typedef char *PGtext; typedef char *PGvarchar; typedef char *PGbpchar;-typedef char *PGuuid;++typedef union+{+	struct+	{+		unsigned w1;+		unsigned w2;+		unsigned w3;+		unsigned w4;+	};+	char data[16];+} PGuuid;+ typedef struct {   int len;

@@ -115,46 +115,31 @@ int pqt_put_uuid(PGtypeArgs *args) {-	PGuuid uuid = va_arg(args->ap, PGuuid);+	PGuuid *uuid = va_arg(args->ap, PGuuid *); 	PUTNULLCHK(args, uuid);-	args->put.out = uuid;-	return 16;+	args->put.out = uuid->data;+	return sizeof(uuid->data); }  int pqt_get_uuid(PGtypeArgs *args) { 	DECLVALUE(args);+	DECLLENGTH(args); 	PGuuid *uuid = va_arg(args->ap, PGuuid *);  	CHKGETVALS(args, uuid);  	if (args->format == TEXTFMT)-	{-		int i;-		char buf[128];-		char *p = buf;-		DECLLENGTH(args);--		/* format: a0eebc99-9c0b-4ef8-bb6d-6bb9bd380a11 */-		for (i=0; i < valuel; i++)-		{-			if (value[i] != '-')-			{-				*p++ = (pqt_hex_to_dec(value[i]) << 4) | pqt_hex_to_dec(value[i+1]);-				i++;-			}-		}--		*uuid = (char *) PQresultAlloc(args->get.result, p - buf);-		if (!*uuid)-			RERR_MEM(args);+		return args->errorf(args, "text format is not supported"); -		memcpy(*uuid, buf, p - buf);-		return 0;-	}+	if (valuel != sizeof(uuid->data))+		return args->errorf(args,+		                    "invalid data: %d bytes expected, %d given",+		                    sizeof(uuid->data),+		                    valuel); -	*uuid = value;+	memcpy(uuid->data, value, valuel); 	return 0; } 

@@ -13,6 +13,7 @@ import Data.Proxy import Data.Time import Data.Word+import Data.UUID.Types import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL import qualified Data.Text as T@@ -102,6 +103,9 @@  instance PQFormat TL.Text where   pqFormat = BS.pack "%btext"++instance PQFormat UUID where+  pqFormat = BS.pack "%uuid"  -- BYTEA 

@@ -14,6 +14,7 @@ import qualified Data.ByteString.Lazy.Char8 as BSL import qualified Data.Text as T import qualified Data.Text.Lazy as TL+import qualified Data.UUID.Types as U  import Database.PostgreSQL.PQTypes.Format import Database.PostgreSQL.PQTypes.Internal.C.Types@@ -94,6 +95,11 @@ instance FromSQL String where   type PQBase String = PGbytea   fromSQL mbytea = T.unpack <$> fromSQL mbytea++instance FromSQL U.UUID where+  type PQBase U.UUID = PGuuid+  fromSQL Nothing = unexpectedNULL+  fromSQL (Just (PGuuid w1 w2 w3 w4)) = return $ U.fromWords w1 w2 w3 w4  -- BYTEA 

@@ -30,11 +30,13 @@   , PGregisterType(..)   , PGarray(..)   , PGbytea(..)+  , PGuuid(..)   , PGdate(..)   , PGtime(..)   , PGtimestamp(..)   ) where +import Data.Word import Data.ByteString.Unsafe import Foreign.C import Foreign.ForeignPtr@@ -53,6 +55,9 @@ #include <libpqtypes.h> #include <libpq-fe.h> +foreign import ccall unsafe htonl :: Word32 -> Word32+foreign import ccall unsafe ntohl :: Word32 -> Word32+ ----------------------------------------  newtype ConnStatusType = ConnStatusType CInt@@ -155,11 +160,11 @@  ---------------------------------------- -data PGregisterType = PGregisterType {-  pgRegisterTypeTypName :: !CString-, pgRegisterTypeTypPut  :: !(FunPtr (Ptr PGtypeArgs -> IO CInt))-, pgRegisterTypeTypGet  :: !(FunPtr (Ptr PGtypeArgs -> IO CInt))-} deriving Show+data PGregisterType = PGregisterType+  { pgRegisterTypeTypName :: !CString+  , pgRegisterTypeTypPut  :: !(FunPtr (Ptr PGtypeArgs -> IO CInt))+  , pgRegisterTypeTypGet  :: !(FunPtr (Ptr PGtypeArgs -> IO CInt))+  } deriving Show  instance Storable PGregisterType where   sizeOf _ = #{size PGregisterType}@@ -178,13 +183,13 @@ c_MAXDIM :: Int c_MAXDIM = #{const MAXDIM} -data PGarray = PGarray {-  pgArrayNDims  :: !CInt-, pgArrayLBound :: !(V.Vector CInt)-, pgArrayDims   :: !(V.Vector CInt)-, pgArrayParam  :: !(Ptr PGparam)-, pgArrayRes    :: !(Ptr PGresult)-} deriving Show+data PGarray = PGarray+  { pgArrayNDims  :: !CInt+  , pgArrayLBound :: !(V.Vector CInt)+  , pgArrayDims   :: !(V.Vector CInt)+  , pgArrayParam  :: !(Ptr PGparam)+  , pgArrayRes    :: !(Ptr PGresult)+  } deriving Show  instance Storable PGarray where   sizeOf _ = #{size PGarray}@@ -219,10 +224,10 @@  ---------------------------------------- -data PGbytea = PGbytea {-  pgByteaLen  :: !CInt-, pgByteaData :: !CString-} deriving Show+data PGbytea = PGbytea+  { pgByteaLen  :: !CInt+  , pgByteaData :: !CString+  } deriving Show  instance Storable PGbytea where   sizeOf _ = #{size PGbytea}@@ -236,16 +241,43 @@  ---------------------------------------- -data PGdate = PGdate {-  pgDateIsBC :: !CInt-, pgDateYear :: !CInt-, pgDateMon  :: !CInt-, pgDateMDay :: !CInt-, pgDateJDay :: !CInt-, pgDateYDay :: !CInt-, pgDateWDay :: !CInt-} deriving Show+-- Same as the UUID type from uuid-types package except for the Storable+-- instance: PostgreSQL expects the binary representation to be encoded in+-- network byte order (as per RFC 4122), whereas Storable instance of UUID+-- preserves host byte order, so we need to have our own version.+data PGuuid = PGuuid+  { pgUuidW1 :: !Word32+  , pgUuidW2 :: !Word32+  , pgUuidW3 :: !Word32+  , pgUuidW4 :: !Word32+  } deriving Show +instance Storable PGuuid where+  sizeOf _ = #{size PGuuid}+  alignment _ = #{alignment PGuuid}++  peek ptr = PGuuid+    <$> (ntohl <$> #{peek PGuuid, w1} ptr)+    <*> (ntohl <$> #{peek PGuuid, w2} ptr)+    <*> (ntohl <$> #{peek PGuuid, w3} ptr)+    <*> (ntohl <$> #{peek PGuuid, w4} ptr)++  poke ptr PGuuid{..} = do+    #{poke PGuuid, w1} ptr $ htonl pgUuidW1+    #{poke PGuuid, w2} ptr $ htonl pgUuidW2+    #{poke PGuuid, w3} ptr $ htonl pgUuidW3+    #{poke PGuuid, w4} ptr $ htonl pgUuidW4++data PGdate = PGdate+  { pgDateIsBC :: !CInt+  , pgDateYear :: !CInt+  , pgDateMon  :: !CInt+  , pgDateMDay :: !CInt+  , pgDateJDay :: !CInt+  , pgDateYDay :: !CInt+  , pgDateWDay :: !CInt+  } deriving Show+ instance Storable PGdate where   sizeOf _ = #{size PGdate}   alignment _ = #{alignment PGdate}@@ -268,16 +300,16 @@  ---------------------------------------- -data PGtime = PGtime {-  pgTimeHour   :: !CInt-, pgTimeMin    :: !CInt-, pgTimeSec    :: !CInt-, pgTimeUSec   :: !CInt-, pgTimeWithTZ :: !CInt-, pgTimeIsDST  :: !CInt-, pgTimeGMTOff :: !CInt-, pgTimeTZAbbr :: !BS.ByteString-} deriving Show+data PGtime = PGtime+  { pgTimeHour   :: !CInt+  , pgTimeMin    :: !CInt+  , pgTimeSec    :: !CInt+  , pgTimeUSec   :: !CInt+  , pgTimeWithTZ :: !CInt+  , pgTimeIsDST  :: !CInt+  , pgTimeGMTOff :: !CInt+  , pgTimeTZAbbr :: !BS.ByteString+  } deriving Show  instance Storable PGtime where   sizeOf _ = #{size PGtime}@@ -306,11 +338,11 @@  ---------------------------------------- -data PGtimestamp = PGtimestamp {-  pgTimestampEpoch :: !CLLong-, pgTimestampDate  :: !PGdate-, pgTimestampTime  :: !PGtime-} deriving Show+data PGtimestamp = PGtimestamp+  { pgTimestampEpoch :: !CLLong+  , pgTimestampDate  :: !PGdate+  , pgTimestampTime  :: !PGtime+  } deriving Show  instance Storable PGtimestamp where   sizeOf _ = #{size PGtimestamp}

@@ -38,15 +38,15 @@ import Database.PostgreSQL.PQTypes.Internal.Error import Database.PostgreSQL.PQTypes.Internal.Utils -data ConnectionSettings = ConnectionSettings {--- | Connection info string.-  csConnInfo       :: !T.Text--- | Client-side encoding. If set to 'Nothing', database encoding is used.-, csClientEncoding :: !(Maybe T.Text)--- | A list of composite types to register. In order to be able to--- (de)serialize specific composite types, you need to register them.-, csComposites     :: ![T.Text]-} deriving (Eq, Ord, Show)+data ConnectionSettings = ConnectionSettings+  { -- | Connection info string.+    csConnInfo       :: !T.Text+    -- | Client-side encoding. If set to 'Nothing', database encoding is used.+  , csClientEncoding :: !(Maybe T.Text)+    -- | A list of composite types to register. In order to be able to+    -- (de)serialize specific composite types, you need to register them.+  , csComposites     :: ![T.Text]+  } deriving (Eq, Ord, Show)  -- | Default connection settings. Note that all strings sent to PostgreSQL by -- the library are encoded as UTF-8, so don't alter client encoding unless you@@ -62,16 +62,16 @@ ----------------------------------------  -- | Simple connection statistics.-data ConnectionStats = ConnectionStats {--- | Number of queries executed so far.-  statsQueries :: !Int--- | Number of rows fetched from the database.-, statsRows    :: !Int--- | Number of values fetched from the database.-, statsValues  :: !Int--- | Number of parameters sent to the database.-, statsParams  :: !Int-} deriving (Eq, Ord, Show)+data ConnectionStats = ConnectionStats+  { -- | Number of queries executed so far.+    statsQueries :: !Int+    -- | Number of rows fetched from the database.+  , statsRows    :: !Int+    -- | Number of values fetched from the database.+  , statsValues  :: !Int+    -- | Number of parameters sent to the database.+  , statsParams  :: !Int+  } deriving (Eq, Ord, Show)  -- | Initial connection statistics. initialStats :: ConnectionStats

@@ -20,20 +20,20 @@  -- | SQL query error. Reference: description of PQresultErrorField -- at <http://www.postgresql.org/docs/devel/static/libpq-exec.html>.-data DetailedQueryError = DetailedQueryError {-  qeSeverity          :: !String-, qeErrorCode         :: !ErrorCode-, qeMessagePrimary    :: !String-, qeMessageDetail     :: !(Maybe String)-, qeMessageHint       :: !(Maybe String)-, qeStatementPosition :: !(Maybe Int)-, qeInternalPosition  :: !(Maybe Int)-, qeInternalQuery     :: !(Maybe String)-, qeContext           :: !(Maybe String)-, qeSourceFile        :: !(Maybe String)-, qeSourceLine        :: !(Maybe Int)-, qeSourceFunction    :: !(Maybe String)-} deriving (Eq, Ord, Show)+data DetailedQueryError = DetailedQueryError+  { qeSeverity          :: !String+  , qeErrorCode         :: !ErrorCode+  , qeMessagePrimary    :: !String+  , qeMessageDetail     :: !(Maybe String)+  , qeMessageHint       :: !(Maybe String)+  , qeStatementPosition :: !(Maybe Int)+  , qeInternalPosition  :: !(Maybe Int)+  , qeInternalQuery     :: !(Maybe String)+  , qeContext           :: !(Maybe String)+  , qeSourceFile        :: !(Maybe String)+  , qeSourceLine        :: !(Maybe Int)+  , qeSourceFunction    :: !(Maybe String)+  } deriving (Eq, Ord, Show)  -- | Simple SQL query error. Thrown when there is no -- PGresult object corresponding to query execution.@@ -50,71 +50,71 @@  -- | Data conversion error. Since it's polymorphic in error type, -- it nicely reports arbitrarily nested conversion errors.-data ConversionError = forall e. E.Exception e => ConversionError {--- | Column number (Starts with 1).-  convColumn     :: !Int--- | Name of the column.-, convColumnName :: !String--- | Row number (Starts with 1).-, convRow        :: !Int--- | Exact error.-, convError      :: !e-}+data ConversionError = forall e. E.Exception e => ConversionError+  { -- | Column number (Starts with 1).+    convColumn     :: !Int+    -- | Name of the column.+  , convColumnName :: !String+    -- | Row number (Starts with 1).+  , convRow        :: !Int+    -- | Exact error.+  , convError      :: !e+  }  deriving instance Show ConversionError  -- | Array item error. Polymorphic in error type -- for the same reason as 'ConversionError'.-data ArrayItemError = forall e. E.Exception e => ArrayItemError {--- | Item index (Starts with 1).-  arrItemIndex :: !Int--- | Exact error.-, arrItemError :: !e+data ArrayItemError = forall e. E.Exception e => ArrayItemError+  { -- | Item index (Starts with 1).+    arrItemIndex :: !Int+    -- | Exact error.+  , arrItemError :: !e }  deriving instance Show ArrayItemError  -- | \"Invalid value\" error for various data types.-data InvalidValue t = InvalidValue {--- | Invalid value.-  ivValue       :: t--- Optional list of valid values.-, ivValidValues :: Maybe [t]-} deriving (Eq, Ord, Show)+data InvalidValue t = InvalidValue+  { -- | Invalid value.+    ivValue       :: t+    -- Optional list of valid values.+  , ivValidValues :: Maybe [t]+  } deriving (Eq, Ord, Show)  -- | Range error for various data types.-data RangeError t = RangeError {--- | Allowed range (sum of acceptable ranges).-  reRange :: [(t, t)]--- | Provided value which is not in above range.-, reValue :: t-} deriving (Eq, Ord, Show)+data RangeError t = RangeError+  { -- | Allowed range (sum of acceptable ranges).+    reRange :: [(t, t)]+    -- | Provided value which is not in above range.+  , reValue :: t+  } deriving (Eq, Ord, Show)  -- | Array dimenstion mismatch error.-data ArrayDimensionMismatch = ArrayDimensionMismatch {--- | Dimension expected by the library.-  arrDimExpected  :: !Int--- | Dimension provided by the database.-, arrDimDelivered :: !Int-} deriving (Eq, Ord, Show)+data ArrayDimensionMismatch = ArrayDimensionMismatch+  { -- | Dimension expected by the library.+    arrDimExpected  :: !Int+    -- | Dimension provided by the database.+  , arrDimDelivered :: !Int+  } deriving (Eq, Ord, Show)  -- | Row length mismatch error.-data RowLengthMismatch = RowLengthMismatch {--- | Length expected by the library.-  lengthExpected  :: !Int--- | Length delivered by the database.-, lengthDelivered :: !Int-} deriving (Eq, Ord, Show)+data RowLengthMismatch = RowLengthMismatch+  { -- | Length expected by the library.+    lengthExpected  :: !Int+    -- | Length delivered by the database.+  , lengthDelivered :: !Int+  } deriving (Eq, Ord, Show)  -- | Affected/returned rows mismatch error.-data AffectedRowsMismatch = AffectedRowsMismatch {--- | Number of rows expected by the library, expressed as sum of--- acceptable ranges, eg. [(1,2), (5,10)] means that it would--- accept 1, 2, 5, 6, 7, 8, 9 or 10 affected/returned rows.-  rowsExpected  :: ![(Int, Int)]--- | Number of affected/returned rows by the database.-, rowsDelivered :: !Int-} deriving (Eq, Ord, Show)+data AffectedRowsMismatch = AffectedRowsMismatch+  { -- | Number of rows expected by the library, expressed as sum of acceptable+    -- ranges, eg. [(1,2), (5,10)] means that it would accept 1, 2, 5, 6, 7, 8,+    -- 9 or 10 affected/returned rows.+    rowsExpected  :: ![(Int, Int)]+    -- | Number of affected/returned rows by the database.+  , rowsDelivered :: !Int+  } deriving (Eq, Ord, Show)  instance E.Exception DetailedQueryError instance E.Exception QueryError

@@ -10,12 +10,12 @@  -- | Main exception type. All exceptions thrown by -- the library are additionally wrapped in this type.-data DBException = forall e sql. (E.Exception e, Show sql) => DBException {--- | Last SQL query that was executed.-  dbeQueryContext :: !sql--- | Specific error.-, dbeError        :: !e-}+data DBException = forall e sql. (E.Exception e, Show sql) => DBException+  { -- | Last SQL query that was executed.+    dbeQueryContext :: !sql+    -- | Specific error.+  , dbeError        :: !e+  }  deriving instance Show DBException 

@@ -44,14 +44,14 @@ ----------------------------------------  -- | Representation of a notification sent by PostgreSQL.-data Notification = Notification {--- | Process ID of notifying server.-  ntPID     :: !CPid-  -- | Notification channel name.-, ntChannel :: !Channel-  -- | Notification payload string.-, ntPayload :: !T.Text-} deriving (Eq, Ord, Show)+data Notification = Notification+  { -- | Process ID of notifying server.+    ntPID     :: !CPid+    -- | Notification channel name.+  , ntChannel :: !Channel+    -- | Notification payload string.+  , ntPayload :: !T.Text+  } deriving (Eq, Ord, Show)  instance Storable Notification where   sizeOf _ = #{size PGnotify}

@@ -25,11 +25,11 @@ -- | Representation of a query result. Provides 'Functor' -- and 'Foldable' instances for data transformation and -- extraction appropriately.-data QueryResult t = forall row. FromRow row => QueryResult {-  qrSQL     :: !SomeSQL-, qrResult  :: !(ForeignPtr PGresult)-, qrFromRow :: !(row -> t)-}+data QueryResult t = forall row. FromRow row => QueryResult+  { qrSQL     :: !SomeSQL+  , qrResult  :: !(ForeignPtr PGresult)+  , qrFromRow :: !(row -> t)+  }  instance Functor QueryResult where   f `fmap` QueryResult ctx fres g = QueryResult ctx fres (f . g)

@@ -10,15 +10,15 @@ import Database.PostgreSQL.PQTypes.Transaction.Settings  -- | Internal DB state.-data DBState m = DBState {--- | Active connection.-  dbConnection          :: !Connection--- | Supplied connection source.-, dbConnectionSource    :: !(ConnectionSourceM m)--- | Current transaction settings.-, dbTransactionSettings :: !TransactionSettings--- | Last SQL query that was executed.-, dbLastQuery           :: !SomeSQL--- | Current query result.-, dbQueryResult         :: !(forall row. FromRow row => Maybe (QueryResult row))-}+data DBState m = DBState+  { -- | Active connection.+    dbConnection          :: !Connection+    -- | Supplied connection source.+  , dbConnectionSource    :: !(ConnectionSourceM m)+    -- | Current transaction settings.+  , dbTransactionSettings :: !TransactionSettings+    -- | Last SQL query that was executed.+  , dbLastQuery           :: !SomeSQL+    -- | Current query result.+  , dbQueryResult         :: !(forall row. FromRow row => Maybe (QueryResult row))+  }

@@ -25,15 +25,15 @@ ----------------------------------------  -- | Representation of INTERVAL PostgreSQL type.-data Interval = Interval {-  intYears         :: !Int32-, intMonths        :: !Int32-, intDays          :: !Int32-, intHours         :: !Int32-, intMinutes       :: !Int32-, intSeconds       :: !Int32-, intMicroseconds  :: !Int32-} deriving (Eq, Ord)+data Interval = Interval+  { intYears         :: !Int32+  , intMonths        :: !Int32+  , intDays          :: !Int32+  , intHours         :: !Int32+  , intMinutes       :: !Int32+  , intSeconds       :: !Int32+  , intMicroseconds  :: !Int32+  } deriving (Eq, Ord)  instance Show Interval where   showsPrec _ Interval{..} = (++) . intercalate ", " $ filter (not . null) [

@@ -17,6 +17,7 @@ import qualified Data.ByteString.Lazy.Char8 as BSL import qualified Data.Text as T import qualified Data.Text.Lazy as TL+import qualified Data.UUID.Types as U  import Database.PostgreSQL.PQTypes.Format import Database.PostgreSQL.PQTypes.Internal.C.Interface@@ -108,6 +109,12 @@ instance ToSQL String where   type PQDest String = PGbytea   toSQL = toSQL . T.pack++instance ToSQL U.UUID where+  type PQDest U.UUID = PGuuid+  toSQL uuid _ = putAsPtr $ PGuuid w1 w2 w3 w4+    where+      (w1, w2, w3, w4) = U.toWords uuid  -- BYTEA 

@@ -15,28 +15,27 @@ instance Show RestartPredicate where   showsPrec _ RestartPredicate{} = (++) "RestartPredicate" -data TransactionSettings = TransactionSettings {--- | If set to True, transaction will be automatically started at the--- beginning of database action and after each 'commit' / 'rollback'.--- If set to False, no transaction will automatically start in either--- of above cases.-  tsAutoTransaction  :: !Bool--- | Isolation level of all transactions.-, tsIsolationLevel   :: !IsolationLevel--- | Defines behavior of 'withTransaction' in case exceptions thrown--- within supplied monadic action are not caught and reach its body.--- If set to 'Nothing', exceptions will be propagated as usual. If--- set to 'Just' f, exceptions will be intercepted and passed to f--- along with a number that indicates how many times the transaction--- block already failed. If f returns 'True', the transaction is--- restarted. Otherwise the exception is further propagated. This--- allows for restarting transactions e.g. in case of serialization--- failure. It is up to the caller to ensure that is it safe to--- execute supplied monadic action multiple times.-, tsRestartPredicate :: !(Maybe RestartPredicate)--- | Permissions of all transactions.-, tsPermissions      :: !Permissions-} deriving Show+data TransactionSettings = TransactionSettings+  { -- | If set to True, transaction will be automatically started at the+    -- beginning of database action and after each 'commit' / 'rollback'.  If+    -- set to False, no transaction will automatically start in either of above+    -- cases.+    tsAutoTransaction  :: !Bool+    -- | Isolation level of all transactions.+  , tsIsolationLevel   :: !IsolationLevel+    -- | Defines behavior of 'withTransaction' in case exceptions thrown within+    -- supplied monadic action are not caught and reach its body.  If set to+    -- 'Nothing', exceptions will be propagated as usual. If set to 'Just' f,+    -- exceptions will be intercepted and passed to f along with a number that+    -- indicates how many times the transaction block already failed. If f+    -- returns 'True', the transaction is restarted. Otherwise the exception is+    -- further propagated. This allows for restarting transactions e.g. in case+    -- of serialization failure. It is up to the caller to ensure that is it+    -- safe to execute supplied monadic action multiple times.+  , tsRestartPredicate :: !(Maybe RestartPredicate)+    -- | Permissions of all transactions.+  , tsPermissions      :: !Permissions+  } deriving Show  data IsolationLevel = DefaultLevel | ReadCommitted | RepeatableRead | Serializable   deriving (Eq, Ord, Show)

@@ -28,6 +28,7 @@ import TextShow import qualified Data.ByteString as BS import qualified Data.Text as T+import qualified Data.UUID.Types as U  import Data.Monoid.Utils import Database.PostgreSQL.PQTypes@@ -425,6 +426,19 @@   v' <- fetchOne runIdentity   assertEqual "Value doesn't change after getting through database" v v' eq +uuidTest :: TestData -> Test+uuidTest td = testCase "UUID encoding / decoding test" $ do+  let uuidStr = "550e8400-e29b-41d4-a716-446655440000"+      (Just uuid) = U.fromText uuidStr+  runTestEnv td defaultTransactionSettings $ do+    runSQL_ $ mkSQL $ "SELECT '" `mappend` uuidStr `mappend` "' :: uuid"+    uuid2 <- fetchOne runIdentity+    assertEqual "UUID is decoded correctly" uuid uuid2 (==)++    runQuery_ $ rawSQL " SELECT $1 :: text" (Identity uuid)+    uuidStr2 <- fetchOne runIdentity+    assertEqual "UUID is encoded correctly" uuidStr uuidStr2 (==)+ xmlTest :: TestData -> Test xmlTest td  = testCase "Put and get XML value works" .               runTestEnv td defaultTransactionSettings $ do@@ -467,7 +481,8 @@   , notifyTest td   , queryInterruptionTest td   , cursorTest td-  ----------------------------------------+  , uuidTest td+  ------------------------------------   , transactionTest td ReadCommitted   , transactionTest td RepeatableRead   , transactionTest td Serializable@@ -483,6 +498,7 @@   , nullTest td (u::String)   , nullTest td (u::BS.ByteString)   , nullTest td (u::T.Text)+  , nullTest td (u::U.UUID)   , nullTest td (u::JSON Value)   , nullTest td (u::JSONB Value)   , nullTest td (u::XML)@@ -508,6 +524,7 @@   , putGetTest td 1000 (u::String0) (==)   , putGetTest td 1000 (u::BS.ByteString) (==)   , putGetTest td 1000 (u::T.Text) (==)+  , putGetTest td 1000 (u::U.UUID) (==)   , putGetTest td 50 (u::JSON Value) (==)   , putGetTest td 50 (u::JSONB Value) (==)   , putGetTest td 20 (u::Array1 (JSON Value)) (==)@@ -577,8 +594,8 @@   , rowTest td (u::(Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString))   , rowTest td (u::(Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text))   , rowTest td (u::(Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString))-  , rowTest td (u::(Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day))-  , rowTest td (u::(Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32))+  , rowTest td (u::(Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, U.UUID))+  , rowTest td (u::(Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, Day, Array1 Int32, Composite Simple, CompositeArray1 Simple, Composite Nested, CompositeArray1 Nested, Int16, Int32, Int64, Float, Double, Bool, AsciiChar, Word8, String0, BS.ByteString, T.Text, BS.ByteString, U.UUID, Day))   ]   where     u = undefined

@@ -14,6 +14,7 @@ import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import qualified Data.Vector as V+import qualified Data.UUID.Types as U  import Database.PostgreSQL.PQTypes @@ -50,6 +51,13 @@  instance Arbitrary T.Text where   arbitrary = T.pack . unString0 <$> arbitrary++uuidFromWords :: (Word32, Word32, Word32, Word32) -> U.UUID+uuidFromWords (a,b,c,d) = U.fromWords a b c d++instance Arbitrary U.UUID where+  arbitrary = uuidFromWords <$> arbitrary+  shrink = map uuidFromWords . shrink . U.toWords  ----------------------------------------