From 5afdba98af683162b8bb93e0be96b6b550bf258b Mon Sep 17 00:00:00 2001
From: Jean-Paul Calderone <exarkun@twistedmatrix.com>
Date: Tue, 29 Oct 2019 14:45:10 -0400
Subject: [PATCH] Switch to running on TLS
---
PaymentServer.cabal | 1 +
src/PaymentServer/Main.hs | 64 ++++++++++++++++++++++++++++++++-------
2 files changed, 54 insertions(+), 11 deletions(-)
diff --git a/PaymentServer.cabal b/PaymentServer.cabal
index 2746523..6359ffb 100644
--- a/PaymentServer.cabal
+++ b/PaymentServer.cabal
@@ -31,6 +31,7 @@ library
, wai-extra
, data-default
, warp
+ , warp-tls
, stripe-core
, text
, containers
diff --git a/src/PaymentServer/Main.hs b/src/PaymentServer/Main.hs
index 93f9ea8..eb6db2c 100644
--- a/src/PaymentServer/Main.hs
+++ b/src/PaymentServer/Main.hs
@@ -9,6 +9,9 @@ module PaymentServer.Main
import Text.Printf
( printf
)
+import Data.Maybe
+ ( maybeToList
+ )
import Data.Text
( Text
)
@@ -16,7 +19,16 @@ import Data.Default
( def
)
import Network.Wai.Handler.Warp
- ( run
+ ( defaultSettings
+ , setPort
+ )
+import Network.Wai.Handler.WarpTLS
+ ( TLSSettings
+ , runTLS
+ , tlsSettingsChain
+ )
+import Network.Wai
+ ( Application
)
import Network.Wai.Middleware.RequestLogger
( OutputFormat(Detailed)
@@ -38,6 +50,7 @@ import PaymentServer.Server
import Options.Applicative
( Parser
, ParserInfo
+ , strOption
, option
, auto
, str
@@ -70,10 +83,14 @@ data Database =
deriving (Show, Eq, Ord, Read)
data ServerConfig = ServerConfig
- { issuer :: Issuer
- , signingKey :: Maybe Text
- , database :: Database
- , databasePath :: Maybe Text
+ { issuer :: Issuer
+ , signingKey :: Maybe Text
+ , database :: Database
+ , databasePath :: Maybe Text
+ , httpPortNumber :: Int
+ , certificatePath :: String
+ , chainPath :: Maybe String
+ , keyPath :: String
}
deriving (Show, Eq)
@@ -97,6 +114,21 @@ sample = ServerConfig
( long "database-path"
<> help "Path to on-disk database (sqlite3 only)"
<> showDefault ) )
+ <*> option auto
+ ( long "https-port"
+ <> help "Port number on which to accept HTTPS connections."
+ <> showDefault
+ <> value 443 )
+ <*> strOption
+ ( long "https-certificate-path"
+ <> help "Filesystem path to the TLS certificate to use for HTTPS." )
+ <*> optional ( strOption
+ ( long "https-certificate-chain-path"
+ <> help "Filesystem path to the TLS certificate chain to use for HTTPS." ) )
+ <*> strOption
+ ( long "https-key-path"
+ <> help "Filesystem path to the TLS private key to use for HTTPS." )
+
opts :: ParserInfo ServerConfig
opts = info (sample <**> helper)
@@ -106,7 +138,20 @@ opts = info (sample <**> helper)
)
main :: IO ()
-main =
+main = do
+ config <- execParser opts
+ let port = httpPortNumber config
+ app <- getApp config
+ tlsSettings <- getTlsSettings config
+ putStrLn (printf "Accepting HTTPS connections on %d" port :: String)
+ runTLS tlsSettings (setPort port defaultSettings) app
+
+getTlsSettings :: ServerConfig -> IO TLSSettings
+getTlsSettings ServerConfig{ certificatePath, chainPath, keyPath } =
+ return $ tlsSettingsChain certificatePath (maybeToList chainPath) keyPath
+
+getApp :: ServerConfig -> IO Application
+getApp config =
let
getIssuer ServerConfig{ issuer, signingKey } =
case (issuer, signingKey) of
@@ -119,20 +164,17 @@ main =
(SQLite3, Just path) -> Right (getDBConnection path)
_ -> Left "invalid options"
in do
- config <- execParser opts
case getIssuer config of
Left err -> do
print err
exitFailure
Right issuer ->
case getDatabase config of
- Left err ->do
+ Left err -> do
print err
exitFailure
Right getDB -> do
db <- getDB
- let port = 8081
let app = paymentServerApp issuer db
logger <- mkRequestLogger (def { outputFormat = Detailed True})
- putStrLn (printf "Listening on %d" port :: String)
- run port $ logger app
+ return $ logger app
--
GitLab