Tick off fetch implementation

Remove LocalTime decoding because it requires IO to convert from Postgres time.

README.md

@@ -62,10 +62,16 @@ getScoreByAge conn = do
 - [x] Implement error reporting i.e. use `Either OpiumError` instead of `Maybe`
 - [x] Implement `Float` and `Double` decoding
 - [x] Clean up and document column table stuff
-- [ ] Implement `fetch` (`fetch_` but with parameter passing)
-- [ ] Implement `UTCTime` and zoned time decoding
+- [x] Decode `LibPQ.Binary`
+- [x] Implement `date -> Day` decoding
+- [x] Implement `UTCTime`
+- [x] Implement `ByteString` decoding (`bytea`)
+- [x] Test negative integer decoding, especially for `Integer`
+- [ ] Implement time intervals
+- [ ] and zoned time decoding
+- [ ] How about `timezone`? This could prove problematic when the server and application have different time zones
+- [x] Implement `fetch` (`fetch_` but with parameter passing)
 - [ ] Implement JSON decoding
-- [ ] Implement `ByteString` decoding (`bytea`)
-  - Can we make the fromField instance choose whether it wants binary or text?
 - [ ] Implement (anonymous) composite types
-  - It seems that in order to decode these, we'd need to use binary mode. In order to avoid writing everything twice it would be wise to move the whole `FromField` machinery to decoding from binary first
+- [ ] Catch [UnicodeException](https://hackage.haskell.org/package/text-2.1/docs/Data-Text-Encoding-Error.html#t:UnicodeException) when decoding text
+- [ ] Implement array decoding

flake.nix

@@ -20,6 +20,7 @@
             hspec
             postgresql-libpq
             text
+            time
             transformers
             vector
           ]))

lib/Database/PostgreSQL/Opium.hs

@@ -15,6 +15,8 @@ module Database.PostgreSQL.Opium
   , ErrorPosition (..)
   , FromField (..)
   , FromRow (..)
+  , RawField (..)
+  , fetch
   , fetch_
   , toListColumnTable
   )
@@ -43,11 +45,18 @@ import qualified Data.Vector as Vector
 import qualified Database.PostgreSQL.LibPQ as LibPQ
 
 import Database.PostgreSQL.Opium.Error (Error (..), ErrorPosition (..))
-import Database.PostgreSQL.Opium.FromField (FromField (..), fromField)
+import Database.PostgreSQL.Opium.FromField (FromField (..), fromField, RawField (..))
+import Database.PostgreSQL.Opium.ToParamList (ToParamList (..))
 
-execParams :: Connection -> ByteString -> ExceptT Error IO Result
-execParams conn query = do
-  liftIO (LibPQ.execParams conn query [] LibPQ.Text) >>= \case
+execParams
+  :: ToParamList a
+  => Connection
+  -> Text
+  -> a
+  -> ExceptT Error IO Result
+execParams conn query params = do
+  let queryBytes = Encoding.encodeUtf8 query
+  liftIO (LibPQ.execParams conn queryBytes (toParamList params) LibPQ.Binary) >>= \case
     Nothing ->
       except $ Left ErrorNoResult
     Just result -> do
@@ -58,13 +67,21 @@ execParams conn query = do
         Nothing -> pure result
         Just message -> except $ Left $ ErrorInvalidResult status $ Encoding.decodeUtf8 message
 
-fetch_ :: forall a. FromRow a => Connection -> ByteString -> IO (Either Error [a])
-fetch_ conn query = runExceptT $ do
-  result <- execParams conn query
-  columnTable <- ExceptT $ getColumnTable @a Proxy result
+fetch
+  :: forall a b. (ToParamList a, FromRow b)
+  => Connection
+  -> Text
+  -> a
+  -> IO (Either Error [b])
+fetch conn query params = runExceptT $ do
+  result <- execParams conn query params
+  columnTable <- ExceptT $ getColumnTable @b Proxy result
   nRows <- liftIO $ LibPQ.ntuples result
   mapM (ExceptT . fromRow result columnTable) [0..nRows - 1]
 
+fetch_ :: forall a. FromRow a => Connection -> Text -> IO (Either Error [a])
+fetch_ conn query = fetch conn query ()
+
 newtype ColumnTable = ColumnTable (Vector (Column, Oid))
   deriving (Eq, Show)
 
@@ -147,20 +164,16 @@ decodeField nameText g (FromRowCtx result columnTable iRef) row = do
   i <- liftIO $ readIORef iRef
   liftIO $ modifyIORef' iRef (+1)
   let (column, oid) = columnTable `indexColumnTable` i
-  mbField <- liftIO $ getFieldText column
+  mbField <- liftIO $ LibPQ.getvalue result row column
   mbValue <- except $ getValue oid mbField
   value <- except $ g row mbValue
   pure $ M1 $ K1 value
   where
