From 9e8ec47501ef5e6b3c99ddc2f49f5b247686b6c8 Mon Sep 17 00:00:00 2001
From: Jon Schoning <jonschoning@gmail.com>
Date: Tue, 28 Sep 2021 22:07:53 -0500
Subject: [PATCH] add app setting enable SSL_ONLY

---
 config/settings.yml |  2 ++
 src/Foundation.hs   | 29 +++++++++++++++++++++++++----
 src/Settings.hs     |  6 +++++-
 3 files changed, 32 insertions(+), 5 deletions(-)

diff --git a/config/settings.yml b/config/settings.yml
index f676b1c..7b708a2 100644
--- a/config/settings.yml
+++ b/config/settings.yml
@@ -41,3 +41,5 @@ archive-socks-proxy-host: "_env:ARCHIVE_SOCKS_PROXY_HOST"
 archive-socks-proxy-port: "_env:ARCHIVE_SOCKS_PROXY_PORT"
 
 source-code-uri: "_env:SOURCE_CODE_URI:https://github.com/jonschoning/espial"
+
+ssl-only: "_env:SSL_ONLY" # false
diff --git a/src/Foundation.hs b/src/Foundation.hs
index 26e0be8..be0eb18 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# OPTIONS_GHC -fno-warn-unused-matches #-}
 
 module Foundation where
@@ -41,6 +42,9 @@ instance YesodPersist App where
 instance YesodPersistRunner App where
     getDBRunner = defaultGetDBRunner appConnPool
 
+session_timeout_minutes :: Int
+session_timeout_minutes = 10080 -- (7 days)
+
 -- Yesod
 
 instance Yesod App where
@@ -49,11 +53,28 @@ instance Yesod App where
             Nothing -> getApprootText guessApproot app req
             Just root -> root
 
-    makeSessionBackend _ = Just <$> defaultClientSessionBackend
-        10080 -- min (7 days)
-        "config/client_session_key.aes"
+    makeSessionBackend :: App -> IO (Maybe SessionBackend)
+    makeSessionBackend App {appSettings} = do
+      backend <-
+        defaultClientSessionBackend
+          session_timeout_minutes
+          "config/client_session_key.aes"
+      maybeSSLOnly $ pure (Just backend)
+      where
+        maybeSSLOnly =
+          if appSSLOnly appSettings
+            then sslOnlySessions
+            else id
 
-    yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
+    yesodMiddleware :: HandlerFor App res -> HandlerFor App res
+    yesodMiddleware = maybeSSLOnly . defaultYesodMiddleware . defaultCsrfMiddleware
+      where
+        maybeSSLOnly handler = do
+          yesod <- getYesod
+          (if appSSLOnly (appSettings yesod)
+             then sslOnlyMiddleware session_timeout_minutes
+             else id)
+            handler
 
     defaultLayout widget = do
         req <- getRequest
diff --git a/src/Settings.hs b/src/Settings.hs
index 2e4b3cb..100258e 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -64,6 +64,8 @@ data AppSettings = AppSettings
 
     , appSourceCodeUri                :: Maybe Text
     -- ^ Uri to app source code
+
+    , appSSLOnly :: Bool
     }
 
 instance FromJSON AppSettings where
@@ -96,7 +98,9 @@ instance FromJSON AppSettings where
 
         appArchiveSocksProxyHost   <- o .:? "archive-socks-proxy-host"
         appArchiveSocksProxyPort   <- o .:? "archive-socks-proxy-port"
-        appSourceCodeUri          <- o .:? "source-code-uri"
+        appSourceCodeUri           <- o .:? "source-code-uri"
+
+        appSSLOnly                 <- fromMaybe False <$> o .:? "ssl-only"
 
         return AppSettings {..}