Store raw idp metadata with typed details in c* (#872)

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

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
 

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'};
+    |]

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

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)

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

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
 --

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": <url>, "cert": <pinned_pubkey>}@.  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 ]
 
 

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 = "<EntityDescriptor xmlns:samlp=\"urn:oasis:names:tc:SAML:2.0:protocol\" xmlns:samla=\"urn:oasis:names"
+            ST.take (ST.length prefix) rawmeta `shouldBe` prefix
 
       context "client is owner without email" $ do
         it "responds with 2xx; makes IdP available for GET /identity-providers/" $ do
@@ -731,10 +738,14 @@ specCRUDIdentityProvider = do
           it "responds with 2xx; makes IdP available for GET /identity-providers/" $ do
             env <- ask
             (owner, _) <- call $ createUserWithTeam (env ^. teBrig) (env ^. teGalley)
-            metadata <- Data.Aeson.encode . IdPMetadataValue <$> 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 = "<EntityDescriptor xmlns:samlp=\"urn:oasis:names:tc:SAML:2.0:protocol\" xmlns:samla=\"urn:oasis:names"
+              ST.take (ST.length prefix) rawmeta `shouldBe` prefix
 
 
 specDeleteCornerCases :: SpecWith TestEnv

services/spar/test-integration/Util/Core.hs

@@ -57,6 +57,7 @@ module Util.Core
   , callAuthnReqPrecheck'
   , callAuthnReq, callAuthnReq'
   , callIdpGet, callIdpGet'
+  , callIdpGetRaw, callIdpGetRaw'
   , callIdpGetAll, callIdpGetAll'
   , callIdpCreate, callIdpCreate', callIdpCreateRaw, callIdpCreateRaw'
   , callIdpDelete, callIdpDelete'
@@ -714,6 +715,15 @@ callIdpGet' :: (MonadIO m, MonadHttp m) => 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

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

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)