-    getFieldText :: Column -> IO (Maybe Text)
-    getFieldText column = 
-      fmap Encoding.decodeUtf8 <$> LibPQ.getvalue result row column
-
-    getValue :: FromField u => LibPQ.Oid -> Maybe Text -> Either Error (Maybe u)
-    getValue oid = maybe (Right Nothing) $ \fieldText ->
+    getValue :: FromField u => LibPQ.Oid -> Maybe ByteString -> Either Error (Maybe u)
+    getValue oid = maybe (Right Nothing) $ \field ->
       mapLeft
-        (ErrorInvalidField (ErrorPosition row nameText) oid fieldText)
-        (Just <$> fromField fieldText)
+        (ErrorInvalidField (ErrorPosition row nameText) oid field)
+        (Just <$> fromField field)
 
 mapLeft :: (b -> c) -> Either b a -> Either c a
 mapLeft f (Left l) = Left $ f l

lib/Database/PostgreSQL/Opium/Error.hs

@@ -1,6 +1,7 @@
 module Database.PostgreSQL.Opium.Error (Error (..), ErrorPosition (..)) where
 
 import Control.Exception (Exception)
+import Data.ByteString (ByteString)
 import Data.Text (Text)
 import Database.PostgreSQL.LibPQ (ExecStatus, Oid, Row)
 
@@ -15,7 +16,7 @@ data Error
   | ErrorMissingColumn Text
   | ErrorInvalidOid Text Oid
   | ErrorUnexpectedNull ErrorPosition
-  | ErrorInvalidField ErrorPosition Oid Text String
+  | ErrorInvalidField ErrorPosition Oid ByteString String
   deriving (Eq, Show)
 
 instance Exception Error where

lib/Database/PostgreSQL/Opium/FromField.hs

