module Database.PostgreSQL.Store.Errand (
ErrandError (..),
ErrorCode (..),
P.ExecStatus (..),
Errand,
runErrand,
execute,
query,
query_,
queryWith,
Result (..),
Single (..)
) where
import Control.Monad.Trans
import Control.Monad.Except
import Control.Monad.Reader
import Data.Maybe
import qualified Data.ByteString as B
import qualified Database.PostgreSQL.LibPQ as P
import Database.PostgreSQL.Store.Query
import Database.PostgreSQL.Store.Result
import Database.PostgreSQL.Store.Columns
data ErrandError
= NoResult
| EmptyResult
| UserError String
| ExecError P.ExecStatus ErrorCode B.ByteString B.ByteString B.ByteString
| ResultError ResultError
deriving (Show, Eq)
data ErrorCode
= UnknownErrorCause B.ByteString
| IntegrityViolation
| RestrictViolation
| NotNullViolation
| ForeignKeyViolation
| UniqueViolation
| CheckViolation
| ExclusionViolation
deriving (Show, Eq)
newtype Errand a = Errand (ReaderT P.Connection (ExceptT ErrandError IO) a)
deriving (Functor, Applicative, Monad, MonadIO, MonadError ErrandError)
runErrand :: P.Connection -> Errand a -> IO (Either ErrandError a)
runErrand con (Errand errand) =
runExceptT (runReaderT errand con)
execute :: Query -> Errand P.Result
execute (Query statement params) = Errand . ReaderT $ \ con -> do
res <- ExceptT $
transformResult <$> P.execParams con statement (map transformParam params) P.Text
status <- lift (P.resultStatus res)
case status of
P.CommandOk -> pure res
P.TuplesOk -> pure res
other -> do
(state, msg, detail, hint) <- lift $
(,,,) <$> P.resultErrorField res P.DiagSqlstate
<*> P.resultErrorField res P.DiagMessagePrimary
<*> P.resultErrorField res P.DiagMessageDetail
<*> P.resultErrorField res P.DiagMessageHint
let cause =
case fromMaybe B.empty state of
"23000" -> IntegrityViolation
"23001" -> RestrictViolation
"23502" -> NotNullViolation
"23503" -> ForeignKeyViolation
"23505" -> UniqueViolation
"23514" -> CheckViolation
"23P01" -> ExclusionViolation
code -> UnknownErrorCause code
throwError (ExecError other
cause
(fromMaybe B.empty msg)
(fromMaybe B.empty detail)
(fromMaybe B.empty hint))
where
transformResult = maybe (throwError NoResult) pure
transformParam (Value typ dat) = Just (typ, dat, P.Text)
transformParam NullValue = Nothing
class Result a where
queryResultProcessor :: ResultProcessor a
instance (Result a, Result b) => Result (a, b) where
queryResultProcessor =
(,) <$> queryResultProcessor <*> queryResultProcessor
instance (Result a, Result b, Result c) => Result (a, b, c) where
queryResultProcessor =
(,,) <$> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor
instance (Result a, Result b, Result c, Result d) => Result (a, b, c, d) where
queryResultProcessor =
(,,,) <$> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor
instance (Result a, Result b, Result c, Result d, Result e) => Result (a, b, c, d, e) where
queryResultProcessor =
(,,,,) <$> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor
instance (Result a, Result b, Result c, Result d, Result e, Result f) => Result (a, b, c, d, e, f) where
queryResultProcessor =
(,,,,,) <$> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor
instance (Result a, Result b, Result c, Result d, Result e, Result f, Result g) => Result (a, b, c, d, e, f, g) where
queryResultProcessor =
(,,,,,,) <$> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor
query :: (Result a) => Query -> Errand [a]
query qry =
queryWith qry queryResultProcessor
query_ :: Query -> Errand ()
query_ qry =
() <$ execute qry
queryWith :: Query -> ResultProcessor a -> Errand [a]
queryWith qry proc = do
result <- execute qry
Errand (lift (withExceptT ResultError (processResult result proc)))
newtype Single a = Single { fromSingle :: a }
deriving (Eq, Ord)
instance (Show a) => Show (Single a) where
show = show . fromSingle
instance (Column a) => Result (Single a) where
queryResultProcessor = Single <$> unpackColumn