From 3832bf5daed8b4a3fc87153590131730daa4e88c Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Sat, 23 Sep 2023 15:33:30 +0200
Subject: ...

---
 overlays/spm/lib/Spm/Api.hs | 31 ++++++++++++++++++++++++++++++-
 1 file changed, 30 insertions(+), 1 deletion(-)

(limited to 'overlays/spm/lib/Spm/Api.hs')

diff --git a/overlays/spm/lib/Spm/Api.hs b/overlays/spm/lib/Spm/Api.hs
index 04dff2c9..8285cc55 100644
--- a/overlays/spm/lib/Spm/Api.hs
+++ b/overlays/spm/lib/Spm/Api.hs
@@ -5,6 +5,7 @@ module Spm.Api
   , SpmMailbox, SpmDomain
   , SpmLocal(..), SpmExtension(..)
   , SpmMapping(..), SpmMappingState(..), SpmMappingListingItem(..), SpmMappingListing(..)
+  , SpmJWTClaims(..), _spmjwtLocal, _SpmJWTLocal
   , _SpmMappingText, _SpmMappingStateReject
   , spmMappingAncestors
   , SpmApi, spmApi
@@ -24,18 +25,21 @@ import Type.Reflection (Typeable)
 
 import Control.Lens
 
+import Control.Monad (guard)
+
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
 import Data.CaseInsensitive.Instances ()
 
 import Crypto.JOSE.JWK (JWKSet)
-import Crypto.JWT (SignedJWT)
+import Crypto.JWT (SignedJWT, ClaimsSet, HasClaimsSet(..), emptyClaimsSet)
 import Crypto.JWT.Instances ()
 
 import Data.UUID (UUID)
 import Data.UUID.Instances ()
 
 import qualified Data.Aeson as JSON
+import qualified Data.Aeson.Lens as JSON
 import Data.Aeson.TH (deriveJSON)
 import Data.Aeson.Casing
 
@@ -163,6 +167,31 @@ deriveJSON (aesonPrefix trainCase) ''SpmMappingListingItem
 instance ToJSON SpmMappingListing where
   toJSON SpmMappingListing{..} = JSON.object [ "mappings" JSON..= unSpmMappingListing ]
 
+data SpmJWTClaims = SpmJWTClaims
+  { spmjwtStdClaims :: ClaimsSet
+  , spmjwtLocal :: SpmLocal
+  } deriving stock (Eq, Show, Generic, Typeable)
+
+makeLensesFor [("spmjwtStdClaims", "_stdClaims"), ("spmjwtLocal", "_spmjwtLocal")] ''SpmJWTClaims
+
+instance HasClaimsSet SpmJWTClaims where
+  claimsSet = _stdClaims
+
+_SpmJWTLocal :: (Wrapped l, Unwrapped l ~ Unwrapped SpmLocal) => Prism' SpmJWTClaims l
+_SpmJWTLocal = prism' toClaims fromClaims
+  where toClaims (view $ _Wrapped' . _Unwrapped' -> spmjwtLocal) = SpmJWTClaims{..}
+          where spmjwtStdClaims = emptyClaimsSet
+        fromClaims SpmJWTClaims{..} = view (_Wrapped' . _Unwrapped') spmjwtLocal <$ guard (spmjwtStdClaims == emptyClaimsSet)
+
+instance JSON.ToJSON SpmJWTClaims where
+  toJSON SpmJWTClaims{..} = JSON.toJSON spmjwtStdClaims
+    & JSON._Object . at "li.yggdrasil.local" .~ Just (JSON.toJSON spmjwtLocal)
+
+instance JSON.FromJSON SpmJWTClaims where
+  parseJSON = JSON.withObject "SpmJWTClaims" $ \o -> SpmJWTClaims
+    <$> JSON.parseJSON (JSON._Object # o)
+    <*> o JSON..: "li.yggdrasil.local"
+
 
 type SpmApi = "whoami" :> Get '[PlainText, JSON] SpmMailbox
          :<|> "domain" :> Get '[PlainText, JSON] SpmDomain
-- 
cgit v1.2.3