{-# 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
  [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)

-- |Run an action using the Template Haskell state.
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) -- 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 :: (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)
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 []

-- |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 (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 ([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

-- |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 ([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
  }

-- |A type-aware wrapper to 'pgDescribe'
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 -- "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 ([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)))


-- |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