diff options
Diffstat (limited to 'overlays/spm/server/Spm')
| -rw-r--r-- | overlays/spm/server/Spm/Server.hs | 16 |
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 | ||
| 118 | spmServerApi :: Proxy SpmServerApi | 119 | spmServerApi :: Proxy SpmServerApi |
| 119 | spmServerApi = Proxy | 120 | spmServerApi = 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 | |||
| 191 | spmSql :: ReaderT SqlBackend Handler' a -> Handler' a | 196 | spmSql :: ReaderT SqlBackend Handler' a -> Handler' a |
| 192 | spmSql act = do | 197 | spmSql 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 | ||
| 209 | spmServer :: MailDomain -> MailMailbox -> Server' SpmApi | 214 | spmServer :: MailDomain -> MailMailbox -> Server' SpmApi |
| 210 | spmServer dom mbox = whoami | 215 | spmServer 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 |
