diff --git a/PaymentServer.cabal b/PaymentServer.cabal index ebbcb7b59acf57c442131a0adab753ba01983769..723a1ba83f16ab2baa774d21f0442a68b5b8236e 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 318e8a0bfbd7812501bf50d6b5a2a22ca05617ac..267a4888b02da6f0114ac8c4854d049f993ad83e 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 7d9ee2a744eb96d4f977e728298e21da1385742a..041ea9a76ede624971e4f7fc4f3823c0b414fbf2 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 6eea6abed47c088abf55b9aea4b66bb3658c53c7..973ef126d9d005873016d075dedff5276796e8b9 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