{-# LANGUAGE
BangPatterns
, DeriveGeneric
, ExistentialQuantification
, FlexibleContexts
, InstanceSigs
, LambdaCase
, OverloadedStrings
, TypeFamilies
, ViewPatterns
#-}
module Gingersnap.Core (
Rsp(..)
, rspGood
, rspBad
, rspBadCommit
, rspBadRollback
, rspGoodCSV
, rspGoodLBS
, rspEmptyGood
, 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 _ = 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
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 -> (Connection -> IO Rsp) -> Snap ()
inTransaction ctx actionThatReturnsAnRsp = do
inTransactionMode ctx PSQL.Serializable PSQL.ReadWrite actionThatReturnsAnRsp
inTransaction_readOnly :: IsCtx ctx => ctx -> (Connection -> IO Rsp) -> Snap ()
inTransaction_readOnly ctx f =
inTransactionMode ctx PSQL.Serializable PSQL.ReadOnly f
inTransaction_override :: IsCtx ctx => ctx -> (Connection -> IO Rsp) -> Snap ()
inTransaction_override ctx action =
inTransaction_internal ctx PSQL.Serializable PSQL.ReadWrite action
inTransactionMode :: IsCtx ctx => ctx -> PSQL.IsolationLevel -> PSQL.ReadWriteMode -> (Connection -> IO Rsp) -> Snap ()
inTransactionMode ctx isolationLevel' readWriteMode' actionThatReturnsAResponse = do
readOnlyMode <- liftIO $ ctxGetReadOnlyMode ctx
when (readOnlyMode && (readWriteMode' /= PSQL.ReadOnly)) $
errorEarlyCode $ ctxErr ctx apiErr_inReadOnlyMode
inTransaction_internal ctx isolationLevel' readWriteMode' actionThatReturnsAResponse
inTransaction_internal :: IsCtx ctx => ctx -> PSQL.IsolationLevel -> PSQL.ReadWriteMode -> (Connection -> IO Rsp) -> Snap ()
inTransaction_internal ctx isolationLevel' readWriteMode' actionThatReturnsAResponse = do
let transactMode = PSQL.TransactionMode isolationLevel' readWriteMode'
rsp <- liftIO $
(Pool.withResource (ctxConnectionPool ctx) $ \conn ->
E.mask $ \restore -> do
PSQL.beginMode transactMode conn
!r <- restore (force <$> actionThatReturnsAResponse conn)
`E.onException` rollback_ conn
(case rspShouldCommit r of
ShouldCommit -> PSQL.commit conn
ShouldRollback -> rollback_ conn
) `E.onException` rollback_ 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
rollback_ :: Connection -> IO ()
rollback_ conn =
PSQL.rollback conn
`E.catch` ((\_ -> return ()) :: IOError -> IO ())
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