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.ResultParser as ResultParser
import qualified Hasql.Postgres.ResultHandler as ResultHandler
import qualified Hasql.Postgres.Statement as Statement
import qualified Hasql.Postgres.StatementPreparer as StatementPreparer
import qualified Hasql.Postgres.TemplateConverter as TemplateConverter
import qualified Hasql.Postgres.PTI as PTI
import qualified Hasql.Postgres.Mapping as Mapping
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,
preparer :: !StatementPreparer.StatementPreparer,
transactionState :: !(IORef (Maybe Word)),
environment :: Mapping.Environment
}
connect p =
do
r <- runExceptT $ Connector.open settings
c <- either (\e -> throwIO $ Backend.CantConnect $ fromString $ show e) return r
Connection <$> pure c <*> StatementPreparer.new c <*> newIORef Nothing <*> 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 c =
ResultHandler.unit =<< execute (liftStatement c s) c
executeAndGetMatrix s c =
execute (liftStatement c s) c >>=
(fmap . fmap . fmap) (Result (environment c)) . ResultHandler.rowsVector
executeAndStream s c =
do
name <- declareCursor
return $
let loop = do
chunk <- lift $ fetchFromCursor name
null <- lift $ ListT.null chunk
guard $ not null
(fmap . fmap) packResult chunk <> loop
in loop
where
packResult =
Result (environment c)
nextName =
do
counterM <- readIORef (transactionState c)
counter <- maybe (throwIO Backend.NotInTransaction) return counterM
writeIORef (transactionState c) (Just (succ counter))
return $ fromString $ 'v' : show counter
declareCursor =
do
name <- nextName
ResultHandler.unit =<< execute (Statement.declareCursor name (liftStatement c s)) c
return name
fetchFromCursor name =
ResultHandler.rowsStream =<< execute (Statement.fetchFromCursor name) c
closeCursor name =
ResultHandler.unit =<< execute (Statement.closeCursor name) c
executeAndCountEffects s c =
do
b <- ResultHandler.rowsAffected =<< execute (liftStatement c s) c
case Atto.parseOnly (Atto.decimal <* Atto.endOfInput) b of
Left m ->
throwIO $ Backend.UnexpectedResult (fromString m)
Right r ->
return r
beginTransaction (isolation, write) c =
do
writeIORef (transactionState c) (Just 0)
ResultHandler.unit =<< execute (Statement.beginTransaction (statementIsolation, write)) c
where
statementIsolation =
case isolation of
Backend.Serializable -> Statement.Serializable
Backend.RepeatableReads -> Statement.RepeatableRead
Backend.ReadCommitted -> Statement.ReadCommitted
Backend.ReadUncommitted -> Statement.ReadCommitted
finishTransaction commit c =
do
ResultHandler.unit =<< execute (bool Statement.abortTransaction Statement.commitTransaction commit) c
writeIORef (transactionState c) Nothing
liftStatement :: Backend.Connection Postgres -> Backend.Statement Postgres -> Statement.Statement
liftStatement c (template, arguments) =
(,,) template (map liftArgument arguments) True
where
liftArgument (StatementArgument o f) =
(,) o ((,) <$> f (environment c) <*> pure PQ.Binary)
execute :: Statement.Statement -> Backend.Connection Postgres -> IO ResultParser.Result
execute s c =
ResultParser.parse (connection c) =<< do
let (template, params, preparable) = s
convertedTemplate <- convertTemplate template
case preparable of
True -> do
let (tl, vl) = unzip params
key <- StatementPreparer.prepare convertedTemplate tl (preparer c)
PQ.execPrepared (connection c) key vl PQ.Binary
False -> do
let params' = map (\(t, v) -> (\(vb, vf) -> (t, vb, vf)) <$> v) params
PQ.execParams (connection c) convertedTemplate params' PQ.Binary
convertTemplate :: ByteString -> IO ByteString
convertTemplate t =
case TemplateConverter.convert t of
Left m ->
throwIO $ Backend.UnparsableTemplate $
"Template: " <> Text.decodeLatin1 t <> ". " <>
"Error: " <> m <> "."
Right r ->
return r
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