From e5e2207ed92af454b70d29b3dad1a8e633c1a6d0 Mon Sep 17 00:00:00 2001 From: fisx Date: Thu, 17 Oct 2019 12:47:50 +0200 Subject: [PATCH] Store raw idp metadata with typed details in c* (#872) --- services/spar/package.yaml | 1 + services/spar/schema/src/Main.hs | 2 + services/spar/schema/src/V6.hs | 18 +++++++++ services/spar/src/Spar/API.hs | 17 ++++++-- services/spar/src/Spar/API/Swagger.hs | 3 ++ services/spar/src/Spar/API/Types.hs | 5 ++- services/spar/src/Spar/Data.hs | 30 +++++++++++++- services/spar/src/Spar/Types.hs | 39 ++++++++++++------- .../test-integration/Test/Spar/APISpec.hs | 27 +++++++++---- services/spar/test-integration/Util/Core.hs | 10 +++++ services/spar/test/Arbitrary.hs | 5 ++- services/spar/test/Test/Spar/APISpec.hs | 5 ++- 12 files changed, 133 insertions(+), 29 deletions(-) create mode 100644 services/spar/schema/src/V6.hs diff --git a/services/spar/package.yaml b/services/spar/package.yaml index 93fbee9f640..ee3d1d1d50c 100644 --- a/services/spar/package.yaml +++ b/services/spar/package.yaml @@ -45,6 +45,7 @@ dependencies: - http-api-data - http-client - http-client-tls + - http-media - http-types - imports - insert-ordered-containers diff --git a/services/spar/schema/src/Main.hs b/services/spar/schema/src/Main.hs index e443d29fed0..9d9988d5e79 100644 --- a/services/spar/schema/src/Main.hs +++ b/services/spar/schema/src/Main.hs @@ -13,6 +13,7 @@ import qualified V2 import qualified V3 import qualified V4 import qualified V5 +import qualified V6 main :: IO () main = do @@ -27,6 +28,7 @@ main = do , V3.migration , V4.migration , V5.migration + , V6.migration -- When adding migrations here, don't forget to update -- 'schemaVersion' in Spar.Data diff --git a/services/spar/schema/src/V6.hs b/services/spar/schema/src/V6.hs new file mode 100644 index 00000000000..2f26b02a147 --- /dev/null +++ b/services/spar/schema/src/V6.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module V6 (migration) where + +import Imports +import Cassandra.Schema +import Text.RawString.QQ + +migration :: Migration +migration = Migration 6 "Store raw XML metadata" $ do + void $ schema' [r| + CREATE TABLE if not exists idp_raw_metadata + ( id uuid + , metadata text + , primary key (id) + ) with compaction = {'class': 'LeveledCompactionStrategy'}; + |] diff --git a/services/spar/src/Spar/API.hs b/services/spar/src/Spar/API.hs index cccae4a5390..3c503e3ba83 100644 --- a/services/spar/src/Spar/API.hs +++ b/services/spar/src/Spar/API.hs @@ -74,6 +74,7 @@ apiSSO opts apiIDP :: ServerT APIIDP Spar apiIDP = idpGet + :<|> idpGetRaw :<|> idpGetAll :<|> idpCreate :<|> idpDelete @@ -164,6 +165,14 @@ idpGet zusr idpid = withDebugLog "idpGet" (Just . show . (^. SAML.idpId)) $ do authorizeIdP zusr idp pure idp +idpGetRaw :: Maybe UserId -> SAML.IdPId -> Spar RawIdPMetadata +idpGetRaw zusr idpid = do + idp <- SAML.getIdPConfig idpid + authorizeIdP zusr idp + wrapMonadClient (Data.getIdPRawMetadata idpid) >>= \case + Just txt -> pure $ RawIdPMetadata txt + Nothing -> throwSpar SparNotFound + idpGetAll :: Maybe UserId -> Spar IdPList idpGetAll zusr = withDebugLog "idpGetAll" (const Nothing) $ do teamid <- Intra.getZUsrOwnedTeam zusr @@ -185,21 +194,23 @@ idpDelete zusr idpid = withDebugLog "idpDelete" (const Nothing) $ do when (stiIdP == Just idpid) $ Data.deleteScimToken team stiId -- Delete IdP config Data.deleteIdPConfig idpid issuer team + Data.deleteIdPRawMetadata idpid return NoContent -- | We generate a new UUID for each IdP used as IdPConfig's path, thereby ensuring uniqueness. -idpCreateXML :: Maybe UserId -> SAML.IdPMetadata -> Spar IdP -idpCreateXML zusr idpmeta = withDebugLog "idpCreate" (Just . show . (^. SAML.idpId)) $ do +idpCreateXML :: Maybe UserId -> Text -> SAML.IdPMetadata -> Spar IdP +idpCreateXML zusr raw idpmeta = withDebugLog "idpCreate" (Just . show . (^. SAML.idpId)) $ do teamid <- Intra.getZUsrOwnedTeam zusr Galley.assertSSOEnabled teamid idp <- validateNewIdP idpmeta teamid + wrapMonadClient $ Data.storeIdPRawMetadata (idp ^. SAML.idpId) raw SAML.storeIdPConfig idp pure idp -- | This handler only does the json parsing, and leaves all authorization checks and -- application logic to 'idpCreateXML'. idpCreate :: Maybe UserId -> IdPMetadataInfo -> Spar IdP -idpCreate zusr (IdPMetadataValue xml) = idpCreateXML zusr xml +idpCreate zusr (IdPMetadataValue raw xml) = idpCreateXML zusr raw xml withDebugLog :: SAML.SP m => String -> (a -> Maybe String) -> m a -> m a diff --git a/services/spar/src/Spar/API/Swagger.hs b/services/spar/src/Spar/API/Swagger.hs index dc07411ef30..078756d0e63 100644 --- a/services/spar/src/Spar/API/Swagger.hs +++ b/services/spar/src/Spar/API/Swagger.hs @@ -157,3 +157,6 @@ instance ToParamSchema BindCookie where instance ToSchema Void where declareNamedSchema _ = declareNamedSchema (Proxy @String) + +instance ToSchema RawIdPMetadata where + declareNamedSchema _ = declareNamedSchema (Proxy @String) diff --git a/services/spar/src/Spar/API/Types.hs b/services/spar/src/Spar/API/Types.hs index 902bff25381..95802beecf9 100644 --- a/services/spar/src/Spar/API/Types.hs +++ b/services/spar/src/Spar/API/Types.hs @@ -132,13 +132,16 @@ type APIAuthResp type APIIDP = Header "Z-User" UserId :> IdpGet + :<|> Header "Z-User" UserId :> IdpGetRaw :<|> Header "Z-User" UserId :> IdpGetAll :<|> Header "Z-User" UserId :> IdpCreate :<|> Header "Z-User" UserId :> IdpDelete +type IdpGetRaw = Capture "id" SAML.IdPId :> "raw" :> Get '[RawXML] RawIdPMetadata + type IdpGet = Capture "id" SAML.IdPId :> Get '[JSON] IdP type IdpGetAll = Get '[JSON] IdPList -type IdpCreate = ReqBodyCustomError '[SAML.XML, JSON] "wai-error" IdPMetadataInfo :> PostCreated '[JSON] IdP +type IdpCreate = ReqBodyCustomError '[RawXML, JSON] "wai-error" IdPMetadataInfo :> PostCreated '[JSON] IdP type IdpDelete = Capture "id" SAML.IdPId :> DeleteNoContent '[JSON] NoContent instance MakeCustomError "wai-error" IdPMetadataInfo where diff --git a/services/spar/src/Spar/Data.hs b/services/spar/src/Spar/Data.hs index 35e4a395242..ba6d3d9dd67 100644 --- a/services/spar/src/Spar/Data.hs +++ b/services/spar/src/Spar/Data.hs @@ -31,6 +31,9 @@ module Spar.Data , getIdPConfigsByTeam , deleteIdPConfig , deleteTeam + , storeIdPRawMetadata + , getIdPRawMetadata + , deleteIdPRawMetadata -- * SCIM auth , insertScimToken @@ -70,7 +73,7 @@ import qualified Web.Scim.Class.User as ScimC.User -- | A lower bound: @schemaVersion <= whatWeFoundOnCassandra@, not @==@. schemaVersion :: Int32 -schemaVersion = 5 +schemaVersion = 6 ---------------------------------------------------------------------- @@ -382,6 +385,31 @@ deleteTeam team = do deleteSAMLUsersByIssuer issuer deleteIdPConfig idpid issuer team +storeIdPRawMetadata + :: (HasCallStack, MonadClient m) + => SAML.IdPId -> ST -> m () +storeIdPRawMetadata idp raw = retry x5 . write ins $ params Quorum (idp, raw) + where + ins :: PrepQuery W (SAML.IdPId, ST) () + ins = "INSERT INTO idp_raw_metadata (id, metadata) VALUES (?, ?)" + +getIdPRawMetadata + :: (HasCallStack, MonadClient m) + => SAML.IdPId -> m (Maybe ST) +getIdPRawMetadata idp = runIdentity <$$> + (retry x1 . query1 sel $ params Quorum (Identity idp)) + where + sel :: PrepQuery R (Identity SAML.IdPId) (Identity ST) + sel = "SELECT metadata FROM idp_raw_metadata WHERE id = ?" + +deleteIdPRawMetadata + :: (HasCallStack, MonadClient m) + => SAML.IdPId -> m () +deleteIdPRawMetadata idp = retry x5 . write del $ params Quorum (Identity idp) + where + del :: PrepQuery W (Identity SAML.IdPId) () + del = "DELETE FROM idp_raw_metadata WHERE id = ?" + ---------------------------------------------------------------------- -- SCIM auth -- diff --git a/services/spar/src/Spar/Types.hs b/services/spar/src/Spar/Types.hs index 425ccf7654b..90943d3a745 100644 --- a/services/spar/src/Spar/Types.hs +++ b/services/spar/src/Spar/Types.hs @@ -6,28 +6,31 @@ module Spar.Types where import Imports + import Control.Lens (makeLenses) import Control.Monad.Except import Data.Aeson import Data.Aeson.TH -import Data.Id (TeamId, UserId, ScimTokenId) import Data.ByteString.Conversion +import Data.Id (TeamId, UserId, ScimTokenId) import Data.Json.Util -import Data.Text.Encoding (encodeUtf8) import Data.Proxy (Proxy(Proxy)) import Data.String.Conversions import Data.String.Conversions (ST) +import Data.Text.Encoding (encodeUtf8) import Data.Time import GHC.TypeLits (KnownSymbol, symbolVal) import GHC.Types (Symbol) +import Network.HTTP.Media ((//)) import SAML2.Util (renderURI, parseURI') import SAML2.WebSSO (IdPConfig, IdPId, ID, AuthnRequest, Assertion, SimpleSetCookie) import SAML2.WebSSO.Types.TH (deriveJSONOptions) +import Servant.API as Servant hiding (MkLink, URI(..)) +import System.Logger.Extended (LogFormat) import URI.ByteString import Util.Options import Web.Cookie import Web.HttpApiData -import System.Logger.Extended (LogFormat) import qualified Data.ByteString.Builder as Builder import qualified Data.Text as ST @@ -67,24 +70,34 @@ deriveJSON deriveJSONOptions ''IdPList -- implement @{"uri": , "cert": }@. check both the certificate we get -- from the server against the pinned one and the metadata url in the metadata against the one -- we fetched the xml from, but it's unclear what the benefit would be.) -newtype IdPMetadataInfo = IdPMetadataValue SAML.IdPMetadata +data IdPMetadataInfo = IdPMetadataValue Text SAML.IdPMetadata deriving (Eq, Show, Generic) -instance SAML.HasXMLRoot IdPMetadataInfo where - renderRoot = error "instance SAML.HasXML IdPMetadataInfo: render not implemented" - -- FUTUREWORK: split up HasXML in saml-web-sso into FromXML and ToXML, then we probably - -- can actually not implement this (this even as an error). should be a nice, - -- backwards-compatible change! +-- | We want to store the raw xml text from the registration request in the database for +-- trouble shooting, but @SAML.XML@ only gives us access to the xml tree, not the raw text. +-- 'RawXML' helps with that. +data RawXML + +instance Accept RawXML where + contentType Proxy = "application" // "xml" + +instance MimeUnrender RawXML IdPMetadataInfo where + mimeUnrender Proxy raw = IdPMetadataValue (cs raw) <$> mimeUnrender (Proxy @SAML.XML) raw + +instance MimeRender RawXML RawIdPMetadata where + mimeRender Proxy (RawIdPMetadata raw) = cs raw + +newtype RawIdPMetadata = RawIdPMetadata Text + deriving (Eq, Show, Generic) -instance SAML.HasXML IdPMetadataInfo where - parse = fmap IdPMetadataValue . SAML.parse instance FromJSON IdPMetadataInfo where parseJSON = withObject "IdPMetadataInfo" $ \obj -> do - either fail (pure . IdPMetadataValue) . SAML.decode =<< (obj .: "value") + raw <- obj .: "value" + either fail (pure . IdPMetadataValue raw) (SAML.decode (cs raw)) instance ToJSON IdPMetadataInfo where - toJSON (IdPMetadataValue xml) = + toJSON (IdPMetadataValue _ xml) = object [ "value" .= SAML.encode xml ] diff --git a/services/spar/test-integration/Test/Spar/APISpec.hs b/services/spar/test-integration/Test/Spar/APISpec.hs index c9bb6591a2e..9767093647c 100644 --- a/services/spar/test-integration/Test/Spar/APISpec.hs +++ b/services/spar/test-integration/Test/Spar/APISpec.hs @@ -24,6 +24,7 @@ import Util.Core import Util.Types import qualified Data.ByteString.Builder as LB +import qualified Data.Text as ST import qualified Data.ZAuth.Token as ZAuth import qualified Galley.Types.Teams as Galley import qualified Spar.Intra.Brig as Intra @@ -298,8 +299,8 @@ specBindingUsers = describe "binding existing users to sso identities" $ do . expect2xx ) - let checkInitiateLogin :: HasCallStack => Bool -> TestSpar UserId -> SpecWith TestEnv - checkInitiateLogin hasZUser createUser = do + let checkInitiateBind :: HasCallStack => Bool -> TestSpar UserId -> SpecWith TestEnv + checkInitiateBind hasZUser createUser = do let testmsg = if hasZUser then "responds with 200 and a bind cookie" else "responds with 403 and 'bind-without-auth'" @@ -333,13 +334,13 @@ specBindingUsers = describe "binding existing users to sso identities" $ do describe "GET /sso-initiate-bind/:idp" $ do context "known IdP, running session without authentication" $ do - checkInitiateLogin False (fmap fst . call . createRandomPhoneUser =<< asks (^. teBrig)) + checkInitiateBind False (fmap fst . call . createRandomPhoneUser =<< asks (^. teBrig)) context "known IdP, running session with non-sso user" $ do - checkInitiateLogin True (fmap fst . call . createRandomPhoneUser =<< asks (^. teBrig)) + checkInitiateBind True (fmap fst . call . createRandomPhoneUser =<< asks (^. teBrig)) context "known IdP, running session with sso user" $ do - checkInitiateLogin True (registerTestIdP >>= \(_, _, idp) -> loginSsoUserFirstTime idp) + checkInitiateBind True (registerTestIdP >>= \(_, _, idp) -> loginSsoUserFirstTime idp) describe "POST /sso/finalize-login" $ do let checkGrantingAuthnResp :: HasCallStack => UserId -> SignedAuthnResponse -> ResponseLBS -> TestSpar () @@ -619,6 +620,8 @@ specCRUDIdentityProvider = do `shouldRespondWith` \resp -> statusCode resp < 300 callIdpGet' (env ^. teSpar) (Just userid) idpid `shouldRespondWith` checkErr (== 404) "not-found" + callIdpGetRaw' (env ^. teSpar) (Just userid) idpid + `shouldRespondWith` checkErr (== 404) "not-found" context "with email" $ it "responds with 2xx and removes IdP" $ do env <- ask @@ -714,7 +717,11 @@ specCRUDIdentityProvider = do metadata <- makeTestIdPMetadata idp <- call $ callIdpCreate (env ^. teSpar) (Just owner) metadata idp' <- call $ callIdpGet (env ^. teSpar) (Just owner) (idp ^. idpId) - liftIO $ idp `shouldBe` idp' + rawmeta <- call $ callIdpGetRaw (env ^. teSpar) (Just owner) (idp ^. idpId) + liftIO $ do + idp `shouldBe` idp' + let prefix = " makeTestIdPMetadata + metadata <- Data.Aeson.encode . (IdPMetadataValue mempty) <$> makeTestIdPMetadata idp <- call $ callIdpCreateRaw (env ^. teSpar) (Just owner) "application/json" metadata idp' <- call $ callIdpGet (env ^. teSpar) (Just owner) (idp ^. idpId) - liftIO $ idp `shouldBe` idp' + rawmeta <- call $ callIdpGetRaw (env ^. teSpar) (Just owner) (idp ^. idpId) + liftIO $ do + idp `shouldBe` idp' + let prefix = " SparReq -> Maybe UserId -> SAML.IdPId callIdpGet' sparreq_ muid idpid = do get $ sparreq_ . maybe id zUser muid . path (cs $ "/identity-providers/" -/ SAML.idPIdToST idpid) +callIdpGetRaw :: (MonadIO m, MonadHttp m) => SparReq -> Maybe UserId -> SAML.IdPId -> m Text +callIdpGetRaw sparreq_ muid idpid = do + resp <- callIdpGetRaw' (sparreq_ . expect2xx) muid idpid + maybe (liftIO . throwIO $ ErrorCall "Nothing") (pure . cs) (responseBody resp) + +callIdpGetRaw' :: (MonadIO m, MonadHttp m) => SparReq -> Maybe UserId -> SAML.IdPId -> m ResponseLBS +callIdpGetRaw' sparreq_ muid idpid = do + get $ sparreq_ . maybe id zUser muid . path (cs $ "/identity-providers/" -/ SAML.idPIdToST idpid -/ "raw") + callIdpGetAll :: (MonadIO m, MonadHttp m) => SparReq -> Maybe UserId -> m IdPList callIdpGetAll sparreq_ muid = do resp <- callIdpGetAll' (sparreq_ . expect2xx) muid diff --git a/services/spar/test/Arbitrary.hs b/services/spar/test/Arbitrary.hs index ad3b706c82a..09393b2abed 100644 --- a/services/spar/test/Arbitrary.hs +++ b/services/spar/test/Arbitrary.hs @@ -11,6 +11,7 @@ import Data.Proxy import "swagger2" Data.Swagger hiding (Header(..)) import Data.Aeson import Data.Id () +import Data.String.Conversions (cs) import SAML2.WebSSO.Test.Arbitrary () import Servant.API.ContentTypes import Spar.Types @@ -46,7 +47,9 @@ instance Arbitrary NoContent where arbitrary = pure NoContent instance Arbitrary IdPMetadataInfo where - arbitrary = IdPMetadataValue <$> arbitrary + arbitrary = do + mdata <- arbitrary + pure $ IdPMetadataValue (cs $ encode mdata) mdata -- This is not required by the servant-server instances, but the swagger -- tests want it. See https://github.com/haskell-servant/servant-swagger/issues/58 diff --git a/services/spar/test/Test/Spar/APISpec.hs b/services/spar/test/Test/Spar/APISpec.hs index 471b92cb600..1696ee29122 100644 --- a/services/spar/test/Test/Spar/APISpec.hs +++ b/services/spar/test/Test/Spar/APISpec.hs @@ -11,7 +11,7 @@ import Data.Metrics.Test (pathsConsistencyCheck) import Data.Proxy (Proxy(Proxy)) import Servant.Swagger (validateEveryToJSON) import Spar.API as API -import Spar.Types (IdPMetadataInfo) +import Spar.Types (IdPMetadataInfo(IdPMetadataValue)) import Test.Hspec (Spec, it, shouldBe) import Test.QuickCheck (property) @@ -25,4 +25,5 @@ spec = do pathsConsistencyCheck (routesToPaths @API.API) `shouldBe` mempty it "roundtrip: IdPMetadataInfo" . property $ \(val :: IdPMetadataInfo) -> do - (eitherDecode . encode) val `shouldBe` Right val + let withoutRaw (IdPMetadataValue _ x) = x + (withoutRaw <$> (eitherDecode . encode) val) `shouldBe` Right (withoutRaw val)