diff options
author | Gregor Kleen <gkleen@yggdrasil.li> | 2022-06-07 21:38:00 +0200 |
---|---|---|
committer | Gregor Kleen <gkleen@yggdrasil.li> | 2022-06-07 21:38:00 +0200 |
commit | 3bf77d7c3144b16d55f35998dddc0d67bb8c17b2 (patch) | |
tree | 805b343e50d733240b3dae8700d43060943b4dab /overlays/spm/server/Spm/Server.hs | |
parent | fc6cf6169868e60c189e4b243330c3717ff159f3 (diff) | |
download | nixos-3bf77d7c3144b16d55f35998dddc0d67bb8c17b2.tar nixos-3bf77d7c3144b16d55f35998dddc0d67bb8c17b2.tar.gz nixos-3bf77d7c3144b16d55f35998dddc0d67bb8c17b2.tar.bz2 nixos-3bf77d7c3144b16d55f35998dddc0d67bb8c17b2.tar.xz nixos-3bf77d7c3144b16d55f35998dddc0d67bb8c17b2.zip |
...
Diffstat (limited to 'overlays/spm/server/Spm/Server.hs')
-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 |