Automatically set approot to https://HOST and require Host header to match

config/settings-default.yaml

@@ -20,10 +20,10 @@ http-port:      "_env:PORT:3000"
 
 ip-from-header: "_env:IP_FROM_HEADER:false"
 
-# Default behavior: determine the application root from the request headers.
+# The instance's host (e.g. "dev.angeley.es"). Used for determining which
-# Uncomment to set an explicit approot
+# requests are federated and which are for this instance, and for generating
-#approot:        "_env:APPROOT:http://localhost:3000"
+# URLs. The database relies on this value, and you shouldn't change it once
-
+# you deploy an instance.
 instance-host:  "_env:INSTANCE_HOST:localhost"
 
 # Encryption key file for encrypting the session cookie sent to clients

src/Vervis/Foundation.hs

@@ -125,10 +125,9 @@ type AppDB = YesodDB App
 instance Yesod App where
     -- Controls the base of generated URLs. For more information on modifying,
     -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
-    approot = ApprootRequest $ \app req ->
+    approot = ApprootMaster $ mkroot . appInstanceHost . appSettings
-        case appRoot $ appSettings app of
+        where
-            Nothing -> getApprootText guessApproot app req
+        mkroot h = "https://" <> h
-            Just root -> root
 
     -- Store session data on the client in encrypted cookies,
     -- default session idle timeout is 120 minutes
@@ -160,7 +159,21 @@ instance Yesod App where
                 defaultCsrfHeaderName
                 defaultCsrfParamName
           )
+        . ( \ handler -> do
+                host <- getsYesod $ appInstanceHost . appSettings
+                bs <- lookupHeaders hHost
+                case bs of
+                    [b] | b == encodeUtf8 host -> handler
+                    _ -> invalidArgs [hostMismatch host bs]
+          )
         . defaultYesodMiddleware
+        where
+        hostMismatch h l = T.concat
+            [ "Request host mismatch: Expected "
+            , h
+            , " but instead got "
+            , T.pack (show l)
+            ]
 
     defaultLayout widget = do
         master <- getYesod

src/Vervis/Secure.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2018 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -31,6 +31,9 @@
 -- approach here is to rely on the configured approot: If you use a reverse
 -- proxy, specify the approot in your web app settings file, otherwise only the
 -- request itself will be consulted.
+--
+-- UPDATE: There's no optional approot setting, we always assume HTTPS. So
+-- 'getSecure' simply always returns 'True'.
 module Vervis.Secure
     ( getSecure
     )
@@ -49,7 +52,8 @@ import Vervis.Foundation
 import Vervis.Settings
 
 getSecure :: Handler Bool
-getSecure = do
+getSecure = return True
+    {-
     let detectScheme t =
             case T.take 5 t of
                 "https" -> Just True
@@ -59,3 +63,4 @@ getSecure = do
     case msec of
         Nothing  -> isSecure <$> waiRequest
         Just sec -> return sec
+    -}

src/Vervis/Settings.hs

@@ -56,11 +56,10 @@ data AppSettings = AppSettings
       -- | Maximal number of keys (personal keys or usage of shared keys) to
       -- remember cached in our database per remote actor.
     , appMaxActorKeys           :: Maybe Int
-      -- | Base for all generated URLs. If @Nothing@, determined from the
+      -- | The instance's host (e.g. \"dev.angeley.es\"). Used for determining
-      -- request headers.
+      -- which requests are remote and which are for this instance, and for
-    , appRoot                   :: Maybe Text
+      -- generating URLs. The database relies on this value, and you shouldn't
-      -- | The instance's host (e.g. \"dev.angeley.es\"), currently used just
+      -- change it once you deploy an instance.
-      -- for display.
     , appInstanceHost           :: Text
       -- | Host/interface the server should bind to.
     , appHost                   :: HostPreference
@@ -148,7 +147,6 @@ instance FromJSON AppSettings where
         appDatabaseConf           <- o .: "database"
         appMaxInstanceKeys        <- o .:? "max-instance-keys"
         appMaxActorKeys           <- o .:? "max-actor-keys"
-        appRoot                   <- o .:? "approot"
         appInstanceHost           <- o .: "instance-host"
         appHost                   <- fromString <$> o .: "host"
         appPort                   <- o .: "http-port"