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

Added options to pass SSL certificate and key to yesod devel

Browse Source
This commit is contained in:
James Burton 2021-02-08 17:59:49 +00:00
parent 1c471acfd5
commit 9f72790df9
2 changed files with 19 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
yesod-bin/Devel.hs
View File

@ -9,6 +9,7 @@ module Devel
) where ) where
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import Control.Arrow ((&&&))
import UnliftIO (race_) import UnliftIO (race_)
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import Control.Concurrent.STM import Control.Concurrent.STM
@ -18,6 +19,7 @@ import Control.Monad (forever, unless, void,
import Data.ByteString (ByteString, isInfixOf) import Data.ByteString (ByteString, isInfixOf)
import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString.Lazy as LB
import Conduit import Conduit
import Data.Bitraversable (bisequence)
import Data.FileEmbed (embedFile) import Data.FileEmbed (embedFile)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe (isJust) import Data.Maybe (isJust)
@ -56,7 +58,7 @@ import Network.Wai (requestHeaderHost,
responseLBS) responseLBS)
import Network.Wai.Handler.Warp (defaultSettings, runSettings, import Network.Wai.Handler.Warp (defaultSettings, runSettings,
setPort, setHost) setPort, setHost)
import Network.Wai.Handler.WarpTLS (runTLS, import Network.Wai.Handler.WarpTLS (runTLS, tlsSettings,
tlsSettingsMemory) tlsSettingsMemory)
import Network.Wai.Parse (parseHttpAccept) import Network.Wai.Parse (parseHttpAccept)
import Say import Say
@ -126,6 +128,8 @@ data DevelOpts = DevelOpts
, proxyTimeout :: Int , proxyTimeout :: Int
, useReverseProxy :: Bool , useReverseProxy :: Bool
, develHost :: Maybe String , develHost :: Maybe String
, certPath :: Maybe 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
@ -170,10 +174,11 @@ reverseProxy opts appPortVar = do
manager manager
defaultSettings' = maybe id (setHost . fromString) (develHost opts) defaultSettings defaultSettings' = maybe id (setHost . fromString) (develHost opts) defaultSettings
runProxyTls port app = do runProxyTls port app = do
let cert = $(embedFile "certificate.pem") let certDef = $(embedFile "certificate.pem")
key = $(embedFile "key.pem") keyDef = $(embedFile "key.pem")
tlsSettings = tlsSettingsMemory cert key certOpts = bisequence $ (certPath &&& keyPath) opts
runTLS tlsSettings (setPort port defaultSettings') $ \req send -> do theSettings = maybe (tlsSettingsMemory certDef keyDef) (uncurry tlsSettings) certOpts
runTLS theSettings (setPort port defaultSettings') $ \req send -> do
let req' = req let req' = req
{ requestHeaders { requestHeaders
= ("X-Forwarded-Proto", "https") = ("X-Forwarded-Proto", "https")

10
yesod-bin/main.hs
View File

@ -30,12 +30,14 @@ data Command = Init [String]
| Build { buildExtraArgs :: [String] } | Build { buildExtraArgs :: [String] }
| Touch | Touch
| Devel { develSuccessHook :: Maybe String | Devel { develSuccessHook :: Maybe String
, develExtraArgs :: [String] , develExtraArgs :: [String]
, develPort :: Int , develPort :: Int
, develTlsPort :: Int , develTlsPort :: Int
, proxyTimeout :: Int , proxyTimeout :: Int
, noReverseProxy :: Bool , noReverseProxy :: Bool
, develHost :: Maybe String , develHost :: Maybe String
, certPath :: Maybe FilePath
, keyPath :: Maybe FilePath
} }
| DevelSignal | DevelSignal
| Test | Test
@ -90,6 +92,8 @@ main = do
, proxyTimeout = proxyTimeout , proxyTimeout = proxyTimeout
, useReverseProxy = not noReverseProxy , useReverseProxy = not noReverseProxy
, develHost = develHost , develHost = develHost
, certPath = certPath
, keyPath = keyPath
} develExtraArgs } develExtraArgs
DevelSignal -> develSignal DevelSignal -> develSignal
where where
@ -167,6 +171,10 @@ 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"
<> help "Path to TLS certificate file, does nothing if --key is not also defined")
<*> optStr (long "key" <> metavar "KEY"
<> help "Path to TLS key file, does nothing if --cert is not also defined")
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"