@@ -3,47 +3,68 @@
 {-# LANGUAGE TypeApplications #-}
 
 module Database.PostgreSQL.Opium.FromField
-  ( FromField (..)
+  ( -- * Decoding data from @libpq@
+    FromField (..)
   , fromField
+    -- * Utility types
+  , RawField (..)
   ) where
 
-import Data.Attoparsec.Text
-  ( Parser
-  , anyChar
-  , choice
-  , decimal
-  , double
-  , parseOnly
-  , signed
-  , string
-  , takeText
-  )
+import Data.Attoparsec.ByteString (Parser)
+import Data.Bits (Bits (..))
+import Data.ByteString (ByteString)
 import Data.Functor (($>))
+import Data.Int (Int16, Int32)
 import Data.Proxy (Proxy (..))
+import Data.Time
+  ( Day (..)
+  , DiffTime
+  , TimeOfDay
+  , UTCTime (..)
+  , addDays
+  , fromGregorian
+  , picosecondsToDiffTime
+  , timeToTimeOfDay
+  )
 import Data.Text (Text)
+import Data.Word (Word16, Word32)
 import Database.PostgreSQL.LibPQ (Oid)
-import GHC.Float (double2Float)
+import Unsafe.Coerce (unsafeCoerce)
 
+import qualified Data.Attoparsec.ByteString as AP
+import qualified Data.ByteString as BS
 import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Encoding
 
 import qualified Database.PostgreSQL.Opium.Oid as Oid
 
 (\/) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
 p \/ q = \x -> p x || q x
 
-fromField :: FromField a => Text -> Either String a
+eq :: Eq a => a -> a -> Bool
+eq = (==)
+
+fromField :: FromField a => ByteString -> Either String a
 fromField =
-  parseOnly parseField
+  AP.parseOnly parseField
 
 class FromField a where
   validOid :: Proxy a -> Oid -> Bool
   parseField :: Parser a
 
--- | See https://www.postgresql.org/docs/current/datatype-character.html.
-instance FromField Text where
-  validOid Proxy = Oid.text \/ Oid.character \/ Oid.characterVarying
-  parseField = takeText
+-- | See https://www.postgresql.org/docs/current/datatype-binary.html.
+-- Accepts @bytea@.
+instance FromField ByteString where
+  validOid Proxy = eq Oid.bytea
+  parseField = AP.takeByteString
 
+-- | See https://www.postgresql.org/docs/current/datatype-character.html.
+-- Accepts @text@, @character@ and @character varying@.
+instance FromField Text where
+  validOid Proxy = eq Oid.text \/ eq Oid.character \/ eq Oid.characterVarying
+  parseField = Encoding.decodeUtf8 <$> AP.takeByteString
+
+-- Accepts @text@, @character@ and @character varying@.
 -- | See https://www.postgresql.org/docs/current/datatype-character.html.
 instance FromField String where
   validOid Proxy = validOid @Text Proxy
@@ -53,48 +74,124 @@ instance FromField String where
 -- This instance accepts all character types but fails to decode fields that are not exactly one character.
 instance FromField Char where
   validOid Proxy = validOid @Text Proxy
-  parseField = anyChar
+  parseField = do
+    str <- parseField
+    case str of
+      [c] -> pure c
+      _ -> fail "Char accepts single characters only"
+
+
+readBigEndian :: (Bits a, Num a) => ByteString -> a
+readBigEndian = BS.foldl' (\x b -> x `shiftL` 8 .|. fromIntegral b) 0
+
+readInt :: Num a => ByteString -> Parser a
+readInt bs = case BS.length bs of
+  4 -> pure $ fromIntegral $ readBigEndian @Int32 bs
+  8 -> pure $ fromIntegral $ readBigEndian @Int bs
+  2 -> pure $ fromIntegral $ readBigEndian @Int16 bs
+  _ -> fail "Wrong number of bytes for integer"
+
+readWord :: Num a => ByteString -> Parser a
+readWord bs = case BS.length bs of
+  4 -> pure $ fromIntegral $ readBigEndian @Word32 bs
+  8 -> pure $ fromIntegral $ readBigEndian @Word bs
+  2 -> pure $ fromIntegral $ readBigEndian @Word16 bs
+  _ -> fail "Wrong number of bytes for word"
 
 -- | See https://www.postgresql.org/docs/current/datatype-numeric.html.
 -- We assume that 'Int' has 64 bits. This is not guaranteed but reasonable enough.
 instance FromField Int where
-  validOid Proxy = Oid.smallint \/ Oid.integer \/ Oid.bigint
-  parseField = signed decimal
+  validOid Proxy = eq Oid.smallint \/ eq Oid.integer \/ eq Oid.bigint
+  parseField = readInt =<< AP.takeByteString
 
 -- | See https://www.postgresql.org/docs/current/datatype-numeric.html.
 instance FromField Integer where
-  validOid Proxy = Oid.smallint \/ Oid.integer \/ Oid.bigint
-  parseField = signed decimal
+  validOid Proxy = eq Oid.smallint \/ eq Oid.integer \/ eq Oid.bigint
+  parseField = readInt =<< AP.takeByteString
 
 instance FromField Word where
-  validOid Proxy = Oid.smallint \/ Oid.integer \/ Oid.bigint
-  parseField = decimal
-
-doubleParser :: Parser Double
-doubleParser = choice
-  [ string "NaN" $> nan
-  , signed (string "Infinity" $> infinity)
-  , double
-  ]
-  where
-    nan = 0 / 0
-    infinity = 1 / 0
+  validOid Proxy = eq Oid.smallint \/ eq Oid.integer \/ eq Oid.bigint
+  parseField = readWord =<< AP.takeByteString
 
+-- | See https://www.postgresql.org/docs/current/datatype-numeric.html.
+-- Accepts only @real@ fields, not @double precision@.
 instance FromField Float where
-  validOid Proxy = Oid.real
-  parseField = fmap double2Float doubleParser
+  validOid Proxy = eq Oid.real
+  -- Afaict there's no cleaner (@base@) way to access the underlying bits.
+  -- In C we'd do
+  --
+  -- union { float a; uint32_t b; } x;
+  -- x.b = ...;
+  -- return x.a;
+  parseField = unsafeCoerce <$> readBigEndian @Word32 <$> AP.takeByteString
 
+-- | See https://www.postgresql.org/docs/current/datatype-numeric.html.
+-- Accepts only @double precision@ fields, not @real@.
 instance FromField Double where
-  validOid Proxy = Oid.real \/ Oid.doublePrecision
-  parseField = doubleParser
+  validOid Proxy = eq Oid.doublePrecision
+  parseField = unsafeCoerce <$> readBigEndian @Word <$> AP.takeByteString
 
 boolParser :: Parser Bool
-boolParser = choice
-  [ string "t" $> True
-  , string "f" $> False
+boolParser = AP.choice
+  [ AP.word8 1 $> True
+  , AP.word8 0 $> False
   ]
 
 -- | See https://www.postgresql.org/docs/current/datatype-boolean.html.
 instance FromField Bool where
-  validOid Proxy = Oid.boolean
+  validOid Proxy = eq Oid.boolean
   parseField = boolParser
+
+postgresEpoch :: Day
+postgresEpoch = fromGregorian 2000 1 1
+
+fromPostgresJulian :: Integer -> Day
+fromPostgresJulian x = addDays x postgresEpoch
+
+-- | See https://www.postgresql.org/docs/current/datatype-datetime.html.
+-- Relevant as well: https://git.postgresql.org/gitweb/?p=postgresql.git;a=blob;f=src/backend/utils/adt/datetime.c;h=267dfd37b2e8b9bc63797c69b9ca2e45e6bfde61;hb=HEAD#l267.
+-- Note that Postgres uses the proleptic Gregorian calendar, whereas @Show Day@ and @fromGregorian@ use an astronomical calendar.
+-- In short, Postgres treats 1 BC as a leap year and doesn't have a year zero.
+-- This means that working with negative dates will be different in Postgres and your application code.
+instance FromField Day where
+  validOid Proxy = eq Oid.date
+  parseField = fromPostgresJulian . fromIntegral <$> readBigEndian @Int32 <$> AP.takeByteString
+
+-- | See https://www.postgresql.org/docs/current/datatype-datetime.html.
+-- Binary format: https://git.postgresql.org/gitweb/?p=postgresql.git;a=blob;f=src/backend/utils/adt/date.c;h=ae0f24de2c3c54eb6d0405cdb212597c2407238e;hb=HEAD#l1542.
+-- Accepts @time@.
+instance FromField DiffTime where
+  validOid Proxy = eq Oid.time
+  parseField = microsecondsToDiffTime . fromIntegral <$> readBigEndian @Int <$> AP.takeByteString
+    where
+      microsecondsToDiffTime :: Integer -> DiffTime
+      microsecondsToDiffTime ms = picosecondsToDiffTime $ ms * 1000000
+
+-- | See https://www.postgresql.org/docs/current/datatype-datetime.html.
+-- Binary format: https://git.postgresql.org/gitweb/?p=postgresql.git;a=blob;f=src/backend/utils/adt/date.c;h=ae0f24de2c3c54eb6d0405cdb212597c2407238e;hb=HEAD#l1542.
+-- Accepts @time@.
+instance FromField TimeOfDay where
+  validOid Proxy = eq Oid.time
+  parseField = timeToTimeOfDay <$> parseField @DiffTime
+
+fromPostgresTimestamp :: Int -> (Day, DiffTime)
+fromPostgresTimestamp ts = (day, time)
+  where
+    (days, microseconds) = ts `divMod` (86400 * 1000000)
+    day = fromPostgresJulian $ fromIntegral days
+    time = picosecondsToDiffTime $ fromIntegral microseconds * 1000000
+
+-- | See https://www.postgresql.org/docs/current/datatype-datetime.html.
+-- Accepts @timestamp with timezone@.
+instance FromField UTCTime where
+  validOid Proxy = eq Oid.timestampWithTimezone
+  parseField = toUTCTime . fromPostgresTimestamp <$> readBigEndian @Int <$> AP.takeByteString
+    where
+      toUTCTime (day, time) = UTCTime day time
+
+newtype RawField a = RawField a
+  deriving (Eq, Show)
+
+instance FromField a => FromField (RawField a) where
+  validOid Proxy = const True
+  parseField = RawField <$> parseField

lib/Database/PostgreSQL/Opium/Oid.hs

@@ -2,44 +2,62 @@ module Database.PostgreSQL.Opium.Oid where
 
 import Database.PostgreSQL.LibPQ (Oid (..))
 
-eq :: Eq a => a -> a -> Bool
-eq = (==)
+-- raw byte string
+
+bytea :: Oid
+bytea = Oid 17
 
 -- string types
 
-text :: Oid -> Bool
-text = eq $ Oid 25
+text :: Oid
+text = Oid 25
 
-character :: Oid -> Bool
-character = eq $ Oid 1042
+character :: Oid
+character = Oid 1042
 
-characterVarying :: Oid -> Bool
-characterVarying = eq $ Oid 1043
+characterVarying :: Oid
+characterVarying = Oid 1043
 
 -- integer types
 
 -- | 16-bit integer
-smallint :: Oid -> Bool
-smallint = eq $ Oid 21
+smallint :: Oid
+smallint = Oid 21
 
 -- | 32-bit integer
-integer :: Oid -> Bool
-integer = eq $ Oid 23
+integer :: Oid
+integer = Oid 23
 
 -- | 64-bit integer
-bigint :: Oid -> Bool
-bigint = eq $ Oid 20
+bigint :: Oid
+bigint = Oid 20
 
 -- floating point types
 
 -- | 32-bit IEEE float
-real :: Oid -> Bool
-real = eq $ Oid 700
+real :: Oid
+real = Oid 700
 
 -- | 64-bit IEEE float
-doublePrecision :: Oid -> Bool
-doublePrecision = eq $ Oid 701
+doublePrecision :: Oid
+doublePrecision = Oid 701
 
--- | Boolean
-boolean :: Oid -> Bool
-boolean = eq $ Oid 16
+-- | Oid
+boolean :: Oid
+boolean = Oid 16
+
+-- | Single days/dates.
+date :: Oid
+date = Oid 1082
+
+-- | Time of day.
+time :: Oid
+time = Oid 1083
+
+-- | A point in time.
+timestamp :: Oid
+timestamp = Oid 1114
+
+-- | A point in time.
+timestampWithTimezone :: Oid
+timestampWithTimezone = Oid 1184

lib/Database/PostgreSQL/Opium/ToField.hs

@@ -0,0 +1,50 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Database.PostgreSQL.Opium.ToField
+  ( ToField (..)
+  ) where
+
+import Data.Bits (Bits (..))
+import Data.ByteString (ByteString)
+import Data.List (singleton)
+import Data.Text (Text)
+import Data.Word (Word32)
+import Database.PostgreSQL.LibPQ (Format (..), Oid)
+import Unsafe.Coerce (unsafeCoerce)
+
+import qualified Data.ByteString as BS
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Encoding
+import qualified Database.PostgreSQL.Opium.Oid as Oid
+
+class ToField a where
+  toField :: a -> Maybe (Oid, ByteString, Format)
+
+instance ToField ByteString where
+  toField x = Just (Oid.bytea, x, Binary)
+
+instance ToField Text where
+  toField x = Just (Oid.text, Encoding.encodeUtf8 x, Binary)
+
+instance ToField String where
+  toField = toField . Text.pack
+
+instance ToField Char where
+  toField = toField . singleton
+
+-- Potentially slow, but good enough for now
+encodeBigEndian :: (Integral a, Bits a) => Int -> a -> ByteString
+encodeBigEndian n = BS.pack . go [] n
+  where
+    go acc 0 _ = acc
+    go acc i x = go (fromIntegral (x .&. 0xff) : acc) (i - 1) (x `shiftR` 8)
+
+instance ToField Int where
+  toField x = Just (Oid.bigint, encodeBigEndian 8 x, Binary)
+
+instance ToField Float where
+  toField x = Just (Oid.real, encodeBigEndian @Word32 4 $ unsafeCoerce x, Binary)
+
+instance ToField Double where
+  toField x = Just (Oid.doublePrecision, encodeBigEndian @Word 8 $ unsafeCoerce x, Binary)

lib/Database/PostgreSQL/Opium/ToParamList.hs

@@ -0,0 +1,62 @@
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Database.PostgreSQL.Opium.ToParamList
+  ( ToParamList (..)
+  ) where
+
+import Data.ByteString (ByteString)
+import Data.Functor.Identity (Identity)
+import Database.PostgreSQL.LibPQ (Format, Oid)
+import GHC.Generics (Generic, K1 (..), M1 (..), Rec0, Rep, U1 (..), from, (:*:) (..))
+
+import Database.PostgreSQL.Opium.ToField (ToField (..))
+
+class ToParamList a where
+  toParamList :: a -> [Maybe (Oid, ByteString, Format)]
+  default toParamList :: (Generic a, ToParamList' (Rep a)) => a -> [Maybe (Oid, ByteString, Format)]
+  toParamList = toParamList' . from
+
+instance ToField a => ToParamList [a] where
+  toParamList = map toField
+
+instance ToParamList () where
+
+instance ToField a => ToParamList (Identity a) where
+
+instance (ToField a, ToField b) => ToParamList (a, b) where
+
+instance (ToField a, ToField b, ToField c) => ToParamList (a, b, c) where
+
+instance (ToField a, ToField b, ToField c, ToField d) => ToParamList (a, b, c, d) where
+
+instance (ToField a, ToField b, ToField c, ToField d, ToField e) => ToParamList (a, b, c, d, e) where
+
+instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f) => ToParamList (a, b, c, d, e, f) where
+
+instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g) => ToParamList (a, b, c, d, e, f, g) where
+
+instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h) => ToParamList (a, b, c, d, e, f, g, h) where
+
+instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i) => ToParamList (a, b, c, d, e, f, g, h, i) where
+
+instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i, ToField j) => ToParamList (a, b, c, d, e, f, g, h, i, j) where
+
+instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i, ToField j, ToField k) => ToParamList (a, b, c, d, e, f, g, h, i, j, k) where
+
+class ToParamList' f where
+  toParamList' :: f p -> [Maybe (Oid, ByteString, Format)]
+
+instance ToField t => ToParamList' (Rec0 t) where
+  toParamList' (K1 x) = [toField x]
+
+instance ToParamList' f => ToParamList' (M1 t c f) where
+  toParamList' (M1 x) = toParamList' x
+
+instance ToParamList' U1 where
+  toParamList' U1 = []
+
+instance (ToParamList' f, ToParamList' g) => ToParamList' (f :*: g) where
+  toParamList' (x :*: y) = toParamList' x ++ toParamList' y

