From 3bf77d7c3144b16d55f35998dddc0d67bb8c17b2 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Tue, 7 Jun 2022 21:38:00 +0200
Subject: ...

---
 overlays/spm/server/Spm/Server.hs | 16 ++++++++++++----
 1 file changed, 12 insertions(+), 4 deletions(-)

(limited to 'overlays/spm/server/Spm')

diff --git a/overlays/spm/server/Spm/Server.hs b/overlays/spm/server/Spm/Server.hs
index 1f785999..0dd3e810 100644
--- a/overlays/spm/server/Spm/Server.hs
+++ b/overlays/spm/server/Spm/Server.hs
@@ -114,6 +114,7 @@ type SpmServerApi =    Header' '[Required, Strict] "SPM-Domain" MailDomain
                     :> AuthProtect "spm_mailbox"
                     :> SpmApi
                :<|>    "ui" :> Raw
+               :<|>    GetNoContent
 
 spmServerApi :: Proxy SpmServerApi
 spmServerApi = Proxy
@@ -183,11 +184,15 @@ mkSpmApp = do
 
       spmServer' = spmServer
               :<|> Tagged uiServer
+              :<|> uiRedirect
 
     logger <- askLoggerIO
     return $ serveWithContextT spmServerApi spmServerContext ((runReaderT ?? ServerCtx{..}) . hoist (runLoggingT ?? logger)) spmServer'
       & requestLogger
 
+  where
+    uiRedirect = throwError err302 { errHeaders = [("Location", "/ui")] }
+
 spmSql :: ReaderT SqlBackend Handler' a -> Handler' a
 spmSql act = do
   sqlPool <- view sctxSqlPool
@@ -208,15 +213,18 @@ generateLocal SpmConsonants = fmap (review _Wrapped . CI.mk) . liftIO $ do
 
 spmServer :: MailDomain -> MailMailbox -> Server' SpmApi
 spmServer dom mbox = whoami
-                 :<|> jwkSet
-                 :<|> instanceId
-                 :<|> generate
-                 :<|> claim
+                :<|> domain
+                :<|> jwkSet
+                :<|> instanceId
+                :<|> generate
+                :<|> claim
   where
     whoami = do
       Entity _ Mailbox{mailboxIdent} <- maybe (throwError err404) return <=< spmSql . getBy $ UniqueMailbox mbox
       return $ mailboxIdent ^. _Wrapped . re _Wrapped
 
+    domain = return $ dom ^. _Wrapped . re _Wrapped
+
     jwkSet = views sctxJwkSet $ over _Wrapped (^.. folded . asPublicKey . _Just)
   
     instanceId = view sctxInstanceId
-- 
cgit v1.2.3