{-# LANGUAGE
BangPatterns
, DefaultSignatures
, DeriveGeneric
, ExistentialQuantification
, FlexibleContexts
, InstanceSigs
, LambdaCase
, OverloadedStrings
, TypeFamilies
, ViewPatterns
#-}
module Gingersnap.Core (
rspGood
, rspBad
, rspBadCommit
, rspBadRollback
, rspGoodCSV
, rspGoodLBS
, rspEmptyGood
, Rsp(..)
, pureRsp
, inTransaction
, inTransactionWithMode
, inTransactionMode
, inTransaction_readOnly
, inTransaction_readWrite
, inTransaction_override
, inTransaction_internal
, 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 (ConnType ctx)
ctxGetReadOnlyMode :: ctx -> IO Bool
ctxGetReadOnlyMode _ = pure False
ctx_wrapSuccess :: ToJSON x => ctx -> x -> JSON.Value
ctx_wrapSuccess _ x = JSON.object ["result" .= x]
type CtxErrType ctx
type instance CtxErrType ctx = DefaultApiErr
type ConnType ctx :: *
type ConnType ctx = PSQL.Connection
ctx_rollback :: ctx -> ConnType ctx -> IO ()
default ctx_rollback :: (ConnType ctx ~ PSQL.Connection) => ctx -> ConnType ctx -> IO ()
ctx_rollback _ conn =
PSQL.rollback conn
`E.catch` ((\_ -> return ()) :: IOError -> IO ())
ctx_commit :: ctx -> ConnType ctx -> IO ()
default ctx_commit :: (ConnType ctx ~ PSQL.Connection) => ctx -> ConnType ctx -> IO ()
ctx_commit _ = PSQL.commit
type TxModeType ctx :: *
type TxModeType ctx = PSQL.TransactionMode
ctx_defaultTransactionMode :: ctx -> TxModeType ctx
default ctx_defaultTransactionMode :: (TxModeType ctx ~ PSQL.TransactionMode) => ctx -> TxModeType ctx
ctx_defaultTransactionMode _ =
PSQL.TransactionMode PSQL.Serializable PSQL.ReadWrite
ctx_txIsReadOnly :: ctx -> TxModeType ctx -> Bool
default ctx_txIsReadOnly :: (TxModeType ctx ~ PSQL.TransactionMode) => ctx -> TxModeType ctx -> Bool
ctx_txIsReadOnly _ (PSQL.TransactionMode _ rwMode) =
case rwMode of
PSQL.ReadOnly -> True
PSQL.ReadWrite -> False
PSQL.DefaultReadWriteMode -> False
ctx_beginTransaction :: ctx -> TxModeType ctx -> ConnType ctx -> IO ()
default ctx_beginTransaction :: (TxModeType ctx ~ PSQL.TransactionMode, ConnType ctx ~ PSQL.Connection) => ctx -> TxModeType ctx -> ConnType ctx -> IO ()
ctx_beginTransaction _ transactMode conn = do
PSQL.beginMode transactMode conn
ctxErr :: IsCtx ctx => ctx -> (CtxErrType ctx) -> (CtxErrType ctx)
ctxErr _ x = 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 (Show, Eq)
instance NFData ErrResult where
rnf (ErrResult (HTTP.Status code msg) v) =
rnf code `seq` rnf msg `seq` rnf 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 (Show, Eq)
instance ApiErr DefaultApiErr where
apiErr_inReadOnlyMode =
DefaultApiErr_ReadOnlyMode
apiErr_missingRequestKey =
DefaultApiErr_MissingRequestKey
apiErr_requestNotJSON =
DefaultApiErr_RequestNotJSON
apiErr_requestNotJSONObject =
DefaultApiErr_RequestNotJSONObject
apiErr_malformedRequestValue =
DefaultApiErr_MalformedRequestValue
apiErr_unexpectedError =
DefaultApiErr_UnexpectedError
errResult :: DefaultApiErr -> ErrResult
errResult = defaultApiErrResult
defaultApiErrResult :: DefaultApiErr -> ErrResult
defaultApiErrResult err =
ErrResult status $
JSON.object [
"errorCode" .= (code :: Int)
, "errorMessage" .= msg
, "errorVals" .= (vals :: [(Text, JSON.Value)])
]
where
(code, status, msg, vals) = case err of
DefaultApiErr_ReadOnlyMode ->
(0, HTTP.serviceUnavailable503, "This action is unavailable in read-only mode", [])
DefaultApiErr_UnexpectedError t ->
(1, HTTP.internalServerError500, "An unexpected error occurred", [
"text" .= t
])
DefaultApiErr_MissingRequestKey k ->
(2, HTTP.unprocessableEntity422, "Required key not present: "++show k, [
"key" .= k
])
DefaultApiErr_RequestNotJSON ->
(3, HTTP.unprocessableEntity422, "Non-JSON message body", [])
DefaultApiErr_RequestNotJSONObject ->
(4, HTTP.unprocessableEntity422, "Message body is not a JSON object", [])
DefaultApiErr_MalformedRequestValue k v ->
(5, HTTP.unprocessableEntity422, "Malformed value: "++show k, [
"key" .= k, "value" .= v
])
DefaultApiErr_Custom s t vs ->
(6, s, t, vs)
data Rsp
= Rsp {
rspShouldCommit :: ShouldCommitOrRollback
, rspPayload :: RspPayload
}
deriving (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 = \case
RspPayload_Empty -> ()
RspPayload_Good x -> (RspPayload_Good $!! (force $ toJSON x)) `seq` ()
RspPayload_Bad e -> rnf $ errResult e
RspPayload_Custom (HTTP.Status a b) c d ->
rnf a `seq` rnf b `seq` rnf c `seq` rnf d
data ShouldCommitOrRollback
= ShouldCommit
| ShouldRollback
deriving (Show, Eq, Generic)
instance NFData ShouldCommitOrRollback
rspGood :: ToJSON x => x -> Rsp
rspGood x = Rsp ShouldCommit $ RspPayload_Good x
rspBad, rspBadCommit, rspBadRollback :: ApiErr ae => ae -> Rsp
rspBad e = Rsp ShouldRollback $ RspPayload_Bad e
rspBadCommit e = Rsp ShouldCommit $ RspPayload_Bad e
rspBadRollback e = Rsp ShouldRollback $ RspPayload_Bad e
rspGoodCSV :: BSL.ByteString -> Rsp
rspGoodCSV bs = Rsp ShouldCommit $ RspPayload_Custom HTTP.ok200 (BS8.pack "text/csv") bs
rspGoodLBS :: BS.ByteString -> BSL.ByteString -> Rsp
rspGoodLBS mimeType bs = Rsp ShouldCommit $ RspPayload_Custom HTTP.ok200 mimeType bs
rspEmptyGood :: Rsp
rspEmptyGood = Rsp ShouldCommit RspPayload_Empty
rspIsGood :: Rsp -> Bool
rspIsGood (Rsp _ payload) = case payload of
RspPayload_Good {} -> True
RspPayload_Bad {} -> False
RspPayload_Custom httpStatus _ _ ->
httpStatus == HTTP.ok200
RspPayload_Empty -> True
instance Show Rsp where
show (Rsp commit payload) =
"Rsp "++show commit++" "++case payload of
RspPayload_Good x -> "(Good "++show (JSON.encode x)++")"
RspPayload_Bad (errResult -> e) -> "(Bad "++show e++")"
RspPayload_Empty -> "Empty"
RspPayload_Custom a b c -> "(Custom "++show (a,b,c)++")"
inTransaction :: IsCtx ctx => ctx -> (ConnType ctx -> IO Rsp) -> Snap ()
inTransaction ctx actionThatReturnsAnRsp = do
inTransactionWithMode ctx (ctx_defaultTransactionMode ctx) actionThatReturnsAnRsp
inTransaction_readOnly :: (IsCtx ctx, TxModeType ctx ~ PSQL.TransactionMode) => ctx -> (ConnType ctx -> IO Rsp) -> Snap ()
inTransaction_readOnly ctx f =
inTransactionWithMode ctx (PSQL.TransactionMode PSQL.Serializable PSQL.ReadOnly) f
inTransaction_readWrite :: (IsCtx ctx, TxModeType ctx ~ PSQL.TransactionMode) => ctx -> (ConnType ctx -> IO Rsp) -> Snap ()
inTransaction_readWrite ctx f =
inTransactionWithMode ctx (PSQL.TransactionMode PSQL.Serializable PSQL.ReadWrite) f
inTransaction_override :: (IsCtx ctx, TxModeType ctx ~ PSQL.TransactionMode) => ctx -> (ConnType ctx -> IO Rsp) -> Snap ()
inTransaction_override ctx action =
inTransaction_internal ctx (PSQL.TransactionMode PSQL.Serializable PSQL.ReadWrite) action
inTransactionMode :: (IsCtx ctx, TxModeType ctx ~ PSQL.TransactionMode) => ctx -> PSQL.IsolationLevel -> PSQL.ReadWriteMode -> (ConnType ctx -> IO Rsp) -> Snap ()
inTransactionMode ctx isolationLevel' readWriteMode' actionThatReturnsAResponse = do
inTransactionWithMode ctx (PSQL.TransactionMode isolationLevel' readWriteMode') actionThatReturnsAResponse
inTransactionWithMode :: IsCtx ctx => ctx -> TxModeType ctx -> (ConnType ctx -> IO Rsp) -> Snap ()
inTransactionWithMode ctx txMode actionThatReturnsAResponse = do
inReadOnlyMode <- liftIO $ ctxGetReadOnlyMode ctx
when (inReadOnlyMode && (not $ ctx_txIsReadOnly ctx txMode)) $
errorEarlyCode $ ctxErr ctx apiErr_inReadOnlyMode
inTransaction_internal ctx txMode actionThatReturnsAResponse
inTransaction_internal :: IsCtx ctx => ctx -> TxModeType ctx -> (ConnType ctx -> IO Rsp) -> Snap ()
inTransaction_internal ctx transactionMode actionThatReturnsAResponse = do
rsp <- liftIO $
(Pool.withResource (ctxConnectionPool ctx) $ \conn ->
E.mask $ \restore -> do
ctx_beginTransaction ctx transactionMode conn
!r <- restore (force <$> actionThatReturnsAResponse conn)
`E.onException` ctx_rollback ctx conn
(case rspShouldCommit r of
ShouldCommit -> ctx_commit ctx conn
ShouldRollback -> ctx_rollback ctx conn
) `E.onException` ctx_rollback ctx conn
pure r)
`E.catch` (\e@(E.SomeException {}) -> pure $ rspBad $
ctxErr ctx $ apiErr_unexpectedError $ T.pack $ show e)
pureRsp ctx rsp
pureRsp :: IsCtx ctx => ctx -> Rsp -> Snap ()
pureRsp ctx (Rsp _ payload) = case payload of
RspPayload_Empty -> Snap.writeBS ""
RspPayload_Good v -> writeJSON $ ctx_wrapSuccess ctx v
RspPayload_Bad e -> writeApiErr e
RspPayload_Custom httpStatus mimeType bs -> do
Snap.modifyResponse $ Snap.setResponseCode $
HTTP.statusCode httpStatus
writeLBSSuccess_dontUseThis mimeType bs
writeLBSSuccess_dontUseThis :: BS.ByteString -> BSL.ByteString -> Snap ()
writeLBSSuccess_dontUseThis contentType b = do
Snap.modifyResponse $
Snap.setHeader "Content-Type" contentType
Snap.writeLBS b
writeJSON :: ToJSON x => x -> Snap ()
writeJSON x = do
Snap.modifyResponse $
Snap.setHeader "Content-Type" "application/json"
Snap.writeLBS $ JSON.encode $ x
errorEarlyCode :: ApiErr ae => ae -> Snap x
errorEarlyCode err = do
writeApiErr err
Snap.getResponse >>= Snap.finishWith
writeApiErr :: ApiErr ae => ae -> Snap ()
writeApiErr (errResult -> (ErrResult httpStatus responseVal)) = do
Snap.modifyResponse $ Snap.setResponseCode $
HTTP.statusCode httpStatus
writeJSON $ toJSON responseVal
(.!) :: (IsCtx ctx, FromJSON x) => ReqObject ctx -> Text -> Snap x
ro@(ReqObject ctx _) .! k = (ro .!? k) >>= \case
Nothing -> errorEarlyCode $ ctxErr ctx $ apiErr_missingRequestKey k
Just x -> pure x
(.!?) :: (IsCtx ctx, FromJSON x) => ReqObject ctx -> Text -> Snap (Maybe x)
(ReqObject ctx hm) .!? k = case HM.lookup k hm of
Nothing -> pure Nothing
Just v -> case fromJSON v of
JSON.Success x -> pure (Just x)
_ -> errorEarlyCode $ ctxErr ctx $ apiErr_malformedRequestValue k v
data ReqObject ctx
= ReqObject ctx (HM.HashMap Text JSON.Value)
reqObject :: IsCtx ctx => ctx -> Snap (ReqObject ctx)
reqObject ctx = reqObject' ctx 2048
reqObject' :: IsCtx ctx => ctx -> Word64 -> Snap (ReqObject ctx)
reqObject' ctx size =
(JSON.decode <$> Snap.readRequestBody size) >>= \case
Nothing -> errorEarlyCode $ ctxErr ctx apiErr_requestNotJSON
Just (JSON.Object o) -> pure $ ReqObject ctx o
Just _ -> errorEarlyCode $ ctxErr ctx apiErr_requestNotJSONObject