{-# LANGUAGE
ExistentialQuantification
, InstanceSigs
, LambdaCase
, OverloadedStrings
, ViewPatterns
#-}
module Gingersnap.Core (
IsCtx(..)
, ApiErr(..)
, ErrResult(..)
, Rsp
, rspGood
, rspBad
, rspBadCommit
, rspBadRollback
, rspGoodCSV
, rspGoodLBS
, rspEmptyGood
, pureRsp
, inTransaction
, inTransaction_readOnly
, inTransaction_override
, inTransactionMode
, rspIsGood
, errorEarlyCode
) where
import qualified Control.Exception as E
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Data.Aeson (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 Data.Pool (Pool)
import qualified Data.Pool as Pool
import Database.PostgreSQL.Simple (Connection)
import qualified Database.PostgreSQL.Simple as PSQL
import qualified Database.PostgreSQL.Simple.Transaction as PSQL
import qualified Network.HTTP.Types.Status as HTTP
import Snap.Core (Snap)
import qualified Snap.Core as Snap
class 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]
ctx_err_inReadOnlyMode :: ctx -> ErrResult
ctx_err_inReadOnlyMode _ = errResult DefaultErrors_ReadOnlyMode
class ApiErr apiErr where
errResult :: apiErr -> ErrResult
data ErrResult
= ErrResult HTTP.Status JSON.Value
deriving (Show, Eq)
instance ApiErr ErrResult where
errResult x = x
data DefaultErrors
= DefaultErrors_ReadOnlyMode
deriving (Show, Eq)
instance ApiErr DefaultErrors where
errResult :: DefaultErrors -> ErrResult
errResult = \case
DefaultErrors_ReadOnlyMode -> ErrResult HTTP.serviceUnavailable503 $
JSON.object [
"errorCode" .= (0 :: Int)
, "errorMessage" .= JSON.String "This action is unavailable in read-only mode"
]
data Rsp
= Rsp {
rspShouldCommit :: ShouldCommitOrRollback
, rspPayload :: RspPayload
}
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
data ShouldCommitOrRollback
= ShouldCommit
| ShouldRollback
deriving (Show, Eq)
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 $ ctx_err_inReadOnlyMode ctx
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 (actionThatReturnsAResponse conn)
`E.onException` rollback_ conn
(case rspShouldCommit r of
ShouldCommit -> PSQL.commit conn
ShouldRollback -> rollback_ conn
) `E.onException` rollback_ conn
pure r
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