module Main.DB
(
module LibPQ,
session,
oneRow,
unit,
integerDatetimes,
)
where
import Main.Prelude
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Either
import Control.Monad.IO.Class
import Database.PostgreSQL.LibPQ as LibPQ
import qualified Data.ByteString as ByteString; import Data.ByteString (ByteString)
type Session =
EitherT ByteString (ReaderT Connection IO)
session :: Session a -> IO (Either ByteString a)
session m =
do
c <- connect
initConnection c
r <- runReaderT (runEitherT m) c
finish c
return r
oneRow :: ByteString -> [Maybe (Oid, ByteString, Format)] -> Format -> Session ByteString
oneRow statement params outFormat =
do
Just result <- result statement params outFormat
Just result <- liftIO $ getvalue result 0 0
return result
unit :: ByteString -> [Maybe (Oid, ByteString, Format)] -> Session ()
unit statement params =
void $ result statement params Binary
result :: ByteString -> [Maybe (Oid, ByteString, Format)] -> Format -> Session (Maybe Result)
result statement params outFormat =
do
result <- EitherT $ ReaderT $ \connection -> fmap Right $ execParams connection statement params outFormat
checkResult result
return result
checkResult :: Maybe Result -> Session ()
checkResult result =
EitherT $ ReaderT $ \connection -> do
case result of
Just result -> do
resultErrorField result DiagMessagePrimary >>= maybe (return (Right ())) (return . Left)
Nothing -> do
m <- errorMessage connection
return $ Left $ maybe "Fatal PQ error" (\m -> "Fatal PQ error: " <> m) m
integerDatetimes :: Session Bool
integerDatetimes =
lift (ReaderT getIntegerDatetimes)
-- *
-------------------------
connect :: IO Connection
connect =
connectdb bs
where
bs =
ByteString.intercalate " " components
where
components =
[
"host=" <> host,
"port=" <> (fromString . show) port,
"user=" <> user,
"password=" <> password,
"dbname=" <> db
]
where
host = "localhost"
port = 5432
user = "postgres"
password = ""
db = "postgres"
initConnection :: Connection -> IO ()
initConnection c =
void $ exec c $ mconcat $ map (<> ";") $
[
"SET client_min_messages TO WARNING",
"SET client_encoding = 'UTF8'",
"SET intervalstyle = 'postgres'"
]
getIntegerDatetimes :: Connection -> IO Bool
getIntegerDatetimes c =
fmap parseResult $ parameterStatus c "integer_datetimes"
where
parseResult =
\case
Just "on" -> True
_ -> False