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')
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