[WPB-18349] tentative servant parsers

libs/wire-api/src/Wire/API/Routes/Public/Spar.hs

@@ -41,6 +41,7 @@ import Wire.API.Routes.Named
 import Wire.API.Routes.Public
 import Wire.API.Routes.Version
 import Wire.API.Routes.Versioned
+import Wire.API.Servant.Tentatively
 import Wire.API.SwaggerServant
 import Wire.API.User.IdentityProvider
 import Wire.API.User.Saml
@@ -142,15 +143,15 @@ type IdpGetAll = Get '[JSON] IdPList
 
 -- | See also: 'validateNewIdP', 'idpCreate', 'idpCreateXML'.
 type IdpCreate =
-  ReqBodyCustomError '[RawXML, JSON] "wai-error" IdPMetadataInfo
+  ReqBodyCustomError '[RawXML, JSON] "internal-error" (Tentatively IdPMetadataInfo)
     :> QueryParam' '[Optional, Strict] "replaces" SAML.IdPId
     :> QueryParam' '[Optional, Strict] "api_version" WireIdPAPIVersion -- see also: 'DeprecateSSOAPIV1'
     -- FUTUREWORK: The handle is restricted to 32 characters. Can we find a more reasonable upper bound and create a type for it? Also see `IdpUpdate`.
     :> QueryParam' '[Optional, Strict] "handle" (Range 1 32 Text)
     :> PostCreated '[JSON] IdP
 
 type IdpUpdate =
-  ReqBodyCustomError '[RawXML, JSON] "wai-error" IdPMetadataInfo
+  ReqBodyCustomError '[RawXML, JSON] "internal-error" (Tentatively IdPMetadataInfo)
     :> Capture "id" SAML.IdPId
     -- FUTUREWORK: The handle is restricted to 32 characters. Can we find a more reasonable upper bound and create a type for it? Also see `IdpCreate`.
     :> QueryParam' '[Optional, Strict] "handle" (Range 1 32 Text)

libs/wire-api/src/Wire/API/Servant/Tentatively.hs

@@ -0,0 +1,63 @@
+-- This file is part of the Wire Server implementation.
+--
+-- Copyright (C) 2025 Wire Swiss GmbH <[email protected]>
+--
+-- This program is free software: you can redistribute it and/or modify it under
+-- the terms of the GNU Affero General Public License as published by the Free
+-- Software Foundation, either version 3 of the License, or (at your option) any
+-- later version.
+--
+-- This program is distributed in the hope that it will be useful, but WITHOUT
+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
+-- details.
+--
+-- You should have received a copy of the GNU Affero General Public License along
+-- with this program. If not, see <https://www.gnu.org/licenses/>.
+
+module Wire.API.Servant.Tentatively
+  ( Tentatively (Tentatively),
+    AccessGranted,
+    forceTentatively,
+  )
+where
+
+import Data.Bifunctor
+import Data.ByteString.Lazy.Char8 as LBS
+import Data.Text qualified as T
+import Imports
+import Servant
+import Servant.API.Extended
+
+-- | Parse data coming in through servant only *tentatively* until after the handler has
+-- carried out some dynamic access control.
+--
+-- FUTUREWORK: can we hide authentication and access control deeper in servant such that the
+-- handler doesn't need to explicitly call it?
+newtype Tentatively a = Tentatively {forceTentatively :: AccessGranted -> Either Text a}
+
+-- | Token to give to a tentatively parsed value to force the parser function.
+--
+-- FUTUREWORK: we could make this abstract and only allow the access control code to construct
+-- any values, then the application logic would not be able to parse unauthorized data even by
+-- accident.  But that would require some rethinking how and where we do access control.
+type AccessGranted = ()
+
+instance {-# OVERLAPPING #-} (FromHttpApiData a) => FromHttpApiData (Tentatively a) where
+  parseUrlPiece raw =
+    pure . Tentatively $ \() -> parseUrlPiece @a raw
+
+instance {-# OVERLAPPING #-} (MimeUnrender ct a) => MimeUnrender ct (Tentatively a) where
+  mimeUnrender proxy payload =
+    pure . Tentatively $ \() -> first T.pack $ mimeUnrender proxy payload
+
+instance MakeCustomError "internal-error" (Tentatively a) where
+  makeCustomError msg =
+    err500
+      { errBody =
+          "parsing part of a request wrapped in `Tentatively` failed with "
+            <> LBS.pack (show msg)
+            <> ".  this is a bug in wire-server."
+      }
+
+-- TODO: move this module to extended?

libs/wire-api/wire-api.cabal

@@ -214,6 +214,7 @@ library
     Wire.API.Routes.Version.Wai
     Wire.API.Routes.Versioned
     Wire.API.Routes.WebSocket
+    Wire.API.Servant.Tentatively
     Wire.API.ServantProto
     Wire.API.SwaggerHelper
     Wire.API.SwaggerServant

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,
@@ -635,7 +644,7 @@ idpCreateV7 ::
     Member (Error SparError) r
   ) =>
   Maybe UserId ->
-  IdPMetadataInfo ->
+  Tentatively IdPMetadataInfo ->
   Maybe SAML.IdPId ->
   Maybe WireIdPAPIVersion ->
   Maybe (Range 1 32 Text) ->
@@ -724,9 +733,6 @@ validateNewIdP apiversion _idpMetadata teamId mReplaces idHandle = withDebugLog
 
   pure SAML.IdPConfig {..}
 
--- | FUTUREWORK: 'idpUpdateXML' is only factored out of this function for symmetry with
--- 'idpCreate', which is not a good reason.  make this one function and pass around
--- 'IdPMetadataInfo' directly where convenient.
 idpUpdate ::
   ( Member Random r,
     Member (Logger String) r,
@@ -737,31 +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) = idpUpdateXML zusr raw xml
-
-idpUpdateXML ::
-  ( Member Random r,
-    Member (Logger String) r,
-    Member GalleyAccess r,
-    Member BrigAccess r,
-    Member IdPConfigStore r,
-    Member IdPRawMetadataStore r,
-    Member (Error SparError) r
-  ) =>
-  Maybe UserId ->
-  Text ->
-  SAML.IdPMetadata ->
-  SAML.IdPId ->
-  Maybe (Range 1 32 Text) ->
-  Sem r IdP
-idpUpdateXML zusr raw idpmeta idpid mHandle = withDebugLog "idpUpdateXML" (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
@@ -792,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
@@ -827,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