{-# LANGUAGE CPP, PatternGuards, ScopedTypeVariables, FlexibleContexts, TemplateHaskell, DataKinds #-}
-- |
-- Module: Database.PostgreSQL.Typed.TH
-- Copyright: 2015 Dylan Simon
-- 
-- Support functions for compile-time PostgreSQL connection and state management.
-- You can use these to build your own Template Haskell functions using the PostgreSQL connection.

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

-- |Generate a 'PGDatabase' based on the environment variables:
-- @TPG_HOST@ (localhost); @TPG_SOCK@ or @TPG_PORT@ (5432); @TPG_DB@ or user; @TPG_USER@ or @USER@ (postgres); @TPG_PASS@ ()
getTPGDatabase :: IO PGDatabase
getTPGDatabase :: IO PGDatabase
getTPGDatabase = do
  String
user <- String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"postgres" (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe String -> Maybe String -> Maybe String)
-> IO (Maybe String) -> IO (Maybe String) -> IO (Maybe String)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Maybe String -> Maybe String -> Maybe String
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) (String -> IO (Maybe String)
lookupEnv String
"TPG_USER") (String -> IO (Maybe String)
lookupEnv String
"USER")
  String
db   <- String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
user (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"TPG_DB"
  String
host <- String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"localhost" (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"TPG_HOST"
  String
pnum <- String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"5432" (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"TPG_PORT"
#ifdef mingw32_HOST_OS
  let port = Right pnum
#else
  Either String String
port <- Either String String
-> (String -> Either String String)
-> Maybe String
-> Either String String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String String
forall a b. b -> Either a b
Right String
pnum) String -> Either String String
forall a b. a -> Either a b
Left (Maybe String -> Either String String)
-> IO (Maybe String) -> IO (Either String String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"TPG_SOCK"
#endif
  String
pass <- String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"TPG_PASS"
  Bool
debug <- Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"TPG_DEBUG"
#ifdef VERSION_tls
  Bool
tlsEnabled <- Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"TPG_TLS"
  PGTlsValidateMode
tlsVerifyMode <- String -> IO (Maybe String)
lookupEnv String
"TPG_TLS_MODE" IO (Maybe String)
-> (Maybe String -> IO PGTlsValidateMode) -> IO PGTlsValidateMode
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe String
modeStr ->
    case Maybe String
modeStr of
      Just String
"full" -> PGTlsValidateMode -> IO PGTlsValidateMode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PGTlsValidateMode
TlsValidateFull
      Just String
"ca"   -> PGTlsValidateMode -> IO PGTlsValidateMode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PGTlsValidateMode
TlsValidateCA
      Just String
other  -> IOError -> IO PGTlsValidateMode
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError (String
"Unknown verify mode: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
other))
      Maybe String
Nothing     -> PGTlsValidateMode -> IO PGTlsValidateMode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PGTlsValidateMode
TlsValidateCA
  Maybe String
mTlsCertPem <- String -> IO (Maybe String)
lookupEnv String
"TPG_TLS_ROOT_CERT"
  PGTlsMode
dbTls <- case Maybe String
mTlsCertPem of
    Just String
certPem ->
      case PGTlsValidateMode -> ByteString -> Either String PGTlsMode
pgTlsValidate PGTlsValidateMode
tlsVerifyMode (String -> ByteString
BSC.pack String
certPem) of
        Right PGTlsMode
x  -> PGTlsMode -> IO PGTlsMode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PGTlsMode
x
        Left String
err -> IOError -> IO PGTlsMode
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
err)
    Maybe String
Nothing | Bool
tlsEnabled -> PGTlsMode -> IO PGTlsMode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PGTlsMode
TlsNoValidate
    Maybe String
Nothing -> PGTlsMode -> IO PGTlsMode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PGTlsMode
TlsDisabled
#endif
  PGDatabase -> IO PGDatabase
forall a. a -> IO a
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 (Right . Net.SockAddrUnix) (Left . (,) host) port
    , pgDBName = BSU.fromString db
    , pgDBUser = BSU.fromString user
    , pgDBPass = BSU.fromString pass
    , pgDBDebug = debug
#ifdef VERSION_tls
    , pgDBTLS = 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)

-- |Run an action using the Template Haskell state.
withTPGTypeConnection :: (PGTypeConnection -> IO a) -> IO a
withTPGTypeConnection :: forall a. (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 a. a -> IO a
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) -- might leave connection open
  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)

