Skip to content
Snippets Groups Projects
Unverified Commit 0acf4349 authored by Jean-Paul Calderone's avatar Jean-Paul Calderone Committed by GitHub
Browse files

Merge pull request #27 from PrivateStorageio/3.https

Support serving either HTTP or HTTPS
parents a0091295 5acae279
No related branches found
No related tags found
No related merge requests found
......@@ -31,6 +31,7 @@ library
, wai-extra
, data-default
, warp
, warp-tls
, stripe-core
, text
, containers
......
......@@ -9,6 +9,9 @@ module PaymentServer.Main
import Text.Printf
( printf
)
import Data.Maybe
( maybeToList
)
import Data.Text
( Text
)
......@@ -16,7 +19,17 @@ import Data.Default
( def
)
import Network.Wai.Handler.Warp
( run
( Port
, defaultSettings
, setPort
, run
)
import Network.Wai.Handler.WarpTLS
( runTLS
, tlsSettingsChain
)
import Network.Wai
( Application
)
import Network.Wai.Middleware.RequestLogger
( OutputFormat(Detailed)
......@@ -38,6 +51,7 @@ import PaymentServer.Server
import Options.Applicative
( Parser
, ParserInfo
, strOption
, option
, auto
, str
......@@ -53,6 +67,7 @@ import Options.Applicative
, progDesc
, header
, (<**>)
, (<|>)
)
import System.Exit
( exitFailure
......@@ -74,9 +89,55 @@ data ServerConfig = ServerConfig
, signingKey :: Maybe Text
, database :: Database
, databasePath :: Maybe Text
, endpoint :: Endpoint
}
deriving (Show, Eq)
-- | An Endpoint represents the configuration for a socket's IP address.
-- There are some layering violations here. I'm just copying Twisted
-- endpoints at the moment. At some point it would be great to implement a
-- general purpose endpoint library outside of PaymentServer and without the
-- layering violations.
data Endpoint =
-- | A TCPEndpoint represents a bare TCP/IP socket address.
TCPEndpoint
{ portNumber :: Port
}
|
-- | A TLSEndpoint represents a TCP/IP socket address which will have TLS
-- used over it.
TLSEndpoint
{ portNumber :: Port
, certificatePath :: FilePath
, chainPath :: Maybe FilePath
, keyPath :: FilePath
}
deriving (Show, Eq)
http :: Parser Endpoint
http = TCPEndpoint
<$> option auto
( long "http-port"
<> help "Port number on which to accept HTTP connections."
)
https :: Parser Endpoint
https = TLSEndpoint
<$> option auto
( long "https-port"
<> help "Port number on which to accept HTTPS connections." )
<*> 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." )
sample :: Parser ServerConfig
sample = ServerConfig
<$> option auto
......@@ -97,6 +158,8 @@ sample = ServerConfig
( long "database-path"
<> help "Path to on-disk database (sqlite3 only)"
<> showDefault ) )
<*> (http <|> https)
opts :: ParserInfo ServerConfig
opts = info (sample <**> helper)
......@@ -106,7 +169,35 @@ opts = info (sample <**> helper)
)
main :: IO ()
main =
main = do
config <- execParser opts
app <- getApp config
let run = getRunner (endpoint config)
logEndpoint (endpoint config)
run app
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
settings = setPort portNumber defaultSettings
in
runTLS tlsSettings settings
logEndpoint :: Endpoint -> IO ()
logEndpoint endpoint =
case endpoint of
TCPEndpoint { portNumber } ->
putStrLn (printf "Accepting HTTP connections on %d" portNumber :: String)
TLSEndpoint { portNumber } ->
putStrLn (printf "Accepting HTTPS connections on %d" portNumber :: String)
getApp :: ServerConfig -> IO Application
getApp config =
let
getIssuer ServerConfig{ issuer, signingKey } =
case (issuer, signingKey) of
......@@ -119,7 +210,6 @@ main =
(SQLite3, Just path) -> Right (getDBConnection path)
_ -> Left "invalid options"
in do
config <- execParser opts
case getIssuer config of
Left err -> do
print err
......@@ -131,8 +221,6 @@ main =
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
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment