From d3847242ed31b1a92eb541f793721fa46b59dee5 Mon Sep 17 00:00:00 2001
From: Jean-Paul Calderone <exarkun@twistedmatrix.com>
Date: Thu, 12 Sep 2019 10:27:24 -0400
Subject: [PATCH] Some command line options to control how the server is
configured
---
PaymentServer.cabal | 1 +
src/PaymentServer/Issuer.hs | 7 ++-
src/PaymentServer/Main.hs | 116 ++++++++++++++++++++++++++++++++++--
src/PaymentServer/Server.hs | 14 ++---
4 files changed, 125 insertions(+), 13 deletions(-)
diff --git a/PaymentServer.cabal b/PaymentServer.cabal
index ebbcb7b..723a1ba 100644
--- a/PaymentServer.cabal
+++ b/PaymentServer.cabal
@@ -23,6 +23,7 @@ library
, PaymentServer.Server
, PaymentServer.Main
build-depends: base >= 4.7 && < 5
+ , optparse-applicative
, aeson
, servant
, servant-server
diff --git a/src/PaymentServer/Issuer.hs b/src/PaymentServer/Issuer.hs
index 318e8a0..267a488 100644
--- a/src/PaymentServer/Issuer.hs
+++ b/src/PaymentServer/Issuer.hs
@@ -58,7 +58,12 @@ trivialIssue tokens =
(replicate (length tokens) "fake-signature")
"fake-proof"
-ristrettoIssue :: SigningKey -> Issuer
+-- | ristrettoIssue uses Ristretto-flavored PrivacyPass (aka
+-- `challenge-bypass-ristretto`) to create token signatures in a
+-- privacy-preserving manner.
+ristrettoIssue
+ :: SigningKey -- ^ The key to provide to the PrivacyPass signer.
+ -> Issuer -- ^ An issuer using the given key.
ristrettoIssue signingKey tokens = do
(publicKey, tokens, proof) <- ristretto signingKey tokens
return $ ChallengeBypass publicKey tokens proof
diff --git a/src/PaymentServer/Main.hs b/src/PaymentServer/Main.hs
index 7d9ee2a..041ea9a 100644
--- a/src/PaymentServer/Main.hs
+++ b/src/PaymentServer/Main.hs
@@ -1,8 +1,17 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
-- | This module implements the main entrypoint to the PaymentServer.
module PaymentServer.Main
( main
) where
+import Text.Printf
+ ( printf
+ )
+import Data.Text
+ ( Text
+ )
import Data.Default
( def
)
@@ -17,13 +26,110 @@ import Network.Wai.Middleware.RequestLogger
import PaymentServer.Persistence
( memory
)
+import PaymentServer.Issuer
+ ( trivialIssue
+ , ristrettoIssue
+ )
import PaymentServer.Server
( paymentServerApp
)
+import Options.Applicative
+ ( Parser
+ , ParserInfo
+ , option
+ , auto
+ , optional
+ , long
+ , help
+ , value
+ , showDefault
+ , execParser
+ , info
+ , helper
+ , fullDesc
+ , progDesc
+ , header
+ , (<**>)
+ )
+import System.Exit
+ ( exitFailure
+ )
+import Data.Semigroup ((<>))
+
+data Issuer =
+ Trivial
+ | Ristretto
+ deriving (Show, Eq, Ord, Read)
+
+data Database =
+ Memory
+ | SQLite3
+ deriving (Show, Eq, Ord, Read)
+
+data ServerConfig = ServerConfig
+ { issuer :: Issuer
+ , signingKey :: Maybe Text
+ , database :: Database
+ , databasePath :: Maybe Text
+ }
+ deriving (Show, Eq)
+
+sample :: Parser ServerConfig
+sample = ServerConfig
+ <$> option auto
+ ( long "issuer"
+ <> help "Which issuer to use: trivial or ristretto"
+ <> showDefault
+ <> value Trivial )
+ <*> optional (option auto
+ ( long "signing-key"
+ <> help "The base64 encoded signing key (ristretto only)"
+ <> showDefault ) )
+ <*> option auto
+ ( long "database"
+ <> help "Which database to use: sqlite3 or memory"
+ <> showDefault
+ <> value Memory )
+ <*> optional ( option auto
+ ( long "database-path"
+ <> help "Path to on-disk database (sqlite3 only)"
+ <> showDefault ) )
+
+opts :: ParserInfo ServerConfig
+opts = info (sample <**> helper)
+ ( fullDesc
+ <> progDesc ""
+ <> header ""
+ )
+
main :: IO ()
-main = do
- db <- memory
- let app = paymentServerApp db
- logger <- mkRequestLogger $ def { outputFormat = Detailed True}
- run 8081 $ logger app
+main =
+ let
+ getIssuer ServerConfig{ issuer, signingKey } =
+ case (issuer, signingKey) of
+ (Trivial, Nothing) -> Right trivialIssue
+ (Ristretto, Just key) -> Right $ ristrettoIssue key
+ otherwise -> Left "invalid options"
+ getDatabase ServerConfig{ database, databasePath } =
+ case (database, databasePath) of
+ (Memory, Nothing) -> Right memory
+ otherwise -> 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
+ 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
diff --git a/src/PaymentServer/Server.hs b/src/PaymentServer/Server.hs
index 6eea6ab..973ef12 100644
--- a/src/PaymentServer/Server.hs
+++ b/src/PaymentServer/Server.hs
@@ -24,7 +24,7 @@ import PaymentServer.Redemption
, redemptionServer
)
import PaymentServer.Issuer
- ( trivialIssue
+ ( Issuer
)
import PaymentServer.Persistence
( VoucherDatabase
@@ -36,15 +36,15 @@ type PaymentServerAPI
:<|> "v1" :> "redeem" :> RedemptionAPI
-- | Create a server which uses the given database.
-paymentServer :: VoucherDatabase d => d -> Server PaymentServerAPI
-paymentServer d =
- stripeServer d
- :<|> redemptionServer trivialIssue d
+paymentServer :: VoucherDatabase d => Issuer -> d -> Server PaymentServerAPI
+paymentServer issuer database =
+ stripeServer database
+ :<|> redemptionServer issuer database
paymentServerAPI :: Proxy PaymentServerAPI
paymentServerAPI = Proxy
-- | Create a Servant Application which serves the payment server API using
-- the given database.
-paymentServerApp :: VoucherDatabase d => d -> Application
-paymentServerApp = serve paymentServerAPI . paymentServer
+paymentServerApp :: VoucherDatabase d => Issuer -> d -> Application
+paymentServerApp issuer = serve paymentServerAPI . paymentServer issuer
--
GitLab