opium.cabal

@@ -60,12 +60,12 @@ library
 
     -- Modules exported by the library.
     exposed-modules:
-        Database.PostgreSQL.Opium
+        Database.PostgreSQL.Opium,
+        Database.PostgreSQL.Opium.FromField,
 
     -- Modules included in this library but not exported.
     other-modules:
         Database.PostgreSQL.Opium.Error,
-        Database.PostgreSQL.Opium.FromField,
         Database.PostgreSQL.Opium.Oid
 
     -- LANGUAGE extensions used by modules in this package.
@@ -79,6 +79,7 @@ library
         containers,
         postgresql-libpq,
         text,
+        time,
         transformers,
         vector
 
@@ -122,4 +123,5 @@ test-suite opium-test
         bytestring,
         hspec,
         postgresql-libpq,
+        time,
         text

test/Database/PostgreSQL/Opium/FromFieldSpec.hs

@@ -4,12 +4,23 @@
 module Database.PostgreSQL.Opium.FromFieldSpec (spec) where
 
 import Data.ByteString (ByteString)
+import Data.Time
+  ( Day (..)
+  , DiffTime
+  , TimeOfDay (..)
+  , UTCTime (..)
+  , fromGregorian
+  , secondsToDiffTime
+  , timeOfDayToTime
+  )
 import Data.Text (Text)
 import Database.PostgreSQL.LibPQ (Connection)
 import Database.PostgreSQL.Opium (FromRow)
 import GHC.Generics (Generic)
 import Test.Hspec (SpecWith, describe, it, shouldBe, shouldSatisfy)
 
