summaryrefslogtreecommitdiff
path: root/overlays/spm/server
diff options
context:
space:
mode:
Diffstat (limited to 'overlays/spm/server')
-rw-r--r--overlays/spm/server/Spm/Server.hs16
1 files changed, 12 insertions, 4 deletions
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
114 :> AuthProtect "spm_mailbox" 114 :> AuthProtect "spm_mailbox"
115 :> SpmApi 115 :> SpmApi
116 :<|> "ui" :> Raw 116 :<|> "ui" :> Raw
117 :<|> GetNoContent
117 118
118spmServerApi :: Proxy SpmServerApi 119spmServerApi :: Proxy SpmServerApi
119spmServerApi = Proxy 120spmServerApi = Proxy
@@ -183,11 +184,15 @@ mkSpmApp = do
183 184
184 spmServer' = spmServer 185 spmServer' = spmServer
185 :<|> Tagged uiServer 186 :<|> Tagged uiServer
187 :<|> uiRedirect
186 188
187 logger <- askLoggerIO 189 logger <- askLoggerIO
188 return $ serveWithContextT spmServerApi spmServerContext ((runReaderT ?? ServerCtx{..}) . hoist (runLoggingT ?? logger)) spmServer' 190 return $ serveWithContextT spmServerApi spmServerContext ((runReaderT ?? ServerCtx{..}) . hoist (runLoggingT ?? logger)) spmServer'
189 & requestLogger 191 & requestLogger
190 192
193 where
194 uiRedirect = throwError err302 { errHeaders = [("Location", "/ui")] }
195
191spmSql :: ReaderT SqlBackend Handler' a -> Handler' a 196spmSql :: ReaderT SqlBackend Handler' a -> Handler' a
192spmSql act = do 197spmSql act = do
193 sqlPool <- view sctxSqlPool 198 sqlPool <- view sctxSqlPool
@@ -208,15 +213,18 @@ generateLocal SpmConsonants = fmap (review _Wrapped . CI.mk) . liftIO $ do
208 213
209spmServer :: MailDomain -> MailMailbox -> Server' SpmApi 214spmServer :: MailDomain -> MailMailbox -> Server' SpmApi
210spmServer dom mbox = whoami 215spmServer dom mbox = whoami
211 :<|> jwkSet 216 :<|> domain
212 :<|> instanceId 217 :<|> jwkSet
213 :<|> generate 218 :<|> instanceId
214 :<|> claim 219 :<|> generate
220 :<|> claim
215 where 221 where
216 whoami = do 222 whoami = do
217 Entity _ Mailbox{mailboxIdent} <- maybe (throwError err404) return <=< spmSql . getBy $ UniqueMailbox mbox 223 Entity _ Mailbox{mailboxIdent} <- maybe (throwError err404) return <=< spmSql . getBy $ UniqueMailbox mbox
218 return $ mailboxIdent ^. _Wrapped . re _Wrapped 224 return $ mailboxIdent ^. _Wrapped . re _Wrapped
219 225
226 domain = return $ dom ^. _Wrapped . re _Wrapped
227
220 jwkSet = views sctxJwkSet $ over _Wrapped (^.. folded . asPublicKey . _Just) 228 jwkSet = views sctxJwkSet $ over _Wrapped (^.. folded . asPublicKey . _Just)
221 229
222 instanceId = view sctxInstanceId 230 instanceId = view sctxInstanceId