From be25e87b69e05221e520b910637a01417b0f4d22 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@fpcomplete.com>
Date: Tue, 2 Feb 2016 07:56:30 +0000
Subject: [PATCH] Force SSL in production (fixes #150)

---
 Application.hs      | 10 ++++++++--
 Settings.hs         |  5 ++++-
 config/settings.yml |  4 +++-
 3 files changed, 15 insertions(+), 4 deletions(-)

diff --git a/Application.hs b/Application.hs
index a91eaf6..846bfde 100644
--- a/Application.hs
+++ b/Application.hs
@@ -12,6 +12,7 @@ import           Import hiding (catch)
 import           Language.Haskell.TH.Syntax (Loc(..))
 import           Network.Wai (Middleware, responseLBS)
 import           Network.Wai.Logger (clockDateCacher)
+import           Network.Wai.Middleware.ForceSSL (forceSSL)
 import           Network.Wai.Middleware.RequestLogger
     ( mkRequestLogger, outputFormat, OutputFormat (..), IPAddrSource (..), destination
     )
@@ -67,7 +68,7 @@ makeApplication echo@True conf = do
        { destination = RequestLogger.Callback (const (return ()))
        }
    Echo.clear
-   return (logWare (defaultMiddlewaresNoLogging app),logFunc)
+   return (forceSSL' conf $ logWare (defaultMiddlewaresNoLogging app),logFunc)
  where logFunc (Loc filename' _pkg _mod (line,_) _) source level str =
            Echo.write (filename',line) (show source ++ ": " ++ show level ++ ": " ++ toStr str)
        toStr = unpack . decodeUtf8 . fromLogStr
@@ -84,9 +85,14 @@ makeApplication echo@False conf = do
     -- Create the WAI application and apply middlewares
     app <- toWaiAppPlain foundation
     let logFunc = messageLoggerSource foundation (appLogger foundation)
-        middleware = nicerExceptions . logWare . defaultMiddlewaresNoLogging
+        middleware = forceSSL' conf . nicerExceptions . logWare . defaultMiddlewaresNoLogging
     return (middleware app, logFunc)
 
+forceSSL' :: AppConfig DefaultEnv Extra -> Middleware
+forceSSL' app
+    | extraForceSsl $ appExtra app = forceSSL
+    | otherwise = id
+
 nicerExceptions :: Middleware
 nicerExceptions app req send = catch (app req send) $ \e -> do
     let text = "Exception thrown to Warp: " ++ tshow (e :: SomeException)
diff --git a/Settings.hs b/Settings.hs
index 883dc2d..0c9d94d 100644
--- a/Settings.hs
+++ b/Settings.hs
@@ -61,8 +61,11 @@ widgetFile = (if development then widgetFileReload
 data Extra = Extra
     { extraDevDownload :: !Bool
     -- ^ Controls how Git and database resources are downloaded (True means less downloading)
+    , extraForceSsl :: !Bool
     }
     deriving Show
 
 parseExtra :: DefaultEnv -> Object -> Parser Extra
-parseExtra _ o = Extra <$> o .:? "dev-download" .!= False
+parseExtra _ o = Extra
+    <$> o .:? "dev-download" .!= False
+    <*> o .: "force-ssl"
diff --git a/config/settings.yml b/config/settings.yml
index 0f9f452..ea42883 100644
--- a/config/settings.yml
+++ b/config/settings.yml
@@ -2,6 +2,7 @@ Default: &defaults
   host: "*4" # any IPv4 host
   port: 3000
   approot: "http://localhost:3000"
+  force-ssl: false
 
 Development:
   <<: *defaults
@@ -14,5 +15,6 @@ Staging:
   <<: *defaults
 
 Production:
-  approot: "http://www.stackage.org"
+  approot: "https://www.stackage.org"
+  force-ssl: true
   <<: *defaults