+import qualified Data.ByteString as BS
+
 import qualified Database.PostgreSQL.Opium as Opium
 
 newtype AnInt = AnInt
@@ -30,6 +41,12 @@ newtype AWord = AWord
 
 instance FromRow AWord where
 
+newtype AByteString = AByteString
+  { bytestring :: ByteString
+  } deriving (Eq, Generic, Show)
+
+instance FromRow AByteString where
+
 newtype AText = AText
   { text :: Text
   } deriving (Eq, Generic, Show)
@@ -66,7 +83,37 @@ newtype ABool = ABool
 
 instance FromRow ABool where
 
-shouldFetch :: (Eq a, FromRow a, Show a) => Connection -> ByteString -> [a] -> IO ()
+newtype ADay = ADay
+  { day :: Day
+  } deriving (Eq, Generic, Show)
+
+instance FromRow ADay where
+
+newtype ADiffTime = ADiffTime
+  { difftime :: DiffTime
+  } deriving (Eq, Generic, Show)
+
+instance FromRow ADiffTime where
+
+newtype ATimeOfDay = ATimeOfDay
+  { timeofday :: TimeOfDay
+  } deriving (Eq, Generic, Show)
+
+instance FromRow ATimeOfDay where
+
+newtype AUTCTime = AUTCTime
+  { utctime :: UTCTime
+  } deriving (Eq, Generic, Show)
+
+instance FromRow AUTCTime where
+
+newtype ARawField = ARawField
+  { raw :: Opium.RawField ByteString
+  } deriving (Eq, Generic, Show)
+
+instance FromRow ARawField where
+
+shouldFetch :: (Eq a, FromRow a, Show a) => Connection -> Text -> [a] -> IO ()
 shouldFetch conn query expectedRows = do
   actualRows <- Opium.fetch_ conn query
   actualRows `shouldBe` Right expectedRows