-- |Run an action using the Template Haskell PostgreSQL connection.
withTPGConnection :: (PGConnection -> IO a) -> IO a
withTPGConnection :: forall a. (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)

-- |Specify an alternative database to use during compilation.
-- This lets you override the default connection parameters that are based on TPG environment variables.
-- This should be called as a top-level declaration and produces no code.
-- It uses 'pgReconnect' so is safe to call multiple times with the same database.
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)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
Tv.mapM (\PGTypeConnection
t -> do
        PGConnection
c <- PGConnection -> PGDatabase -> IO PGConnection
pgReconnect (PGTypeConnection -> PGConnection
pgConnection PGTypeConnection
t) PGDatabase
db
        PGTypeConnection -> IO PGTypeConnection
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PGTypeConnection
t{ pgConnection = c }) Maybe PGTypeConnection
tpg'
      else Maybe PGTypeConnection
forall a. Maybe a
Nothing Maybe PGTypeConnection -> IO () -> IO (Maybe PGTypeConnection)
forall a b. a -> IO b -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- |Force reloading of all types from the database.
-- This may be needed if you make structural changes to the database during compile-time.
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 a b. a -> IO b -> IO a
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)

-- |Lookup a type name by OID.
-- Error if not found.
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 (String -> IO PGName
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO PGName) -> String -> IO PGName
forall a b. (a -> b) -> a -> b
$ String
"Unknown PostgreSQL type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ OID -> String
forall a. Show a => a -> String
show OID
o String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nYou may need to use reloadTPGTypes or adjust search_path, or your postgresql-typed application may need to be rebuilt.") PGName -> IO PGName
forall a. a -> IO a
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

-- |Lookup a type OID by type name.
-- This is less common and thus less efficient than going the other way.
-- Fail if not found.
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 (String -> IO OID
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO OID) -> String -> IO OID
forall a b. (a -> b) -> a -> b
$ String
"Unknown PostgreSQL type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PGName -> String
forall a. Show a => a -> String
show PGName
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"; be sure to use the exact type name from \\dTS") OID -> IO OID
forall a. a -> IO a
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
  }

-- |A type-aware wrapper to 'pgDescribe'
tpgDescribe :: BS.ByteString -> [String] -> Bool -> IO ([TPGValueInfo], [TPGValueInfo])
tpgDescribe :: ByteString
-> [String] -> Bool -> IO ([TPGValueInfo], [TPGValueInfo])
tpgDescribe ByteString
sql [String]
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 <- (String -> IO OID) -> [String] -> IO [OID]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (PGTypeConnection -> PGName -> IO OID
getTPGTypeOID PGTypeConnection
tpg (PGName -> IO OID) -> (String -> PGName) -> String -> IO OID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> PGName
forall a. IsString a => String -> a
fromString) [String]
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\OID
o -> do
      PGName
ot <- PGTypeConnection -> OID -> IO PGName
tpgType PGTypeConnection
tpg OID
o
      TPGValueInfo -> IO TPGValueInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return 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 a b. IO (a -> b) -> IO a -> IO b
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(ByteString
c, OID
o, Bool
n) -> do
      PGName
ot <- PGTypeConnection -> OID -> IO PGName
tpgType PGTypeConnection
tpg OID
o
      TPGValueInfo -> IO TPGValueInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return 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 -- "void"
        }) [(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 (String -> TyLit
TH.StrTyLit (String -> TyLit) -> String -> TyLit
forall a b. (a -> b) -> a -> b
$ PGName -> String
pgNameString (PGName -> String) -> PGName -> String
forall a b. (a -> b) -> a -> b
$ PGName
t)))


-- |TH expression to encode a 'PGParameter' value to a 'Maybe' 'L.ByteString'.
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

-- |TH expression to decode a 'Maybe' 'L.ByteString' to a ('Maybe') 'PGColumn' value.
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

-- |TH expression calling 'pgBinaryColumn'.
tpgTypeBinary :: TPGValueInfo -> TH.Name -> TH.Exp
tpgTypeBinary :: TPGValueInfo -> Name -> Exp
tpgTypeBinary TPGValueInfo
v = PGName -> Name -> Name -> Exp
typeApply (TPGValueInfo -> PGName
tpgValueType TPGValueInfo
v) 'pgBinaryColumn