summaryrefslogtreecommitdiff
path: root/overlays/spm/lib/Spm
diff options
context:
space:
mode:
Diffstat (limited to 'overlays/spm/lib/Spm')
-rw-r--r--overlays/spm/lib/Spm/Api.hs31
1 files changed, 30 insertions, 1 deletions
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
5 , SpmMailbox, SpmDomain 5 , SpmMailbox, SpmDomain
6 , SpmLocal(..), SpmExtension(..) 6 , SpmLocal(..), SpmExtension(..)
7 , SpmMapping(..), SpmMappingState(..), SpmMappingListingItem(..), SpmMappingListing(..) 7 , SpmMapping(..), SpmMappingState(..), SpmMappingListingItem(..), SpmMappingListing(..)
8 , SpmJWTClaims(..), _spmjwtLocal, _SpmJWTLocal
8 , _SpmMappingText, _SpmMappingStateReject 9 , _SpmMappingText, _SpmMappingStateReject
9 , spmMappingAncestors 10 , spmMappingAncestors
10 , SpmApi, spmApi 11 , SpmApi, spmApi
@@ -24,18 +25,21 @@ import Type.Reflection (Typeable)
24 25
25import Control.Lens 26import Control.Lens
26 27
28import Control.Monad (guard)
29
27import Data.CaseInsensitive (CI) 30import Data.CaseInsensitive (CI)
28import qualified Data.CaseInsensitive as CI 31import qualified Data.CaseInsensitive as CI
29import Data.CaseInsensitive.Instances () 32import Data.CaseInsensitive.Instances ()
30 33
31import Crypto.JOSE.JWK (JWKSet) 34import Crypto.JOSE.JWK (JWKSet)
32import Crypto.JWT (SignedJWT) 35import Crypto.JWT (SignedJWT, ClaimsSet, HasClaimsSet(..), emptyClaimsSet)
33import Crypto.JWT.Instances () 36import Crypto.JWT.Instances ()
34 37
35import Data.UUID (UUID) 38import Data.UUID (UUID)
36import Data.UUID.Instances () 39import Data.UUID.Instances ()
37 40
38import qualified Data.Aeson as JSON 41import qualified Data.Aeson as JSON
42import qualified Data.Aeson.Lens as JSON
39import Data.Aeson.TH (deriveJSON) 43import Data.Aeson.TH (deriveJSON)
40import Data.Aeson.Casing 44import Data.Aeson.Casing
41 45
@@ -163,6 +167,31 @@ deriveJSON (aesonPrefix trainCase) ''SpmMappingListingItem
163instance ToJSON SpmMappingListing where 167instance ToJSON SpmMappingListing where
164 toJSON SpmMappingListing{..} = JSON.object [ "mappings" JSON..= unSpmMappingListing ] 168 toJSON SpmMappingListing{..} = JSON.object [ "mappings" JSON..= unSpmMappingListing ]
165 169
170data SpmJWTClaims = SpmJWTClaims
171 { spmjwtStdClaims :: ClaimsSet
172 , spmjwtLocal :: SpmLocal
173 } deriving stock (Eq, Show, Generic, Typeable)
174
175makeLensesFor [("spmjwtStdClaims", "_stdClaims"), ("spmjwtLocal", "_spmjwtLocal")] ''SpmJWTClaims
176
177instance HasClaimsSet SpmJWTClaims where
178 claimsSet = _stdClaims
179
180_SpmJWTLocal :: (Wrapped l, Unwrapped l ~ Unwrapped SpmLocal) => Prism' SpmJWTClaims l
181_SpmJWTLocal = prism' toClaims fromClaims
182 where toClaims (view $ _Wrapped' . _Unwrapped' -> spmjwtLocal) = SpmJWTClaims{..}
183 where spmjwtStdClaims = emptyClaimsSet
184 fromClaims SpmJWTClaims{..} = view (_Wrapped' . _Unwrapped') spmjwtLocal <$ guard (spmjwtStdClaims == emptyClaimsSet)
185
186instance JSON.ToJSON SpmJWTClaims where
187 toJSON SpmJWTClaims{..} = JSON.toJSON spmjwtStdClaims
188 & JSON._Object . at "li.yggdrasil.local" .~ Just (JSON.toJSON spmjwtLocal)
189
190instance JSON.FromJSON SpmJWTClaims where
191 parseJSON = JSON.withObject "SpmJWTClaims" $ \o -> SpmJWTClaims
192 <$> JSON.parseJSON (JSON._Object # o)
193 <*> o JSON..: "li.yggdrasil.local"
194
166 195
167type SpmApi = "whoami" :> Get '[PlainText, JSON] SpmMailbox 196type SpmApi = "whoami" :> Get '[PlainText, JSON] SpmMailbox
168 :<|> "domain" :> Get '[PlainText, JSON] SpmDomain 197 :<|> "domain" :> Get '[PlainText, JSON] SpmDomain