pgtype time support

.travis.yml

@@ -1,5 +1,5 @@
 # Use new container infrastructure to enable caching
-dist: trusty
+dist: xenial
 sudo: false
 
 # Do not choose a language; we provide our own build tools.
@@ -8,8 +8,9 @@ language: generic
 os:
   - linux
 env:
-  - STACK_YAML=stack-ghc7.10.3.yaml
-  - STACK_YAML=stack-ghc8.0.2.yaml
+  - STACK_YAML=stack-ghc8.2.2.yaml
+  - STACK_YAML=stack-ghc8.4.4.yaml
+  - STACK_YAML=stack-ghc8.6.3.yaml
 
 services:
   - postgresql
@@ -24,7 +25,7 @@ addons:
   apt:
     packages:
       - libgmp-dev
-  postgresql: "9.6"
+  postgresql: "10"
 
 before_install:
   # Download and unpack the stack executable

src/Database/PostgreSQL/Protocol/Codecs/Decoders.hs

@@ -17,6 +17,8 @@ module Database.PostgreSQL.Protocol.Codecs.Decoders
     , bsJsonBytes
     , numeric
     , bsText
+    , time
+    , timetz
     , timestamp
     , timestamptz
     , uuid
@@ -28,7 +30,7 @@ import Data.ByteString  (ByteString)
 import Data.Char        (chr)
 import Data.Int         (Int16, Int32, Int64)
 import Data.Scientific  (Scientific)
-import Data.Time        (Day, UTCTime, LocalTime, DiffTime)
+import Data.Time        (Day, UTCTime, LocalTime, DiffTime, TimeOfDay)
 import Data.UUID        (UUID, fromWords)
 import qualified Data.Vector as V
 
@@ -164,6 +166,17 @@ numeric _ = do
 bsText :: FieldDecoder ByteString
 bsText = getByteString
 
