Compare commits
No commits in common. "main" and "feature/more-instances" have entirely different histories.
main
...
feature/mo
31
README.md
31
README.md
@ -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
6
flake.lock
generated
@ -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": {
|
||||
|
||||
40
flake.nix
40
flake.nix
@ -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.cabal-install
|
||||
pkgs.haskellPackages.implicit-hie
|
||||
pkgs.haskell-language-server
|
||||
];
|
||||
};
|
||||
pkgs = nixpkgs.legacyPackages.x86_64-linux;
|
||||
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;
|
||||
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
|
||||
]))
|
||||
|
||||
devShells.${system}.default = opium.env;
|
||||
pkgs.haskell-language-server
|
||||
];
|
||||
shellHook = ''
|
||||
PS1="<opium> ''${PS1}"
|
||||
'';
|
||||
};
|
||||
};
|
||||
}
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
@ -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
|
||||
13
opium.cabal
13
opium.cabal
@ -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
|
||||
|
||||
@ -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]]
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user