@@ -86,6 +133,15 @@ spec = do
     it "Decodes bigint" $ \conn -> do
       shouldFetch conn "SELECT pow(2, 48)::BIGINT AS int" [AnInt $ (2 :: Int) ^ (48 :: Int)]
 
+    it "Decodes smallint -42" $ \conn -> do
+      shouldFetch conn "SELECT -42::SMALLINT AS int" [AnInt (-42)]
+
+    it "Decodes integer -42" $ \conn -> do
+      shouldFetch conn "SELECT -42::INTEGER AS int" [AnInt (-42)]
+
+    it "Decodes bigint -42" $ \conn -> do
+      shouldFetch conn "SELECT -42::BIGINT AS int" [AnInt (-42)]
+
   describe "FromField Integer" $ do
     it "Decodes smallint" $ \conn -> do
       shouldFetch conn "SELECT 42::SMALLINT AS integer" [AnInteger 42]
@@ -96,6 +152,9 @@ spec = do
     it "Decodes bigint" $ \conn -> do
       shouldFetch conn "SELECT pow(2, 48)::BIGINT AS integer" [AnInteger $ (2 :: Integer) ^ (48 :: Integer)]
 
+    it "Decodes -42" $ \conn -> do
+      shouldFetch conn "SELECT -42 AS integer" [AnInteger (-42)]
+
   describe "FromField Word" $ do
     it "Decodes smallint" $ \conn -> do
       shouldFetch conn "SELECT 42::SMALLINT AS word" [AWord 42]
@@ -106,6 +165,16 @@ spec = do
     it "Decodes bigint" $ \conn -> do
       shouldFetch conn "SELECT pow(2, 48)::BIGINT AS word" [AWord $ (2 :: Word) ^ (48 :: Word)]
 
+    it "Decodes negative one as 2^64-1" $ \conn -> do
+      shouldFetch conn "SELECT -1::BIGINT AS word" [AWord maxBound]
+
+    it "Decodes integer negative one as 2^32-1" $ \conn -> do
+      shouldFetch conn "SELECT -1::INTEGER AS word" [AWord $ (2 :: Word) ^ (32 :: Word) - 1]
+
+  describe "FromField ByteString" $ do
+    it "Decodes bytea" $ \conn -> do
+      shouldFetch conn "SELECT 'Hello, World!'::BYTEA AS bytestring" [AByteString "Hello, World!"]
+
   describe "FromField Text" $ do
     it "Decodes text" $ \conn -> do
       shouldFetch conn "SELECT 'Hello, World!'::TEXT AS text" [AText "Hello, World!"]