+{-# INLINE time #-}
+time :: FieldDecoder TimeOfDay
+time _ = mcsToTimeOfDay <$> getInt64BE
+
+{-# INLINE timetz #-}
+timetz :: FieldDecoder TimeOfDay
+timetz _ = do
+  t <- getInt64BE
+  skipBytes 4
+  return $ mcsToTimeOfDay t
+
 {-# INLINE timestamp #-}
 timestamp :: FieldDecoder LocalTime
 timestamp _ = microsToLocalTime <$> getInt64BE

src/Database/PostgreSQL/Protocol/Codecs/Encoders.hs

@@ -13,6 +13,8 @@ module Database.PostgreSQL.Protocol.Codecs.Encoders
     , bsJsonBytes
     , numeric
     , bsText
+    , time
+    , timetz
     , timestamp
     , timestamptz
     , uuid
@@ -23,7 +25,7 @@ import Data.Char        (ord)
 import Data.Int         (Int16, Int32, Int64)
 import Data.Monoid      ((<>))
 import Data.Scientific  (Scientific)
-import Data.Time        (Day, UTCTime, LocalTime, DiffTime)
+import Data.Time        (Day, UTCTime, LocalTime, DiffTime, TimeOfDay)
 import Data.UUID        (UUID, toWords)
 
 import Database.PostgreSQL.Protocol.Store.Encode
@@ -46,7 +48,9 @@ bytea = putByteString
 
 {-# INLINE char #-}
 char :: Char -> Encode
-char = putWord8 . fromIntegral . ord 
+char c
+  | ord c >= 128 = error "Character code must be below 128"
+  | otherwise = (putWord8 . fromIntegral . ord) c
 
 {-# INLINE date #-}
 date :: Day -> Encode
@@ -102,6 +106,14 @@ numeric n =
 bsText :: ByteString -> Encode
 bsText = putByteString
 
+{-# INLINE time #-}
+time :: TimeOfDay -> Encode
+time = putInt64BE . timeOfDayToMcs
+
+{-# INLINE timetz #-}
+timetz :: TimeOfDay -> Encode
+timetz t = putInt64BE (timeOfDayToMcs t) <> putInt32BE 0
+
 {-# INLINE timestamp #-}
 timestamp :: LocalTime -> Encode
 timestamp = putInt64BE . localTimeToMicros 

src/Database/PostgreSQL/Protocol/Codecs/PgTypes.hs

@@ -18,6 +18,8 @@ module Database.PostgreSQL.Protocol.Codecs.PgTypes
     , jsonb
     , numeric
     , text
+    , time
+    , timetz
     , timestamp
     , timestamptz
     , uuid 
@@ -88,6 +90,12 @@ numeric = mkOids 1700 1231
 text :: Oids              
 text = mkOids 25 1009    
 
+time :: Oids
+time = mkOids 1083 1183
+
+timetz :: Oids
+timetz = mkOids 1266 1270
+
 timestamp :: Oids       
 timestamp = mkOids 1114 1115 
 

src/Database/PostgreSQL/Protocol/Codecs/Time.hs

@@ -2,11 +2,15 @@ module Database.PostgreSQL.Protocol.Codecs.Time
     ( dayToPgj
     , utcToMicros
     , localTimeToMicros
+    , timeOfDayToMcs
     , pgjToDay
     , microsToUTC
     , microsToLocalTime
+    , mcsToTimeOfDay
+    , mcsToDiffTime
     , intervalToDiffTime
     , diffTimeToInterval
+    , diffTimeToMcs
     ) where
 
 import Data.Int  (Int64, Int32, Int64)

src/Database/PostgreSQL/Protocol/Store/Encode.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 module Database.PostgreSQL.Protocol.Store.Encode 
     ( Encode
     , getEncodeLen
@@ -26,14 +27,21 @@ import Data.ByteString.Internal (toForeignPtr)
 import Data.Store.Core          (Poke(..), unsafeEncodeWith, pokeStatePtr,
                                  pokeFromForeignPtr)
 
+import qualified Data.Semigroup as Sem
+
 data Encode = Encode {-# UNPACK #-} !Int !(Poke ())
 
+instance Sem.Semigroup Encode where
+  {-# INLINE (<>) #-}
+  (Encode len1 f1) <> (Encode len2 f2) = Encode (len1 + len2) (f1 *> f2)
+
 instance Monoid Encode where
     {-# INLINE mempty #-}
     mempty = Encode 0 . Poke $ \_ offset -> pure (offset, ())
+#if !(MIN_VERSION_base(4,11,0))
+    mappend = (Sem.<>)
+#endif
 
-    {-# INLINE mappend #-}
-    (Encode len1 f1) `mappend` (Encode len2 f2) = Encode (len1 + len2) (f1 *> f2)
 
 instance Show Encode where
     show (Encode len _) = "Encode instance of length " ++ show len

stack-ghc8.2.2.yaml

@@ -0,0 +1,22 @@
+# This file was automatically generated by 'stack init'
+#
+resolver: lts-11.22
+
+packages:
+- '.'
+# Dependency packages to be pulled from upstream that are not in the resolver
+# (e.g., acme-missiles-0.3)
+extra-deps: 
+    - socket-0.8.2.0
+    - socket-unix-0.2.0.0
+# <<<<<<< HEAD
+# =======
+#     - store-core-0.3
+#     - QuickCheck-2.9.2
+# >>>>>>> QuickCheck tests for existing codecs
+
+# Override default flag values for local packages and extra-deps
+flags: {}
+
+# Extra package databases containing global packages
+extra-package-dbs: []

stack-ghc8.4.4.yaml

@@ -0,0 +1,22 @@
+# This file was automatically generated by 'stack init'
+#
+resolver: lts-12.26
+
+packages:
+- '.'
+# Dependency packages to be pulled from upstream that are not in the resolver
+# (e.g., acme-missiles-0.3)
+extra-deps: 
+    - socket-0.8.2.0
+    - socket-unix-0.2.0.0
+# <<<<<<< HEAD
+# =======
+#     - store-core-0.3
+#     - QuickCheck-2.9.2
+# >>>>>>> QuickCheck tests for existing codecs
+
+# Override default flag values for local packages and extra-deps
+flags: {}
+
+# Extra package databases containing global packages
+extra-package-dbs: []

stack-ghc8.0.2.yaml → stack-ghc8.6.3.yaml

@@ -1,13 +1,13 @@
 # This file was automatically generated by 'stack init'
 #
-resolver: lts-8.21
+resolver: lts-13.4
 
 packages:
 - '.'
 # Dependency packages to be pulled from upstream that are not in the resolver
 # (e.g., acme-missiles-0.3)
 extra-deps: 
-    - socket-0.8.0.0
+    - socket-0.8.2.0
     - socket-unix-0.2.0.0
 # <<<<<<< HEAD
 # =======

stack.yaml

@@ -1 +1 @@
-stack-ghc8.0.2.yaml
+stack-ghc8.6.3.yaml

tests/Codecs/QuickCheck.hs

@@ -95,20 +95,23 @@ testCodecsEncodeDecode :: TestTree
 testCodecsEncodeDecode = testGroup "Codecs property 'encode . decode = id'"
     [ mkCodecTest "bool" PGT.bool PE.bool PD.bool
     , mkCodecTest "bytea" PGT.bytea PE.bytea PD.bytea
-    , mkCodecTest "char" PGT.char PE.char PD.char
+    , mkCodecTest "char" PGT.char (PE.char . unAsciiChar)
+                                  (fmap AsciiChar <$> PD.char)
     , mkCodecTest "date" PGT.date PE.date PD.date
     , mkCodecTest "float4" PGT.float4 PE.float4 PD.float4
     , mkCodecTest "float8" PGT.float8 PE.float8 PD.float8
     , mkCodecTest "int2" PGT.int2 PE.int2 PD.int2
     , mkCodecTest "int4" PGT.int4 PE.int4 PD.int4
     , mkCodecTest "int8" PGT.int8 PE.int8 PD.int8
     , mkCodecTest "interval" PGT.interval PE.interval PD.interval
-    , mkCodecTest "json" PGT.json (PE.bsJsonText . unJsonString ) 
+    , mkCodecTest "json" PGT.json (PE.bsJsonText . unJsonString)
                                   (fmap JsonString <$> PD.bsJsonText)
-    , mkCodecTest "jsonb" PGT.jsonb (PE.bsJsonBytes .unJsonString) 
+    , mkCodecTest "jsonb" PGT.jsonb (PE.bsJsonBytes . unJsonString)
                                     (fmap JsonString <$> PD.bsJsonBytes)
     , mkCodecTest "numeric" PGT.numeric PE.numeric PD.numeric
     , mkCodecTest "text" PGT.text PE.bsText PD.bsText
+    , mkCodecTest "time" PGT.time PE.time PD.time
+    , mkCodecTest "timetz" PGT.timetz PE.timetz PD.timetz
     , mkCodecTest "timestamp" PGT.timestamp PE.timestamp PD.timestamp
     , mkCodecTest "timestamptz" PGT.timestamptz PE.timestamptz PD.timestamptz
     , mkCodecTest "uuid" PGT.uuid PE.uuid PD.uuid
@@ -145,6 +148,12 @@ testCodecsEncodePrint = testGroup
 -- Orphan instances
 --
 
+newtype AsciiChar = AsciiChar { unAsciiChar :: Char }
+    deriving (Show, Eq)
+
+instance Arbitrary AsciiChar where
+    arbitrary = AsciiChar <$> choose ('\0', '\127')
+
 -- Helper to generate valid json strings
 newtype JsonString = JsonString { unJsonString :: B.ByteString }
     deriving (Show, Eq, IsString)
@@ -167,6 +176,9 @@ instance Arbitrary Day where
 instance Arbitrary DiffTime where
     arbitrary = secondsToDiffTime <$> choose (0, 86400 - 1)
 
+instance Arbitrary TimeOfDay where
+    arbitrary = timeToTimeOfDay <$> arbitrary
+
 instance Arbitrary LocalTime where
     arbitrary = LocalTime <$> arbitrary <*> fmap timeToTimeOfDay arbitrary
 

tests/Driver.hs

@@ -5,7 +5,7 @@ import Data.Foldable
 import Control.Monad
 import Data.Maybe
 import Data.Int
-import Data.Either
+import Data.Either hiding (fromRight)
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.ByteString.Char8 as BS

tests_connection/test.hs

@@ -39,7 +39,7 @@ testConnection name confContent = testCase name $ withPghba confContent $
         }
 
 pghbaFilename :: FilePath
-pghbaFilename = "/etc/postgresql/9.5/main/pg_hba.conf"
+pghbaFilename = "/etc/postgresql/10/main/pg_hba.conf"
 
 withPghba :: B.ByteString -> IO a -> IO a
 withPghba confContent action = do