Compare commits

..

No commits in common. "main" and "feature/more-instances" have entirely different histories.

13 changed files with 279 additions and 800 deletions

View File

@ -33,8 +33,8 @@ data User = User
instance Opium.FromRow User where
getUsers :: Connection -> IO (Either Opium.Error [User])
getUsers = Opium.fetch_ "SELECT * FROM user"
getUsers :: Connection -> IO (Either Opium.Error [Users])
getUsers conn = Opium.fetch_ conn "SELECT * FROM user"
```
The `Opium.FromRow` instance is implemented generically for all product types ("records"). It looks up the field name in the query result and decodes the column value using `Opium.FromField`.
@ -51,7 +51,7 @@ instance Opium.FromRow ScoreByAge where
getScoreByAge :: Connection -> IO ScoreByAge
getScoreByAge conn = do
let query = "SELECT regr_intercept(score, age) AS t, regr_slope(score, age) AS m FROM user"
Right (Identity x) <- Opium.fetch_ query conn
Right [x] <- Opium.fetch_ conn query
pure x
```
@ -62,25 +62,10 @@ 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
- [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 `fetch` (`fetch_` but with parameter passing)
- [ ] Implement `UTCTime` and zoned time decoding
- [ ] Implement JSON decoding
- [ ] Implement `ByteString` decoding (`bytea`)
- Can we make the fromField instance choose whether it wants binary or text?
- [ ] Implement (anonymous) composite types
- [ ] Catch [UnicodeException](https://hackage.haskell.org/package/text-2.1/docs/Data-Text-Encoding-Error.html#t:UnicodeException) when decoding text
- This might not be necessary if Postgres guarantees us that having a textual OID on a field means that the field is encoded correctly.
- [ ] Implement array decoding
- [ ] Better docs and structure for `FromRow` module
- [ ] Lexer for PostgreSQL that replaces $name by $1, $2, etc.
- [ ] Tutorial
- [ ] Rationale
- [ ] `FromRow`
- [ ] Custom `FromField` impls
- [ ] Improve type errors when trying to `instance` a type that isn't a record (e.g. sum type)
- [ ] Improve documentation for `fromRow` module
- 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

6
flake.lock generated
View File

@ -2,11 +2,11 @@
"nodes": {
"nixpkgs": {
"locked": {
"lastModified": 1719285171,
"narHash": "sha256-kOUKtKfYEh8h8goL/P6lKF4Jb0sXnEkFyEganzdTGvo=",
"lastModified": 1681753173,
"narHash": "sha256-MrGmzZWLUqh2VstoikKLFFIELXm/lsf/G9U9zR96VD4=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "cfb89a95f19bea461fc37228dc4d07b22fe617c2",
"rev": "0a4206a51b386e5cda731e8ac78d76ad924c7125",
"type": "github"
},
"original": {

View File

@ -3,24 +3,32 @@
outputs = { self, nixpkgs }:
let
system = "x86_64-linux";
pkgs = nixpkgs.legacyPackages.${system};
opium = pkgs.haskellPackages.developPackage {
root = ./.;
modifier = drv:
pkgs.haskell.lib.addBuildTools drv [
pkgs = nixpkgs.legacyPackages.x86_64-linux;
in {
apps.x86_64-linux.cabal = {
type = "app";
program = "${nixpkgs.legacyPackages.x86_64-linux.cabal-install}/bin/cabal";
};
devShells.x86_64-linux.default = pkgs.mkShell {
packages = [
pkgs.cabal-install
pkgs.haskellPackages.implicit-hie
(pkgs.ghc.withPackages (hp: with hp; [
attoparsec
containers
bytestring
hspec
postgresql-libpq
text
transformers
vector
]))
pkgs.haskell-language-server
];
shellHook = ''
PS1="<opium> ''${PS1}"
'';
};
in {
packages.${system}.opium = pkgs.haskell.lib.overrideCabal opium {
# Currently the tests require a running Postgres instance.
# This is not automated yet, so don't export the tests.
doCheck = false;
};
devShells.${system}.default = opium.env;
};
}

View File

@ -1,105 +1,53 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Database.PostgreSQL.Opium
-- * Queries
--
-- Functions for performing queries. @fetch@ retrieves rows, @execute@ doesn't.
-- The 'Connection' parameter comes last to facilitate currying for implicitly passing in the connection, e.g. from some framework's connection pool.
--
-- | TODO: Add @newtype Query = Query Text@ with @IsString@ instance to make constructing query strings at run time harder.
( fetch
, fetch_
, execute
, execute_
-- * Classes to Implement
, FromRow (..)
, FromField (..)
, ToParamList (..)
, ToField (..)
-- * Utility Stuff
( ColumnTable
, Error (..)
, ErrorPosition (..)
, RawField (..)
, FromField (..)
, FromRow (..)
, fetch_
, toListColumnTable
)
where
import Control.Monad (unless, void)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except (ExceptT (..), except, runExceptT, throwE)
import Data.Functor.Identity (Identity (..))
import Control.Monad.Trans.Except (ExceptT (..), except, runExceptT)
import Data.ByteString (ByteString)
import Data.IORef (IORef, modifyIORef', newIORef, readIORef)
import Data.Proxy (Proxy (..))
import Data.Text (Text)
import Data.Vector (Vector)
import Database.PostgreSQL.LibPQ
( Connection
( Column
, Connection
, Oid
, Result
, Row
)
import GHC.Generics (C, D, Generic, K1 (..), M1 (..), Meta (..), Rec0, Rep, S, to, (:*:) (..))
import GHC.TypeLits (KnownSymbol, symbolVal)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Encoding
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 (..), RawField (..))
import Database.PostgreSQL.Opium.FromRow (FromRow (..), ColumnTable)
import Database.PostgreSQL.Opium.ToField (ToField (..))
import Database.PostgreSQL.Opium.ToParamList (ToParamList (..))
import Database.PostgreSQL.Opium.FromField (FromField (..), fromField)
class RowContainer c where
extract :: FromRow a => Result -> LibPQ.Row -> ColumnTable -> ExceptT Error IO (c a)
instance RowContainer [] where
extract result nRows columnTable = do
mapM (ExceptT . fromRow result columnTable) [0..nRows - 1]
instance RowContainer Maybe where
extract result nRows columnTable
| nRows == 0 = pure Nothing
| nRows == 1 = Just <$> ExceptT (fromRow result columnTable 0)
| otherwise = throwE ErrorMoreThanOneRow
instance RowContainer Identity where
extract result nRows columnTable = do
unless (nRows == 1) $ throwE ErrorNotExactlyOneRow
Identity <$> ExceptT (fromRow result columnTable 0)
-- The order of the type parameters is important, because it is more common to use type applications for providing the row type and row container type.
fetch
:: forall a b c. (ToParamList c, FromRow a, RowContainer b)
=> Text
-> c
-> Connection
-> IO (Either Error (b a))
fetch query params conn = runExceptT $ do
result <- execParams conn query params
nRows <- liftIO $ LibPQ.ntuples result
columnTable <- ExceptT $ getColumnTable @a Proxy result
extract result nRows columnTable
fetch_ :: forall a c. (FromRow a, RowContainer c) => Text -> Connection -> IO (Either Error (c a))
fetch_ query = fetch query ()
execute
:: forall a. ToParamList a
=> Text
-> a
-> Connection
-> IO (Either Error ())
execute query params conn = runExceptT $ void $ execParams conn query params
execute_ :: Text -> Connection -> IO (Either Error ())
execute_ query = execute query ()
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
execParams :: Connection -> ByteString -> ExceptT Error IO Result
execParams conn query = do
liftIO (LibPQ.execParams conn query [] LibPQ.Text) >>= \case
Nothing ->
except $ Left ErrorNoResult
Just result -> do
@ -109,3 +57,122 @@ execParams conn query params = do
Just "" -> pure result
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
nRows <- liftIO $ LibPQ.ntuples result
mapM (ExceptT . fromRow result columnTable) [0..nRows - 1]
newtype ColumnTable = ColumnTable (Vector (Column, Oid))
deriving (Eq, Show)
newColumnTable :: [(Column, Oid)] -> ColumnTable
newColumnTable = ColumnTable . Vector.fromList
indexColumnTable :: ColumnTable -> Int -> (Column, Oid)
indexColumnTable (ColumnTable v) i = v `Vector.unsafeIndex` i
toListColumnTable :: ColumnTable -> [(Column, Oid)]
toListColumnTable (ColumnTable v) = Vector.toList v
class FromRow a where
getColumnTable :: Proxy a -> Result -> IO (Either Error ColumnTable)
default getColumnTable :: (Generic a, GetColumnTable' (Rep a)) => Proxy a -> Result -> IO (Either Error ColumnTable)
getColumnTable Proxy = runExceptT . fmap newColumnTable . getColumnTable' @(Rep a) Proxy
fromRow :: Result -> ColumnTable -> Row -> IO (Either Error a)
default fromRow :: (Generic a, FromRow' (Rep a)) => Result -> ColumnTable -> Row -> IO (Either Error a)
fromRow result columnTable row = do
iRef <- newIORef 0
runExceptT $ to <$> fromRow' (FromRowCtx result columnTable iRef) row
class GetColumnTable' f where
getColumnTable' :: Proxy (f p) -> Result -> ExceptT Error IO [(Column, Oid)]
instance GetColumnTable' f => GetColumnTable' (M1 D c f) where
getColumnTable' Proxy = getColumnTable' @f Proxy
instance GetColumnTable' f => GetColumnTable' (M1 C c f) where
getColumnTable' Proxy = getColumnTable' @f Proxy
instance (GetColumnTable' f, GetColumnTable' g) => GetColumnTable' (f :*: g) where
getColumnTable' Proxy result =
(++) <$> getColumnTable' @f Proxy result <*> getColumnTable' @g Proxy result
checkColumn :: forall a. FromField a => Proxy a -> String -> Result -> ExceptT Error IO [(Column, Oid)]
checkColumn Proxy nameStr result = do
column <- ExceptT $ maybe (Left $ ErrorMissingColumn nameText) Right <$> LibPQ.fnumber result name
oid <- liftIO $ LibPQ.ftype result column
if validOid @a Proxy oid then
pure [(column, oid)]
else
except $ Left $ ErrorInvalidOid nameText oid
where
nameText = Text.pack nameStr
name = Encoding.encodeUtf8 nameText
instance {-# OVERLAPPABLE #-} (FromField t, KnownSymbol nameSym) => GetColumnTable' (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 t)) where
getColumnTable' Proxy = checkColumn @t Proxy $ symbolVal @nameSym Proxy
instance {-# OVERLAPPING #-} (KnownSymbol nameSym, FromField t) => GetColumnTable' (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 (Maybe t))) where
getColumnTable' Proxy = checkColumn @t Proxy $ symbolVal @nameSym Proxy
data FromRowCtx = FromRowCtx Result ColumnTable (IORef Int)
class FromRow' f where
fromRow' :: FromRowCtx -> Row -> ExceptT Error IO (f p)
instance FromRow' f => FromRow' (M1 D c f) where
fromRow' ctx row = M1 <$> fromRow' ctx row
instance FromRow' f => FromRow' (M1 C c f) where
fromRow' ctx row = M1 <$> fromRow' ctx row
instance (FromRow' f, FromRow' g) => FromRow' (f :*: g) where
fromRow' ctx row = do
y <- fromRow' ctx row
z <- fromRow' ctx row
pure $ y :*: z
decodeField
:: FromField t
=> Text
-> (Row -> Maybe t -> Either Error t')
-> FromRowCtx
-> Row
-> ExceptT Error IO (M1 S m (Rec0 t') p)
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
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 ->
mapLeft
(ErrorInvalidField (ErrorPosition row nameText) oid fieldText)
(Just <$> fromField fieldText)
mapLeft :: (b -> c) -> Either b a -> Either c a
mapLeft f (Left l) = Left $ f l
mapLeft _ (Right r) = Right r
instance {-# OVERLAPPABLE #-} (FromField t, KnownSymbol nameSym) => FromRow' (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 t)) where
fromRow' = decodeField nameText $ \row ->
maybe (Left $ ErrorUnexpectedNull $ ErrorPosition row nameText) Right
where
nameText = Text.pack $ symbolVal @nameSym Proxy
instance {-# OVERLAPPING #-} (KnownSymbol nameSym, FromField t) => FromRow' (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 (Maybe t))) where
fromRow' = decodeField nameText $ const pure
where
nameText = Text.pack $ symbolVal @nameSym Proxy

View File

@ -1,7 +1,6 @@
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)
@ -16,9 +15,7 @@ data Error
| ErrorMissingColumn Text
| ErrorInvalidOid Text Oid
| ErrorUnexpectedNull ErrorPosition
| ErrorInvalidField ErrorPosition Oid ByteString String
| ErrorNotExactlyOneRow
| ErrorMoreThanOneRow
| ErrorInvalidField ErrorPosition Oid Text String
deriving (Eq, Show)
instance Exception Error where

View File

@ -3,68 +3,47 @@
{-# LANGUAGE TypeApplications #-}
module Database.PostgreSQL.Opium.FromField
( -- * Decoding data from @libpq@
FromField (..)
( FromField (..)
, fromField
-- * Utility types
, RawField (..)
) where
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.Attoparsec.Text
( Parser
, anyChar
, choice
, decimal
, double
, parseOnly
, signed
, string
, takeText
)
import Data.Functor (($>))
import Data.Proxy (Proxy (..))
import Data.Text (Text)
import Data.Word (Word16, Word32)
import Database.PostgreSQL.LibPQ (Oid)
import Unsafe.Coerce (unsafeCoerce)
import GHC.Float (double2Float)
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
eq :: Eq a => a -> a -> Bool
eq = (==)
fromField :: FromField a => ByteString -> Either String a
fromField :: FromField a => Text -> Either String a
fromField =
AP.parseOnly parseField
parseOnly parseField
class FromField a where
validOid :: Proxy a -> Oid -> Bool
parseField :: Parser a
-- | 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
validOid Proxy = Oid.text \/ Oid.character \/ Oid.characterVarying
parseField = takeText
-- 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
@ -74,124 +53,48 @@ 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 = 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"
parseField = anyChar
-- | 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 = eq Oid.smallint \/ eq Oid.integer \/ eq Oid.bigint
parseField = readInt =<< AP.takeByteString
validOid Proxy = Oid.smallint \/ Oid.integer \/ Oid.bigint
parseField = signed decimal
-- | See https://www.postgresql.org/docs/current/datatype-numeric.html.
instance FromField Integer where
validOid Proxy = eq Oid.smallint \/ eq Oid.integer \/ eq Oid.bigint
parseField = readInt =<< AP.takeByteString
validOid Proxy = Oid.smallint \/ Oid.integer \/ Oid.bigint
parseField = signed decimal
instance FromField Word where
validOid Proxy = eq Oid.smallint \/ eq Oid.integer \/ eq Oid.bigint
parseField = readWord =<< AP.takeByteString
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
-- | See https://www.postgresql.org/docs/current/datatype-numeric.html.
-- Accepts only @real@ fields, not @double precision@.
instance FromField Float where
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
validOid Proxy = Oid.real
parseField = fmap double2Float doubleParser
-- | See https://www.postgresql.org/docs/current/datatype-numeric.html.
-- Accepts only @double precision@ fields, not @real@.
instance FromField Double where
validOid Proxy = eq Oid.doublePrecision
parseField = unsafeCoerce <$> readBigEndian @Word <$> AP.takeByteString
validOid Proxy = Oid.real \/ Oid.doublePrecision
parseField = doubleParser
boolParser :: Parser Bool
boolParser = AP.choice
[ AP.word8 1 $> True
, AP.word8 0 $> False
boolParser = choice
[ string "t" $> True
, string "f" $> False
]
-- | See https://www.postgresql.org/docs/current/datatype-boolean.html.
instance FromField Bool where
validOid Proxy = eq Oid.boolean
validOid Proxy = 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

View File

@ -1,187 +0,0 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
module Database.PostgreSQL.Opium.FromRow
-- * FromRow
( FromRow (..)
-- * Internal
, ColumnTable
, toListColumnTable
) where
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except (ExceptT (..), except, runExceptT)
import Data.ByteString (ByteString)
import Data.Bifunctor (first)
import Data.Kind (Type)
import Data.Proxy (Proxy (..))
import Data.Text (Text)
import Data.Vector (Vector)
import Database.PostgreSQL.LibPQ
( Column
, Oid
, Result
, Row
)
import GHC.Generics (Generic, C, D, K1 (..), M1 (..), Meta (..), Rec0, Rep, S, to, (:*:) (..))
import GHC.TypeLits (KnownNat, KnownSymbol, Nat, natVal, symbolVal, type (+))
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Encoding
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)
class FromRow a where
getColumnTable :: Proxy a -> Result -> IO (Either Error ColumnTable)
default getColumnTable :: (Generic a, GetColumnTable' (Rep a)) => Proxy a -> Result -> IO (Either Error ColumnTable)
getColumnTable Proxy = runExceptT . fmap newColumnTable . getColumnTable' @(Rep a) Proxy
fromRow :: Result -> ColumnTable -> Row -> IO (Either Error a)
default fromRow :: (Generic a, FromRow' 0 (Rep a)) => Result -> ColumnTable -> Row -> IO (Either Error a)
fromRow result columnTable row =
runExceptT $ to <$> fromRow' @0 FRProxy (FromRowCtx result columnTable) row
instance
( Generic a
, GetColumnTable' (Rep a)
, FromRow' 0 (Rep a)
, Generic b
, GetColumnTable' (Rep b)
, FromRow' (NumberOfMembers (Rep a)) (Rep b)
) => FromRow (a, b) where
getColumnTable Proxy result = runExceptT $ do
ctA <- newColumnTable <$> getColumnTable' @(Rep a) Proxy result
ctB <- newColumnTable <$> getColumnTable' @(Rep b) Proxy result
pure $ ctA `concatColumnTables` ctB
fromRow result ct row = runExceptT $ do
x <- to <$> fromRow' @0 FRProxy (FromRowCtx result ct) row
y <- to <$> fromRow' @(NumberOfMembers (Rep a)) FRProxy (FromRowCtx result ct) row
pure (x, y)
newtype ColumnTable = ColumnTable (Vector (Column, Oid))
deriving (Eq, Show)
newColumnTable :: [(Column, Oid)] -> ColumnTable
newColumnTable = ColumnTable . Vector.fromList
concatColumnTables :: ColumnTable -> ColumnTable -> ColumnTable
concatColumnTables (ColumnTable a) (ColumnTable b) =
ColumnTable $ a <> b
indexColumnTable :: ColumnTable -> Int -> (Column, Oid)
indexColumnTable (ColumnTable v) i = v `Vector.unsafeIndex` i
toListColumnTable :: ColumnTable -> [(Column, Oid)]
toListColumnTable (ColumnTable v) = Vector.toList v
class GetColumnTable' f where
getColumnTable' :: Proxy (f p) -> Result -> ExceptT Error IO [(Column, Oid)]
instance GetColumnTable' f => GetColumnTable' (M1 D c f) where
getColumnTable' Proxy = getColumnTable' @f Proxy
instance GetColumnTable' f => GetColumnTable' (M1 C c f) where
getColumnTable' Proxy = getColumnTable' @f Proxy
instance (GetColumnTable' f, GetColumnTable' g) => GetColumnTable' (f :*: g) where
getColumnTable' Proxy result =
(++) <$> getColumnTable' @f Proxy result <*> getColumnTable' @g Proxy result
instance {-# OVERLAPPABLE #-} (FromField t, KnownSymbol nameSym) => GetColumnTable' (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 t)) where
getColumnTable' Proxy = checkColumn @t Proxy $ symbolVal @nameSym Proxy
instance {-# OVERLAPPING #-} (KnownSymbol nameSym, FromField t) => GetColumnTable' (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 (Maybe t))) where
getColumnTable' Proxy = checkColumn @t Proxy $ symbolVal @nameSym Proxy
-- | Number of members in the generic representation of a record type (doesn't support sum types).
type family NumberOfMembers f where
-- The data type itself has as many members as the type that it defines.
NumberOfMembers (M1 D _ f) = NumberOfMembers f
-- The constructor has as many members as the type that it contains.
NumberOfMembers (M1 C _ f) = NumberOfMembers f
-- A product type has as many members as its subtypes have together.
NumberOfMembers (f :*: g) = NumberOfMembers f + NumberOfMembers g
-- A selector has/is exactly one member.
NumberOfMembers (M1 S _ f) = 1
-- | State kept for a call to 'fromRow'.
data FromRowCtx = FromRowCtx
Result -- ^ Obtained from 'LibPQ.execParams'.
ColumnTable -- ^ 'Vector' of expected columns indices and OIDs.
-- Specialized proxy type to be used instead of `Proxy (n, f)`
data FRProxy (n :: Nat) (f :: Type -> Type) = FRProxy
class FromRow' (n :: Nat) (f :: Type -> Type) where
fromRow' :: FRProxy n f -> FromRowCtx -> Row -> ExceptT Error IO (f p)
instance FromRow' n f => FromRow' n (M1 D c f) where
fromRow' FRProxy ctx row =
M1 <$> fromRow' @n FRProxy ctx row
instance FromRow' n f => FromRow' n (M1 C c f) where
fromRow' FRProxy ctx row =
M1 <$> fromRow' @n FRProxy ctx row
instance (FromRow' n f, FromRow' (n + NumberOfMembers f) g) => FromRow' n (f :*: g) where
fromRow' FRProxy ctx row =
(:*:) <$> fromRow' @n FRProxy ctx row <*> fromRow' @(n + NumberOfMembers f) FRProxy ctx row
instance {-# OVERLAPPABLE #-} (KnownNat n, KnownSymbol nameSym, FromField t) => FromRow' n (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 t)) where
fromRow' FRProxy = decodeField memberIndex nameText $ \row ->
maybe (Left $ ErrorUnexpectedNull $ ErrorPosition row nameText) Right
where
memberIndex = fromIntegral $ natVal @n Proxy
nameText = Text.pack $ symbolVal @nameSym Proxy
instance {-# OVERLAPPING #-} (KnownNat n, KnownSymbol nameSym, FromField t) => FromRow' n (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 (Maybe t))) where
fromRow' FRProxy = decodeField memberIndex nameText $ const pure
where
memberIndex = fromIntegral $ natVal @n Proxy
nameText = Text.pack $ symbolVal @nameSym Proxy
checkColumn :: forall a. FromField a => Proxy a -> String -> Result -> ExceptT Error IO [(Column, Oid)]
checkColumn Proxy nameStr result = do
column <- ExceptT $ maybe (Left $ ErrorMissingColumn nameText) Right <$> LibPQ.fnumber result name
oid <- liftIO $ LibPQ.ftype result column
if validOid @a Proxy oid then
pure [(column, oid)]
else
except $ Left $ ErrorInvalidOid nameText oid
where
nameText = Text.pack nameStr
name = Encoding.encodeUtf8 nameText
decodeField
:: FromField t
=> Int
-> Text
-> (Row -> Maybe t -> Either Error t')
-> FromRowCtx
-> Row
-> ExceptT Error IO (M1 S m (Rec0 t') p)
decodeField memberIndex nameText g (FromRowCtx result columnTable) row = do
let (column, oid) = columnTable `indexColumnTable` memberIndex
mbField <- liftIO $ LibPQ.getvalue result row column
mbValue <- except $ fromFieldIfPresent oid mbField
value <- except $ g row mbValue
pure $ M1 $ K1 value
where
fromFieldIfPresent :: FromField u => LibPQ.Oid -> Maybe ByteString -> Either Error (Maybe u)
fromFieldIfPresent oid = maybe (Right Nothing) $ \field ->
first
(ErrorInvalidField (ErrorPosition row nameText) oid field)
(Just <$> fromField field)

View File

@ -2,62 +2,44 @@ module Database.PostgreSQL.Opium.Oid where
import Database.PostgreSQL.LibPQ (Oid (..))
-- raw byte string
bytea :: Oid
bytea = Oid 17
eq :: Eq a => a -> a -> Bool
eq = (==)
-- string types
text :: Oid
text = Oid 25
text :: Oid -> Bool
text = eq $ Oid 25
character :: Oid
character = Oid 1042
character :: Oid -> Bool
character = eq $ Oid 1042
characterVarying :: Oid
characterVarying = Oid 1043
characterVarying :: Oid -> Bool
characterVarying = eq $ Oid 1043
-- integer types
-- | 16-bit integer
smallint :: Oid
smallint = Oid 21
smallint :: Oid -> Bool
smallint = eq $ Oid 21
-- | 32-bit integer
integer :: Oid
integer = Oid 23
integer :: Oid -> Bool
integer = eq $ Oid 23
-- | 64-bit integer
bigint :: Oid
bigint = Oid 20
bigint :: Oid -> Bool
bigint = eq $ Oid 20
-- floating point types
-- | 32-bit IEEE float
real :: Oid
real = Oid 700
real :: Oid -> Bool
real = eq $ Oid 700
-- | 64-bit IEEE float
doublePrecision :: Oid
doublePrecision = Oid 701
doublePrecision :: Oid -> Bool
doublePrecision = eq $ Oid 701
-- | 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
-- | Boolean
boolean :: Oid -> Bool
boolean = eq $ Oid 16

View File

@ -1,50 +0,0 @@
{-# 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)

View File

@ -1,62 +0,0 @@
{-# 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

View File

@ -52,7 +52,7 @@ build-type: Simple
-- extra-source-files:
common warnings
ghc-options: -Wall -Wextra
ghc-options: -Wall
library
-- Import common warning flags.
@ -60,16 +60,13 @@ library
-- Modules exported by the library.
exposed-modules:
Database.PostgreSQL.Opium,
Database.PostgreSQL.Opium.FromField,
Database.PostgreSQL.Opium.FromRow,
Database.PostgreSQL.Opium.ToField
Database.PostgreSQL.Opium
-- Modules included in this library but not exported.
other-modules:
Database.PostgreSQL.Opium.Error,
Database.PostgreSQL.Opium.Oid,
Database.PostgreSQL.Opium.ToParamList
Database.PostgreSQL.Opium.FromField,
Database.PostgreSQL.Opium.Oid
-- LANGUAGE extensions used by modules in this package.
-- other-extensions:
@ -82,7 +79,6 @@ library
containers,
postgresql-libpq,
text,
time,
transformers,
vector
@ -126,5 +122,4 @@ test-suite opium-test
bytestring,
hspec,
postgresql-libpq,
time,
text

View File

@ -4,23 +4,12 @@
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
@ -41,12 +30,6 @@ 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)
@ -83,39 +66,9 @@ newtype ABool = ABool
instance FromRow ABool where
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 :: (Eq a, FromRow a, Show a) => Connection -> ByteString -> [a] -> IO ()
shouldFetch conn query expectedRows = do
actualRows <- Opium.fetch_ query conn
actualRows <- Opium.fetch_ conn query
actualRows `shouldBe` Right expectedRows
(/\) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
@ -133,15 +86,6 @@ 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]
@ -152,9 +96,6 @@ 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]
@ -165,16 +106,6 @@ 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!"]
@ -213,38 +144,41 @@ spec = do
shouldFetch conn "SELECT 4.2::real AS float" [AFloat 4.2]
it "Decodes NaN::real" $ \conn -> do
Right [AFloat value] <- Opium.fetch_ "SELECT 'NaN'::real AS float" conn
Right [AFloat value] <- Opium.fetch_ conn "SELECT 'NaN'::real AS float"
value `shouldSatisfy` isNaN
it "Decodes Infinity::real" $ \conn -> do
Right [AFloat value] <- Opium.fetch_ "SELECT 'Infinity'::real AS float" conn
Right [AFloat value] <- Opium.fetch_ conn "SELECT 'Infinity'::real AS float"
value `shouldSatisfy` (isInfinite /\ (> 0))
it "Decodes -Infinity::real" $ \conn -> do
Right [AFloat value] <- Opium.fetch_ "SELECT '-Infinity'::real AS float" conn
Right [AFloat value] <- Opium.fetch_ conn "SELECT '-Infinity'::real AS float"
value `shouldSatisfy` (isInfinite /\ (< 0))
describe "FromField Double" $ 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_ "SELECT 'NaN'::double precision AS double" conn
Right [ADouble value] <- Opium.fetch_ conn "SELECT 'NaN'::double precision AS double"
value `shouldSatisfy` isNaN
it "Decodes Infinity::double precision" $ \conn -> do
Right [ADouble value] <- Opium.fetch_ "SELECT 'Infinity'::double precision AS double" conn
Right [ADouble value] <- Opium.fetch_ conn "SELECT 'Infinity'::double precision AS double"
value `shouldSatisfy` (isInfinite /\ (> 0))
it "Decodes -Infinity::double precision" $ \conn -> do
Right [ADouble value] <- Opium.fetch_ "SELECT '-Infinity'::double precision AS double" conn
Right [ADouble value] <- Opium.fetch_ conn "SELECT '-Infinity'::double precision AS double"
value `shouldSatisfy` (isInfinite /\ (< 0))
it "Decodes {inf,-inf}::double precision" $ \conn -> do
Right [ADouble value0] <- Opium.fetch_ "SELECT 'inf'::double precision AS double" conn
Right [ADouble value0] <- Opium.fetch_ conn "SELECT 'inf'::double precision AS double"
value0 `shouldSatisfy` (isInfinite /\ (> 0))
Right [ADouble value1] <- Opium.fetch_ "SELECT '-inf'::double precision AS double" conn
Right [ADouble value1] <- Opium.fetch_ conn "SELECT '-inf'::double precision AS double"
value1 `shouldSatisfy` (isInfinite /\ (< 0))
describe "FromField Bool" $ do
@ -259,51 +193,3 @@ 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]]

View File

@ -7,8 +7,6 @@
module Database.PostgreSQL.OpiumSpec (spec) where
import Data.ByteString (ByteString)
import Data.Either (isLeft)
import Data.Functor.Identity (Identity (..))
import Data.Proxy (Proxy (..))
import Data.Text (Text)
import Database.PostgreSQL.LibPQ (Connection)
@ -17,7 +15,6 @@ import Test.Hspec (SpecWith, describe, it, shouldBe, shouldSatisfy)
import qualified Database.PostgreSQL.LibPQ as LibPQ
import qualified Database.PostgreSQL.Opium as Opium
import qualified Database.PostgreSQL.Opium.FromRow as Opium.FromRow
data Person = Person
{ name :: Text
@ -49,11 +46,9 @@ data ScoreByAge = ScoreByAge
instance Opium.FromRow ScoreByAge where
newtype 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
shouldHaveColumns
:: Opium.FromRow a
@ -63,9 +58,9 @@ shouldHaveColumns
-> [LibPQ.Column]
-> IO ()
shouldHaveColumns proxy conn query expectedColumns = do
Just result <- LibPQ.execParams conn query [] LibPQ.Binary
Just result <- LibPQ.execParams conn query [] LibPQ.Text
columnTable <- Opium.getColumnTable proxy result
let actualColumns = fmap (map fst . Opium.FromRow.toListColumnTable) columnTable
let actualColumns = fmap (map fst . Opium.toListColumnTable) columnTable
actualColumns `shouldBe` Right expectedColumns
spec :: SpecWith Connection
@ -86,13 +81,13 @@ spec = do
[5, 3]
it "Fails for missing columns" $ \conn -> do
Just result <- LibPQ.execParams conn "SELECT 0 AS a FROM person" [] LibPQ.Binary
Just result <- LibPQ.execParams conn "SELECT 0 AS a FROM person" [] LibPQ.Text
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.Binary
Just result <- LibPQ.execParams conn "SELECT * FROM person" [] LibPQ.Text
Right columnTable <- Opium.getColumnTable @Person Proxy result
row0 <- Opium.fromRow @Person result columnTable 0
@ -102,83 +97,43 @@ 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.Binary
Just result <- LibPQ.execParams conn "SELECT NULL AS a" [] LibPQ.Text
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.Binary
Just result <- LibPQ.execParams conn "SELECT 'abc' AS a" [] LibPQ.Text
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.Binary
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
Right columnTable <- Opium.getColumnTable @ManyFields Proxy result
row <- Opium.fromRow result columnTable 0
row `shouldBe` Right (ManyFields "abc" 42 1.0 "test" True)
it "Decodes multiple records into a tuple" $ \conn -> do
Just result <- LibPQ.execParams conn "SELECT 'albus' AS name, 123 AS age, 42 AS only" [] LibPQ.Binary
Right columnTable <- Opium.getColumnTable @(Person, Only Int) Proxy result
row <- Opium.fromRow @(Person, Only Int) result columnTable 0
row `shouldBe` Right (Person "albus" 123, Only 42)
describe "fetch" $ do
it "Passes numbered parameters and retrieves a list of rows" $ \conn -> do
rows <- Opium.fetch "SELECT ($1 + $2) AS only" (17 :: Int, 25 :: Int) conn
rows `shouldBe` Right [Only (42 :: Int)]
it "Uses Identity to pass single parameters" $ \conn -> do
rows <- Opium.fetch "SELECT count(*) AS only FROM person WHERE name = $1" (Identity ("paul" :: Text)) conn
rows `shouldBe` Right [Only (1 :: Int)]
describe "fetch_" $ do
it "Retrieves a list of rows" $ \conn -> do
rows <- Opium.fetch_ "SELECT * FROM person" conn
rows <- Opium.fetch_ conn "SELECT * FROM person"
rows `shouldBe` Right [Person "paul" 25, Person "albus" 103]
it "Fails for invalid queries" $ \conn -> do
rows <- Opium.fetch_ @Person @[] "MRTLBRNFT" conn
rows <- Opium.fetch_ @Person conn "MRTLBRNFT"
rows `shouldSatisfy` isLeft
it "Fails for unexpected NULLs" $ \conn -> do
rows <- Opium.fetch_ @Person @[] "SELECT NULL AS name, 0 AS age" conn
rows <- Opium.fetch_ @Person conn "SELECT NULL AS name, 0 AS age"
rows `shouldBe` Left (Opium.ErrorUnexpectedNull (Opium.ErrorPosition 0 "name"))
it "Fails for the wrong column type" $ \conn -> do
rows <- Opium.fetch_ @Person @[] "SELECT 'quby' AS name, 'indeterminate' AS age" conn
rows <- Opium.fetch_ @Person conn "SELECT 'quby' AS name, 'indeterminate' AS age"
rows `shouldBe` Left (Opium.ErrorInvalidOid "age" $ LibPQ.Oid 25)
it "Works for the readme regression example" $ \conn -> do
rows <- Opium.fetch_ @ScoreByAge @[] "SELECT regr_intercept(score, age) AS t, regr_slope(score, age) AS m FROM person" conn
rows <- Opium.fetch_ @ScoreByAge conn "SELECT regr_intercept(score, age) AS t, regr_slope(score, age) AS m FROM person"
rows `shouldSatisfy` \case { (Right [ScoreByAge _ _]) -> True; _ -> False }
it "Accepts exactly one row when Identity is the row container type" $ \conn -> do
row <- Opium.fetch_ "SELECT 42 AS only" conn
row `shouldBe` Right (Identity (Only (42 :: Int)))
it "Does not accept zero rows when Identity is the row container type" $ \conn -> do
row <- Opium.fetch_ @(Only Int) @Identity "SELECT 42 AS only WHERE false" conn
row `shouldSatisfy` isLeft
it "Does not accept two rows when Identity is the row container type" $ \conn -> do
row <- Opium.fetch_ @(Only Int) @Identity "SELECT 17 AS only UNION ALL SELECT 25 AS only" conn
row `shouldSatisfy` isLeft
it "Accepts zero rows when Maybe is the row container type" $ \conn -> do
row <- Opium.fetch_ @(Only Int) @Maybe "SELECT 17 AS only WHERE false" conn
row `shouldBe` Right Nothing
it "Accepts one row when Maybe is the row container type" $ \conn -> do
row <- Opium.fetch_ @(Only Int) @Maybe "SELECT 42 AS only" conn
row `shouldBe` Right (Just (Only 42))
it "Does not accept two rows when Maybe is the row container type" $ \conn -> do
row <- Opium.fetch_ @(Only Int) @Maybe "SELECT 17 AS only UNION ALL SELECT 25 AS only" conn
row `shouldSatisfy` isLeft