module Hasql.Postgres
(
Postgres(..),
)
where
import Hasql.Postgres.Prelude
import qualified Database.PostgreSQL.LibPQ as PQ
import qualified Hasql.Backend as Backend
import qualified Hasql.Postgres.Connector as Connector
import qualified Hasql.Postgres.Statement as Statement
import qualified Hasql.Postgres.PTI as PTI
import qualified Hasql.Postgres.Mapping as Mapping
import qualified Hasql.Postgres.Session.Transaction as Transaction
import qualified Hasql.Postgres.Session.Execution as Execution
import qualified Language.Haskell.TH as TH
import qualified Data.Attoparsec.ByteString.Char8 as Atto
import qualified Data.Text.Encoding as Text
import qualified ListT
data Postgres =
Postgres {
host :: ByteString,
port :: Word16,
user :: Text,
password :: Text,
database :: Text
}
instance Backend.Backend Postgres where
data StatementArgument Postgres =
StatementArgument PQ.Oid (Mapping.Environment -> Maybe ByteString)
data Result Postgres =
Result Mapping.Environment (Maybe ByteString)
data Connection Postgres =
Connection {
connection :: !PQ.Connection,
executionEnv :: !Execution.Env,
transactionEnv :: !Transaction.Env,
mappingEnv :: !Mapping.Environment
}
connect p =
do
r <- Connector.open settings
c <- either (\e -> throwIO $ Backend.CantConnect $ fromString $ show e) return r
ee <- Execution.newEnv c
Connection <$> pure c <*> pure ee <*> Transaction.newEnv ee <*> getIntegerDatetimes c
where
settings =
Connector.Settings (host p) (port p) (user p) (password p) (database p)
getIntegerDatetimes c =
fmap parseResult $ PQ.parameterStatus c "integer_datetimes"
where
parseResult =
\case
Just "on" -> True
_ -> False
disconnect c =
PQ.finish (connection c)
execute s =
do s' <- liftStatement s
liftExecution $ Execution.unitResult =<< Execution.statement s'
executeAndGetMatrix s =
do s' <- liftStatement s
c <- id
(fmap . fmap . fmap . fmap) (Result (mappingEnv c)) $ liftExecution $
Execution.vectorResult =<< Execution.statement s'
executeAndStream s =
do s' <- liftStatement s
c <- id
return $ return $ liftTransactionStream (Transaction.streamWithCursor s') c
executeAndCountEffects s =
do s' <- liftStatement s
liftExecution $ Execution.countResult =<< Execution.statement s'
beginTransaction (isolation, write) =
liftTransaction $ Transaction.beginTransaction (mapIsolation isolation, write)
where
mapIsolation =
\case
Backend.Serializable -> Statement.Serializable
Backend.RepeatableReads -> Statement.RepeatableRead
Backend.ReadCommitted -> Statement.ReadCommitted
Backend.ReadUncommitted -> Statement.ReadCommitted
finishTransaction commit =
liftTransaction $ Transaction.finishTransaction commit
type M a =
Backend.Connection Postgres -> a
liftExecution :: Execution.M a -> M (IO a)
liftExecution m =
\c -> Execution.run (executionEnv c) m >>= either (throwIO . mapExecutionError) return
liftTransaction :: Transaction.M a -> M (IO a)
liftTransaction m =
\c -> Transaction.run (transactionEnv c) m >>= either (throwIO . mapError) return
where
mapError =
\case
Transaction.NotInTransaction -> Backend.NotInTransaction
Transaction.ExecutionError e -> mapExecutionError e
liftStatement :: Backend.Statement Postgres -> M Statement.Statement
liftStatement (template, arguments, preparable) c =
(,,) template (map liftArgument arguments) preparable
where
liftArgument (StatementArgument o f) =
(,) o ((,) <$> f (mappingEnv c) <*> pure PQ.Binary)
liftTransactionStream :: Transaction.Stream -> M (Backend.Stream Postgres)
liftTransactionStream s c =
(fmap . fmap) (Result (mappingEnv c)) $ hoist (flip liftTransaction c) s
mapExecutionError :: Execution.Error -> Backend.Error
mapExecutionError =
\case
Execution.UnexpectedResult m -> Backend.UnexpectedResult m
Execution.ErroneousResult m -> Backend.ErroneousResult m
Execution.UnparsableTemplate t m -> Backend.UnparsableTemplate $
"Message: " <> m <> "; " <>
"Template: " <> fromString (show t)
Execution.TransactionConflict -> Backend.TransactionConflict
renderValueUsingMapping :: Mapping.Mapping a => a -> Backend.StatementArgument Postgres
renderValueUsingMapping x =
StatementArgument
(PTI.oidPQ $ Mapping.oid x)
(flip Mapping.encode x)
parseResultUsingMapping :: Mapping.Mapping a => Backend.Result Postgres -> Either Text a
parseResultUsingMapping (Result e x) =
Mapping.decode e x
instance Mapping.Mapping a => Backend.Mapping Postgres (Maybe a) where
renderValue = renderValueUsingMapping
parseResult = parseResultUsingMapping
instance (Mapping.Mapping a, Mapping.ArrayMapping a) => Backend.Mapping Postgres [a] where
renderValue = renderValueUsingMapping
parseResult = parseResultUsingMapping
instance (Mapping.Mapping a, Mapping.ArrayMapping a) => Backend.Mapping Postgres (Vector a) where
renderValue = renderValueUsingMapping
parseResult = parseResultUsingMapping
instance Backend.Mapping Postgres Int where
renderValue = renderValueUsingMapping
parseResult = parseResultUsingMapping
instance Backend.Mapping Postgres Int8 where
renderValue = renderValueUsingMapping
parseResult = parseResultUsingMapping
instance Backend.Mapping Postgres Int16 where
renderValue = renderValueUsingMapping
parseResult = parseResultUsingMapping
instance Backend.Mapping Postgres Int32 where
renderValue = renderValueUsingMapping
parseResult = parseResultUsingMapping
instance Backend.Mapping Postgres Int64 where
renderValue = renderValueUsingMapping
parseResult = parseResultUsingMapping
instance Backend.Mapping Postgres Word where
renderValue = renderValueUsingMapping
parseResult = parseResultUsingMapping
instance Backend.Mapping Postgres Word8 where
renderValue = renderValueUsingMapping
parseResult = parseResultUsingMapping
instance Backend.Mapping Postgres Word16 where
renderValue = renderValueUsingMapping
parseResult = parseResultUsingMapping
instance Backend.Mapping Postgres Word32 where
renderValue = renderValueUsingMapping
parseResult = parseResultUsingMapping
instance Backend.Mapping Postgres Word64 where
renderValue = renderValueUsingMapping
parseResult = parseResultUsingMapping
instance Backend.Mapping Postgres Float where
renderValue = renderValueUsingMapping
parseResult = parseResultUsingMapping
instance Backend.Mapping Postgres Double where
renderValue = renderValueUsingMapping
parseResult = parseResultUsingMapping
instance Backend.Mapping Postgres Scientific where
renderValue = renderValueUsingMapping
parseResult = parseResultUsingMapping
instance Backend.Mapping Postgres Day where
renderValue = renderValueUsingMapping
parseResult = parseResultUsingMapping
instance Backend.Mapping Postgres TimeOfDay where
renderValue = renderValueUsingMapping
parseResult = parseResultUsingMapping
instance Backend.Mapping Postgres (TimeOfDay, TimeZone) where
renderValue = renderValueUsingMapping
parseResult = parseResultUsingMapping
instance Backend.Mapping Postgres LocalTime where
renderValue = renderValueUsingMapping
parseResult = parseResultUsingMapping
instance Backend.Mapping Postgres UTCTime where
renderValue = renderValueUsingMapping
parseResult = parseResultUsingMapping
instance Backend.Mapping Postgres DiffTime where
renderValue = renderValueUsingMapping
parseResult = parseResultUsingMapping
instance Backend.Mapping Postgres Char where
renderValue = renderValueUsingMapping
parseResult = parseResultUsingMapping
instance Backend.Mapping Postgres Text where
renderValue = renderValueUsingMapping
parseResult = parseResultUsingMapping
instance Backend.Mapping Postgres LazyText where
renderValue = renderValueUsingMapping
parseResult = parseResultUsingMapping
instance Backend.Mapping Postgres ByteString where
renderValue = renderValueUsingMapping
parseResult = parseResultUsingMapping
instance Backend.Mapping Postgres LazyByteString where
renderValue = renderValueUsingMapping
parseResult = parseResultUsingMapping
instance Backend.Mapping Postgres Bool where
renderValue = renderValueUsingMapping
parseResult = parseResultUsingMapping
instance Backend.Mapping Postgres UUID where
renderValue = renderValueUsingMapping
parseResult = parseResultUsingMapping