{-# LANGUAGE
BangPatterns
, DeriveGeneric
, ExistentialQuantification
, FlexibleContexts
, InstanceSigs
, LambdaCase
, OverloadedStrings
, TypeFamilies
, ViewPatterns
#-}
module Gingersnap.Core (
rspGood
, rspBad
, rspBadCommit
, rspBadRollback
, rspGoodCSV
, rspGoodLBS
, rspEmptyGood
, Rsp(..)
, pureRsp
, inTransaction
, inTransactionMode
, inTransaction_readOnly
, inTransaction_override
, rspIsGood
, IsCtx(..)
, reqObject
, reqObject'
, (.!)
, (.!?)
, ReqObject(..)
, errorEarlyCode
, ApiErr(..)
, ErrResult(..)
, DefaultApiErr(..)
, ctxErr
, RspPayload(..)
, ShouldCommitOrRollback(..)
, Pool
, createPool
, Connection
) where
import Control.DeepSeq
import qualified Control.Exception as E
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Data.Aeson (FromJSON, fromJSON, ToJSON(..), (.=))
import qualified Data.Aeson as JSON
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BSL
import qualified Data.HashMap.Strict as HM
import Data.Pool (Pool, createPool)
import qualified Data.Pool as Pool
import Data.Text (Text)
import qualified Data.Text as T
import Data.Word
import Database.PostgreSQL.Simple (Connection)
import qualified Database.PostgreSQL.Simple as PSQL
import qualified Database.PostgreSQL.Simple.Transaction as PSQL
import GHC.Generics (Generic)
import qualified Network.HTTP.Types.Status as HTTP
import Snap.Core (Snap)
import qualified Snap.Core as Snap
class ApiErr (CtxErrType ctx) => IsCtx ctx where
ctxConnectionPool :: ctx -> Pool Connection
ctxGetReadOnlyMode :: ctx -> IO Bool
ctxGetReadOnlyMode ctx
_ = Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
ctx_wrapSuccess :: ToJSON x => ctx -> x -> JSON.Value
ctx_wrapSuccess ctx
_ x
x = [Pair] -> Value
JSON.object [Text
"result" Text -> x -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= x
x]
type CtxErrType ctx
type instance CtxErrType ctx = DefaultApiErr
ctxErr :: IsCtx ctx => ctx -> (CtxErrType ctx) -> (CtxErrType ctx)
ctxErr :: ctx -> CtxErrType ctx -> CtxErrType ctx
ctxErr ctx
_ CtxErrType ctx
x = CtxErrType ctx
x
class ApiErr apiErr where
errResult :: apiErr -> ErrResult
apiErr_missingRequestKey :: Text -> apiErr
apiErr_requestNotJSON :: apiErr
apiErr_requestNotJSONObject :: apiErr
apiErr_malformedRequestValue :: Text -> JSON.Value -> apiErr
apiErr_unexpectedError :: Text -> apiErr
apiErr_inReadOnlyMode :: apiErr
data ErrResult
= ErrResult HTTP.Status JSON.Value
deriving (Int -> ErrResult -> ShowS
[ErrResult] -> ShowS
ErrResult -> String
(Int -> ErrResult -> ShowS)
-> (ErrResult -> String)
-> ([ErrResult] -> ShowS)
-> Show ErrResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrResult] -> ShowS
$cshowList :: [ErrResult] -> ShowS
show :: ErrResult -> String
$cshow :: ErrResult -> String
showsPrec :: Int -> ErrResult -> ShowS
$cshowsPrec :: Int -> ErrResult -> ShowS
Show, ErrResult -> ErrResult -> Bool
(ErrResult -> ErrResult -> Bool)
-> (ErrResult -> ErrResult -> Bool) -> Eq ErrResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrResult -> ErrResult -> Bool
$c/= :: ErrResult -> ErrResult -> Bool
== :: ErrResult -> ErrResult -> Bool
$c== :: ErrResult -> ErrResult -> Bool
Eq)
instance NFData ErrResult where
rnf :: ErrResult -> ()
rnf (ErrResult (HTTP.Status Int
code ByteString
msg) Value
v) =
Int -> ()
forall a. NFData a => a -> ()
rnf Int
code () -> () -> ()
`seq` ByteString -> ()
forall a. NFData a => a -> ()
rnf ByteString
msg () -> () -> ()
`seq` Value -> ()
forall a. NFData a => a -> ()
rnf Value
v
data DefaultApiErr
= DefaultApiErr_ReadOnlyMode
| DefaultApiErr_MissingRequestKey Text
| DefaultApiErr_RequestNotJSON
| DefaultApiErr_RequestNotJSONObject
| DefaultApiErr_MalformedRequestValue Text JSON.Value
| DefaultApiErr_UnexpectedError Text
| DefaultApiErr_Custom HTTP.Status String [(Text, JSON.Value)]
deriving (Int -> DefaultApiErr -> ShowS
[DefaultApiErr] -> ShowS
DefaultApiErr -> String
(Int -> DefaultApiErr -> ShowS)
-> (DefaultApiErr -> String)
-> ([DefaultApiErr] -> ShowS)
-> Show DefaultApiErr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DefaultApiErr] -> ShowS
$cshowList :: [DefaultApiErr] -> ShowS
show :: DefaultApiErr -> String
$cshow :: DefaultApiErr -> String
showsPrec :: Int -> DefaultApiErr -> ShowS
$cshowsPrec :: Int -> DefaultApiErr -> ShowS
Show, DefaultApiErr -> DefaultApiErr -> Bool
(DefaultApiErr -> DefaultApiErr -> Bool)
-> (DefaultApiErr -> DefaultApiErr -> Bool) -> Eq DefaultApiErr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DefaultApiErr -> DefaultApiErr -> Bool
$c/= :: DefaultApiErr -> DefaultApiErr -> Bool
== :: DefaultApiErr -> DefaultApiErr -> Bool
$c== :: DefaultApiErr -> DefaultApiErr -> Bool
Eq)
instance ApiErr DefaultApiErr where
apiErr_inReadOnlyMode :: DefaultApiErr
apiErr_inReadOnlyMode =
DefaultApiErr
DefaultApiErr_ReadOnlyMode
apiErr_missingRequestKey :: Text -> DefaultApiErr
apiErr_missingRequestKey =
Text -> DefaultApiErr
DefaultApiErr_MissingRequestKey
apiErr_requestNotJSON :: DefaultApiErr
apiErr_requestNotJSON =
DefaultApiErr
DefaultApiErr_RequestNotJSON
apiErr_requestNotJSONObject :: DefaultApiErr
apiErr_requestNotJSONObject =
DefaultApiErr
DefaultApiErr_RequestNotJSONObject
apiErr_malformedRequestValue :: Text -> Value -> DefaultApiErr
apiErr_malformedRequestValue =
Text -> Value -> DefaultApiErr
DefaultApiErr_MalformedRequestValue
apiErr_unexpectedError :: Text -> DefaultApiErr
apiErr_unexpectedError =
Text -> DefaultApiErr
DefaultApiErr_UnexpectedError
errResult :: DefaultApiErr -> ErrResult
errResult :: DefaultApiErr -> ErrResult
errResult = DefaultApiErr -> ErrResult
defaultApiErrResult
defaultApiErrResult :: DefaultApiErr -> ErrResult
defaultApiErrResult :: DefaultApiErr -> ErrResult
defaultApiErrResult DefaultApiErr
err =
Status -> Value -> ErrResult
ErrResult Status
status (Value -> ErrResult) -> Value -> ErrResult
forall a b. (a -> b) -> a -> b
$
[Pair] -> Value
JSON.object [
Text
"errorCode" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Int
code :: Int)
, Text
"errorMessage" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String
msg
, Text
"errorVals" Text -> [Pair] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ([Pair]
vals :: [(Text, JSON.Value)])
]
where
(Int
code, Status
status, String
msg, [Pair]
vals) = case DefaultApiErr
err of
DefaultApiErr
DefaultApiErr_ReadOnlyMode ->
(Int
0, Status
HTTP.serviceUnavailable503, String
"This action is unavailable in read-only mode", [])
DefaultApiErr_UnexpectedError Text
t ->
(Int
1, Status
HTTP.internalServerError500, String
"An unexpected error occurred", [
Text
"text" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
t
])
DefaultApiErr_MissingRequestKey Text
k ->
(Int
2, Status
HTTP.unprocessableEntity422, String
"Required key not present: "String -> ShowS
forall a. [a] -> [a] -> [a]
++Text -> String
forall a. Show a => a -> String
show Text
k, [
Text
"key" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
k
])
DefaultApiErr
DefaultApiErr_RequestNotJSON ->
(Int
3, Status
HTTP.unprocessableEntity422, String
"Non-JSON message body", [])
DefaultApiErr
DefaultApiErr_RequestNotJSONObject ->
(Int
4, Status
HTTP.unprocessableEntity422, String
"Message body is not a JSON object", [])
DefaultApiErr_MalformedRequestValue Text
k Value
v ->
(Int
5, Status
HTTP.unprocessableEntity422, String
"Malformed value: "String -> ShowS
forall a. [a] -> [a] -> [a]
++Text -> String
forall a. Show a => a -> String
show Text
k, [
Text
"key" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
k, Text
"value" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Value
v
])
DefaultApiErr_Custom Status
s String
t [Pair]
vs ->
(Int
6, Status
s, String
t, [Pair]
vs)
data Rsp
= Rsp {
Rsp -> ShouldCommitOrRollback
rspShouldCommit :: ShouldCommitOrRollback
, Rsp -> RspPayload
rspPayload :: RspPayload
}
deriving ((forall x. Rsp -> Rep Rsp x)
-> (forall x. Rep Rsp x -> Rsp) -> Generic Rsp
forall x. Rep Rsp x -> Rsp
forall x. Rsp -> Rep Rsp x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Rsp x -> Rsp
$cfrom :: forall x. Rsp -> Rep Rsp x
Generic)
instance NFData Rsp
data RspPayload
= forall x. ToJSON x => RspPayload_Good x
| forall e. ApiErr e => RspPayload_Bad e
| RspPayload_Custom HTTP.Status BS.ByteString BSL.ByteString
| RspPayload_Empty
instance NFData RspPayload where
rnf :: RspPayload -> ()
rnf = \case
RspPayload
RspPayload_Empty -> ()
RspPayload_Good x
x -> (Value -> RspPayload
forall x. ToJSON x => x -> RspPayload
RspPayload_Good (Value -> RspPayload) -> Value -> RspPayload
forall a b. NFData a => (a -> b) -> a -> b
$!! (Value -> Value
forall a. NFData a => a -> a
force (Value -> Value) -> Value -> Value
forall a b. (a -> b) -> a -> b
$ x -> Value
forall a. ToJSON a => a -> Value
toJSON x
x)) RspPayload -> () -> ()
`seq` ()
RspPayload_Bad e
e -> ErrResult -> ()
forall a. NFData a => a -> ()
rnf (ErrResult -> ()) -> ErrResult -> ()
forall a b. (a -> b) -> a -> b
$ e -> ErrResult
forall apiErr. ApiErr apiErr => apiErr -> ErrResult
errResult e
e
RspPayload_Custom (HTTP.Status Int
a ByteString
b) ByteString
c ByteString
d ->
Int -> ()
forall a. NFData a => a -> ()
rnf Int
a () -> () -> ()
`seq` ByteString -> ()
forall a. NFData a => a -> ()
rnf ByteString
b () -> () -> ()
`seq` ByteString -> ()
forall a. NFData a => a -> ()
rnf ByteString
c () -> () -> ()
`seq` ByteString -> ()
forall a. NFData a => a -> ()
rnf ByteString
d
data ShouldCommitOrRollback
= ShouldCommit
| ShouldRollback
deriving (Int -> ShouldCommitOrRollback -> ShowS
[ShouldCommitOrRollback] -> ShowS
ShouldCommitOrRollback -> String
(Int -> ShouldCommitOrRollback -> ShowS)
-> (ShouldCommitOrRollback -> String)
-> ([ShouldCommitOrRollback] -> ShowS)
-> Show ShouldCommitOrRollback
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShouldCommitOrRollback] -> ShowS
$cshowList :: [ShouldCommitOrRollback] -> ShowS
show :: ShouldCommitOrRollback -> String
$cshow :: ShouldCommitOrRollback -> String
showsPrec :: Int -> ShouldCommitOrRollback -> ShowS
$cshowsPrec :: Int -> ShouldCommitOrRollback -> ShowS
Show, ShouldCommitOrRollback -> ShouldCommitOrRollback -> Bool
(ShouldCommitOrRollback -> ShouldCommitOrRollback -> Bool)
-> (ShouldCommitOrRollback -> ShouldCommitOrRollback -> Bool)
-> Eq ShouldCommitOrRollback
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ShouldCommitOrRollback -> ShouldCommitOrRollback -> Bool
$c/= :: ShouldCommitOrRollback -> ShouldCommitOrRollback -> Bool
== :: ShouldCommitOrRollback -> ShouldCommitOrRollback -> Bool
$c== :: ShouldCommitOrRollback -> ShouldCommitOrRollback -> Bool
Eq, (forall x. ShouldCommitOrRollback -> Rep ShouldCommitOrRollback x)
-> (forall x.
Rep ShouldCommitOrRollback x -> ShouldCommitOrRollback)
-> Generic ShouldCommitOrRollback
forall x. Rep ShouldCommitOrRollback x -> ShouldCommitOrRollback
forall x. ShouldCommitOrRollback -> Rep ShouldCommitOrRollback x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ShouldCommitOrRollback x -> ShouldCommitOrRollback
$cfrom :: forall x. ShouldCommitOrRollback -> Rep ShouldCommitOrRollback x
Generic)
instance NFData ShouldCommitOrRollback
rspGood :: ToJSON x => x -> Rsp
rspGood :: x -> Rsp
rspGood x
x = ShouldCommitOrRollback -> RspPayload -> Rsp
Rsp ShouldCommitOrRollback
ShouldCommit (RspPayload -> Rsp) -> RspPayload -> Rsp
forall a b. (a -> b) -> a -> b
$ x -> RspPayload
forall x. ToJSON x => x -> RspPayload
RspPayload_Good x
x
rspBad, rspBadCommit, rspBadRollback :: ApiErr ae => ae -> Rsp
rspBad :: ae -> Rsp
rspBad ae
e = ShouldCommitOrRollback -> RspPayload -> Rsp
Rsp ShouldCommitOrRollback
ShouldRollback (RspPayload -> Rsp) -> RspPayload -> Rsp
forall a b. (a -> b) -> a -> b
$ ae -> RspPayload
forall e. ApiErr e => e -> RspPayload
RspPayload_Bad ae
e
rspBadCommit :: ae -> Rsp
rspBadCommit ae
e = ShouldCommitOrRollback -> RspPayload -> Rsp
Rsp ShouldCommitOrRollback
ShouldCommit (RspPayload -> Rsp) -> RspPayload -> Rsp
forall a b. (a -> b) -> a -> b
$ ae -> RspPayload
forall e. ApiErr e => e -> RspPayload
RspPayload_Bad ae
e
rspBadRollback :: ae -> Rsp
rspBadRollback ae
e = ShouldCommitOrRollback -> RspPayload -> Rsp
Rsp ShouldCommitOrRollback
ShouldRollback (RspPayload -> Rsp) -> RspPayload -> Rsp
forall a b. (a -> b) -> a -> b
$ ae -> RspPayload
forall e. ApiErr e => e -> RspPayload
RspPayload_Bad ae
e
rspGoodCSV :: BSL.ByteString -> Rsp
rspGoodCSV :: ByteString -> Rsp
rspGoodCSV ByteString
bs = ShouldCommitOrRollback -> RspPayload -> Rsp
Rsp ShouldCommitOrRollback
ShouldCommit (RspPayload -> Rsp) -> RspPayload -> Rsp
forall a b. (a -> b) -> a -> b
$ Status -> ByteString -> ByteString -> RspPayload
RspPayload_Custom Status
HTTP.ok200 (String -> ByteString
BS8.pack String
"text/csv") ByteString
bs
rspGoodLBS :: BS.ByteString -> BSL.ByteString -> Rsp
rspGoodLBS :: ByteString -> ByteString -> Rsp
rspGoodLBS ByteString
mimeType ByteString
bs = ShouldCommitOrRollback -> RspPayload -> Rsp
Rsp ShouldCommitOrRollback
ShouldCommit (RspPayload -> Rsp) -> RspPayload -> Rsp
forall a b. (a -> b) -> a -> b
$ Status -> ByteString -> ByteString -> RspPayload
RspPayload_Custom Status
HTTP.ok200 ByteString
mimeType ByteString
bs
rspEmptyGood :: Rsp
rspEmptyGood :: Rsp
rspEmptyGood = ShouldCommitOrRollback -> RspPayload -> Rsp
Rsp ShouldCommitOrRollback
ShouldCommit RspPayload
RspPayload_Empty
rspIsGood :: Rsp -> Bool
rspIsGood :: Rsp -> Bool
rspIsGood (Rsp ShouldCommitOrRollback
_ RspPayload
payload) = case RspPayload
payload of
RspPayload_Good {} -> Bool
True
RspPayload_Bad {} -> Bool
False
RspPayload_Custom Status
httpStatus ByteString
_ ByteString
_ ->
Status
httpStatus Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
HTTP.ok200
RspPayload
RspPayload_Empty -> Bool
True
instance Show Rsp where
show :: Rsp -> String
show (Rsp ShouldCommitOrRollback
commit RspPayload
payload) =
String
"Rsp "String -> ShowS
forall a. [a] -> [a] -> [a]
++ShouldCommitOrRollback -> String
forall a. Show a => a -> String
show ShouldCommitOrRollback
commitString -> ShowS
forall a. [a] -> [a] -> [a]
++String
" "String -> ShowS
forall a. [a] -> [a] -> [a]
++case RspPayload
payload of
RspPayload_Good x
x -> String
"(Good "String -> ShowS
forall a. [a] -> [a] -> [a]
++ByteString -> String
forall a. Show a => a -> String
show (x -> ByteString
forall a. ToJSON a => a -> ByteString
JSON.encode x
x)String -> ShowS
forall a. [a] -> [a] -> [a]
++String
")"
RspPayload_Bad (e -> ErrResult
forall apiErr. ApiErr apiErr => apiErr -> ErrResult
errResult -> ErrResult
e) -> String
"(Bad "String -> ShowS
forall a. [a] -> [a] -> [a]
++ErrResult -> String
forall a. Show a => a -> String
show ErrResult
eString -> ShowS
forall a. [a] -> [a] -> [a]
++String
")"
RspPayload
RspPayload_Empty -> String
"Empty"
RspPayload_Custom Status
a ByteString
b ByteString
c -> String
"(Custom "String -> ShowS
forall a. [a] -> [a] -> [a]
++(Status, ByteString, ByteString) -> String
forall a. Show a => a -> String
show (Status
a,ByteString
b,ByteString
c)String -> ShowS
forall a. [a] -> [a] -> [a]
++String
")"
inTransaction :: IsCtx ctx => ctx -> (Connection -> IO Rsp) -> Snap ()
inTransaction :: ctx -> (Connection -> IO Rsp) -> Snap ()
inTransaction ctx
ctx Connection -> IO Rsp
actionThatReturnsAnRsp = do
ctx
-> IsolationLevel
-> ReadWriteMode
-> (Connection -> IO Rsp)
-> Snap ()
forall ctx.
IsCtx ctx =>
ctx
-> IsolationLevel
-> ReadWriteMode
-> (Connection -> IO Rsp)
-> Snap ()
inTransactionMode ctx
ctx IsolationLevel
PSQL.Serializable ReadWriteMode
PSQL.ReadWrite Connection -> IO Rsp
actionThatReturnsAnRsp
inTransaction_readOnly :: IsCtx ctx => ctx -> (Connection -> IO Rsp) -> Snap ()
inTransaction_readOnly :: ctx -> (Connection -> IO Rsp) -> Snap ()
inTransaction_readOnly ctx
ctx Connection -> IO Rsp
f =
ctx
-> IsolationLevel
-> ReadWriteMode
-> (Connection -> IO Rsp)
-> Snap ()
forall ctx.
IsCtx ctx =>
ctx
-> IsolationLevel
-> ReadWriteMode
-> (Connection -> IO Rsp)
-> Snap ()
inTransactionMode ctx
ctx IsolationLevel
PSQL.Serializable ReadWriteMode
PSQL.ReadOnly Connection -> IO Rsp
f
inTransaction_override :: IsCtx ctx => ctx -> (Connection -> IO Rsp) -> Snap ()
inTransaction_override :: ctx -> (Connection -> IO Rsp) -> Snap ()
inTransaction_override ctx
ctx Connection -> IO Rsp
action =
ctx
-> IsolationLevel
-> ReadWriteMode
-> (Connection -> IO Rsp)
-> Snap ()
forall ctx.
IsCtx ctx =>
ctx
-> IsolationLevel
-> ReadWriteMode
-> (Connection -> IO Rsp)
-> Snap ()
inTransaction_internal ctx
ctx IsolationLevel
PSQL.Serializable ReadWriteMode
PSQL.ReadWrite Connection -> IO Rsp
action
inTransactionMode :: IsCtx ctx => ctx -> PSQL.IsolationLevel -> PSQL.ReadWriteMode -> (Connection -> IO Rsp) -> Snap ()
inTransactionMode :: ctx
-> IsolationLevel
-> ReadWriteMode
-> (Connection -> IO Rsp)
-> Snap ()
inTransactionMode ctx
ctx IsolationLevel
isolationLevel' ReadWriteMode
readWriteMode' Connection -> IO Rsp
actionThatReturnsAResponse = do
Bool
readOnlyMode <- IO Bool -> Snap Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Snap Bool) -> IO Bool -> Snap Bool
forall a b. (a -> b) -> a -> b
$ ctx -> IO Bool
forall ctx. IsCtx ctx => ctx -> IO Bool
ctxGetReadOnlyMode ctx
ctx
Bool -> Snap () -> Snap ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
readOnlyMode Bool -> Bool -> Bool
&& (ReadWriteMode
readWriteMode' ReadWriteMode -> ReadWriteMode -> Bool
forall a. Eq a => a -> a -> Bool
/= ReadWriteMode
PSQL.ReadOnly)) (Snap () -> Snap ()) -> Snap () -> Snap ()
forall a b. (a -> b) -> a -> b
$
CtxErrType ctx -> Snap ()
forall ae x. ApiErr ae => ae -> Snap x
errorEarlyCode (CtxErrType ctx -> Snap ()) -> CtxErrType ctx -> Snap ()
forall a b. (a -> b) -> a -> b
$ ctx -> CtxErrType ctx -> CtxErrType ctx
forall ctx. IsCtx ctx => ctx -> CtxErrType ctx -> CtxErrType ctx
ctxErr ctx
ctx CtxErrType ctx
forall apiErr. ApiErr apiErr => apiErr
apiErr_inReadOnlyMode
ctx
-> IsolationLevel
-> ReadWriteMode
-> (Connection -> IO Rsp)
-> Snap ()
forall ctx.
IsCtx ctx =>
ctx
-> IsolationLevel
-> ReadWriteMode
-> (Connection -> IO Rsp)
-> Snap ()
inTransaction_internal ctx
ctx IsolationLevel
isolationLevel' ReadWriteMode
readWriteMode' Connection -> IO Rsp
actionThatReturnsAResponse
inTransaction_internal :: IsCtx ctx => ctx -> PSQL.IsolationLevel -> PSQL.ReadWriteMode -> (Connection -> IO Rsp) -> Snap ()
inTransaction_internal :: ctx
-> IsolationLevel
-> ReadWriteMode
-> (Connection -> IO Rsp)
-> Snap ()
inTransaction_internal ctx
ctx IsolationLevel
isolationLevel' ReadWriteMode
readWriteMode' Connection -> IO Rsp
actionThatReturnsAResponse = do
let transactMode :: TransactionMode
transactMode = IsolationLevel -> ReadWriteMode -> TransactionMode
PSQL.TransactionMode IsolationLevel
isolationLevel' ReadWriteMode
readWriteMode'
Rsp
rsp <- IO Rsp -> Snap Rsp
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Rsp -> Snap Rsp) -> IO Rsp -> Snap Rsp
forall a b. (a -> b) -> a -> b
$
(Pool Connection -> (Connection -> IO Rsp) -> IO Rsp
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
Pool a -> (a -> m b) -> m b
Pool.withResource (ctx -> Pool Connection
forall ctx. IsCtx ctx => ctx -> Pool Connection
ctxConnectionPool ctx
ctx) ((Connection -> IO Rsp) -> IO Rsp)
-> (Connection -> IO Rsp) -> IO Rsp
forall a b. (a -> b) -> a -> b
$ \Connection
conn ->
((forall a. IO a -> IO a) -> IO Rsp) -> IO Rsp
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
E.mask (((forall a. IO a -> IO a) -> IO Rsp) -> IO Rsp)
-> ((forall a. IO a -> IO a) -> IO Rsp) -> IO Rsp
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
TransactionMode -> Connection -> IO ()
PSQL.beginMode TransactionMode
transactMode Connection
conn
!Rsp
r <- IO Rsp -> IO Rsp
forall a. IO a -> IO a
restore (Rsp -> Rsp
forall a. NFData a => a -> a
force (Rsp -> Rsp) -> IO Rsp -> IO Rsp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO Rsp
actionThatReturnsAResponse Connection
conn)
IO Rsp -> IO () -> IO Rsp
forall a b. IO a -> IO b -> IO a
`E.onException` Connection -> IO ()
rollback_ Connection
conn
(case Rsp -> ShouldCommitOrRollback
rspShouldCommit Rsp
r of
ShouldCommitOrRollback
ShouldCommit -> Connection -> IO ()
PSQL.commit Connection
conn
ShouldCommitOrRollback
ShouldRollback -> Connection -> IO ()
rollback_ Connection
conn
) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`E.onException` Connection -> IO ()
rollback_ Connection
conn
Rsp -> IO Rsp
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rsp
r)
IO Rsp -> (SomeException -> IO Rsp) -> IO Rsp
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` (\e :: SomeException
e@(E.SomeException {}) -> Rsp -> IO Rsp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rsp -> IO Rsp) -> Rsp -> IO Rsp
forall a b. (a -> b) -> a -> b
$ CtxErrType ctx -> Rsp
forall ae. ApiErr ae => ae -> Rsp
rspBad (CtxErrType ctx -> Rsp) -> CtxErrType ctx -> Rsp
forall a b. (a -> b) -> a -> b
$
ctx -> CtxErrType ctx -> CtxErrType ctx
forall ctx. IsCtx ctx => ctx -> CtxErrType ctx -> CtxErrType ctx
ctxErr ctx
ctx (CtxErrType ctx -> CtxErrType ctx)
-> CtxErrType ctx -> CtxErrType ctx
forall a b. (a -> b) -> a -> b
$ Text -> CtxErrType ctx
forall apiErr. ApiErr apiErr => Text -> apiErr
apiErr_unexpectedError (Text -> CtxErrType ctx) -> Text -> CtxErrType ctx
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
ctx -> Rsp -> Snap ()
forall ctx. IsCtx ctx => ctx -> Rsp -> Snap ()
pureRsp ctx
ctx Rsp
rsp
pureRsp :: IsCtx ctx => ctx -> Rsp -> Snap ()
pureRsp :: ctx -> Rsp -> Snap ()
pureRsp ctx
ctx (Rsp ShouldCommitOrRollback
_ RspPayload
payload) = case RspPayload
payload of
RspPayload
RspPayload_Empty -> ByteString -> Snap ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
Snap.writeBS ByteString
""
RspPayload_Good x
v -> Value -> Snap ()
forall x. ToJSON x => x -> Snap ()
writeJSON (Value -> Snap ()) -> Value -> Snap ()
forall a b. (a -> b) -> a -> b
$ ctx -> x -> Value
forall ctx x. (IsCtx ctx, ToJSON x) => ctx -> x -> Value
ctx_wrapSuccess ctx
ctx x
v
RspPayload_Bad e
e -> e -> Snap ()
forall ae. ApiErr ae => ae -> Snap ()
writeApiErr e
e
RspPayload_Custom Status
httpStatus ByteString
mimeType ByteString
bs -> do
(Response -> Response) -> Snap ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
Snap.modifyResponse ((Response -> Response) -> Snap ())
-> (Response -> Response) -> Snap ()
forall a b. (a -> b) -> a -> b
$ Int -> Response -> Response
Snap.setResponseCode (Int -> Response -> Response) -> Int -> Response -> Response
forall a b. (a -> b) -> a -> b
$
Status -> Int
HTTP.statusCode Status
httpStatus
ByteString -> ByteString -> Snap ()
writeLBSSuccess_dontUseThis ByteString
mimeType ByteString
bs
rollback_ :: Connection -> IO ()
rollback_ :: Connection -> IO ()
rollback_ Connection
conn =
Connection -> IO ()
PSQL.rollback Connection
conn
IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` ((\IOError
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) :: IOError -> IO ())
writeLBSSuccess_dontUseThis :: BS.ByteString -> BSL.ByteString -> Snap ()
writeLBSSuccess_dontUseThis :: ByteString -> ByteString -> Snap ()
writeLBSSuccess_dontUseThis ByteString
contentType ByteString
b = do
(Response -> Response) -> Snap ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
Snap.modifyResponse ((Response -> Response) -> Snap ())
-> (Response -> Response) -> Snap ()
forall a b. (a -> b) -> a -> b
$
CI ByteString -> ByteString -> Response -> Response
forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
Snap.setHeader CI ByteString
"Content-Type" ByteString
contentType
ByteString -> Snap ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
Snap.writeLBS ByteString
b
writeJSON :: ToJSON x => x -> Snap ()
writeJSON :: x -> Snap ()
writeJSON x
x = do
(Response -> Response) -> Snap ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
Snap.modifyResponse ((Response -> Response) -> Snap ())
-> (Response -> Response) -> Snap ()
forall a b. (a -> b) -> a -> b
$
CI ByteString -> ByteString -> Response -> Response
forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
Snap.setHeader CI ByteString
"Content-Type" ByteString
"application/json"
ByteString -> Snap ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
Snap.writeLBS (ByteString -> Snap ()) -> ByteString -> Snap ()
forall a b. (a -> b) -> a -> b
$ x -> ByteString
forall a. ToJSON a => a -> ByteString
JSON.encode (x -> ByteString) -> x -> ByteString
forall a b. (a -> b) -> a -> b
$ x
x
errorEarlyCode :: ApiErr ae => ae -> Snap x
errorEarlyCode :: ae -> Snap x
errorEarlyCode ae
err = do
ae -> Snap ()
forall ae. ApiErr ae => ae -> Snap ()
writeApiErr ae
err
Snap Response
forall (m :: * -> *). MonadSnap m => m Response
Snap.getResponse Snap Response -> (Response -> Snap x) -> Snap x
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Response -> Snap x
forall (m :: * -> *) a. MonadSnap m => Response -> m a
Snap.finishWith
writeApiErr :: ApiErr ae => ae -> Snap ()
writeApiErr :: ae -> Snap ()
writeApiErr (ae -> ErrResult
forall apiErr. ApiErr apiErr => apiErr -> ErrResult
errResult -> (ErrResult Status
httpStatus Value
responseVal)) = do
(Response -> Response) -> Snap ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
Snap.modifyResponse ((Response -> Response) -> Snap ())
-> (Response -> Response) -> Snap ()
forall a b. (a -> b) -> a -> b
$ Int -> Response -> Response
Snap.setResponseCode (Int -> Response -> Response) -> Int -> Response -> Response
forall a b. (a -> b) -> a -> b
$
Status -> Int
HTTP.statusCode Status
httpStatus
Value -> Snap ()
forall x. ToJSON x => x -> Snap ()
writeJSON (Value -> Snap ()) -> Value -> Snap ()
forall a b. (a -> b) -> a -> b
$ Value -> Value
forall a. ToJSON a => a -> Value
toJSON Value
responseVal
(.!) :: (IsCtx ctx, FromJSON x) => ReqObject ctx -> Text -> Snap x
ro :: ReqObject ctx
ro@(ReqObject ctx
ctx HashMap Text Value
_) .! :: ReqObject ctx -> Text -> Snap x
.! Text
k = (ReqObject ctx
ro ReqObject ctx -> Text -> Snap (Maybe x)
forall ctx x.
(IsCtx ctx, FromJSON x) =>
ReqObject ctx -> Text -> Snap (Maybe x)
.!? Text
k) Snap (Maybe x) -> (Maybe x -> Snap x) -> Snap x
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe x
Nothing -> CtxErrType ctx -> Snap x
forall ae x. ApiErr ae => ae -> Snap x
errorEarlyCode (CtxErrType ctx -> Snap x) -> CtxErrType ctx -> Snap x
forall a b. (a -> b) -> a -> b
$ ctx -> CtxErrType ctx -> CtxErrType ctx
forall ctx. IsCtx ctx => ctx -> CtxErrType ctx -> CtxErrType ctx
ctxErr ctx
ctx (CtxErrType ctx -> CtxErrType ctx)
-> CtxErrType ctx -> CtxErrType ctx
forall a b. (a -> b) -> a -> b
$ Text -> CtxErrType ctx
forall apiErr. ApiErr apiErr => Text -> apiErr
apiErr_missingRequestKey Text
k
Just x
x -> x -> Snap x
forall (f :: * -> *) a. Applicative f => a -> f a
pure x
x
(.!?) :: (IsCtx ctx, FromJSON x) => ReqObject ctx -> Text -> Snap (Maybe x)
(ReqObject ctx
ctx HashMap Text Value
hm) .!? :: ReqObject ctx -> Text -> Snap (Maybe x)
.!? Text
k = case Text -> HashMap Text Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
k HashMap Text Value
hm of
Maybe Value
Nothing -> Maybe x -> Snap (Maybe x)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe x
forall a. Maybe a
Nothing
Just Value
v -> case Value -> Result x
forall a. FromJSON a => Value -> Result a
fromJSON Value
v of
JSON.Success x
x -> Maybe x -> Snap (Maybe x)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (x -> Maybe x
forall a. a -> Maybe a
Just x
x)
Result x
_ -> CtxErrType ctx -> Snap (Maybe x)
forall ae x. ApiErr ae => ae -> Snap x
errorEarlyCode (CtxErrType ctx -> Snap (Maybe x))
-> CtxErrType ctx -> Snap (Maybe x)
forall a b. (a -> b) -> a -> b
$ ctx -> CtxErrType ctx -> CtxErrType ctx
forall ctx. IsCtx ctx => ctx -> CtxErrType ctx -> CtxErrType ctx
ctxErr ctx
ctx (CtxErrType ctx -> CtxErrType ctx)
-> CtxErrType ctx -> CtxErrType ctx
forall a b. (a -> b) -> a -> b
$ Text -> Value -> CtxErrType ctx
forall apiErr. ApiErr apiErr => Text -> Value -> apiErr
apiErr_malformedRequestValue Text
k Value
v
data ReqObject ctx
= ReqObject ctx (HM.HashMap Text JSON.Value)
reqObject :: IsCtx ctx => ctx -> Snap (ReqObject ctx)
reqObject :: ctx -> Snap (ReqObject ctx)
reqObject ctx
ctx = ctx -> Word64 -> Snap (ReqObject ctx)
forall ctx. IsCtx ctx => ctx -> Word64 -> Snap (ReqObject ctx)
reqObject' ctx
ctx Word64
2048
reqObject' :: IsCtx ctx => ctx -> Word64 -> Snap (ReqObject ctx)
reqObject' :: ctx -> Word64 -> Snap (ReqObject ctx)
reqObject' ctx
ctx Word64
size =
(ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
JSON.decode (ByteString -> Maybe Value)
-> Snap ByteString -> Snap (Maybe Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word64 -> Snap ByteString
forall (m :: * -> *). MonadSnap m => Word64 -> m ByteString
Snap.readRequestBody Word64
size) Snap (Maybe Value)
-> (Maybe Value -> Snap (ReqObject ctx)) -> Snap (ReqObject ctx)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Value
Nothing -> CtxErrType ctx -> Snap (ReqObject ctx)
forall ae x. ApiErr ae => ae -> Snap x
errorEarlyCode (CtxErrType ctx -> Snap (ReqObject ctx))
-> CtxErrType ctx -> Snap (ReqObject ctx)
forall a b. (a -> b) -> a -> b
$ ctx -> CtxErrType ctx -> CtxErrType ctx
forall ctx. IsCtx ctx => ctx -> CtxErrType ctx -> CtxErrType ctx
ctxErr ctx
ctx CtxErrType ctx
forall apiErr. ApiErr apiErr => apiErr
apiErr_requestNotJSON
Just (JSON.Object HashMap Text Value
o) -> ReqObject ctx -> Snap (ReqObject ctx)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReqObject ctx -> Snap (ReqObject ctx))
-> ReqObject ctx -> Snap (ReqObject ctx)
forall a b. (a -> b) -> a -> b
$ ctx -> HashMap Text Value -> ReqObject ctx
forall ctx. ctx -> HashMap Text Value -> ReqObject ctx
ReqObject ctx
ctx HashMap Text Value
o
Just Value
_ -> CtxErrType ctx -> Snap (ReqObject ctx)
forall ae x. ApiErr ae => ae -> Snap x
errorEarlyCode (CtxErrType ctx -> Snap (ReqObject ctx))
-> CtxErrType ctx -> Snap (ReqObject ctx)
forall a b. (a -> b) -> a -> b
$ ctx -> CtxErrType ctx -> CtxErrType ctx
forall ctx. IsCtx ctx => ctx -> CtxErrType ctx -> CtxErrType ctx
ctxErr ctx
ctx CtxErrType ctx
forall apiErr. ApiErr apiErr => apiErr
apiErr_requestNotJSONObject