@@ -159,9 +228,6 @@ spec = do
     it "Decodes double precision" $ \conn -> do
       shouldFetch conn "SELECT 4.2::double precision AS double" [ADouble 4.2]
 
-    it "Decodes real" $ \conn -> do
-      shouldFetch conn "SELECT 4.2::real AS double" [ADouble 4.2]
-
     it "Decodes NaN::double precision" $ \conn -> do
       Right [ADouble value] <- Opium.fetch_ conn "SELECT 'NaN'::double precision AS double"
       value `shouldSatisfy` isNaN
@@ -193,3 +259,51 @@ spec = do
       shouldFetch conn "SELECT 'no'::boolean AS bool" [ABool False]
       shouldFetch conn "SELECT 'off'::boolean AS bool" [ABool False]
       shouldFetch conn "SELECT 0::boolean AS bool" [ABool False]
+
+  describe "FromField Day" $ do
+    it "Decodes date" $ \conn -> do
+      shouldFetch conn "SELECT date '1970-01-01' AS day" [ADay $ fromGregorian 1970 1 1]
+      shouldFetch conn "SELECT date '2023-09-23' AS day" [ADay $ fromGregorian 2023 9 23]
+      -- Example from postgres doc page
+      shouldFetch conn "SELECT date 'J2451187' AS day" [ADay $ fromGregorian 1999 1 8]
+
+      -- BC
+      -- See https://www.postgresql.org/docs/current/datetime-input-rules.html:
+      -- "If BC has been specified, negate the year and add one for internal storage. (There is no year zero in the Gregorian calendar, so numerically 1 BC becomes year zero.)"
+      shouldFetch conn "SELECT date '0001-02-29 BC' AS day" [ADay $ fromGregorian 0 2 29]
+
+  describe "FromField DiffTime" $ do
+    it "Decodes the time" $ \conn -> do
+      shouldFetch conn "SELECT time '00:00:00' AS difftime" [ADiffTime 0]
+      shouldFetch conn "SELECT time '00:01:00' AS difftime" [ADiffTime $ secondsToDiffTime 60]
+      shouldFetch conn "SELECT time '13:07:43' AS difftime" [ADiffTime $ secondsToDiffTime $ 13 * 3600 + 7 * 60 + 43]
+
+  describe "FromField TimeOfDay" $ do
+    it "Decodes the time" $ \conn -> do
+      shouldFetch conn "SELECT time '00:00:00' AS timeofday" [ATimeOfDay $ TimeOfDay 0 0 0]
+      shouldFetch conn "SELECT time '00:01:00' AS timeofday" [ATimeOfDay $ TimeOfDay 0 1 0]
+      shouldFetch conn "SELECT time '13:07:43' AS timeofday" [ATimeOfDay $ TimeOfDay 13 7 43]
+
+  describe "FromField UTCTime" $ do
+    it "Decodes timestamp with timezone" $ \conn -> do
+      let ts0 = UTCTime (fromGregorian 2023 10 2) (timeOfDayToTime $ TimeOfDay 12 42 23)
+      shouldFetch conn "SELECT timestamp with time zone '2023-10-02 12:42:23' AS utctime" [AUTCTime ts0]
+
+      let ts1 = UTCTime (fromGregorian 294275 12 31) (timeOfDayToTime $ TimeOfDay 23 59 59)
+      shouldFetch conn "SELECT timestamp with time zone '294275-12-31 23:59:59' AS utctime" [AUTCTime ts1]
+
+      let ts2 = UTCTime (fromGregorian 1 1 1) (timeOfDayToTime $ TimeOfDay 0 0 0)
+      shouldFetch conn "SELECT timestamp with time zone '0001-01-01 00:00:00' AS utctime" [AUTCTime ts2]
+
+      -- See note at the FromField Day instance.
+      let ts3 = UTCTime (fromGregorian 0 2 29) (timeOfDayToTime $ TimeOfDay 0 0 0)
+      shouldFetch conn "SELECT timestamp with time zone '0001-02-29 BC 00:00:00' AS utctime" [AUTCTime ts3]
+
+  describe "FromField RawField" $ do
+    it "Simply returns the bytestring without decoding it" $ \conn -> do
+      shouldFetch conn "SELECT 'Hello, World!'::bytea AS raw" [ARawField $ Opium.RawField "Hello, World!"]
+      shouldFetch conn "SELECT 42::int AS raw" [ARawField $ Opium.RawField "\0\0\0\42"]
+      shouldFetch conn "SELECT 42::bigint AS raw" [ARawField $ Opium.RawField "\0\0\0\0\0\0\0\42"]
+      -- Opium assumes that the connection always uses UTF-8.
+      -- The query string is encoded using UTF-8 before passing it to @libpq@.
+      shouldFetch conn "SELECT 'Ära'::text AS raw" [ARawField $ Opium.RawField $ BS.pack [0xC3, 0x84, 0x72, 0x61]]

