haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Parser now requires that both cert/key be provided or neither

Browse Source
This commit is contained in:
James Burton 2021-02-09 17:38:50 +00:00
parent 8a4fb790cf
commit 818e8e3781
2 changed files with 16 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
yesod-bin/Devel.hs
View File

@ -128,8 +128,7 @@ data DevelOpts = DevelOpts
, proxyTimeout :: Int , proxyTimeout :: Int
, useReverseProxy :: Bool , useReverseProxy :: Bool
, develHost :: Maybe String , develHost :: Maybe String
, certPath :: Maybe FilePath , cert :: Maybe (FilePath, FilePath)
, keyPath :: Maybe FilePath
} deriving (Show, Eq) } deriving (Show, Eq)
-- | Run a reverse proxy from the develPort and develTlsPort ports to -- | Run a reverse proxy from the develPort and develTlsPort ports to
@ -176,8 +175,9 @@ reverseProxy opts appPortVar = do
runProxyTls port app = do runProxyTls port app = do
let certDef = $(embedFile "certificate.pem") let certDef = $(embedFile "certificate.pem")
keyDef = $(embedFile "key.pem") keyDef = $(embedFile "key.pem")
certOpts = bisequence $ (certPath &&& keyPath) opts theSettings = case cert opts of
theSettings = maybe (tlsSettingsMemory certDef keyDef) (uncurry tlsSettings) certOpts Nothing -> tlsSettingsMemory certDef keyDef
Just (c,k) -> tlsSettings c k
runTLS theSettings (setPort port defaultSettings') $ \req send -> do runTLS theSettings (setPort port defaultSettings') $ \req send -> do
let req' = req let req' = req
{ requestHeaders { requestHeaders

20
yesod-bin/main.hs
View File

@ -2,6 +2,7 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
module Main (main) where module Main (main) where
import Data.Bitraversable (bisequence)
import Data.Monoid import Data.Monoid
import Data.Version (showVersion) import Data.Version (showVersion)
import Options.Applicative import Options.Applicative
@ -36,8 +37,7 @@ data Command = Init [String]
, proxyTimeout :: Int , proxyTimeout :: Int
, noReverseProxy :: Bool , noReverseProxy :: Bool
, develHost :: Maybe String , develHost :: Maybe String
, certPath :: Maybe FilePath , cert :: Maybe (FilePath, FilePath)
, keyPath :: Maybe FilePath
} }
| DevelSignal | DevelSignal
| Test | Test
@ -92,8 +92,7 @@ main = do
, proxyTimeout = proxyTimeout , proxyTimeout = proxyTimeout
, useReverseProxy = not noReverseProxy , useReverseProxy = not noReverseProxy
, develHost = develHost , develHost = develHost
, certPath = certPath , cert = cert
, keyPath = keyPath
} develExtraArgs } develExtraArgs
DevelSignal -> develSignal DevelSignal -> develSignal
where where
@ -171,10 +170,15 @@ develOptions = Devel <$> optStr ( long "success-hook" <> short 's' <> metavar "C
<> help "Disable reverse proxy" ) <> help "Disable reverse proxy" )
<*> optStr (long "host" <> metavar "HOST" <*> optStr (long "host" <> metavar "HOST"
<> help "Host interface to bind to; IP address, '*' for all interfaces, '*4' for IP4, '*6' for IP6") <> help "Host interface to bind to; IP address, '*' for all interfaces, '*4' for IP4, '*6' for IP6")
<*> optStr (long "cert" <> metavar "CERT" <*> optionPair
<> help "Path to TLS certificate file, does nothing if --key is not also defined") (strOption (long "cert" <> metavar "CERT"
<*> optStr (long "key" <> metavar "KEY" <> help "Path to TLS certificate file, requires that --key is also defined"))
<> help "Path to TLS key file, does nothing if --cert is not also defined") (strOption (long "key" <> metavar "KEY"
<> help "Path to TLS key file, requires that --cert is also defined"))
optionPair :: Parser a -> Parser b -> Parser (Maybe (a,b))
optionPair pa pb = Just <$> liftA2 (,) pa pb
<|> pure Nothing
extraStackArgs :: Parser [String] extraStackArgs :: Parser [String]
extraStackArgs = many (strOption ( long "extra-stack-arg" <> short 'e' <> metavar "ARG" extraStackArgs = many (strOption ( long "extra-stack-arg" <> short 'e' <> metavar "ARG"