{-# LANGUAGE CPP, PatternGuards, ScopedTypeVariables, FlexibleContexts, TemplateHaskell, DataKinds #-}
module Database.PostgreSQL.Typed.TH
( getTPGDatabase
, withTPGTypeConnection
, withTPGConnection
, useTPGDatabase
, reloadTPGTypes
, TPGValueInfo(..)
, tpgDescribe
, tpgTypeEncoder
, tpgTypeDecoder
, tpgTypeBinary
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>), (<$))
#endif
import Control.Applicative ((<|>))
import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar, withMVar)
import Control.Exception (onException, finally)
#ifdef VERSION_tls
import Control.Exception (throwIO)
#endif
import Control.Monad (liftM2)
import qualified Data.ByteString as BS
#ifdef VERSION_tls
import qualified Data.ByteString.Char8 as BSC
#endif
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.UTF8 as BSU
import qualified Data.Foldable as Fold
import Data.Maybe (isJust, fromMaybe)
import Data.String (fromString)
import qualified Data.Traversable as Tv
import qualified Language.Haskell.TH as TH
import qualified Network.Socket as Net
import System.Environment (lookupEnv)
import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO)
import Database.PostgreSQL.Typed.Types
import Database.PostgreSQL.Typed.Protocol
import Database.PostgreSQL.Typed.TypeCache
getTPGDatabase :: IO PGDatabase
getTPGDatabase :: IO PGDatabase
getTPGDatabase = do
[Char]
user <- [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
"postgres" (Maybe [Char] -> [Char]) -> IO (Maybe [Char]) -> IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe [Char] -> Maybe [Char] -> Maybe [Char])
-> IO (Maybe [Char]) -> IO (Maybe [Char]) -> IO (Maybe [Char])
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Maybe [Char] -> Maybe [Char] -> Maybe [Char]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) ([Char] -> IO (Maybe [Char])
lookupEnv [Char]
"TPG_USER") ([Char] -> IO (Maybe [Char])
lookupEnv [Char]
"USER")
[Char]
db <- [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
user (Maybe [Char] -> [Char]) -> IO (Maybe [Char]) -> IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"TPG_DB"
[Char]
host <- [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
"localhost" (Maybe [Char] -> [Char]) -> IO (Maybe [Char]) -> IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"TPG_HOST"
[Char]
pnum <- [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
"5432" (Maybe [Char] -> [Char]) -> IO (Maybe [Char]) -> IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"TPG_PORT"
#ifdef mingw32_HOST_OS
let port = Right pnum
#else
Either [Char] [Char]
port <- Either [Char] [Char]
-> ([Char] -> Either [Char] [Char])
-> Maybe [Char]
-> Either [Char] [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Either [Char] [Char]
forall a b. b -> Either a b
Right [Char]
pnum) [Char] -> Either [Char] [Char]
forall a b. a -> Either a b
Left (Maybe [Char] -> Either [Char] [Char])
-> IO (Maybe [Char]) -> IO (Either [Char] [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"TPG_SOCK"
#endif
[Char]
pass <- [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
"" (Maybe [Char] -> [Char]) -> IO (Maybe [Char]) -> IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"TPG_PASS"
Bool
debug <- Maybe [Char] -> Bool
forall a. Maybe a -> Bool
isJust (Maybe [Char] -> Bool) -> IO (Maybe [Char]) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"TPG_DEBUG"
#ifdef VERSION_tls
Bool
tlsEnabled <- Maybe [Char] -> Bool
forall a. Maybe a -> Bool
isJust (Maybe [Char] -> Bool) -> IO (Maybe [Char]) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"TPG_TLS"
PGTlsValidateMode
tlsVerifyMode <- [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"TPG_TLS_MODE" IO (Maybe [Char])
-> (Maybe [Char] -> IO PGTlsValidateMode) -> IO PGTlsValidateMode
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe [Char]
modeStr ->
case Maybe [Char]
modeStr of
Just [Char]
"full" -> PGTlsValidateMode -> IO PGTlsValidateMode
forall (f :: * -> *) a. Applicative f => a -> f a
pure PGTlsValidateMode
TlsValidateFull
Just [Char]
"ca" -> PGTlsValidateMode -> IO PGTlsValidateMode
forall (f :: * -> *) a. Applicative f => a -> f a
pure PGTlsValidateMode
TlsValidateCA
Just [Char]
other -> IOError -> IO PGTlsValidateMode
forall e a. Exception e => e -> IO a
throwIO ([Char] -> IOError
userError ([Char]
"Unknown verify mode: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
other))
Maybe [Char]
Nothing -> PGTlsValidateMode -> IO PGTlsValidateMode
forall (f :: * -> *) a. Applicative f => a -> f a
pure PGTlsValidateMode
TlsValidateCA
Maybe [Char]
mTlsCertPem <- [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"TPG_TLS_ROOT_CERT"
PGTlsMode
dbTls <- case Maybe [Char]
mTlsCertPem of
Just [Char]
certPem ->
case PGTlsValidateMode -> ByteString -> Either [Char] PGTlsMode
pgTlsValidate PGTlsValidateMode
tlsVerifyMode ([Char] -> ByteString
BSC.pack [Char]
certPem) of
Right PGTlsMode
x -> PGTlsMode -> IO PGTlsMode
forall (f :: * -> *) a. Applicative f => a -> f a
pure PGTlsMode
x
Left [Char]
err -> IOError -> IO PGTlsMode
forall e a. Exception e => e -> IO a
throwIO ([Char] -> IOError
userError [Char]
err)
Maybe [Char]
Nothing | Bool
tlsEnabled -> PGTlsMode -> IO PGTlsMode
forall (f :: * -> *) a. Applicative f => a -> f a
pure PGTlsMode
TlsNoValidate
Maybe [Char]
Nothing -> PGTlsMode -> IO PGTlsMode
forall (f :: * -> *) a. Applicative f => a -> f a
pure PGTlsMode
TlsDisabled
#endif
PGDatabase -> IO PGDatabase
forall (m :: * -> *) a. Monad m => a -> m a
return (PGDatabase -> IO PGDatabase) -> PGDatabase -> IO PGDatabase
forall a b. (a -> b) -> a -> b
$ PGDatabase
defaultPGDatabase
{ pgDBAddr :: Either ([Char], [Char]) SockAddr
pgDBAddr = ([Char] -> Either ([Char], [Char]) SockAddr)
-> ([Char] -> Either ([Char], [Char]) SockAddr)
-> Either [Char] [Char]
-> Either ([Char], [Char]) SockAddr
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (SockAddr -> Either ([Char], [Char]) SockAddr
forall a b. b -> Either a b
Right (SockAddr -> Either ([Char], [Char]) SockAddr)
-> ([Char] -> SockAddr)
-> [Char]
-> Either ([Char], [Char]) SockAddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> SockAddr
Net.SockAddrUnix) (([Char], [Char]) -> Either ([Char], [Char]) SockAddr
forall a b. a -> Either a b
Left (([Char], [Char]) -> Either ([Char], [Char]) SockAddr)
-> ([Char] -> ([Char], [Char]))
-> [Char]
-> Either ([Char], [Char]) SockAddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) [Char]
host) Either [Char] [Char]
port
, pgDBName :: ByteString
pgDBName = [Char] -> ByteString
BSU.fromString [Char]
db
, pgDBUser :: ByteString
pgDBUser = [Char] -> ByteString
BSU.fromString [Char]
user
, pgDBPass :: ByteString
pgDBPass = [Char] -> ByteString
BSU.fromString [Char]
pass
, pgDBDebug :: Bool
pgDBDebug = Bool
debug
#ifdef VERSION_tls
, pgDBTLS :: PGTlsMode
pgDBTLS = PGTlsMode
dbTls
#endif
}
{-# NOINLINE tpgState #-}
tpgState :: MVar (PGDatabase, Maybe PGTypeConnection)
tpgState :: MVar (PGDatabase, Maybe PGTypeConnection)
tpgState = IO (MVar (PGDatabase, Maybe PGTypeConnection))
-> MVar (PGDatabase, Maybe PGTypeConnection)
forall a. IO a -> a
unsafePerformIO (IO (MVar (PGDatabase, Maybe PGTypeConnection))
-> MVar (PGDatabase, Maybe PGTypeConnection))
-> IO (MVar (PGDatabase, Maybe PGTypeConnection))
-> MVar (PGDatabase, Maybe PGTypeConnection)
forall a b. (a -> b) -> a -> b
$ do
PGDatabase
db <- IO PGDatabase -> IO PGDatabase
forall a. IO a -> IO a
unsafeInterleaveIO IO PGDatabase
getTPGDatabase
(PGDatabase, Maybe PGTypeConnection)
-> IO (MVar (PGDatabase, Maybe PGTypeConnection))
forall a. a -> IO (MVar a)
newMVar (PGDatabase
db, Maybe PGTypeConnection
forall a. Maybe a
Nothing)
withTPGTypeConnection :: (PGTypeConnection -> IO a) -> IO a
withTPGTypeConnection :: (PGTypeConnection -> IO a) -> IO a
withTPGTypeConnection PGTypeConnection -> IO a
f = do
(PGDatabase
db, Maybe PGTypeConnection
tpg') <- MVar (PGDatabase, Maybe PGTypeConnection)
-> IO (PGDatabase, Maybe PGTypeConnection)
forall a. MVar a -> IO a
takeMVar MVar (PGDatabase, Maybe PGTypeConnection)
tpgState
PGTypeConnection
tpg <- IO PGTypeConnection
-> (PGTypeConnection -> IO PGTypeConnection)
-> Maybe PGTypeConnection
-> IO PGTypeConnection
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PGConnection -> IO PGTypeConnection
newPGTypeConnection (PGConnection -> IO PGTypeConnection)
-> IO PGConnection -> IO PGTypeConnection
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PGDatabase -> IO PGConnection
pgConnect PGDatabase
db) PGTypeConnection -> IO PGTypeConnection
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe PGTypeConnection
tpg'
IO PGTypeConnection -> IO () -> IO PGTypeConnection
forall a b. IO a -> IO b -> IO a
`onException` MVar (PGDatabase, Maybe PGTypeConnection)
-> (PGDatabase, Maybe PGTypeConnection) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (PGDatabase, Maybe PGTypeConnection)
tpgState (PGDatabase
db, Maybe PGTypeConnection
forall a. Maybe a
Nothing)
PGTypeConnection -> IO a
f PGTypeConnection
tpg IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finally` MVar (PGDatabase, Maybe PGTypeConnection)
-> (PGDatabase, Maybe PGTypeConnection) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (PGDatabase, Maybe PGTypeConnection)
tpgState (PGDatabase
db, PGTypeConnection -> Maybe PGTypeConnection
forall a. a -> Maybe a
Just PGTypeConnection
tpg)
withTPGConnection :: (PGConnection -> IO a) -> IO a
withTPGConnection :: (PGConnection -> IO a) -> IO a
withTPGConnection PGConnection -> IO a
f = (PGTypeConnection -> IO a) -> IO a
forall a. (PGTypeConnection -> IO a) -> IO a
withTPGTypeConnection (PGConnection -> IO a
f (PGConnection -> IO a)
-> (PGTypeConnection -> PGConnection) -> PGTypeConnection -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTypeConnection -> PGConnection
pgConnection)
useTPGDatabase :: PGDatabase -> TH.DecsQ
useTPGDatabase :: PGDatabase -> DecsQ
useTPGDatabase PGDatabase
db = IO [Dec] -> DecsQ
forall a. IO a -> Q a
TH.runIO (IO [Dec] -> DecsQ) -> IO [Dec] -> DecsQ
forall a b. (a -> b) -> a -> b
$ do
(PGDatabase
db', Maybe PGTypeConnection
tpg') <- MVar (PGDatabase, Maybe PGTypeConnection)
-> IO (PGDatabase, Maybe PGTypeConnection)
forall a. MVar a -> IO a
takeMVar MVar (PGDatabase, Maybe PGTypeConnection)
tpgState
MVar (PGDatabase, Maybe PGTypeConnection)
-> (PGDatabase, Maybe PGTypeConnection) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (PGDatabase, Maybe PGTypeConnection)
tpgState ((PGDatabase, Maybe PGTypeConnection) -> IO ())
-> (Maybe PGTypeConnection -> (PGDatabase, Maybe PGTypeConnection))
-> Maybe PGTypeConnection
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) PGDatabase
db (Maybe PGTypeConnection -> IO ())
-> IO (Maybe PGTypeConnection) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
(if PGDatabase
db PGDatabase -> PGDatabase -> Bool
forall a. Eq a => a -> a -> Bool
== PGDatabase
db'
then (PGTypeConnection -> IO PGTypeConnection)
-> Maybe PGTypeConnection -> IO (Maybe PGTypeConnection)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
Tv.mapM (\PGTypeConnection
t -> do
PGConnection
c <- PGConnection -> PGDatabase -> IO PGConnection
pgReconnect (PGTypeConnection -> PGConnection
pgConnection PGTypeConnection
t) PGDatabase
db
PGTypeConnection -> IO PGTypeConnection
forall (m :: * -> *) a. Monad m => a -> m a
return PGTypeConnection
t{ pgConnection :: PGConnection
pgConnection = PGConnection
c }) Maybe PGTypeConnection
tpg'
else Maybe PGTypeConnection
forall a. Maybe a
Nothing Maybe PGTypeConnection -> IO () -> IO (Maybe PGTypeConnection)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (PGTypeConnection -> IO ()) -> Maybe PGTypeConnection -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
Fold.mapM_ (PGConnection -> IO ()
pgDisconnect (PGConnection -> IO ())
-> (PGTypeConnection -> PGConnection) -> PGTypeConnection -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTypeConnection -> PGConnection
pgConnection) Maybe PGTypeConnection
tpg')
IO (Maybe PGTypeConnection) -> IO () -> IO (Maybe PGTypeConnection)
forall a b. IO a -> IO b -> IO a
`onException` MVar (PGDatabase, Maybe PGTypeConnection)
-> (PGDatabase, Maybe PGTypeConnection) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (PGDatabase, Maybe PGTypeConnection)
tpgState (PGDatabase
db, Maybe PGTypeConnection
forall a. Maybe a
Nothing)
[Dec] -> IO [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
reloadTPGTypes :: TH.DecsQ
reloadTPGTypes :: DecsQ
reloadTPGTypes = IO [Dec] -> DecsQ
forall a. IO a -> Q a
TH.runIO (IO [Dec] -> DecsQ) -> IO [Dec] -> DecsQ
forall a b. (a -> b) -> a -> b
$ [] [Dec] -> IO () -> IO [Dec]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ MVar (PGDatabase, Maybe PGTypeConnection)
-> ((PGDatabase, Maybe PGTypeConnection) -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar (PGDatabase, Maybe PGTypeConnection)
tpgState ((PGTypeConnection -> IO ()) -> Maybe PGTypeConnection -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ PGTypeConnection -> IO ()
flushPGTypeConnection (Maybe PGTypeConnection -> IO ())
-> ((PGDatabase, Maybe PGTypeConnection) -> Maybe PGTypeConnection)
-> (PGDatabase, Maybe PGTypeConnection)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PGDatabase, Maybe PGTypeConnection) -> Maybe PGTypeConnection
forall a b. (a, b) -> b
snd)
tpgType :: PGTypeConnection -> OID -> IO PGName
tpgType :: PGTypeConnection -> OID -> IO PGName
tpgType PGTypeConnection
c OID
o =
IO PGName -> (PGName -> IO PGName) -> Maybe PGName -> IO PGName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> IO PGName
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO PGName) -> [Char] -> IO PGName
forall a b. (a -> b) -> a -> b
$ [Char]
"Unknown PostgreSQL type: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ OID -> [Char]
forall a. Show a => a -> [Char]
show OID
o [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\nYou may need to use reloadTPGTypes or adjust search_path, or your postgresql-typed application may need to be rebuilt.") PGName -> IO PGName
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PGName -> IO PGName) -> IO (Maybe PGName) -> IO PGName
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PGTypeConnection -> OID -> IO (Maybe PGName)
lookupPGType PGTypeConnection
c OID
o
getTPGTypeOID :: PGTypeConnection -> PGName -> IO OID
getTPGTypeOID :: PGTypeConnection -> PGName -> IO OID
getTPGTypeOID PGTypeConnection
c PGName
t =
IO OID -> (OID -> IO OID) -> Maybe OID -> IO OID
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> IO OID
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO OID) -> [Char] -> IO OID
forall a b. (a -> b) -> a -> b
$ [Char]
"Unknown PostgreSQL type: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PGName -> [Char]
forall a. Show a => a -> [Char]
show PGName
t [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"; be sure to use the exact type name from \\dTS") OID -> IO OID
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe OID -> IO OID) -> IO (Maybe OID) -> IO OID
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PGTypeConnection -> PGName -> IO (Maybe OID)
findPGType PGTypeConnection
c PGName
t
data TPGValueInfo = TPGValueInfo
{ TPGValueInfo -> ByteString
tpgValueName :: BS.ByteString
, TPGValueInfo -> OID
tpgValueTypeOID :: !OID
, TPGValueInfo -> PGName
tpgValueType :: PGName
, TPGValueInfo -> Bool
tpgValueNullable :: Bool
}
tpgDescribe :: BS.ByteString -> [String] -> Bool -> IO ([TPGValueInfo], [TPGValueInfo])
tpgDescribe :: ByteString
-> [[Char]] -> Bool -> IO ([TPGValueInfo], [TPGValueInfo])
tpgDescribe ByteString
sql [[Char]]
types Bool
nulls = (PGTypeConnection -> IO ([TPGValueInfo], [TPGValueInfo]))
-> IO ([TPGValueInfo], [TPGValueInfo])
forall a. (PGTypeConnection -> IO a) -> IO a
withTPGTypeConnection ((PGTypeConnection -> IO ([TPGValueInfo], [TPGValueInfo]))
-> IO ([TPGValueInfo], [TPGValueInfo]))
-> (PGTypeConnection -> IO ([TPGValueInfo], [TPGValueInfo]))
-> IO ([TPGValueInfo], [TPGValueInfo])
forall a b. (a -> b) -> a -> b
$ \PGTypeConnection
tpg -> do
[OID]
at <- ([Char] -> IO OID) -> [[Char]] -> IO [OID]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (PGTypeConnection -> PGName -> IO OID
getTPGTypeOID PGTypeConnection
tpg (PGName -> IO OID) -> ([Char] -> PGName) -> [Char] -> IO OID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> PGName
forall a. IsString a => [Char] -> a
fromString) [[Char]]
types
([OID]
pt, [(ByteString, OID, Bool)]
rt) <- PGConnection
-> ByteString
-> [OID]
-> Bool
-> IO ([OID], [(ByteString, OID, Bool)])
pgDescribe (PGTypeConnection -> PGConnection
pgConnection PGTypeConnection
tpg) (ByteString -> ByteString
BSL.fromStrict ByteString
sql) [OID]
at Bool
nulls
(,)
([TPGValueInfo]
-> [TPGValueInfo] -> ([TPGValueInfo], [TPGValueInfo]))
-> IO [TPGValueInfo]
-> IO ([TPGValueInfo] -> ([TPGValueInfo], [TPGValueInfo]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (OID -> IO TPGValueInfo) -> [OID] -> IO [TPGValueInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\OID
o -> do
PGName
ot <- PGTypeConnection -> OID -> IO PGName
tpgType PGTypeConnection
tpg OID
o
TPGValueInfo -> IO TPGValueInfo
forall (m :: * -> *) a. Monad m => a -> m a
return TPGValueInfo :: ByteString -> OID -> PGName -> Bool -> TPGValueInfo
TPGValueInfo
{ tpgValueName :: ByteString
tpgValueName = ByteString
BS.empty
, tpgValueTypeOID :: OID
tpgValueTypeOID = OID
o
, tpgValueType :: PGName
tpgValueType = PGName
ot
, tpgValueNullable :: Bool
tpgValueNullable = Bool
True
}) [OID]
pt
IO ([TPGValueInfo] -> ([TPGValueInfo], [TPGValueInfo]))
-> IO [TPGValueInfo] -> IO ([TPGValueInfo], [TPGValueInfo])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((ByteString, OID, Bool) -> IO TPGValueInfo)
-> [(ByteString, OID, Bool)] -> IO [TPGValueInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(ByteString
c, OID
o, Bool
n) -> do
PGName
ot <- PGTypeConnection -> OID -> IO PGName
tpgType PGTypeConnection
tpg OID
o
TPGValueInfo -> IO TPGValueInfo
forall (m :: * -> *) a. Monad m => a -> m a
return TPGValueInfo :: ByteString -> OID -> PGName -> Bool -> TPGValueInfo
TPGValueInfo
{ tpgValueName :: ByteString
tpgValueName = ByteString
c
, tpgValueTypeOID :: OID
tpgValueTypeOID = OID
o
, tpgValueType :: PGName
tpgValueType = PGName
ot
, tpgValueNullable :: Bool
tpgValueNullable = Bool
n Bool -> Bool -> Bool
&& OID
o OID -> OID -> Bool
forall a. Eq a => a -> a -> Bool
/= OID
2278
}) [(ByteString, OID, Bool)]
rt
typeApply :: PGName -> TH.Name -> TH.Name -> TH.Exp
typeApply :: PGName -> Name -> Name -> Exp
typeApply PGName
t Name
f Name
e =
Name -> Exp
TH.VarE Name
f Exp -> Exp -> Exp
`TH.AppE` Name -> Exp
TH.VarE Name
e
Exp -> Exp -> Exp
`TH.AppE` (Name -> Exp
TH.ConE 'PGTypeProxy Exp -> Type -> Exp
`TH.SigE` (Name -> Type
TH.ConT ''PGTypeID Type -> Type -> Type
`TH.AppT` TyLit -> Type
TH.LitT ([Char] -> TyLit
TH.StrTyLit ([Char] -> TyLit) -> [Char] -> TyLit
forall a b. (a -> b) -> a -> b
$ PGName -> [Char]
pgNameString (PGName -> [Char]) -> PGName -> [Char]
forall a b. (a -> b) -> a -> b
$ PGName
t)))
tpgTypeEncoder :: Bool -> TPGValueInfo -> TH.Name -> TH.Exp
tpgTypeEncoder :: Bool -> TPGValueInfo -> Name -> Exp
tpgTypeEncoder Bool
lit TPGValueInfo
v = PGName -> Name -> Name -> Exp
typeApply (TPGValueInfo -> PGName
tpgValueType TPGValueInfo
v) (Name -> Name -> Exp) -> Name -> Name -> Exp
forall a b. (a -> b) -> a -> b
$
if Bool
lit
then 'pgEscapeParameter
else 'pgEncodeParameter
tpgTypeDecoder :: Bool -> TPGValueInfo -> TH.Name -> TH.Exp
tpgTypeDecoder :: Bool -> TPGValueInfo -> Name -> Exp
tpgTypeDecoder Bool
nulls TPGValueInfo
v = PGName -> Name -> Name -> Exp
typeApply (TPGValueInfo -> PGName
tpgValueType TPGValueInfo
v) (Name -> Name -> Exp) -> Name -> Name -> Exp
forall a b. (a -> b) -> a -> b
$
if Bool
nulls Bool -> Bool -> Bool
&& TPGValueInfo -> Bool
tpgValueNullable TPGValueInfo
v
then 'pgDecodeColumn
else 'pgDecodeColumnNotNull
tpgTypeBinary :: TPGValueInfo -> TH.Name -> TH.Exp
tpgTypeBinary :: TPGValueInfo -> Name -> Exp
tpgTypeBinary TPGValueInfo
v = PGName -> Name -> Name -> Exp
typeApply (TPGValueInfo -> PGName
tpgValueType TPGValueInfo
v) 'pgBinaryColumn