From 9f72790df9b3b930cdbee912caa012e8a7beaaab Mon Sep 17 00:00:00 2001 From: James Burton Date: Mon, 8 Feb 2021 17:59:49 +0000 Subject: [PATCH 1/8] Added options to pass SSL certificate and key to yesod devel --- yesod-bin/Devel.hs | 15 ++++++++++----- yesod-bin/main.hs | 10 +++++++++- 2 files changed, 19 insertions(+), 6 deletions(-) diff --git a/yesod-bin/Devel.hs b/yesod-bin/Devel.hs index 901616f8..bb8d6c11 100644 --- a/yesod-bin/Devel.hs +++ b/yesod-bin/Devel.hs @@ -9,6 +9,7 @@ module Devel ) where import Control.Applicative ((<|>)) +import Control.Arrow ((&&&)) import UnliftIO (race_) import Control.Concurrent (threadDelay) import Control.Concurrent.STM @@ -18,6 +19,7 @@ import Control.Monad (forever, unless, void, import Data.ByteString (ByteString, isInfixOf) import qualified Data.ByteString.Lazy as LB import Conduit +import Data.Bitraversable (bisequence) import Data.FileEmbed (embedFile) import qualified Data.Map as Map import Data.Maybe (isJust) @@ -56,7 +58,7 @@ import Network.Wai (requestHeaderHost, responseLBS) import Network.Wai.Handler.Warp (defaultSettings, runSettings, setPort, setHost) -import Network.Wai.Handler.WarpTLS (runTLS, +import Network.Wai.Handler.WarpTLS (runTLS, tlsSettings, tlsSettingsMemory) import Network.Wai.Parse (parseHttpAccept) import Say @@ -126,6 +128,8 @@ data DevelOpts = DevelOpts , proxyTimeout :: Int , useReverseProxy :: Bool , develHost :: Maybe String + , certPath :: Maybe FilePath + , keyPath :: Maybe FilePath } deriving (Show, Eq) -- | Run a reverse proxy from the develPort and develTlsPort ports to @@ -170,10 +174,11 @@ reverseProxy opts appPortVar = do manager defaultSettings' = maybe id (setHost . fromString) (develHost opts) defaultSettings runProxyTls port app = do - let cert = $(embedFile "certificate.pem") - key = $(embedFile "key.pem") - tlsSettings = tlsSettingsMemory cert key - runTLS tlsSettings (setPort port defaultSettings') $ \req send -> do + let certDef = $(embedFile "certificate.pem") + keyDef = $(embedFile "key.pem") + certOpts = bisequence $ (certPath &&& keyPath) opts + theSettings = maybe (tlsSettingsMemory certDef keyDef) (uncurry tlsSettings) certOpts + runTLS theSettings (setPort port defaultSettings') $ \req send -> do let req' = req { requestHeaders = ("X-Forwarded-Proto", "https") diff --git a/yesod-bin/main.hs b/yesod-bin/main.hs index 3f3a071b..3cc1b2a9 100755 --- a/yesod-bin/main.hs +++ b/yesod-bin/main.hs @@ -30,12 +30,14 @@ data Command = Init [String] | Build { buildExtraArgs :: [String] } | Touch | Devel { develSuccessHook :: Maybe String - , develExtraArgs :: [String] + , develExtraArgs :: [String] , develPort :: Int , develTlsPort :: Int , proxyTimeout :: Int , noReverseProxy :: Bool , develHost :: Maybe String + , certPath :: Maybe FilePath + , keyPath :: Maybe FilePath } | DevelSignal | Test @@ -90,6 +92,8 @@ main = do , proxyTimeout = proxyTimeout , useReverseProxy = not noReverseProxy , develHost = develHost + , certPath = certPath + , keyPath = keyPath } develExtraArgs DevelSignal -> develSignal where @@ -167,6 +171,10 @@ develOptions = Devel <$> optStr ( long "success-hook" <> short 's' <> metavar "C <> help "Disable reverse proxy" ) <*> optStr (long "host" <> metavar "HOST" <> 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 = many (strOption ( long "extra-stack-arg" <> short 'e' <> metavar "ARG" From 045d05f7d6a7572704a7ac2d7d238e81dabe1ef7 Mon Sep 17 00:00:00 2001 From: James Burton Date: Mon, 8 Feb 2021 18:19:40 +0000 Subject: [PATCH 2/8] Bumped version --- yesod-bin/yesod-bin.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index a8535770..20da5ef8 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -1,5 +1,5 @@ name: yesod-bin -version: 1.6.0.6 +version: 1.6.1 license: MIT license-file: LICENSE author: Michael Snoyman From 52cf6339933a7f174f8723344b0dc3019b0f0a5f Mon Sep 17 00:00:00 2001 From: James Burton Date: Mon, 8 Feb 2021 22:42:26 +0000 Subject: [PATCH 3/8] Fixed indentation --- yesod-bin/Devel.hs | 44 ++++++++++++++++++++++---------------------- 1 file changed, 22 insertions(+), 22 deletions(-) diff --git a/yesod-bin/Devel.hs b/yesod-bin/Devel.hs index bb8d6c11..7e52a68f 100644 --- a/yesod-bin/Devel.hs +++ b/yesod-bin/Devel.hs @@ -174,28 +174,28 @@ reverseProxy opts appPortVar = do manager defaultSettings' = maybe id (setHost . fromString) (develHost opts) defaultSettings runProxyTls port app = do - let certDef = $(embedFile "certificate.pem") - keyDef = $(embedFile "key.pem") - certOpts = bisequence $ (certPath &&& keyPath) opts - theSettings = maybe (tlsSettingsMemory certDef keyDef) (uncurry tlsSettings) certOpts - runTLS theSettings (setPort port defaultSettings') $ \req send -> do - let req' = req - { requestHeaders - = ("X-Forwarded-Proto", "https") - -- Workaround for - -- https://github.com/yesodweb/wai/issues/478, where - -- the Host headers aren't set. Without this, generated - -- URLs from guestApproot are incorrect, see: - -- https://github.com/yesodweb/yesod-scaffold/issues/114 - : (case lookup "host" (requestHeaders req) of - Nothing -> - case requestHeaderHost req of - Just host -> (("Host", host):) - Nothing -> id - Just _ -> id) - (requestHeaders req) - } - app req' send + let certDef = $(embedFile "certificate.pem") + keyDef = $(embedFile "key.pem") + certOpts = bisequence $ (certPath &&& keyPath) opts + theSettings = maybe (tlsSettingsMemory certDef keyDef) (uncurry tlsSettings) certOpts + runTLS theSettings (setPort port defaultSettings') $ \req send -> do + let req' = req + { requestHeaders + = ("X-Forwarded-Proto", "https") + -- Workaround for + -- https://github.com/yesodweb/wai/issues/478, where + -- the Host headers aren't set. Without this, generated + -- URLs from guestApproot are incorrect, see: + -- https://github.com/yesodweb/yesod-scaffold/issues/114 + : (case lookup "host" (requestHeaders req) of + Nothing -> + case requestHeaderHost req of + Just host -> (("Host", host):) + Nothing -> id + Just _ -> id) + (requestHeaders req) + } + app req' send httpProxy = runSettings (setPort (develPort opts) defaultSettings') proxyApp httpsProxy = runProxyTls (develTlsPort opts) proxyApp say "Application can be accessed at:\n" From 8a4fb790cfcb72a4eb939592d7280e35c9a6e3a6 Mon Sep 17 00:00:00 2001 From: James Burton Date: Tue, 9 Feb 2021 12:07:56 +0000 Subject: [PATCH 4/8] Revert "Fixed indentation" This reverts commit 52cf6339933a7f174f8723344b0dc3019b0f0a5f. --- yesod-bin/Devel.hs | 44 ++++++++++++++++++++++---------------------- 1 file changed, 22 insertions(+), 22 deletions(-) diff --git a/yesod-bin/Devel.hs b/yesod-bin/Devel.hs index 7e52a68f..bb8d6c11 100644 --- a/yesod-bin/Devel.hs +++ b/yesod-bin/Devel.hs @@ -174,28 +174,28 @@ reverseProxy opts appPortVar = do manager defaultSettings' = maybe id (setHost . fromString) (develHost opts) defaultSettings runProxyTls port app = do - let certDef = $(embedFile "certificate.pem") - keyDef = $(embedFile "key.pem") - certOpts = bisequence $ (certPath &&& keyPath) opts - theSettings = maybe (tlsSettingsMemory certDef keyDef) (uncurry tlsSettings) certOpts - runTLS theSettings (setPort port defaultSettings') $ \req send -> do - let req' = req - { requestHeaders - = ("X-Forwarded-Proto", "https") - -- Workaround for - -- https://github.com/yesodweb/wai/issues/478, where - -- the Host headers aren't set. Without this, generated - -- URLs from guestApproot are incorrect, see: - -- https://github.com/yesodweb/yesod-scaffold/issues/114 - : (case lookup "host" (requestHeaders req) of - Nothing -> - case requestHeaderHost req of - Just host -> (("Host", host):) - Nothing -> id - Just _ -> id) - (requestHeaders req) - } - app req' send + let certDef = $(embedFile "certificate.pem") + keyDef = $(embedFile "key.pem") + certOpts = bisequence $ (certPath &&& keyPath) opts + theSettings = maybe (tlsSettingsMemory certDef keyDef) (uncurry tlsSettings) certOpts + runTLS theSettings (setPort port defaultSettings') $ \req send -> do + let req' = req + { requestHeaders + = ("X-Forwarded-Proto", "https") + -- Workaround for + -- https://github.com/yesodweb/wai/issues/478, where + -- the Host headers aren't set. Without this, generated + -- URLs from guestApproot are incorrect, see: + -- https://github.com/yesodweb/yesod-scaffold/issues/114 + : (case lookup "host" (requestHeaders req) of + Nothing -> + case requestHeaderHost req of + Just host -> (("Host", host):) + Nothing -> id + Just _ -> id) + (requestHeaders req) + } + app req' send httpProxy = runSettings (setPort (develPort opts) defaultSettings') proxyApp httpsProxy = runProxyTls (develTlsPort opts) proxyApp say "Application can be accessed at:\n" From 818e8e3781b18dd6f88fb2bb9bbfa78ea1f1f551 Mon Sep 17 00:00:00 2001 From: James Burton Date: Tue, 9 Feb 2021 17:38:50 +0000 Subject: [PATCH 5/8] Parser now requires that both cert/key be provided or neither --- yesod-bin/Devel.hs | 8 ++++---- yesod-bin/main.hs | 20 ++++++++++++-------- 2 files changed, 16 insertions(+), 12 deletions(-) diff --git a/yesod-bin/Devel.hs b/yesod-bin/Devel.hs index bb8d6c11..37f22427 100644 --- a/yesod-bin/Devel.hs +++ b/yesod-bin/Devel.hs @@ -128,8 +128,7 @@ data DevelOpts = DevelOpts , proxyTimeout :: Int , useReverseProxy :: Bool , develHost :: Maybe String - , certPath :: Maybe FilePath - , keyPath :: Maybe FilePath + , cert :: Maybe (FilePath, FilePath) } deriving (Show, Eq) -- | Run a reverse proxy from the develPort and develTlsPort ports to @@ -176,8 +175,9 @@ reverseProxy opts appPortVar = do runProxyTls port app = do let certDef = $(embedFile "certificate.pem") keyDef = $(embedFile "key.pem") - certOpts = bisequence $ (certPath &&& keyPath) opts - theSettings = maybe (tlsSettingsMemory certDef keyDef) (uncurry tlsSettings) certOpts + theSettings = case cert opts of + Nothing -> tlsSettingsMemory certDef keyDef + Just (c,k) -> tlsSettings c k runTLS theSettings (setPort port defaultSettings') $ \req send -> do let req' = req { requestHeaders diff --git a/yesod-bin/main.hs b/yesod-bin/main.hs index 3cc1b2a9..a137c68d 100755 --- a/yesod-bin/main.hs +++ b/yesod-bin/main.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RecordWildCards #-} module Main (main) where +import Data.Bitraversable (bisequence) import Data.Monoid import Data.Version (showVersion) import Options.Applicative @@ -36,8 +37,7 @@ data Command = Init [String] , proxyTimeout :: Int , noReverseProxy :: Bool , develHost :: Maybe String - , certPath :: Maybe FilePath - , keyPath :: Maybe FilePath + , cert :: Maybe (FilePath, FilePath) } | DevelSignal | Test @@ -92,8 +92,7 @@ main = do , proxyTimeout = proxyTimeout , useReverseProxy = not noReverseProxy , develHost = develHost - , certPath = certPath - , keyPath = keyPath + , cert = cert } develExtraArgs DevelSignal -> develSignal where @@ -171,10 +170,15 @@ develOptions = Devel <$> optStr ( long "success-hook" <> short 's' <> metavar "C <> help "Disable reverse proxy" ) <*> optStr (long "host" <> metavar "HOST" <> 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") + <*> optionPair + (strOption (long "cert" <> metavar "CERT" + <> help "Path to TLS certificate file, requires that --key is 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 = many (strOption ( long "extra-stack-arg" <> short 'e' <> metavar "ARG" From 8d0866f08b4658379a9b0334cd776b787da85c67 Mon Sep 17 00:00:00 2001 From: James Burton Date: Tue, 9 Feb 2021 17:41:49 +0000 Subject: [PATCH 6/8] Updated changelog --- yesod-bin/ChangeLog.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/yesod-bin/ChangeLog.md b/yesod-bin/ChangeLog.md index c739d782..a7780c0a 100644 --- a/yesod-bin/ChangeLog.md +++ b/yesod-bin/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yesod-bin +## 1.6.1 + +Added command line options `cert` and `key` to allow TLS certificate and key files to be passed to `yesod devel` [#1717](https://github.com/yesodweb/yesod/pull/1717) + ## 1.6.0.6 Fix the `add-handler` subcommand to support both the old default routes filename (`routes`) and the new one (`routes.yesodroutes`) [#1688](https://github.com/yesodweb/yesod/pull/1688) From 4699479bbb81b9f1da27a740e168b3bf060b961d Mon Sep 17 00:00:00 2001 From: James Burton Date: Tue, 9 Feb 2021 17:52:55 +0000 Subject: [PATCH 7/8] Removed unused imports --- yesod-bin/Devel.hs | 2 -- yesod-bin/main.hs | 1 - 2 files changed, 3 deletions(-) diff --git a/yesod-bin/Devel.hs b/yesod-bin/Devel.hs index 37f22427..658119be 100644 --- a/yesod-bin/Devel.hs +++ b/yesod-bin/Devel.hs @@ -9,7 +9,6 @@ module Devel ) where import Control.Applicative ((<|>)) -import Control.Arrow ((&&&)) import UnliftIO (race_) import Control.Concurrent (threadDelay) import Control.Concurrent.STM @@ -19,7 +18,6 @@ import Control.Monad (forever, unless, void, import Data.ByteString (ByteString, isInfixOf) import qualified Data.ByteString.Lazy as LB import Conduit -import Data.Bitraversable (bisequence) import Data.FileEmbed (embedFile) import qualified Data.Map as Map import Data.Maybe (isJust) diff --git a/yesod-bin/main.hs b/yesod-bin/main.hs index a137c68d..38ccf51b 100755 --- a/yesod-bin/main.hs +++ b/yesod-bin/main.hs @@ -2,7 +2,6 @@ {-# LANGUAGE RecordWildCards #-} module Main (main) where -import Data.Bitraversable (bisequence) import Data.Monoid import Data.Version (showVersion) import Options.Applicative From a068bbdb8ce1b4cc70e7eb2c6607d784a2a97236 Mon Sep 17 00:00:00 2001 From: James Burton Date: Wed, 10 Feb 2021 13:54:22 +0000 Subject: [PATCH 8/8] Simplified implementation of cert/key parser option --- yesod-bin/main.hs | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) diff --git a/yesod-bin/main.hs b/yesod-bin/main.hs index 38ccf51b..9e5d7d66 100755 --- a/yesod-bin/main.hs +++ b/yesod-bin/main.hs @@ -169,15 +169,11 @@ develOptions = Devel <$> optStr ( long "success-hook" <> short 's' <> metavar "C <> help "Disable reverse proxy" ) <*> optStr (long "host" <> metavar "HOST" <> help "Host interface to bind to; IP address, '*' for all interfaces, '*4' for IP4, '*6' for IP6") - <*> optionPair - (strOption (long "cert" <> metavar "CERT" - <> help "Path to TLS certificate file, requires that --key is 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 + <*> optional ( (,) + <$> strOption (long "cert" <> metavar "CERT" + <> help "Path to TLS certificate file, requires that --key is also defined") + <*> strOption (long "key" <> metavar "KEY" + <> help "Path to TLS key file, requires that --cert is also defined") ) extraStackArgs :: Parser [String] extraStackArgs = many (strOption ( long "extra-stack-arg" <> short 'e' <> metavar "ARG"