From 7fdfb25ce0d529e61d91ad105d191d515c5c8dd2 Mon Sep 17 00:00:00 2001
From: rnhmjoj <rnhmjoj@inventati.org>
Date: Wed, 6 Nov 2019 19:36:31 +0100
Subject: [PATCH] fix the https redirection

---
 src/Application.hs |  7 +++++++
 src/Main.hs        | 29 ++++++++++++++++-------------
 2 files changed, 23 insertions(+), 13 deletions(-)

diff --git a/src/Application.hs b/src/Application.hs
index 333d0e7..05182f8 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -100,6 +100,13 @@ type API =
 breve :: FilePath -> Url -> UrlTable -> Application
 breve static url table = serve (Proxy :: Proxy Breve) (breveServer static url table)
 
+-- | Empty application
+--
+-- This app does *nothing* but it's useful nonetheless:
+-- it will be used as a basis to run the 'forceSSL'
+-- middleware.
+emptyApp :: Application
+emptyApp = serve (Proxy :: Proxy EmptyAPI) emptyServer
 
 -- * Handlers
 
diff --git a/src/Main.hs b/src/Main.hs
index 58d5c9d..d71418e 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -19,24 +19,26 @@ import Data.String     (IsString(..))
 import Data.Maybe      (listToMaybe)
 
 -- IO
+import Control.Monad      (when, void)
+import Control.Concurrent (forkIO)
 import System.Environment (getArgs)
-import Data.Text.IO        as T
+import Data.Text.IO       as T
 
 -- Web server
 import Servant                      (Application)
-import Network.Wai.Handler.Warp     (defaultSettings, setPort, setHost)
+import Network.Wai.Handler.Warp     (run, defaultSettings, setPort, setHost)
 import Network.Wai.Handler.WarpTLS  (runTLS, TLSSettings)
 
 -- Middlewares
-import Network.Wai.Middleware.ForceSSL      (forceSSL)
 import Network.Wai.Middleware.RequestLogger (logStdout)
+import Network.Wai.Middleware.ForceSSL      (forceSSL)
 
 
 -- * Helpers
 
 -- | Runs Breve on the Warp webserver
-run :: AppSettings -> Application -> IO ()
-run (AppSettings{..}) =
+runApp :: AppSettings -> Application -> IO ()
+runApp (AppSettings{..}) =
   runTLS tlsSettings warpSettings
   where
     host = unpack bindHost
@@ -54,13 +56,14 @@ main = do
   table                    <- load urlTable
   static                   <- getDataFileName "static/"
 
-  -- Middlewares are just functions of type
-  -- (Application -> Application). We use a couple here
-  -- to add requests logging and HTTPS redirection.
-  let
-    middlewares =
-      logStdout .
-      (if bindPort == 433 then forceSSL else id)
+  -- Redirect from HTTP to HTTPS when listening
+  -- on the standard port
+  when (bindPort == 443) $ void $
+    forkIO (run 80 $ forceSSL emptyApp)
+
+  -- Middlewares are functions (Application -> Application).
+  -- We use one here to add requests
+  let middlewares = logStdout
 
   T.putStrLn ("Serving on " <> bindUrl)
-  run config (middlewares $ breve static bindUrl table)
+  runApp config (middlewares $ breve static bindUrl table)