Merge pull request #23 from quetz/time

Anton Gushcha · web-flow · commit fda5e3b70c3c · 2019-01-29T11:11:44.000+03:00
pgtype time support
diff --git a/src/Database/PostgreSQL/Protocol/Codecs/Decoders.hs b/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
diff --git a/src/Database/PostgreSQL/Protocol/Codecs/Encoders.hs b/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
@@ -47,7 +49,7 @@ bytea = putByteString
 {-# INLINE char #-}
 char :: Char -> Encode
 char c
-  | ord(c) >= 128 = error "Character code must be below 128"
+  | ord c >= 128 = error "Character code must be below 128"
   | otherwise = (putWord8 . fromIntegral . ord) c
 
 {-# INLINE date #-}
@@ -104,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 
diff --git a/src/Database/PostgreSQL/Protocol/Codecs/PgTypes.hs b/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 
 
diff --git a/src/Database/PostgreSQL/Protocol/Codecs/Time.hs b/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)
diff --git a/tests/Codecs/QuickCheck.hs b/tests/Codecs/QuickCheck.hs
@@ -110,6 +110,8 @@ testCodecsEncodeDecode = testGroup "Codecs property 'encode . decode = id'"
                                     (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
@@ -174,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
 
