From 81e382bfc234407fa9b1325349753d2023d7a1a0 Mon Sep 17 00:00:00 2001
From: Jean-Paul Calderone <exarkun@twistedmatrix.com>
Date: Fri, 22 Nov 2019 15:32:30 -0500
Subject: [PATCH] Make sure settings are applied for http and https
---
src/PaymentServer/Main.hs | 47 ++++++++++++++++++++++-----------------
1 file changed, 26 insertions(+), 21 deletions(-)
diff --git a/src/PaymentServer/Main.hs b/src/PaymentServer/Main.hs
index 274bc94..07c3521 100644
--- a/src/PaymentServer/Main.hs
+++ b/src/PaymentServer/Main.hs
@@ -30,7 +30,7 @@ import Network.Wai.Handler.Warp
, setPort
, setOnException
, setOnExceptionResponse
- , run
+ , runSettings
)
import Network.Wai.Handler.WarpTLS
( runTLS
@@ -201,28 +201,33 @@ main = do
logEndpoint (endpoint config)
run app
+getPortNumber (TCPEndpoint portNumber) = portNumber
+getPortNumber (TLSEndpoint portNumber _ _ _) = portNumber
+
getRunner :: Endpoint -> (Application -> IO ())
getRunner endpoint =
- case endpoint of
- (TCPEndpoint portNumber) ->
- run portNumber
- (TLSEndpoint portNumber certificatePath chainPath keyPath) ->
- let
- tlsSettings = tlsSettingsChain certificatePath (maybeToList chainPath) keyPath
- 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
+ let
+ 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 (getPortNumber endpoint) .
+ setOnException onException .
+ setOnExceptionResponse onExceptionResponse $
+ defaultSettings
+ in
+ case endpoint of
+ (TCPEndpoint _) ->
+ runSettings settings
+ (TLSEndpoint _ certificatePath chainPath keyPath) ->
+ let
+ tlsSettings = tlsSettingsChain certificatePath (maybeToList chainPath) keyPath
+ in
+ runTLS tlsSettings settings
logEndpoint :: Endpoint -> IO ()
logEndpoint endpoint =
--
GitLab