summaryrefslogtreecommitdiff
path: root/overlays/spm/server/Spm
diff options
context:
space:
mode:
authorGregor Kleen <gkleen@yggdrasil.li>2023-09-23 15:33:30 +0200
committerGregor Kleen <gkleen@yggdrasil.li>2023-09-23 15:33:30 +0200
commit3832bf5daed8b4a3fc87153590131730daa4e88c (patch)
tree49b30717e86de623d00cec243ef84138e339716c /overlays/spm/server/Spm
parent83549be4db488711263808a54afd2652d6d99ca9 (diff)
downloadnixos-3832bf5daed8b4a3fc87153590131730daa4e88c.tar
nixos-3832bf5daed8b4a3fc87153590131730daa4e88c.tar.gz
nixos-3832bf5daed8b4a3fc87153590131730daa4e88c.tar.bz2
nixos-3832bf5daed8b4a3fc87153590131730daa4e88c.tar.xz
nixos-3832bf5daed8b4a3fc87153590131730daa4e88c.zip
...
Diffstat (limited to 'overlays/spm/server/Spm')
-rw-r--r--overlays/spm/server/Spm/Server.hs24
1 files changed, 13 insertions, 11 deletions
diff --git a/overlays/spm/server/Spm/Server.hs b/overlays/spm/server/Spm/Server.hs
index df12e3d8..8e7f8786 100644
--- a/overlays/spm/server/Spm/Server.hs
+++ b/overlays/spm/server/Spm/Server.hs
@@ -44,7 +44,7 @@ import Database.Persist
44import Database.Persist.Postgresql 44import Database.Persist.Postgresql
45import UnliftIO.Pool 45import UnliftIO.Pool
46 46
47import Control.Monad.Trans.Reader (ReaderT, runReaderT) 47import Control.Monad.Trans.Reader (ReaderT, runReaderT, mapReaderT)
48 48
49import Control.Monad.Logger 49import Control.Monad.Logger
50 50
@@ -58,12 +58,12 @@ import qualified Data.UUID as UUID
58import qualified Data.UUID.V4 as UUID 58import qualified Data.UUID.V4 as UUID
59 59
60import qualified Data.Aeson as JSON 60import qualified Data.Aeson as JSON
61import Data.Aeson.Lens (_JSON)
62 61
63import System.FilePath ((</>), isRelative) 62import System.FilePath ((</>), isRelative)
64 63
65import Crypto.JOSE.JWK hiding (Context) 64import Crypto.JOSE.JWK hiding (Context)
66import Crypto.JOSE.JWK.Instances () 65import Crypto.JOSE.JWK.Instances ()
66import Crypto.JOSE.Error.Instances ()
67 67
68import Crypto.Random.Instances () 68import Crypto.Random.Instances ()
69import qualified Crypto.Random as Crypto 69import qualified Crypto.Random as Crypto
@@ -197,10 +197,13 @@ mkSpmApp = do
197spmSql :: ReaderT SqlBackend Handler' a -> Handler' a 197spmSql :: ReaderT SqlBackend Handler' a -> Handler' a
198spmSql act = do 198spmSql act = do
199 sqlPool <- view sctxSqlPool 199 sqlPool <- view sctxSqlPool
200 withResource sqlPool $ runReaderT act 200 mapReaderT (mapLoggingT $ either throwError pure <=< liftIO) . withResource sqlPool $ mapReaderT (mapLoggingT runHandler) . runReaderT act
201 201
202spmJWT :: forall error a. Show error => ServerError -> ExceptT error IO a -> Handler' a 202spmJWT :: forall error a. Show error => ServerError -> JOSE error IO a -> Handler' a
203spmJWT errTemplate = either (\err -> throwError errTemplate{ errBody = LBS.fromStrict . Text.encodeUtf8 . Text.pack $ show err }) return <=< liftIO . runExceptT 203spmJWT errTemplate = either (\err -> throwError errTemplate{ errBody = LBS.fromStrict . Text.encodeUtf8 . Text.pack $ show err }) return <=< liftIO . runJOSE
204
205withJOSE :: forall m e e' a. Functor m => (e -> e') -> JOSE e m a -> JOSE e' m a
206withJOSE f = JOSE . withExceptT f . unwrapJOSE
204 207
205generateLocal :: MonadIO m => SpmStyle -> m MailLocal 208generateLocal :: MonadIO m => SpmStyle -> m MailLocal
206generateLocal SpmWords = fmap (review _Wrapped . CI.mk) . liftIO $ do 209generateLocal SpmWords = fmap (review _Wrapped . CI.mk) . liftIO $ do
@@ -254,24 +257,23 @@ spmServer dom mbox = whoami
254 instanceId' <- view sctxInstanceId 257 instanceId' <- view sctxInstanceId
255 jwks <- view $ sctxJwkSet . _Wrapped 258 jwks <- view $ sctxJwkSet . _Wrapped
256 tokenId <- liftIO UUID.nextRandom 259 tokenId <- liftIO UUID.nextRandom
257 let claimsSet = emptyClaimsSet 260 let jwtClaims = (_SpmJWTLocal # local)
258 & claimIss ?~ (JWT.string # UUID.toText instanceId') 261 & claimIss ?~ (JWT.string # UUID.toText instanceId')
259 & claimAud ?~ Audience (pure $ dom ^. _Wrapped . to CI.original . re JWT.string) 262 & claimAud ?~ Audience (pure $ dom ^. _Wrapped . to CI.original . re JWT.string)
260 & claimNbf ?~ NumericDate t 263 & claimNbf ?~ NumericDate t
261 & claimIat ?~ NumericDate t 264 & claimIat ?~ NumericDate t
262 & claimExp ?~ NumericDate (600 `addUTCTime` t) 265 & claimExp ?~ NumericDate (600 `addUTCTime` t)
263 & claimJti ?~ UUID.toText tokenId 266 & claimJti ?~ UUID.toText tokenId
264 & unregisteredClaims . at "local" ?~ view (_Wrapped . re _JSON) local
265 spmJWT @JWT.Error err500 $ do 267 spmJWT @JWT.Error err500 $ do
266 (jwsAlg, selectedJwk) <- withExceptT (fromMaybe JWT.NoUsableKeys . getFirst) . asum $ map (\jwk' -> (, jwk') <$> withExceptT (First . Just) (bestJWSAlg jwk')) jwks 268 (jwsAlg, selectedJwk) <- withJOSE (fromMaybe JWT.NoUsableKeys . getFirst) . asum $ map (\jwk' -> (, jwk') <$> withJOSE (First . Just) (bestJWSAlg jwk')) jwks
267 signClaims selectedJwk (newJWSHeader ((), jwsAlg)) claimsSet 269 signJWT selectedJwk (newJWSHeader ((), jwsAlg)) jwtClaims
268 270
269 claim jwt = do 271 claim jwt = do
270 jwks <- view sctxJwkSet 272 jwks <- view sctxJwkSet
271 let validationSettings' = defaultJWTValidationSettings ((== Just dom) . fmap (review _Wrapped . CI.mk) . preview JWT.string) 273 let validationSettings' = defaultJWTValidationSettings ((== Just dom) . fmap (review _Wrapped . CI.mk) . preview JWT.string)
272 & jwtValidationSettingsAllowedSkew .~ 5 274 & jwtValidationSettingsAllowedSkew .~ 5
273 claims <- spmJWT @JWT.JWTError err403 $ verifyClaims validationSettings' jwks jwt 275 jwtClaims <- spmJWT @JWT.JWTError err403 $ verifyJWT validationSettings' jwks jwt
274 mailboxMappingLocal <- maybe (throwError err400{ errBody = "Claim ‘local’ missing" }) (return . Just) $ claims ^? unregisteredClaims . ix "local" . _JSON . to CI.mk . re _Wrapped 276 let mailboxMappingLocal = Just $ jwtClaims ^. _spmjwtLocal . _Wrapped . _Unwrapped
275 277
276 spmSql $ do 278 spmSql $ do
277 Entity mailboxMappingMailbox _ <- maybe (throwError err404) return <=< getBy $ UniqueMailbox mbox 279 Entity mailboxMappingMailbox _ <- maybe (throwError err404) return <=< getBy $ UniqueMailbox mbox