-- |
-- Module: Database.PostgreSQL.Typed.HDBC
-- Copyright: 2016 Dylan Simon
-- 
-- Use postgresql-typed as a backend for HDBC.
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Database.PostgreSQL.Typed.HDBC
  ( Connection
  , connect
  , fromPGConnection
  , withPGConnection
  , reloadTypes
  , connectionFetchSize
  , setFetchSize
  ) where

import Control.Arrow ((&&&))
import Control.Concurrent.MVar (MVar, newMVar, withMVar)
import Control.Exception (handle, throwIO)
import Control.Monad (void, guard)
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy.Char8 as BSLC
import Data.IORef (newIORef, readIORef, writeIORef, modifyIORef')
import Data.Int (Int16)
import qualified Data.IntMap.Lazy as IntMap
import Data.List (uncons)
import qualified Data.Map.Lazy as Map
import Data.Maybe (fromMaybe, isNothing)
import Data.Time.Clock (DiffTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Time.LocalTime (zonedTimeToUTC)
import Data.Word (Word32)
import qualified Database.HDBC.Types as HDBC
import qualified Database.HDBC.ColTypes as HDBC
import System.Mem.Weak (addFinalizer)
import Text.Read (readMaybe)

import Database.PostgreSQL.Typed.Types
import Database.PostgreSQL.Typed.Protocol
import Database.PostgreSQL.Typed.Dynamic
import Database.PostgreSQL.Typed.TypeCache
import Database.PostgreSQL.Typed.SQLToken
import Paths_postgresql_typed (version)

-- |A wrapped 'PGConnection'.
-- This differs from a bare 'PGConnection' in a few ways:
--
--   1. It always has exactly one active transaction (with 'pgBegin')
--   2. It automatically disconnects on GC
--   3. It provides a mutex around the underlying 'PGConnection' for thread-safety
--
data Connection = Connection
  { Connection -> MVar PGConnection
connectionPG :: MVar PGConnection
  , Connection -> String
connectionServerVer :: String
  , Connection -> IntMap SqlType
connectionTypes :: IntMap.IntMap SqlType
  , Connection -> Word32
connectionFetchSize :: Word32 -- ^Number of rows to fetch (and cache) with 'HDBC.execute' and each time 'HDBC.fetchRow' requires more rows. A higher value will result in fewer round-trips to the database but potentially more wasted data. Defaults to 1. 0 means fetch all rows.
  }

sqlError :: IO a -> IO a
sqlError :: IO a -> IO a
sqlError = (PGError -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle ((PGError -> IO a) -> IO a -> IO a)
-> (PGError -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ \(PGError MessageFields
m) -> 
  let f :: Char -> String
f Char
c = ByteString -> String
BSC.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Char -> MessageFields -> ByteString
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault ByteString
BSC.empty Char
c MessageFields
m
      fC :: String
fC = Char -> String
f Char
'C'
      fD :: String
fD = Char -> String
f Char
'D' in
  SqlError -> IO a
forall e a. Exception e => e -> IO a
throwIO SqlError :: String -> Int -> String -> SqlError
HDBC.SqlError 
    { seState :: String
HDBC.seState = String
fC
    , seNativeError :: Int
HDBC.seNativeError = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
fC then -Int
1 else Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (Char -> String
f Char
'P')
    , seErrorMsg :: String
HDBC.seErrorMsg = Char -> String
f Char
'S' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
f Char
'M' String -> String -> String
forall a. [a] -> [a] -> [a]
++ if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
fD then String
fD else Char
'\n'Char -> String -> String
forall a. a -> [a] -> [a]
:String
fD
    }

-- |Use the underlying 'PGConnection' directly. You must be careful to ensure that the first invariant is preserved: you should not call 'pgBegin', 'pgCommit', or 'pgRollback' on it. All other operations should be safe.
withPGConnection :: Connection -> (PGConnection -> IO a) -> IO a
withPGConnection :: Connection -> (PGConnection -> IO a) -> IO a
withPGConnection Connection
c = IO a -> IO a
forall a. IO a -> IO a
sqlError (IO a -> IO a)
-> ((PGConnection -> IO a) -> IO a)
-> (PGConnection -> IO a)
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar PGConnection -> (PGConnection -> IO a) -> IO a
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (Connection -> MVar PGConnection
connectionPG Connection
c)

takePGConnection :: PGConnection -> IO (MVar PGConnection)
takePGConnection :: PGConnection -> IO (MVar PGConnection)
takePGConnection PGConnection
pg = do
  PGConnection -> IO () -> IO ()
forall key. key -> IO () -> IO ()
addFinalizer PGConnection
pg (PGConnection -> IO ()
pgDisconnectOnce PGConnection
pg)
  PGConnection -> IO ()
pgBegin PGConnection
pg
  PGConnection -> IO (MVar PGConnection)
forall a. a -> IO (MVar a)
newMVar PGConnection
pg

-- |Convert an existing 'PGConnection' to an HDBC-compatible 'Connection'.
-- The caveats under 'connectionPG' apply if you plan to continue using the original 'PGConnection'.
fromPGConnection :: PGConnection -> IO Connection
fromPGConnection :: PGConnection -> IO Connection
fromPGConnection PGConnection
pg = do
  MVar PGConnection
pgv <- PGConnection -> IO (MVar PGConnection)
takePGConnection PGConnection
pg
  Connection -> IO Connection
reloadTypes Connection :: MVar PGConnection
-> String -> IntMap SqlType -> Word32 -> Connection
Connection
    { connectionPG :: MVar PGConnection
connectionPG = MVar PGConnection
pgv
    , connectionServerVer :: String
connectionServerVer = String -> (ByteString -> String) -> Maybe ByteString -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ByteString -> String
BSC.unpack (Maybe ByteString -> String) -> Maybe ByteString -> String
forall a b. (a -> b) -> a -> b
$ PGTypeEnv -> Maybe ByteString
pgServerVersion (PGTypeEnv -> Maybe ByteString) -> PGTypeEnv -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ PGConnection -> PGTypeEnv
pgTypeEnv PGConnection
pg
    , connectionTypes :: IntMap SqlType
connectionTypes = IntMap SqlType
forall a. Monoid a => a
mempty
    , connectionFetchSize :: Word32
connectionFetchSize = Word32
1
    }

-- |Connect to a database for HDBC use (equivalent to 'pgConnect' and 'pgBegin').
connect :: PGDatabase -> IO Connection
connect :: PGDatabase -> IO Connection
connect PGDatabase
d = IO Connection -> IO Connection
forall a. IO a -> IO a
sqlError (IO Connection -> IO Connection) -> IO Connection -> IO Connection
forall a b. (a -> b) -> a -> b
$ do
  PGConnection
pg <- PGDatabase -> IO PGConnection
pgConnect PGDatabase
d
  PGConnection -> IO Connection
fromPGConnection PGConnection
pg

-- |Reload the table of all types from the database.
-- This may be needed if you make structural changes to the database.
reloadTypes :: Connection -> IO Connection
reloadTypes :: Connection -> IO Connection
reloadTypes Connection
c = Connection -> (PGConnection -> IO Connection) -> IO Connection
forall a. Connection -> (PGConnection -> IO a) -> IO a
withPGConnection Connection
c ((PGConnection -> IO Connection) -> IO Connection)
-> (PGConnection -> IO Connection) -> IO Connection
forall a b. (a -> b) -> a -> b
$ \PGConnection
pg -> do
  PGTypes
t <- PGConnection -> IO PGTypes
pgGetTypes PGConnection
pg
  Connection -> IO Connection
forall (m :: * -> *) a. Monad m => a -> m a
return Connection
c{ connectionTypes :: IntMap SqlType
connectionTypes = (PGName -> SqlType) -> PGTypes -> IntMap SqlType
forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map (PGTypeEnv -> String -> SqlType
sqlType (PGConnection -> PGTypeEnv
pgTypeEnv PGConnection
pg) (String -> SqlType) -> (PGName -> String) -> PGName -> SqlType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGName -> String
pgNameString) PGTypes
t }

-- |Change the 'connectionFetchSize' for new 'HDBC.Statement's created with 'HDBC.prepare'.
-- Ideally this could be set with each call to 'HDBC.execute' and 'HDBC.fetchRow', but the HDBC interface provides no way to do this.
setFetchSize :: Word32 -> Connection -> Connection
setFetchSize :: Word32 -> Connection -> Connection
setFetchSize Word32
i Connection
c = Connection
c{ connectionFetchSize :: Word32
connectionFetchSize = Word32
i }

sqls :: String -> BSLC.ByteString
sqls :: String -> ByteString
sqls = String -> ByteString
BSLC.pack

placeholders :: Int -> [SQLToken] -> [SQLToken]
placeholders :: Int -> [SQLToken] -> [SQLToken]
placeholders Int
n (SQLQMark Bool
False : [SQLToken]
l) = Int -> SQLToken
SQLParam Int
n SQLToken -> [SQLToken] -> [SQLToken]
forall a. a -> [a] -> [a]
: Int -> [SQLToken] -> [SQLToken]
placeholders (Int -> Int
forall a. Enum a => a -> a
succ Int
n) [SQLToken]
l
placeholders Int
n (SQLQMark Bool
True : [SQLToken]
l) = Bool -> SQLToken
SQLQMark Bool
False SQLToken -> [SQLToken] -> [SQLToken]
forall a. a -> [a] -> [a]
: Int -> [SQLToken] -> [SQLToken]
placeholders Int
n [SQLToken]
l
placeholders Int
n (SQLToken
t : [SQLToken]
l) = SQLToken
t SQLToken -> [SQLToken] -> [SQLToken]
forall a. a -> [a] -> [a]
: Int -> [SQLToken] -> [SQLToken]
placeholders Int
n [SQLToken]
l
placeholders Int
_ [] = []

data ColDesc = ColDesc
  { ColDesc -> String
colDescName :: String
  , ColDesc -> SqlColDesc
colDesc :: HDBC.SqlColDesc
  , ColDesc -> PGValue -> SqlValue
colDescDecode :: PGValue -> HDBC.SqlValue
  }

data Cursor = Cursor
  { Cursor -> [ColDesc]
cursorDesc :: [ColDesc]
  , Cursor -> [PGValues]
cursorRow :: [PGValues]
  , Cursor -> Bool
cursorActive :: Bool
  , Cursor -> Statement
_cursorStatement :: HDBC.Statement -- keep a handle to prevent GC
  }

noCursor :: HDBC.Statement -> Cursor
noCursor :: Statement -> Cursor
noCursor = [ColDesc] -> [PGValues] -> Bool -> Statement -> Cursor
Cursor [] [] Bool
False

getType :: Connection -> PGConnection -> Maybe Bool -> PGColDescription -> ColDesc
getType :: Connection
-> PGConnection -> Maybe Bool -> PGColDescription -> ColDesc
getType Connection
c PGConnection
pg Maybe Bool
nul PGColDescription{Bool
Int16
Int32
Word32
ByteString
pgColBinary :: PGColDescription -> Bool
pgColModifier :: PGColDescription -> Int32
pgColSize :: PGColDescription -> Int16
pgColType :: PGColDescription -> Word32
pgColNumber :: PGColDescription -> Int16
pgColTable :: PGColDescription -> Word32
pgColName :: PGColDescription -> ByteString
pgColBinary :: Bool
pgColModifier :: Int32
pgColSize :: Int16
pgColType :: Word32
pgColNumber :: Int16
pgColTable :: Word32
pgColName :: ByteString
..} = ColDesc :: String -> SqlColDesc -> (PGValue -> SqlValue) -> ColDesc
ColDesc
  { colDescName :: String
colDescName = ByteString -> String
BSC.unpack ByteString
pgColName
  , colDesc :: SqlColDesc
colDesc = SqlColDesc :: SqlTypeId
-> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Bool -> SqlColDesc
HDBC.SqlColDesc
    { colType :: SqlTypeId
HDBC.colType = SqlType -> SqlTypeId
sqlTypeId SqlType
t
    , colSize :: Maybe Int
HDBC.colSize = Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
pgColModifier Int -> Maybe () -> Maybe Int
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int32
pgColModifier Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int32
0)
    , colOctetLength :: Maybe Int
HDBC.colOctetLength = Int16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
pgColSize Int -> Maybe () -> Maybe Int
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int16
pgColSize Int16 -> Int16 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int16
0)
    , colDecDigits :: Maybe Int
HDBC.colDecDigits = Maybe Int
forall a. Maybe a
Nothing
    , colNullable :: Maybe Bool
HDBC.colNullable = Maybe Bool
nul
    }
  , colDescDecode :: PGValue -> SqlValue
colDescDecode = SqlType -> PGValue -> SqlValue
sqlTypeDecode SqlType
t
  } where t :: SqlType
t = SqlType -> Int -> IntMap SqlType -> SqlType
forall a. a -> Int -> IntMap a -> a
IntMap.findWithDefault (PGTypeEnv -> String -> SqlType
sqlType (PGConnection -> PGTypeEnv
pgTypeEnv PGConnection
pg) (String -> SqlType) -> String -> SqlType
forall a b. (a -> b) -> a -> b
$ Word32 -> String
forall a. Show a => a -> String
show Word32
pgColType) (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
pgColType) (Connection -> IntMap SqlType
connectionTypes Connection
c)

instance HDBC.IConnection Connection where
  disconnect :: Connection -> IO ()
disconnect Connection
c = Connection -> (PGConnection -> IO ()) -> IO ()
forall a. Connection -> (PGConnection -> IO a) -> IO a
withPGConnection Connection
c
    PGConnection -> IO ()
pgDisconnectOnce
  commit :: Connection -> IO ()
commit Connection
c = Connection -> (PGConnection -> IO ()) -> IO ()
forall a. Connection -> (PGConnection -> IO a) -> IO a
withPGConnection Connection
c ((PGConnection -> IO ()) -> IO ())
-> (PGConnection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \PGConnection
pg -> do
    PGConnection -> IO ()
pgCommitAll PGConnection
pg
    PGConnection -> IO ()
pgBegin PGConnection
pg
  rollback :: Connection -> IO ()
rollback Connection
c = Connection -> (PGConnection -> IO ()) -> IO ()
forall a. Connection -> (PGConnection -> IO a) -> IO a
withPGConnection Connection
c ((PGConnection -> IO ()) -> IO ())
-> (PGConnection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \PGConnection
pg -> do
    PGConnection -> IO ()
pgRollbackAll PGConnection
pg
    PGConnection -> IO ()
pgBegin PGConnection
pg
  runRaw :: Connection -> String -> IO ()
runRaw Connection
c String
q = Connection -> (PGConnection -> IO ()) -> IO ()
forall a. Connection -> (PGConnection -> IO a) -> IO a
withPGConnection Connection
c ((PGConnection -> IO ()) -> IO ())
-> (PGConnection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \PGConnection
pg ->
    PGConnection -> ByteString -> IO ()
pgSimpleQueries_ PGConnection
pg (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString
sqls String
q
  run :: Connection -> String -> [SqlValue] -> IO Integer
run Connection
c String
q [SqlValue]
v = Connection -> (PGConnection -> IO Integer) -> IO Integer
forall a. Connection -> (PGConnection -> IO a) -> IO a
withPGConnection Connection
c ((PGConnection -> IO Integer) -> IO Integer)
-> (PGConnection -> IO Integer) -> IO Integer
forall a b. (a -> b) -> a -> b
$ \PGConnection
pg -> do
    let q' :: ByteString
q' = String -> ByteString
sqls (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [SQLToken] -> String
forall a. Show a => a -> String
show ([SQLToken] -> String) -> [SQLToken] -> String
forall a b. (a -> b) -> a -> b
$ Int -> [SQLToken] -> [SQLToken]
placeholders Int
1 ([SQLToken] -> [SQLToken]) -> [SQLToken] -> [SQLToken]
forall a b. (a -> b) -> a -> b
$ String -> [SQLToken]
sqlTokens String
q
        v' :: PGValues
v' = (SqlValue -> PGValue) -> [SqlValue] -> PGValues
forall a b. (a -> b) -> [a] -> [b]
map SqlValue -> PGValue
encode [SqlValue]
v
    Integer -> Maybe Integer -> Integer
forall a. a -> Maybe a -> a
fromMaybe Integer
0 (Maybe Integer -> Integer) -> IO (Maybe Integer) -> IO Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PGConnection
-> ByteString -> [Word32] -> PGValues -> IO (Maybe Integer)
pgRun PGConnection
pg ByteString
q' [] PGValues
v'
  prepare :: Connection -> String -> IO Statement
prepare Connection
c String
q = do
    let q' :: ByteString
q' = String -> ByteString
sqls (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [SQLToken] -> String
forall a. Show a => a -> String
show ([SQLToken] -> String) -> [SQLToken] -> String
forall a b. (a -> b) -> a -> b
$ Int -> [SQLToken] -> [SQLToken]
placeholders Int
1 ([SQLToken] -> [SQLToken]) -> [SQLToken] -> [SQLToken]
forall a b. (a -> b) -> a -> b
$ String -> [SQLToken]
sqlTokens String
q
    PGPreparedStatement
n <- Connection
-> (PGConnection -> IO PGPreparedStatement)
-> IO PGPreparedStatement
forall a. Connection -> (PGConnection -> IO a) -> IO a
withPGConnection Connection
c ((PGConnection -> IO PGPreparedStatement)
 -> IO PGPreparedStatement)
-> (PGConnection -> IO PGPreparedStatement)
-> IO PGPreparedStatement
forall a b. (a -> b) -> a -> b
$ \PGConnection
pg -> PGConnection -> ByteString -> [Word32] -> IO PGPreparedStatement
pgPrepare PGConnection
pg ByteString
q' []
    IORef Cursor
cr <- Cursor -> IO (IORef Cursor)
forall a. a -> IO (IORef a)
newIORef (Cursor -> IO (IORef Cursor)) -> Cursor -> IO (IORef Cursor)
forall a b. (a -> b) -> a -> b
$ String -> Cursor
forall a. HasCallStack => String -> a
error String
"Cursor"
    let
      execute :: [SqlValue] -> IO Integer
execute [SqlValue]
v = Connection -> (PGConnection -> IO Integer) -> IO Integer
forall a. Connection -> (PGConnection -> IO a) -> IO a
withPGConnection Connection
c ((PGConnection -> IO Integer) -> IO Integer)
-> (PGConnection -> IO Integer) -> IO Integer
forall a b. (a -> b) -> a -> b
$ \PGConnection
pg -> do
        PGRowDescription
d <- PGConnection
-> PGPreparedStatement -> PGValues -> IO PGRowDescription
pgBind PGConnection
pg PGPreparedStatement
n ((SqlValue -> PGValue) -> [SqlValue] -> PGValues
forall a b. (a -> b) -> [a] -> [b]
map SqlValue -> PGValue
encode [SqlValue]
v)
        ([PGValues]
r, Maybe Integer
e) <- PGConnection
-> PGPreparedStatement -> Word32 -> IO ([PGValues], Maybe Integer)
pgFetch PGConnection
pg PGPreparedStatement
n (Connection -> Word32
connectionFetchSize Connection
c)
        IORef Cursor -> (Cursor -> Cursor) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Cursor
cr ((Cursor -> Cursor) -> IO ()) -> (Cursor -> Cursor) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Cursor
p -> Cursor
p
          { cursorDesc :: [ColDesc]
cursorDesc = (PGColDescription -> ColDesc) -> PGRowDescription -> [ColDesc]
forall a b. (a -> b) -> [a] -> [b]
map (Connection
-> PGConnection -> Maybe Bool -> PGColDescription -> ColDesc
getType Connection
c PGConnection
pg Maybe Bool
forall a. Maybe a
Nothing) PGRowDescription
d
          , cursorRow :: [PGValues]
cursorRow = [PGValues]
r
          , cursorActive :: Bool
cursorActive = Maybe Integer -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Integer
e
          }
        Integer -> IO Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> IO Integer) -> Integer -> IO Integer
forall a b. (a -> b) -> a -> b
$ Integer -> Maybe Integer -> Integer
forall a. a -> Maybe a -> a
fromMaybe Integer
0 Maybe Integer
e
      stmt :: Statement
stmt = Statement :: ([SqlValue] -> IO Integer)
-> IO ()
-> ([[SqlValue]] -> IO ())
-> IO ()
-> IO (Maybe [SqlValue])
-> IO [String]
-> String
-> IO [(String, SqlColDesc)]
-> Statement
HDBC.Statement
        { execute :: [SqlValue] -> IO Integer
HDBC.execute = [SqlValue] -> IO Integer
execute
        , executeRaw :: IO ()
HDBC.executeRaw = IO Integer -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Integer -> IO ()) -> IO Integer -> IO ()
forall a b. (a -> b) -> a -> b
$ [SqlValue] -> IO Integer
execute []
        , executeMany :: [[SqlValue]] -> IO ()
HDBC.executeMany = ([SqlValue] -> IO Integer) -> [[SqlValue]] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [SqlValue] -> IO Integer
execute
        , finish :: IO ()
HDBC.finish = Connection -> (PGConnection -> IO ()) -> IO ()
forall a. Connection -> (PGConnection -> IO a) -> IO a
withPGConnection Connection
c ((PGConnection -> IO ()) -> IO ())
-> (PGConnection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \PGConnection
pg -> do
          IORef Cursor -> Cursor -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Cursor
cr (Cursor -> IO ()) -> Cursor -> IO ()
forall a b. (a -> b) -> a -> b
$ Statement -> Cursor
noCursor Statement
stmt
          PGConnection -> PGPreparedStatement -> IO ()
pgClose PGConnection
pg PGPreparedStatement
n
        , fetchRow :: IO (Maybe [SqlValue])
HDBC.fetchRow = Connection
-> (PGConnection -> IO (Maybe [SqlValue])) -> IO (Maybe [SqlValue])
forall a. Connection -> (PGConnection -> IO a) -> IO a
withPGConnection Connection
c ((PGConnection -> IO (Maybe [SqlValue])) -> IO (Maybe [SqlValue]))
-> (PGConnection -> IO (Maybe [SqlValue])) -> IO (Maybe [SqlValue])
forall a b. (a -> b) -> a -> b
$ \PGConnection
pg -> do
          Cursor
p <- IORef Cursor -> IO Cursor
forall a. IORef a -> IO a
readIORef IORef Cursor
cr
          (PGValues -> [SqlValue]) -> Maybe PGValues -> Maybe [SqlValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ColDesc -> PGValue -> SqlValue)
-> [ColDesc] -> PGValues -> [SqlValue]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ColDesc -> PGValue -> SqlValue
colDescDecode (Cursor -> [ColDesc]
cursorDesc Cursor
p)) (Maybe PGValues -> Maybe [SqlValue])
-> IO (Maybe PGValues) -> IO (Maybe [SqlValue])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Cursor -> [PGValues]
cursorRow Cursor
p of
            [] | Cursor -> Bool
cursorActive Cursor
p -> do
                ([PGValues]
rl, Maybe Integer
e) <- PGConnection
-> PGPreparedStatement -> Word32 -> IO ([PGValues], Maybe Integer)
pgFetch PGConnection
pg PGPreparedStatement
n (Connection -> Word32
connectionFetchSize Connection
c)
                let rl' :: Maybe (PGValues, [PGValues])
rl' = [PGValues] -> Maybe (PGValues, [PGValues])
forall a. [a] -> Maybe (a, [a])
uncons [PGValues]
rl
                IORef Cursor -> Cursor -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Cursor
cr Cursor
p
                  { cursorRow :: [PGValues]
cursorRow = [PGValues]
-> ((PGValues, [PGValues]) -> [PGValues])
-> Maybe (PGValues, [PGValues])
-> [PGValues]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (PGValues, [PGValues]) -> [PGValues]
forall a b. (a, b) -> b
snd Maybe (PGValues, [PGValues])
rl'
                  , cursorActive :: Bool
cursorActive = Maybe Integer -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Integer
e
                  }
                Maybe PGValues -> IO (Maybe PGValues)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PGValues -> IO (Maybe PGValues))
-> Maybe PGValues -> IO (Maybe PGValues)
forall a b. (a -> b) -> a -> b
$ (PGValues, [PGValues]) -> PGValues
forall a b. (a, b) -> a
fst ((PGValues, [PGValues]) -> PGValues)
-> Maybe (PGValues, [PGValues]) -> Maybe PGValues
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (PGValues, [PGValues])
rl'
               | Bool
otherwise ->
                Maybe PGValues -> IO (Maybe PGValues)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe PGValues
forall a. Maybe a
Nothing
            (PGValues
r:[PGValues]
l) -> do
              IORef Cursor -> Cursor -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Cursor
cr Cursor
p{ cursorRow :: [PGValues]
cursorRow = [PGValues]
l }
              Maybe PGValues -> IO (Maybe PGValues)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PGValues -> IO (Maybe PGValues))
-> Maybe PGValues -> IO (Maybe PGValues)
forall a b. (a -> b) -> a -> b
$ PGValues -> Maybe PGValues
forall a. a -> Maybe a
Just PGValues
r
        , getColumnNames :: IO [String]
HDBC.getColumnNames =
          (ColDesc -> String) -> [ColDesc] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ColDesc -> String
colDescName ([ColDesc] -> [String])
-> (Cursor -> [ColDesc]) -> Cursor -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cursor -> [ColDesc]
cursorDesc (Cursor -> [String]) -> IO Cursor -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Cursor -> IO Cursor
forall a. IORef a -> IO a
readIORef IORef Cursor
cr
        , originalQuery :: String
HDBC.originalQuery = String
q
        , describeResult :: IO [(String, SqlColDesc)]
HDBC.describeResult =
          (ColDesc -> (String, SqlColDesc))
-> [ColDesc] -> [(String, SqlColDesc)]
forall a b. (a -> b) -> [a] -> [b]
map (ColDesc -> String
colDescName (ColDesc -> String)
-> (ColDesc -> SqlColDesc) -> ColDesc -> (String, SqlColDesc)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ColDesc -> SqlColDesc
colDesc) ([ColDesc] -> [(String, SqlColDesc)])
-> (Cursor -> [ColDesc]) -> Cursor -> [(String, SqlColDesc)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cursor -> [ColDesc]
cursorDesc (Cursor -> [(String, SqlColDesc)])
-> IO Cursor -> IO [(String, SqlColDesc)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Cursor -> IO Cursor
forall a. IORef a -> IO a
readIORef IORef Cursor
cr
        }
    IORef Cursor -> Cursor -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Cursor
cr (Cursor -> IO ()) -> Cursor -> IO ()
forall a b. (a -> b) -> a -> b
$ Statement -> Cursor
noCursor Statement
stmt
    Statement -> IO () -> IO ()
forall key. key -> IO () -> IO ()
addFinalizer Statement
stmt (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> (PGConnection -> IO ()) -> IO ()
forall a. Connection -> (PGConnection -> IO a) -> IO a
withPGConnection Connection
c ((PGConnection -> IO ()) -> IO ())
-> (PGConnection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \PGConnection
pg -> PGConnection -> PGPreparedStatement -> IO ()
pgClose PGConnection
pg PGPreparedStatement
n
    Statement -> IO Statement
forall (m :: * -> *) a. Monad m => a -> m a
return Statement
stmt
  clone :: Connection -> IO Connection
clone Connection
c = Connection -> (PGConnection -> IO Connection) -> IO Connection
forall a. Connection -> (PGConnection -> IO a) -> IO a
withPGConnection Connection
c ((PGConnection -> IO Connection) -> IO Connection)
-> (PGConnection -> IO Connection) -> IO Connection
forall a b. (a -> b) -> a -> b
$ \PGConnection
pg -> do
    PGConnection
pg' <- PGDatabase -> IO PGConnection
pgConnect (PGDatabase -> IO PGConnection) -> PGDatabase -> IO PGConnection
forall a b. (a -> b) -> a -> b
$ PGConnection -> PGDatabase
pgConnectionDatabase PGConnection
pg
    MVar PGConnection
pgv <- PGConnection -> IO (MVar PGConnection)
takePGConnection PGConnection
pg'
    Connection -> IO Connection
forall (m :: * -> *) a. Monad m => a -> m a
return Connection
c{ connectionPG :: MVar PGConnection
connectionPG = MVar PGConnection
pgv }
  hdbcDriverName :: Connection -> String
hdbcDriverName Connection
_ = String
"postgresql-typed"
  hdbcClientVer :: Connection -> String
hdbcClientVer Connection
_ = Version -> String
forall a. Show a => a -> String
show Version
version
  proxiedClientName :: Connection -> String
proxiedClientName = Connection -> String
forall conn. IConnection conn => conn -> String
HDBC.hdbcDriverName
  proxiedClientVer :: Connection -> String
proxiedClientVer = Connection -> String
forall conn. IConnection conn => conn -> String
HDBC.hdbcClientVer
  dbServerVer :: Connection -> String
dbServerVer = Connection -> String
connectionServerVer
  dbTransactionSupport :: Connection -> Bool
dbTransactionSupport Connection
_ = Bool
True
  getTables :: Connection -> IO [String]
getTables Connection
c = Connection -> (PGConnection -> IO [String]) -> IO [String]
forall a. Connection -> (PGConnection -> IO a) -> IO a
withPGConnection Connection
c ((PGConnection -> IO [String]) -> IO [String])
-> (PGConnection -> IO [String]) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \PGConnection
pg ->
    (PGValues -> String) -> [PGValues] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (PGValue -> String
forall a. PGRep a => PGValue -> a
pgDecodeRep (PGValue -> String) -> (PGValues -> PGValue) -> PGValues -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGValues -> PGValue
forall a. [a] -> a
head) ([PGValues] -> [String])
-> ((Int, [PGValues]) -> [PGValues])
-> (Int, [PGValues])
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, [PGValues]) -> [PGValues]
forall a b. (a, b) -> b
snd ((Int, [PGValues]) -> [String])
-> IO (Int, [PGValues]) -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PGConnection -> ByteString -> IO (Int, [PGValues])
pgSimpleQuery PGConnection
pg ([ByteString] -> ByteString
BSLC.fromChunks
      [ ByteString
"SELECT relname"
      ,  ByteString
" FROM pg_catalog.pg_class"
      ,  ByteString
" JOIN pg_catalog.pg_namespace ON relnamespace = pg_namespace.oid"
      , ByteString
" WHERE nspname = ANY (current_schemas(false))"
      ,   ByteString
" AND relkind IN ('r','v','m','f')"
      ])
  describeTable :: Connection -> String -> IO [(String, SqlColDesc)]
describeTable Connection
c String
t = Connection
-> (PGConnection -> IO [(String, SqlColDesc)])
-> IO [(String, SqlColDesc)]
forall a. Connection -> (PGConnection -> IO a) -> IO a
withPGConnection Connection
c ((PGConnection -> IO [(String, SqlColDesc)])
 -> IO [(String, SqlColDesc)])
-> (PGConnection -> IO [(String, SqlColDesc)])
-> IO [(String, SqlColDesc)]
forall a b. (a -> b) -> a -> b
$ \PGConnection
pg ->
    (PGValues -> (String, SqlColDesc))
-> [PGValues] -> [(String, SqlColDesc)]
forall a b. (a -> b) -> [a] -> [b]
map (\[PGValue
attname, PGValue
attrelid, PGValue
attnum, PGValue
atttypid, PGValue
attlen, PGValue
atttypmod, PGValue
attnotnull] ->
      ColDesc -> String
colDescName (ColDesc -> String)
-> (ColDesc -> SqlColDesc) -> ColDesc -> (String, SqlColDesc)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ColDesc -> SqlColDesc
colDesc (ColDesc -> (String, SqlColDesc))
-> ColDesc -> (String, SqlColDesc)
forall a b. (a -> b) -> a -> b
$ Connection
-> PGConnection -> Maybe Bool -> PGColDescription -> ColDesc
getType Connection
c PGConnection
pg (Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ PGValue -> Bool
forall a. PGRep a => PGValue -> a
pgDecodeRep PGValue
attnotnull) PGColDescription :: ByteString
-> Word32
-> Int16
-> Word32
-> Int16
-> Int32
-> Bool
-> PGColDescription
PGColDescription
        { pgColName :: ByteString
pgColName = PGValue -> ByteString
forall a. PGRep a => PGValue -> a
pgDecodeRep PGValue
attname
        , pgColTable :: Word32
pgColTable = PGValue -> Word32
forall a. PGRep a => PGValue -> a
pgDecodeRep PGValue
attrelid
        , pgColNumber :: Int16
pgColNumber = PGValue -> Int16
forall a. PGRep a => PGValue -> a
pgDecodeRep PGValue
attnum
        , pgColType :: Word32
pgColType = PGValue -> Word32
forall a. PGRep a => PGValue -> a
pgDecodeRep PGValue
atttypid
        , pgColSize :: Int16
pgColSize = PGValue -> Int16
forall a. PGRep a => PGValue -> a
pgDecodeRep PGValue
attlen
        , pgColModifier :: Int32
pgColModifier = PGValue -> Int32
forall a. PGRep a => PGValue -> a
pgDecodeRep PGValue
atttypmod
        , pgColBinary :: Bool
pgColBinary = Bool
False
        })
      ([PGValues] -> [(String, SqlColDesc)])
-> ((Int, [PGValues]) -> [PGValues])
-> (Int, [PGValues])
-> [(String, SqlColDesc)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, [PGValues]) -> [PGValues]
forall a b. (a, b) -> b
snd ((Int, [PGValues]) -> [(String, SqlColDesc)])
-> IO (Int, [PGValues]) -> IO [(String, SqlColDesc)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PGConnection -> ByteString -> IO (Int, [PGValues])
pgSimpleQuery PGConnection
pg ([ByteString] -> ByteString
BSLC.fromChunks
        [ ByteString
"SELECT attname, attrelid, attnum, atttypid, attlen, atttypmod, attnotnull"
        ,  ByteString
" FROM pg_catalog.pg_attribute"
        , ByteString
" WHERE attrelid = ", String -> ByteString
forall a. PGRep a => a -> ByteString
pgLiteralRep String
t, ByteString
"::regclass"
        , ByteString
"   AND attnum > 0 AND NOT attisdropped"
        , ByteString
" ORDER BY attrelid, attnum"
        ])

encodeRep :: PGRep a => a -> PGValue
encodeRep :: a -> PGValue
encodeRep a
x = ByteString -> PGValue
PGTextValue (ByteString -> PGValue) -> ByteString -> PGValue
forall a b. (a -> b) -> a -> b
$ PGTypeID (PGRepType a) -> a -> ByteString
forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> ByteString
pgEncode (a -> PGTypeID (PGRepType a)
forall a. a -> PGTypeID (PGRepType a)
pgTypeOf a
x) a
x

encode :: HDBC.SqlValue -> PGValue
encode :: SqlValue -> PGValue
encode (HDBC.SqlString String
x)                 = String -> PGValue
forall a. PGRep a => a -> PGValue
encodeRep String
x
encode (HDBC.SqlByteString ByteString
x)             = ByteString -> PGValue
forall a. PGRep a => a -> PGValue
encodeRep ByteString
x
encode (HDBC.SqlWord32 Word32
x)                 = Word32 -> PGValue
forall a. PGRep a => a -> PGValue
encodeRep Word32
x
encode (HDBC.SqlWord64 Word64
x)                 = Rational -> PGValue
forall a. PGRep a => a -> PGValue
encodeRep (Word64 -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
x :: Rational)
encode (HDBC.SqlInt32 Int32
x)                  = Int32 -> PGValue
forall a. PGRep a => a -> PGValue
encodeRep Int32
x
encode (HDBC.SqlInt64 Int64
x)                  = Int64 -> PGValue
forall a. PGRep a => a -> PGValue
encodeRep Int64
x
encode (HDBC.SqlInteger Integer
x)                = Rational -> PGValue
forall a. PGRep a => a -> PGValue
encodeRep (Integer -> Rational
forall a. Num a => Integer -> a
fromInteger Integer
x :: Rational)
encode (HDBC.SqlChar Char
x)                   = Char -> PGValue
forall a. PGRep a => a -> PGValue
encodeRep Char
x
encode (HDBC.SqlBool Bool
x)                   = Bool -> PGValue
forall a. PGRep a => a -> PGValue
encodeRep Bool
x
encode (HDBC.SqlDouble Double
x)                 = Double -> PGValue
forall a. PGRep a => a -> PGValue
encodeRep Double
x
encode (HDBC.SqlRational Rational
x)               = Rational -> PGValue
forall a. PGRep a => a -> PGValue
encodeRep Rational
x
encode (HDBC.SqlLocalDate Day
x)              = Day -> PGValue
forall a. PGRep a => a -> PGValue
encodeRep Day
x
encode (HDBC.SqlLocalTimeOfDay TimeOfDay
x)         = TimeOfDay -> PGValue
forall a. PGRep a => a -> PGValue
encodeRep TimeOfDay
x
encode (HDBC.SqlZonedLocalTimeOfDay TimeOfDay
t TimeZone
z)  = (TimeOfDay, TimeZone) -> PGValue
forall a. PGRep a => a -> PGValue
encodeRep (TimeOfDay
t, TimeZone
z)
encode (HDBC.SqlLocalTime LocalTime
x)              = LocalTime -> PGValue
forall a. PGRep a => a -> PGValue
encodeRep LocalTime
x
encode (HDBC.SqlZonedTime ZonedTime
x)              = UTCTime -> PGValue
forall a. PGRep a => a -> PGValue
encodeRep (ZonedTime -> UTCTime
zonedTimeToUTC ZonedTime
x)
encode (HDBC.SqlUTCTime UTCTime
x)                = UTCTime -> PGValue
forall a. PGRep a => a -> PGValue
encodeRep UTCTime
x
encode (HDBC.SqlDiffTime NominalDiffTime
x)               = DiffTime -> PGValue
forall a. PGRep a => a -> PGValue
encodeRep (NominalDiffTime -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac NominalDiffTime
x :: DiffTime)
encode (HDBC.SqlPOSIXTime NominalDiffTime
x)              = Rational -> PGValue
forall a. PGRep a => a -> PGValue
encodeRep (NominalDiffTime -> Rational
forall a b. (Real a, Fractional b) => a -> b
realToFrac NominalDiffTime
x :: Rational) -- (posixSecondsToUTCTime x)
encode (HDBC.SqlEpochTime Integer
x)              = UTCTime -> PGValue
forall a. PGRep a => a -> PGValue
encodeRep (NominalDiffTime -> UTCTime
posixSecondsToUTCTime (Integer -> NominalDiffTime
forall a. Num a => Integer -> a
fromInteger Integer
x))
encode (HDBC.SqlTimeDiff Integer
x)               = DiffTime -> PGValue
forall a. PGRep a => a -> PGValue
encodeRep (Integer -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
x :: DiffTime)
encode SqlValue
HDBC.SqlNull = PGValue
PGNullValue

data SqlType = SqlType
  { SqlType -> SqlTypeId
sqlTypeId :: HDBC.SqlTypeId
  , SqlType -> PGValue -> SqlValue
sqlTypeDecode :: PGValue -> HDBC.SqlValue
  }

sqlType :: PGTypeEnv -> String -> SqlType
sqlType :: PGTypeEnv -> String -> SqlType
sqlType PGTypeEnv
e String
t = SqlType :: SqlTypeId -> (PGValue -> SqlValue) -> SqlType
SqlType
  { sqlTypeId :: SqlTypeId
sqlTypeId = String -> SqlTypeId
typeId String
t
  , sqlTypeDecode :: PGValue -> SqlValue
sqlTypeDecode = String -> PGTypeEnv -> PGValue -> SqlValue
decode String
t PGTypeEnv
e
  }

typeId :: String -> HDBC.SqlTypeId
typeId :: String -> SqlTypeId
typeId String
"boolean"                      = SqlTypeId
HDBC.SqlBitT
typeId String
"bytea"                        = SqlTypeId
HDBC.SqlVarBinaryT
typeId String
"\"char\""                     = SqlTypeId
HDBC.SqlCharT
typeId String
"name"                         = SqlTypeId
HDBC.SqlVarCharT
typeId String
"bigint"                       = SqlTypeId
HDBC.SqlBigIntT
typeId String
"smallint"                     = SqlTypeId
HDBC.SqlSmallIntT
typeId String
"integer"                      = SqlTypeId
HDBC.SqlIntegerT
typeId String
"text"                         = SqlTypeId
HDBC.SqlLongVarCharT
typeId String
"oid"                          = SqlTypeId
HDBC.SqlIntegerT
typeId String
"real"                         = SqlTypeId
HDBC.SqlFloatT
typeId String
"double precision"             = SqlTypeId
HDBC.SqlDoubleT
typeId String
"abstime"                      = SqlTypeId
HDBC.SqlUTCDateTimeT
typeId String
"reltime"                      = SqlInterval -> SqlTypeId
HDBC.SqlIntervalT SqlInterval
HDBC.SqlIntervalSecondT
typeId String
"tinterval"                    = SqlInterval -> SqlTypeId
HDBC.SqlIntervalT SqlInterval
HDBC.SqlIntervalDayToSecondT
typeId String
"bpchar"                       = SqlTypeId
HDBC.SqlVarCharT
typeId String
"character varying"            = SqlTypeId
HDBC.SqlVarCharT
typeId String
"date"                         = SqlTypeId
HDBC.SqlDateT
typeId String
"time without time zone"       = SqlTypeId
HDBC.SqlTimeT
typeId String
"timestamp without time zone"  = SqlTypeId
HDBC.SqlTimestampT
typeId String
"timestamp with time zone"     = SqlTypeId
HDBC.SqlTimestampWithZoneT -- XXX really SQLUTCDateTimeT
typeId String
"interval"                     = SqlInterval -> SqlTypeId
HDBC.SqlIntervalT SqlInterval
HDBC.SqlIntervalDayToSecondT
typeId String
"time with time zone"          = SqlTypeId
HDBC.SqlTimeWithZoneT
typeId String
"numeric"                      = SqlTypeId
HDBC.SqlDecimalT
typeId String
"uuid"                         = SqlTypeId
HDBC.SqlGUIDT
typeId String
t = String -> SqlTypeId
HDBC.SqlUnknownT String
t

decodeRep :: PGColumn t a => PGTypeID t -> PGTypeEnv -> (a -> HDBC.SqlValue) -> PGValue -> HDBC.SqlValue
decodeRep :: PGTypeID t -> PGTypeEnv -> (a -> SqlValue) -> PGValue -> SqlValue
decodeRep PGTypeID t
t PGTypeEnv
e a -> SqlValue
f (PGBinaryValue ByteString
v) = a -> SqlValue
f (a -> SqlValue) -> a -> SqlValue
forall a b. (a -> b) -> a -> b
$ PGTypeEnv -> PGTypeID t -> ByteString -> a
forall (t :: Symbol) a.
PGColumn t a =>
PGTypeEnv -> PGTypeID t -> ByteString -> a
pgDecodeBinary PGTypeEnv
e PGTypeID t
t ByteString
v
decodeRep PGTypeID t
t PGTypeEnv
_ a -> SqlValue
f (PGTextValue ByteString
v) = a -> SqlValue
f (a -> SqlValue) -> a -> SqlValue
forall a b. (a -> b) -> a -> b
$ PGTypeID t -> ByteString -> a
forall (t :: Symbol) a.
PGColumn t a =>
PGTypeID t -> ByteString -> a
pgDecode PGTypeID t
t ByteString
v
decodeRep PGTypeID t
_ PGTypeEnv
_ a -> SqlValue
_ PGValue
PGNullValue = SqlValue
HDBC.SqlNull

#define DECODE(T) \
  decode T e = decodeRep (PGTypeProxy :: PGTypeID T) e

decode :: String -> PGTypeEnv -> PGValue -> HDBC.SqlValue
decode :: String -> PGTypeEnv -> PGValue -> SqlValue
DECODE(String
"boolean")                     HDBC.SqlBool
DECODE(String
"\"char\"")                    HDBC.SqlChar
DECODE(String
"name")                        HDBC.SqlString
DECODE(String
"bigint")                      HDBC.SqlInt64
DECODE(String
"smallint")                    (HDBC.SqlInt32 . fromIntegral :: Int16 -> HDBC.SqlValue)
DECODE(String
"integer")                     HDBC.SqlInt32
DECODE(String
"text")                        HDBC.SqlString
DECODE(String
"oid")                         HDBC.SqlWord32
DECODE(String
"real")                        HDBC.SqlDouble
DECODE(String
"double precision")            HDBC.SqlDouble
DECODE(String
"bpchar")                      HDBC.SqlString
DECODE(String
"character varying")           HDBC.SqlString
DECODE(String
"date")                        HDBC.SqlLocalDate
DECODE(String
"time without time zone")      HDBC.SqlLocalTimeOfDay
DECODE(String
"time with time zone")         (uncurry HDBC.SqlZonedLocalTimeOfDay)
DECODE(String
"timestamp without time zone") HDBC.SqlLocalTime
DECODE(String
"timestamp with time zone")    HDBC.SqlUTCTime
DECODE(String
"interval")                    (HDBC.SqlDiffTime . realToFrac :: DiffTime -> HDBC.SqlValue)
DECODE(String
"numeric")                     HDBC.SqlRational
decode String
_ PGTypeEnv
_ = PGValue -> SqlValue
decodeRaw where
  decodeRaw :: PGValue -> SqlValue
decodeRaw (PGBinaryValue ByteString
v) = ByteString -> SqlValue
HDBC.SqlByteString ByteString
v
  decodeRaw (PGTextValue ByteString
v)   = ByteString -> SqlValue
HDBC.SqlByteString ByteString
v
  decodeRaw PGValue
PGNullValue       = SqlValue
HDBC.SqlNull