test/Database/PostgreSQL/OpiumSpec.hs

@@ -7,6 +7,7 @@
 module Database.PostgreSQL.OpiumSpec (spec) where
 
 import Data.ByteString (ByteString)
+import Data.Functor.Identity (Identity (..))
 import Data.Proxy (Proxy (..))
 import Data.Text (Text)
 import Database.PostgreSQL.LibPQ (Connection)
@@ -46,6 +47,12 @@ data ScoreByAge = ScoreByAge
 
 instance Opium.FromRow ScoreByAge where
 
+data Only a = Only
+  { only :: a
+  } deriving (Eq, Generic, Show)
+
+instance Opium.FromField a => Opium.FromRow (Only a) where
+
 isLeft :: Either a b -> Bool
 isLeft (Left _) = True
 isLeft _ = False
@@ -58,7 +65,7 @@ shouldHaveColumns
   -> [LibPQ.Column]
   -> IO ()
 shouldHaveColumns proxy conn query expectedColumns = do
-  Just result <- LibPQ.execParams conn query [] LibPQ.Text
+  Just result <- LibPQ.execParams conn query [] LibPQ.Binary
   columnTable <- Opium.getColumnTable proxy result
   let actualColumns = fmap (map fst . Opium.toListColumnTable) columnTable
   actualColumns `shouldBe` Right expectedColumns
@@ -81,13 +88,13 @@ spec = do
         [5, 3]
 
     it "Fails for missing columns" $ \conn -> do
-      Just result <- LibPQ.execParams conn "SELECT 0 AS a FROM person" [] LibPQ.Text
+      Just result <- LibPQ.execParams conn "SELECT 0 AS a FROM person" [] LibPQ.Binary
       columnTable <- Opium.getColumnTable @Person Proxy result
       columnTable `shouldBe` Left (Opium.ErrorMissingColumn "name")
 
   describe "fromRow" $ do
     it "Decodes rows in a Result" $ \conn -> do
-      Just result <- LibPQ.execParams conn "SELECT * FROM person" [] LibPQ.Text
+      Just result <- LibPQ.execParams conn "SELECT * FROM person" [] LibPQ.Binary
       Right columnTable <- Opium.getColumnTable @Person Proxy result
 
       row0 <- Opium.fromRow @Person result columnTable 0
@@ -97,26 +104,35 @@ spec = do
       row1 `shouldBe` Right (Person "albus" 103)
 
     it "Decodes NULL into Nothing for Maybes" $ \conn -> do
-      Just result <- LibPQ.execParams conn "SELECT NULL AS a" [] LibPQ.Text
+      Just result <- LibPQ.execParams conn "SELECT NULL AS a" [] LibPQ.Binary
       Right columnTable <- Opium.getColumnTable @MaybeTest Proxy result
 
       row <- Opium.fromRow result columnTable 0
       row `shouldBe` Right (MaybeTest Nothing)
 
     it "Decodes values into Just for Maybes" $ \conn -> do
-      Just result <- LibPQ.execParams conn "SELECT 'abc' AS a" [] LibPQ.Text
+      Just result <- LibPQ.execParams conn "SELECT 'abc' AS a" [] LibPQ.Binary
       Right columnTable <- Opium.getColumnTable @MaybeTest Proxy result
 
       row <- Opium.fromRow result columnTable 0
       row `shouldBe` Right (MaybeTest $ Just "abc")
 
     it "Works for many fields" $ \conn -> do
-      Just result <- LibPQ.execParams conn "SELECT 'abc' AS a, 42 AS b, 1.0::double precision AS c, 'test' AS d, true AS e" [] LibPQ.Text
+      Just result <- LibPQ.execParams conn "SELECT 'abc' AS a, 42 AS b, 1.0::double precision AS c, 'test' AS d, true AS e" [] LibPQ.Binary
       Right columnTable <- Opium.getColumnTable @ManyFields Proxy result
 
       row <- Opium.fromRow result columnTable 0
       row `shouldBe` Right (ManyFields "abc" 42 1.0 "test" True)
 
+  describe "fetch" $ do
+    it "Passes numbered parameters and retrieves a list of rows" $ \conn -> do
+      rows <- Opium.fetch conn "SELECT ($1 + $2) AS only" (17 :: Int, 25 :: Int)
+      rows `shouldBe` Right [Only (42 :: Int)]
+
+    it "Uses Identity to pass single parameters" $ \conn -> do
+      rows <- Opium.fetch conn "SELECT count(*) AS only FROM person WHERE name = $1" $ Identity ("paul" :: Text)
+      rows `shouldBe` Right [Only (1 :: Int)]
+
   describe "fetch_" $ do
     it "Retrieves a list of rows" $ \conn -> do
       rows <- Opium.fetch_ conn "SELECT * FROM person"