{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-deprecations #-}
module Database.PostgreSQL.Typed.TemplatePG
( queryTuples
, queryTuple
, execute
, insertIgnore
, withTransaction
, rollback
, PGException
, pgConnect
#if !MIN_VERSION_network(2,7,0)
, PortID(..)
#endif
, PG.pgDisconnect
) where
import Control.Exception (catchJust)
import Control.Monad (liftM, void, guard)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy.Char8 as BSLC
import Data.Maybe (listToMaybe, isJust)
import qualified Language.Haskell.TH as TH
#if MIN_VERSION_network(2,7,0)
import Data.Word (Word16)
#else
import Network (PortID(..))
#endif
#if !defined(mingw32_HOST_OS)
import qualified Network.Socket as Net
#endif
import System.Environment (lookupEnv)
import qualified Database.PostgreSQL.Typed.Protocol as PG
import Database.PostgreSQL.Typed.Query
querySQL :: String -> String
querySQL :: String -> String
querySQL (Char
'{':String
s) = Char
'$'forall a. a -> [a] -> [a]
:Char
'{'forall a. a -> [a] -> [a]
:String -> String
querySQL String
s
querySQL (Char
c:String
s) = Char
cforall a. a -> [a] -> [a]
:String -> String
querySQL String
s
querySQL String
"" = String
""
queryTuples :: String -> TH.ExpQ
queryTuples :: String -> ExpQ
queryTuples String
sql = [| \c -> pgQuery c $(makePGQuery simpleQueryFlags $ querySQL sql) |]
queryTuple :: String -> TH.ExpQ
queryTuple :: String -> ExpQ
queryTuple String
sql = [| liftM listToMaybe . $(queryTuples sql) |]
execute :: String -> TH.ExpQ
execute :: String -> ExpQ
execute String
sql = [| \c -> void $ pgExecute c $(makePGQuery simpleQueryFlags $ querySQL sql) |]
withTransaction :: PG.PGConnection -> IO a -> IO a
withTransaction :: forall a. PGConnection -> IO a -> IO a
withTransaction = forall a. PGConnection -> IO a -> IO a
PG.pgTransaction
rollback :: PG.PGConnection -> IO ()
rollback :: PGConnection -> IO ()
rollback PGConnection
h = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ PGConnection -> ByteString -> IO (Int, [PGValues])
PG.pgSimpleQuery PGConnection
h forall a b. (a -> b) -> a -> b
$ String -> ByteString
BSLC.pack String
"ROLLBACK"
insertIgnore :: IO () -> IO ()
insertIgnore :: IO () -> IO ()
insertIgnore IO ()
q = forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
catchJust forall {f :: * -> *}. Alternative f => PGError -> f ()
uniquenessError IO ()
q (\ ()
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()) where
uniquenessError :: PGError -> f ()
uniquenessError PGError
e = forall (f :: * -> *). Alternative f => Bool -> f ()
guard (PGError -> ByteString
PG.pgErrorCode PGError
e forall a. Eq a => a -> a -> Bool
== String -> ByteString
BSC.pack String
"23505")
type PGException = PG.PGError
#if MIN_VERSION_network(2,7,0)
data PortID
= Service String
| PortNumber Word16
#if !defined(mingw32_HOST_OS)
| UnixSocket String
#endif
#endif
pgConnect :: String
-> PortID
-> ByteString
-> ByteString
-> ByteString
-> IO PG.PGConnection
pgConnect :: String
-> PortID
-> ByteString
-> ByteString
-> ByteString
-> IO PGConnection
pgConnect String
h PortID
n ByteString
d ByteString
u ByteString
p = do
Bool
debug <- forall a. Maybe a -> Bool
isJust forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` String -> IO (Maybe String)
lookupEnv String
"TPG_DEBUG"
PGDatabase -> IO PGConnection
PG.pgConnect forall a b. (a -> b) -> a -> b
$ PGDatabase
PG.defaultPGDatabase
{ pgDBAddr :: Either (String, String) SockAddr
PG.pgDBAddr = case PortID
n of
PortNumber Word16
s -> forall a b. a -> Either a b
Left (String
h, forall a. Show a => a -> String
show Word16
s)
Service String
s -> forall a b. a -> Either a b
Left (String
h, String
s)
#if !defined(mingw32_HOST_OS)
UnixSocket String
s -> forall a b. b -> Either a b
Right (String -> SockAddr
Net.SockAddrUnix String
s)
#endif
, pgDBName :: ByteString
PG.pgDBName = ByteString
d
, pgDBUser :: ByteString
PG.pgDBUser = ByteString
u
, pgDBPass :: ByteString
PG.pgDBPass = ByteString
p
, pgDBDebug :: Bool
PG.pgDBDebug = Bool
debug
}