291 lines
11 KiB
Haskell
291 lines
11 KiB
Haskell
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
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
|
|
{ int :: Int
|
|
} deriving (Eq, Generic, Show)
|
|
|
|
instance FromRow AnInt where
|
|
|
|
newtype AnInteger = AnInteger
|
|
{ integer :: Integer
|
|
} deriving (Eq, Generic, Show)
|
|
|
|
instance FromRow AnInteger where
|
|
|
|
newtype AWord = AWord
|
|
{ word :: Word
|
|
} deriving (Eq, Generic, Show)
|
|
|
|
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)
|
|
|
|
instance FromRow AText where
|
|
|
|
newtype AString = AString
|
|
{ string :: String
|
|
} deriving (Eq, Generic, Show)
|
|
|
|
instance FromRow AString where
|
|
|
|
newtype AChar = AChar
|
|
{ char :: Char
|
|
} deriving (Eq, Generic, Show)
|
|
|
|
instance FromRow AChar where
|
|
|
|
newtype AFloat = AFloat
|
|
{ float :: Float
|
|
} deriving (Eq, Generic, Show)
|
|
|
|
instance FromRow AFloat
|
|
|
|
newtype ADouble = ADouble
|
|
{ double :: Double
|
|
} deriving (Eq, Generic, Show)
|
|
|
|
instance FromRow ADouble where
|
|
|
|
newtype ABool = ABool
|
|
{ bool :: Bool
|
|
} deriving (Eq, Generic, Show)
|
|
|
|
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 conn query expectedRows = do
|
|
actualRows <- Opium.fetch_ conn query
|
|
actualRows `shouldBe` Right expectedRows
|
|
|
|
(/\) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
|
|
p /\ q = \x -> p x && q x
|
|
|
|
spec :: SpecWith Connection
|
|
spec = do
|
|
describe "FromField Int" $ do
|
|
it "Decodes smallint" $ \conn -> do
|
|
shouldFetch conn "SELECT 42::SMALLINT AS int" [AnInt 42]
|
|
|
|
it "Decodes integer" $ \conn -> do
|
|
shouldFetch conn "SELECT 42::INTEGER AS int" [AnInt 42]
|
|
|
|
it "Decodes bigint" $ \conn -> do
|
|
shouldFetch conn "SELECT pow(2, 48)::BIGINT AS int" [AnInt $ (2 :: Int) ^ (48 :: Int)]
|
|
|
|
describe "FromField Integer" $ do
|
|
it "Decodes smallint" $ \conn -> do
|
|
shouldFetch conn "SELECT 42::SMALLINT AS integer" [AnInteger 42]
|
|
|
|
it "Decodes integer" $ \conn -> do
|
|
shouldFetch conn "SELECT pow(2, 20)::INTEGER AS integer" [AnInteger $ (2 :: Integer) ^ (20 :: Integer)]
|
|
|
|
it "Decodes bigint" $ \conn -> do
|
|
shouldFetch conn "SELECT pow(2, 48)::BIGINT AS integer" [AnInteger $ (2 :: Integer) ^ (48 :: Integer)]
|
|
|
|
describe "FromField Word" $ do
|
|
it "Decodes smallint" $ \conn -> do
|
|
shouldFetch conn "SELECT 42::SMALLINT AS word" [AWord 42]
|
|
|
|
it "Decodes integer" $ \conn -> do
|
|
shouldFetch conn "SELECT pow(2, 20)::INTEGER AS word" [AWord $ (2 :: Word) ^ (20 :: Word)]
|
|
|
|
it "Decodes bigint" $ \conn -> do
|
|
shouldFetch conn "SELECT pow(2, 48)::BIGINT AS word" [AWord $ (2 :: Word) ^ (48 :: Word)]
|
|
|
|
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!"]
|
|
|
|
it "Decodes character" $ \conn -> do
|
|
shouldFetch conn "SELECT 'Hello, World!'::CHARACTER(10) AS text" [AText "Hello, Wor"]
|
|
shouldFetch conn "SELECT 'Hello, World!'::CHARACTER(20) AS text" [AText "Hello, World! "]
|
|
|
|
it "Decodes character varying" $ \conn -> do
|
|
shouldFetch conn "SELECT 'Hello, World!'::CHARACTER VARYING (20) AS text" [AText "Hello, World!"]
|
|
|
|
describe "FromField String" $ do
|
|
it "Decodes text" $ \conn -> do
|
|
shouldFetch conn "SELECT 'Hello, World!'::TEXT AS string" [AString "Hello, World!"]
|
|
|
|
it "Decodes character" $ \conn -> do
|
|
shouldFetch conn "SELECT 'Hello, World!'::CHARACTER(10) AS string" [AString "Hello, Wor"]
|
|
shouldFetch conn "SELECT 'Hello, World!'::CHARACTER(20) AS string" [AString "Hello, World! "]
|
|
|
|
it "Decodes character varying" $ \conn -> do
|
|
shouldFetch conn "SELECT 'Hello, World!'::CHARACTER VARYING (20) AS string" [AString "Hello, World!"]
|
|
|
|
describe "FromField Char" $ do
|
|
it "Decodes text" $ \conn -> do
|
|
shouldFetch conn "SELECT 'X'::TEXT AS char" [AChar 'X']
|
|
|
|
it "Decodes character" $ \conn -> do
|
|
shouldFetch conn "SELECT 'XYZ'::CHARACTER(1) AS char" [AChar 'X']
|
|
shouldFetch conn "SELECT ''::CHARACTER(1) AS char" [AChar ' ']
|
|
|
|
it "Decodes character varying" $ \conn -> do
|
|
shouldFetch conn "SELECT 'X'::CHARACTER VARYING (20) AS char" [AChar 'X']
|
|
|
|
describe "FromField Float" $ do
|
|
it "Decodes real" $ \conn -> do
|
|
shouldFetch conn "SELECT 4.2::real AS float" [AFloat 4.2]
|
|
|
|
it "Decodes NaN::real" $ \conn -> do
|
|
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_ conn "SELECT 'Infinity'::real AS float"
|
|
value `shouldSatisfy` (isInfinite /\ (> 0))
|
|
|
|
it "Decodes -Infinity::real" $ \conn -> do
|
|
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 NaN::double precision" $ \conn -> do
|
|
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_ conn "SELECT 'Infinity'::double precision AS double"
|
|
value `shouldSatisfy` (isInfinite /\ (> 0))
|
|
|
|
it "Decodes -Infinity::double precision" $ \conn -> do
|
|
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_ conn "SELECT 'inf'::double precision AS double"
|
|
value0 `shouldSatisfy` (isInfinite /\ (> 0))
|
|
|
|
Right [ADouble value1] <- Opium.fetch_ conn "SELECT '-inf'::double precision AS double"
|
|
value1 `shouldSatisfy` (isInfinite /\ (< 0))
|
|
|
|
describe "FromField Bool" $ do
|
|
it "Decodes boolean" $ \conn -> do
|
|
shouldFetch conn "SELECT true AS bool" [ABool True]
|
|
shouldFetch conn "SELECT 't'::boolean AS bool" [ABool True]
|
|
shouldFetch conn "SELECT 'yes'::boolean AS bool" [ABool True]
|
|
shouldFetch conn "SELECT 'on'::boolean AS bool" [ABool True]
|
|
shouldFetch conn "SELECT 1::boolean AS bool" [ABool True]
|
|
shouldFetch conn "SELECT false AS bool" [ABool False]
|
|
shouldFetch conn "SELECT 'f'::boolean AS bool" [ABool False]
|
|
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 'January 1, 4710 BC' AS day" [ADay $ fromGregorian (-4710) 1 1]
|
|
|
|
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" $ \conn -> do
|
|
let ts0 = UTCTime (fromGregorian 2023 10 2) (timeOfDayToTime $ TimeOfDay 12 42 23)
|
|
shouldFetch conn "SELECT timestamp '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 '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 '0001-01-01 00:00:00' AS utctime" [AUTCTime ts2]
|
|
|
|
let ts3 = UTCTime (fromGregorian (-4710) 1 1) (timeOfDayToTime $ TimeOfDay 0 0 0)
|
|
shouldFetch conn "SELECT timestamp 'January 1, 4710 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]]
|