From c41f1183e0eb4c4b140485cd30d285af837f50ba Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@riseup.net>
Date: Mon, 4 Mar 2019 09:06:23 +0000
Subject: [PATCH] Display instance host at the top of all pages

---
 config/settings-default.yaml     | 2 ++
 src/Vervis/Foundation.hs         | 1 +
 src/Vervis/Settings.hs           | 4 ++++
 templates/default-layout.cassius | 4 ++++
 templates/default-layout.hamlet  | 3 +++
 5 files changed, 14 insertions(+)

diff --git a/config/settings-default.yaml b/config/settings-default.yaml
index 52d1f11..eeb8037 100644
--- a/config/settings-default.yaml
+++ b/config/settings-default.yaml
@@ -24,6 +24,8 @@ ip-from-header: "_env:IP_FROM_HEADER:false"
 # Uncomment to set an explicit approot
 #approot:        "_env:APPROOT:http://localhost:3000"
 
+instance-host:  "_env:INSTANCE_HOST:localhost"
+
 # Encryption key file for encrypting the session cookie sent to clients
 client-session-key:     config/client_session_key.aes
 
diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs
index d393883..fcdcbfe 100644
--- a/src/Vervis/Foundation.hs
+++ b/src/Vervis/Foundation.hs
@@ -174,6 +174,7 @@ instance Yesod App where
         pc <- widgetToPageContent $ do
             setTitle $ toHtml $
                 T.intercalate " → " (map snd bcs) <> " → " <> title
+            let instanceHost = appInstanceHost $ appSettings master
             $(widgetFile "default-layout")
         withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
 
diff --git a/src/Vervis/Settings.hs b/src/Vervis/Settings.hs
index a6a2e5a..cccbf45 100644
--- a/src/Vervis/Settings.hs
+++ b/src/Vervis/Settings.hs
@@ -59,6 +59,9 @@ data AppSettings = AppSettings
       -- | Base for all generated URLs. If @Nothing@, determined from the
       -- request headers.
     , appRoot                   :: Maybe Text
+      -- | The instance's host (e.g. \"dev.angeley.es\"), currently used just
+      -- for display.
+    , appInstanceHost           :: Text
       -- | Host/interface the server should bind to.
     , appHost                   :: HostPreference
       -- | Port to listen on
@@ -143,6 +146,7 @@ instance FromJSON AppSettings where
         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"
         appIpFromHeader           <- o .: "ip-from-header"
diff --git a/templates/default-layout.cassius b/templates/default-layout.cassius
index dad3bbc..bfa60b4 100644
--- a/templates/default-layout.cassius
+++ b/templates/default-layout.cassius
@@ -57,3 +57,7 @@ input[type="submit"]
     padding:       0.618em
     border:        none
     border-radius: 0.618em
+
+.instance
+    color: #{light blue}
+    font:  180% monospace
diff --git a/templates/default-layout.hamlet b/templates/default-layout.hamlet
index b996966..f4dfd63 100644
--- a/templates/default-layout.hamlet
+++ b/templates/default-layout.hamlet
@@ -33,6 +33,9 @@ $nothing
   UPDATE: Federation is coming!
   <a href=@{OutboxR}>Very early testing
 
+<.instance>
+  Vervis @ #{instanceHost}
+
 ^{breadcrumbsW}
 
 $maybe msg <- mmsg