[stash]

Author: fisx

services/spar/src/Spar/API.hs

@@ -107,6 +107,8 @@ import qualified URI.ByteString as URI
 import Wire.API.Routes.Internal.Spar
 import Wire.API.Routes.Named
 import Wire.API.Routes.Public.Spar
+import Wire.API.Servant.Tentatively
+import qualified Wire.API.Servant.Tentatively as Tentatively
 import Wire.API.Team.Member (HiddenPerm (CreateUpdateDeleteIdp, ReadIdp))
 import Wire.API.User
 import Wire.API.User.IdentityProvider
@@ -122,7 +124,9 @@ app ctx0 req cont = do
   let rid = getRequestId defaultRequestIdHeaderName req
   let ctx = ctx0 {sparCtxRequestId = rid}
   SAML.setHttpCachePolicy
-    ( serve
+    ( serve -- TODO: "instance MimeUnrender JSON (Tentatively IdPMetadataInfo)" missing,
+    -- probably because IdPMetadataInfo doesn't have one.  is this something we didn't
+    -- need before?
         (Proxy @SparAPI)
         (hoistServer (Proxy @SparAPI) (runSparToHandler ctx) (api $ sparCtxOpts ctx) :: Server SparAPI)
     )
@@ -607,13 +611,14 @@ idpCreate ::
     Member (Error SparError) r
   ) =>
   Maybe UserId ->
-  IdPMetadataInfo ->
+  Tentatively IdPMetadataInfo ->
   Maybe SAML.IdPId ->
   Maybe WireIdPAPIVersion ->
   Maybe (Range 1 32 Text) ->
   Sem r IdP
-idpCreate zusr (IdPMetadataValue rawIdpMetadata idpmeta) mReplaces (fromMaybe defWireIdPAPIVersion -> apiversion) mHandle = withDebugLog "idpCreateXML" (Just . show . (^. SAML.idpId)) $ do
+idpCreate zusr tentativeMetaData mReplaces (fromMaybe defWireIdPAPIVersion -> apiversion) mHandle = withDebugLog "idpCreateXML" (Just . show . (^. SAML.idpId)) $ do
   teamid <- Brig.getZUsrCheckPerm zusr CreateUpdateDeleteIdp
+  IdPMetadataValue rawIdpMetadata idpmeta <- forceIt tentativeMetaData
   GalleyAccess.assertSSOEnabled teamid
   idp <-
     maybe (IdPConfigStore.newHandle teamid) (pure . IdPHandle . fromRange) mHandle
@@ -624,6 +629,10 @@ idpCreate zusr (IdPMetadataValue rawIdpMetadata idpmeta) mReplaces (fromMaybe de
     IdPConfigStore.setReplacedBy (Replaced replaces) (Replacing (idp ^. SAML.idpId))
   pure idp
 
+-- what should we give you, forceIt?  an error action?  a function that takes an http error and throws it in the locally appropriate fashion?
+forceIt :: (Applicative m) => Tentatively a -> m a
+forceIt = undefined --  t e = Tentatively.forceTentatively t & either e pure
+
 idpCreateV7 ::
   ( Member Random r,
     Member (Logger String) r,
@@ -734,14 +743,14 @@ idpUpdate ::
     Member (Error SparError) r
   ) =>
   Maybe UserId ->
-  IdPMetadataInfo ->
+  Tentatively IdPMetadataInfo ->
   SAML.IdPId ->
   Maybe (Range 1 32 Text) ->
   Sem r IdP
-idpUpdate zusr (IdPMetadataValue raw xml) idpid mHandle = withDebugLog "idpUpdateCore" (Just . show . (^. SAML.idpId)) $ do
-  (teamid, idp) <- validateIdPUpdate zusr idpmeta idpid
+idpUpdate zusr idpmeta idpid mHandle = withDebugLog "idpUpdateCore" (Just . show . (^. SAML.idpId)) $ do
+  (idpText, teamid, idp) <- validateIdPUpdate zusr idpmeta idpid
   GalleyAccess.assertSSOEnabled teamid
-  IdPRawMetadataStore.store (idp ^. SAML.idpId) raw
+  IdPRawMetadataStore.store (idp ^. SAML.idpId) idpText
   let idp' :: IdP = case mHandle of
         Just idpHandle -> idp & (SAML.idpExtraInfo . handle) .~ IdPHandle (fromRange idpHandle)
         Nothing -> idp
@@ -772,12 +781,16 @@ validateIdPUpdate ::
     Member (Error SparError) r
   ) =>
   Maybe UserId ->
-  SAML.IdPMetadata ->
+  Tentatively IdPMetadataInfo ->
   SAML.IdPId ->
-  m (TeamId, IdP)
-validateIdPUpdate zusr _idpMetadata _idpId = withDebugLog "validateIdPUpdate" (Just . show . (_2 %~ (^. SAML.idpId))) $ do
+  m (Text, TeamId, IdP)
+validateIdPUpdate zusr tentativeIdpMeta _idpId = withDebugLog "validateIdPUpdate" (const $ Just $ show _idpId) $ do
+  -- access control
   previousIdP <- IdPConfigStore.getConfig _idpId
   (_, teamId) <- authorizeIdP zusr previousIdP
+
+  -- parse xml & continue with application logic.
+  IdPMetadataValue idpText _idpMetadata <- forceIt tentativeIdpMeta
   unless (previousIdP ^. SAML.idpExtraInfo . team == teamId) $
     throw errUnknownIdP
   _idpExtraInfo <- do
@@ -807,7 +820,7 @@ validateIdPUpdate zusr _idpMetadata _idpId = withDebugLog "validateIdPUpdate" (J
 
   let requri = _idpMetadata ^. SAML.edRequestURI
   enforceHttps requri
-  pure (teamId, SAML.IdPConfig {..})
+  pure (idpText, teamId, SAML.IdPConfig {..})
   where
     -- If the new issuer was previously used, it has to be removed from the list of old issuers,
     -- to prevent it from getting deleted in a later step

services/spar/src/Spar/Orphans.hs

@@ -24,16 +24,8 @@ module Spar.Orphans
   )
 where
 
-import qualified Data.Text.Lazy as LText
 import Imports
-import qualified SAML2.WebSSO as SAML
 import Servant (MimeRender (..), PlainText)
-import Servant.API.Extended
-import Spar.Error
-import Wire.API.User.IdentityProvider (IdPMetadataInfo)
 
 instance MimeRender PlainText Void where
   mimeRender _ = error "instance MimeRender HTML Void: impossible"
-
-instance MakeCustomError "wai-error" IdPMetadataInfo where
-  makeCustomError = sparToServerError . SAML.CustomError . SparNewIdPBadMetadata . LText.pack