summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--overlays/spm/frontend/src/app/spm/spm.component.ts4
-rw-r--r--overlays/spm/lib/Spm/Api.hs31
-rw-r--r--overlays/spm/package.yaml3
-rw-r--r--overlays/spm/server/Crypto/JOSE/Error/Instances.hs11
-rw-r--r--overlays/spm/server/Spm/Server.hs24
-rw-r--r--overlays/spm/spm.nix4
6 files changed, 60 insertions, 17 deletions
diff --git a/overlays/spm/frontend/src/app/spm/spm.component.ts b/overlays/spm/frontend/src/app/spm/spm.component.ts
index f6892d7c..361a1ce4 100644
--- a/overlays/spm/frontend/src/app/spm/spm.component.ts
+++ b/overlays/spm/frontend/src/app/spm/spm.component.ts
@@ -36,7 +36,7 @@ export interface ClaimedSpmMail {
36} 36}
37 37
38export interface SpmJwtUnregisteredPayload { 38export interface SpmJwtUnregisteredPayload {
39 local: string; 39 'li.yggdrasil.local': string;
40} 40}
41 41
42type SpmJwtPayload = JwtPayload & SpmJwtUnregisteredPayload; 42type SpmJwtPayload = JwtPayload & SpmJwtUnregisteredPayload;
@@ -136,7 +136,7 @@ export class SpmComponent implements OnInit, OnDestroy {
136 const curr: Map<string, SpmMail> = this.spmMails$.getValue(); 136 const curr: Map<string, SpmMail> = this.spmMails$.getValue();
137 curr.set(k, { 137 curr.set(k, {
138 state: 'loaded', 138 state: 'loaded',
139 local: payload.local, 139 local: payload['li.yggdrasil.local'],
140 domain: payload.aud, 140 domain: payload.aud,
141 jwt: encoded, 141 jwt: encoded,
142 expiration: payload.exp ? new Date(1000 * payload.exp) : undefined, 142 expiration: payload.exp ? new Date(1000 * payload.exp) : undefined,
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
diff --git a/overlays/spm/package.yaml b/overlays/spm/package.yaml
index e188dc77..6d4abe1c 100644
--- a/overlays/spm/package.yaml
+++ b/overlays/spm/package.yaml
@@ -1,5 +1,5 @@
1name: spm 1name: spm
2version: 0.1.0 2version: 0.1.1
3 3
4default-extensions: 4default-extensions:
5 - NoImplicitPrelude 5 - NoImplicitPrelude
@@ -36,6 +36,7 @@ library:
36 - lens 36 - lens
37 - case-insensitive 37 - case-insensitive
38 - aeson 38 - aeson
39 - lens-aeson
39 - jose 40 - jose
40 - uuid 41 - uuid
41 - containers 42 - containers
diff --git a/overlays/spm/server/Crypto/JOSE/Error/Instances.hs b/overlays/spm/server/Crypto/JOSE/Error/Instances.hs
new file mode 100644
index 00000000..9f3eea51
--- /dev/null
+++ b/overlays/spm/server/Crypto/JOSE/Error/Instances.hs
@@ -0,0 +1,11 @@
1{-# OPTIONS_GHC -Wno-orphans #-}
2
3module Crypto.JOSE.Error.Instances () where
4
5import Data.Monoid (Monoid)
6import Control.Monad (Monad)
7import Control.Applicative (Alternative)
8
9import Crypto.JOSE.Error
10
11deriving newtype instance (Monad m, Monoid e) => Alternative (JOSE e m)
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
diff --git a/overlays/spm/spm.nix b/overlays/spm/spm.nix
index 7c9eb933..2d1f7eed 100644
--- a/overlays/spm/spm.nix
+++ b/overlays/spm/spm.nix
@@ -10,13 +10,13 @@
10}: 10}:
11mkDerivation { 11mkDerivation {
12 pname = "spm"; 12 pname = "spm";
13 version = "0.1.0"; 13 version = "0.1.1";
14 src = ./.; 14 src = ./.;
15 isLibrary = true; 15 isLibrary = true;
16 isExecutable = true; 16 isExecutable = true;
17 libraryHaskellDepends = [ 17 libraryHaskellDepends = [
18 aeson aeson-casing base case-insensitive containers jose lens 18 aeson aeson-casing base case-insensitive containers jose lens
19 servant text uuid 19 lens-aeson servant text uuid
20 ]; 20 ];
21 libraryToolDepends = [ hpack ]; 21 libraryToolDepends = [ hpack ];
22 executableHaskellDepends = [ 22 executableHaskellDepends = [