From 5ffd3ac0f5dc39e9407338d760d9f72c9b560160 Mon Sep 17 00:00:00 2001
From: Jean-Paul Calderone <exarkun@twistedmatrix.com>
Date: Fri, 22 Nov 2019 10:33:50 -0500
Subject: [PATCH] [wip] always display exceptions
---
PaymentServer.cabal | 2 ++
src/PaymentServer/Main.hs | 25 ++++++++++++++++++++++++-
src/PaymentServer/Processors/Stripe.hs | 11 +++++++++--
3 files changed, 35 insertions(+), 3 deletions(-)
diff --git a/PaymentServer.cabal b/PaymentServer.cabal
index bd1e969..246e201 100644
--- a/PaymentServer.cabal
+++ b/PaymentServer.cabal
@@ -26,8 +26,10 @@ library
, optparse-applicative
, aeson
, bytestring
+ , utf8-string
, servant
, servant-server
+ , http-types
, wai
, wai-extra
, wai-cors
diff --git a/src/PaymentServer/Main.hs b/src/PaymentServer/Main.hs
index 0c0dd73..274bc94 100644
--- a/src/PaymentServer/Main.hs
+++ b/src/PaymentServer/Main.hs
@@ -6,6 +6,9 @@ module PaymentServer.Main
( main
) where
+import Control.Exception.Base
+ ( SomeException
+ )
import Text.Printf
( printf
)
@@ -18,10 +21,15 @@ import Data.Text
import Data.Default
( def
)
+import Network.HTTP.Types.Status
+ ( status500
+ )
import Network.Wai.Handler.Warp
( Port
, defaultSettings
, setPort
+ , setOnException
+ , setOnExceptionResponse
, run
)
import Network.Wai.Handler.WarpTLS
@@ -30,6 +38,9 @@ import Network.Wai.Handler.WarpTLS
)
import Network.Wai
( Application
+ , Request
+ , Response
+ , responseLBS
)
import Network.Wai.Middleware.Cors
( Origin
@@ -79,6 +90,7 @@ import System.Exit
import Data.Semigroup ((<>))
import qualified Data.Text.IO as TIO
import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy.UTF8 as LBS
data Issuer =
Trivial
@@ -197,7 +209,18 @@ getRunner endpoint =
(TLSEndpoint portNumber certificatePath chainPath keyPath) ->
let
tlsSettings = tlsSettingsChain certificatePath (maybeToList chainPath) keyPath
- settings = setPort portNumber defaultSettings
+ onException :: Maybe Request -> SomeException -> IO ()
+ onException _ exc = do
+ print "onException"
+ print exc
+ return ()
+ onExceptionResponse :: SomeException -> Response
+ onExceptionResponse = (responseLBS status500 []) . LBS.fromString . ("exception: " ++) . show
+ settings =
+ setPort portNumber .
+ setOnException onException .
+ setOnExceptionResponse onExceptionResponse $
+ defaultSettings
in
runTLS tlsSettings settings
diff --git a/src/PaymentServer/Processors/Stripe.hs b/src/PaymentServer/Processors/Stripe.hs
index 57137ed..9ee9c27 100644
--- a/src/PaymentServer/Processors/Stripe.hs
+++ b/src/PaymentServer/Processors/Stripe.hs
@@ -37,7 +37,7 @@ import Servant
, Handler
, err400
, err500
- , ServerError(errBody)
+ , ServerError(errHTTPCode, errBody)
, throwError
)
import Servant.API
@@ -171,7 +171,14 @@ charge d key (Charges token voucher amount currency) = do
else
throwError err500 { errBody = "Voucher code mismatch" }
_ -> throwError err400 { errBody = "Voucher code not found" }
- Left StripeError {} -> throwError err400 { errBody = "Stripe charge didn't succeed" }
+ Left StripeError {} ->
+ let
+ errCode = (read "foo") :: Int
+ in
+ throwError err400
+ { errHTTPCode = errCode
+ , errBody = "Stripe charge didn't succeed"
+ }
where
getCurrency :: Text -> Handler Currency
getCurrency maybeCurrency =
--
GitLab