backend/feat: Stripe payout webhook

lib/mobility-core/mobility-core.cabal

@@ -222,6 +222,8 @@ library
       Kernel.External.Payout.Stripe.Types.Common
       Kernel.External.Payout.Stripe.Types.Payout
       Kernel.External.Payout.Stripe.Types.Transfer
+      Kernel.External.Payout.Stripe.Types.Webhook
+      Kernel.External.Payout.Stripe.Webhook
       Kernel.External.Payout.Types
       Kernel.External.Plasma
       Kernel.External.Plasma.Interface

lib/mobility-core/src/Kernel/External/Payment/Stripe/Webhook.hs

@@ -15,6 +15,7 @@
 module Kernel.External.Payment.Stripe.Webhook
   ( StripeWebhookAPI,
     serviceEventWebhook,
+    verifyStripeWebhookSignature,
     RawByteString (..),
   )
 where
@@ -89,24 +90,21 @@ serviceEventWebhook paymentConfig checkDuplicatedEvent serviceEventHandler mbSig
         logInfo $ "Stripe webhook parsing failed: " <> show err
         throwError $ InvalidRequest "STRIPE_WEBHOOK_PARSING_FAILED"
 
-verifyAuth ::
+-- | Verify @Stripe-Signature@ for a raw webhook body using the endpoint signing secret
+-- (same algorithm for payment and payout Stripe webhook endpoints).
+verifyStripeWebhookSignature ::
   EncFlow m r =>
-  PaymentServiceConfig ->
+  EncryptedField 'AsEncrypted Text ->
+  Seconds ->
   Text ->
   RawByteString ->
   m ()
-verifyAuth config sigHeader (RawByteString rawBody) = do
-  (secret, tolerance) <- case config of
-    StripeConfig cfg -> do
-      webhookEndpointSecret <- cfg.webhookEndpointSecret & fromMaybeM (InternalError "STRIPE_WEBHOOK_SECRET_NOT_FOUND")
-      s <- decrypt webhookEndpointSecret
-      pure (s, fromMaybe 300 cfg.webhookToleranceSeconds)
-    _ -> throwError (InternalError "NOT_STRIPE_CONFIG")
-
+verifyStripeWebhookSignature encryptedWebhookSecret toleranceSeconds sigHeader (RawByteString rawBody) = do
+  secret <- decrypt encryptedWebhookSecret
   (ts, sigsV1) <- parseStripeSignature sigHeader
   now <- getCurrentTime
   let tsUtc = posixSecondsToUTCTime (fromIntegral ts)
-  when (diffUTCTime now tsUtc > fromIntegral tolerance) $
+  when (diffUTCTime now tsUtc > fromIntegral toleranceSeconds) $
     throwError (InvalidRequest "STRIPE_SIGNATURE_TIMESTAMP_OUT_OF_TOLERANCE")
 
   let rawStrictBody = LBS.toStrict rawBody
@@ -116,6 +114,19 @@ verifyAuth config sigHeader (RawByteString rawBody) = do
   unless (any (secureEqHex expected) sigsV1) $
     throwError (InvalidRequest "INVALID_STRIPE_SIGNATURE")
 
+verifyAuth ::
+  EncFlow m r =>
+  PaymentServiceConfig ->
+  Text ->
+  RawByteString ->
+  m ()
+verifyAuth config sigHeader rawBytes = case config of
+  StripeConfig cfg -> do
+    encryptedSecret <- cfg.webhookEndpointSecret & fromMaybeM (InternalError "STRIPE_WEBHOOK_SECRET_NOT_FOUND")
+    let tolerance = fromMaybe 300 cfg.webhookToleranceSeconds
+    verifyStripeWebhookSignature encryptedSecret tolerance sigHeader rawBytes
+  _ -> throwError (InternalError "NOT_STRIPE_CONFIG")
+
 parseStripeSignature :: (MonadThrow m, Log m) => Text -> m (Int, [BS.ByteString])
 parseStripeSignature hdr = do
   -- format: t=1697040000, v1=abcdef..., v1=...

lib/mobility-core/src/Kernel/External/Payout/Interface/Stripe.hs

@@ -2,21 +2,31 @@ module Kernel.External.Payout.Interface.Stripe
   ( createExternalPayout,
     externalPayoutOrderStatus,
     createTransfer,
+    payoutStripeServiceEventWebhook,
+    castPayoutStatus,
+    unPayoutId,
+    module Reexport,
   )
 where
 
 import Control.Applicative ((<|>))
 import qualified Data.Text as T
 import Kernel.External.Encryption
 import Kernel.External.Payment.Interface.Stripe (centsToUsd, eurToCents, usdToCents)
-import Kernel.External.Payout.Interface.Types
+import Kernel.External.Payment.Stripe.Types.Common (Event)
+import Kernel.External.Payment.Stripe.Webhook (RawByteString (..))
+import Kernel.External.Payout.Interface.Types as IPayout
 import qualified Kernel.External.Payout.Juspay.Types.Payout as Juspay
 import Kernel.External.Payout.Stripe.Config as Reexport
 import qualified Kernel.External.Payout.Stripe.Flow as Stripe
 import qualified Kernel.External.Payout.Stripe.Types as Stripe
+import qualified Kernel.External.Payout.Stripe.Types.Webhook as PayoutWh
+import qualified Kernel.External.Payout.Stripe.Webhook as PayoutStripeWh
 import Kernel.Prelude
 import qualified Kernel.Tools.Metrics.CoreMetrics as Metrics
+import Kernel.Types.Beckn.Ack
 import Kernel.Types.Error
+import Kernel.Types.Id
 import Kernel.Utils.Common
 
 createExternalPayout ::
@@ -119,3 +129,21 @@ createTransfer config req = do
 
     mkCreateTransferResp :: Stripe.TransferObject -> CreateTransferResp
     mkCreateTransferResp Stripe.TransferObject {..} = CreateTransferResp {transferId = id, transferStatus = TRANSFERRED}
+
+payoutStripeServiceEventWebhook ::
+  ( EncFlow m r,
+    HasRequestId r,
+    MonadReader r m
+  ) =>
+  PayoutServiceConfig ->
+  (Id Event -> m Bool) ->
+  (PayoutWh.PayoutStripeWebhookReq -> Text -> m AckResponse) ->
+  Maybe Text ->
+  RawByteString ->
+  m AckResponse
+payoutStripeServiceEventWebhook serviceConfig checkDuplicatedEvent serviceEventHandler mbSigHeader rawBytes =
+  case serviceConfig of
+    IPayout.StripeConfig cfg ->
+      PayoutStripeWh.payoutServiceEventWebhook cfg checkDuplicatedEvent serviceEventHandler mbSigHeader rawBytes
+    IPayout.JuspayConfig _ ->
+      throwError $ InternalError "NOT_STRIPE_PAYOUT_SERVICE_FOR_WEBHOOK"

lib/mobility-core/src/Kernel/External/Payout/Stripe/Types.hs

@@ -6,3 +6,4 @@ where
 import Kernel.External.Payout.Stripe.Types.Common as Reexport
 import Kernel.External.Payout.Stripe.Types.Payout as Reexport
 import Kernel.External.Payout.Stripe.Types.Transfer as Reexport
+import Kernel.External.Payout.Stripe.Types.Webhook as Reexport

lib/mobility-core/src/Kernel/External/Payout/Stripe/Types/Transfer.hs

@@ -6,10 +6,12 @@ module Kernel.External.Payout.Stripe.Types.Transfer where
 
 import Data.Aeson
 import qualified Data.HashMap.Strict as HM
+import Data.OpenApi (ToSchema (declareNamedSchema), genericDeclareNamedSchema)
 import Data.Time.Clock.POSIX (POSIXTime)
 import Kernel.External.Payment.Stripe.Types.Common
 import Kernel.Prelude
 import Kernel.Utils.JSON
+import qualified Kernel.Utils.Schema as S
 import Web.FormUrlEncoded
 import Web.HttpApiData (ToHttpApiData (..))
 
@@ -37,7 +39,6 @@ instance ToForm TransferReq where
             ("description",) . pure . toQueryParam <$> description
           ]
 
--- TODO webhook transfer.created, transfer.reversed, transfer.updated
 -- Currently transfer api would throw error instead of transfer object in case of failure, so there is no status field
 data TransferObject = TransferObject
   { id :: TransferId,
@@ -54,3 +55,6 @@ instance FromJSON TransferObject where
 
 instance ToJSON TransferObject where
   toJSON = genericToJSON stripPrefixUnderscoreIfAny
+
+instance ToSchema TransferObject where
+  declareNamedSchema = genericDeclareNamedSchema S.stripPrefixUnderscoreIfAny

lib/mobility-core/src/Kernel/External/Payout/Stripe/Types/Webhook.hs

@@ -0,0 +1,157 @@
+{-# LANGUAGE DerivingStrategies #-}
+
+-- | Stripe webhook payloads for the dedicated Connect payout webhook endpoint
+-- (separate from payment webhooks; separate Stripe config).
+--
+-- Includes @payout.*@ events and @transfer.*@ for a future transfer webhook or
+-- the same endpoint if both event classes are subscribed.
+module Kernel.External.Payout.Stripe.Types.Webhook where
+
+import Data.Aeson
+import qualified Data.Aeson as A
+import qualified Data.Bimap as BM
+import Data.OpenApi (ToSchema (declareNamedSchema), genericDeclareNamedSchema)
+import Data.Time.Clock.POSIX (POSIXTime)
+import Kernel.External.Payment.Stripe.Types.Common (Event)
+import Kernel.External.Payout.Stripe.Types.Payout (PayoutObject)
+import Kernel.External.Payout.Stripe.Types.Transfer (TransferObject)
+import Kernel.Prelude
+import Kernel.Types.HideSecrets
+import Kernel.Types.Id
+import qualified Kernel.Utils.JSON as J
+import qualified Kernel.Utils.Schema as S
+
+-- | Stripe @payout.*@ and @transfer.*@ webhook @type@ strings (Connect payout flow).
+data PayoutStripeWebhookEventType
+  = -- Payout (data.object is a payout)
+    PayoutCanceled
+  | PayoutCreated
+  | PayoutFailed
+  | PayoutPaid
+  | PayoutReconciliationCompleted
+  | PayoutUpdated
+  | -- Transfer (data.object is a transfer); for future transfer webhook
+    TransferCreated
+  | TransferReversed
+  | TransferUpdated
+  | -- Unknown
+    PayoutStripeWebhookCustomEvent Text
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (ToSchema)
+
+payoutStripeWebhookEventTypeBimap :: BM.Bimap PayoutStripeWebhookEventType Text
+payoutStripeWebhookEventTypeBimap =
+  BM.fromList
+    [ (PayoutCanceled, "payout.canceled"),
+      (PayoutCreated, "payout.created"),
+      (PayoutFailed, "payout.failed"),
+      (PayoutPaid, "payout.paid"),
+      (PayoutReconciliationCompleted, "payout.reconciliation_completed"),
+      (PayoutUpdated, "payout.updated"),
+      (TransferCreated, "transfer.created"),
+      (TransferReversed, "transfer.reversed"),
+      (TransferUpdated, "transfer.updated")
+    ]
+
+instance FromJSON PayoutStripeWebhookEventType where
+  parseJSON = withText "PayoutStripeWebhookEventType" $ \txt ->
+    pure $ fromMaybe (PayoutStripeWebhookCustomEvent txt) $ BM.lookupR txt payoutStripeWebhookEventTypeBimap
+
+instance ToJSON PayoutStripeWebhookEventType where
+  toJSON = String . payoutStripeWebhookEventTypeToText
+
+payoutStripeWebhookEventTypeToText :: PayoutStripeWebhookEventType -> Text
+payoutStripeWebhookEventTypeToText eventType = case BM.lookup eventType payoutStripeWebhookEventTypeBimap of
+  Just txt -> txt
+  Nothing -> case eventType of
+    PayoutStripeWebhookCustomEvent t -> t
+    _ -> show eventType
+
+data PayoutStripeWebhookReq = PayoutStripeWebhookReq
+  { id :: Id Event,
+    _object :: Text,
+    api_version :: Text,
+    created :: POSIXTime,
+    _data :: PayoutStripeWebhookReqData,
+    livemode :: Bool,
+    pending_webhooks :: Integer,
+    request :: PayoutStripeWebhookRequest,
+    _type :: PayoutStripeWebhookEventType
+  }
+  deriving stock (Show, Generic)
+
+instance HideSecrets PayoutStripeWebhookReq where
+  hideSecrets PayoutStripeWebhookReq {..} =
+    PayoutStripeWebhookReq
+      { _data = hideSecrets @PayoutStripeWebhookReqData _data,
+        ..
+      }
+
+instance FromJSON PayoutStripeWebhookReq where
+  parseJSON = genericParseJSON J.stripPrefixUnderscoreIfAny
+
+instance ToJSON PayoutStripeWebhookReq where
+  toJSON = genericToJSON J.stripPrefixUnderscoreIfAny
+
+instance ToSchema PayoutStripeWebhookReq where
+  declareNamedSchema = genericDeclareNamedSchema S.stripPrefixUnderscoreIfAny
+
+newtype PayoutStripeWebhookReqData = PayoutStripeWebhookReqData
+  { _object :: PayoutStripeWebhookObject
+  }
+  deriving stock (Show, Generic)
+
+instance HideSecrets PayoutStripeWebhookReqData where
+  hideSecrets PayoutStripeWebhookReqData {..} =
+    PayoutStripeWebhookReqData
+      { _object = hideSecrets @PayoutStripeWebhookObject _object
+      }
+
+instance FromJSON PayoutStripeWebhookReqData where
+  parseJSON = genericParseJSON J.stripPrefixUnderscoreIfAny
+
+instance ToJSON PayoutStripeWebhookReqData where
+  toJSON = genericToJSON J.stripPrefixUnderscoreIfAny
+
+instance ToSchema PayoutStripeWebhookReqData where
+  declareNamedSchema = genericDeclareNamedSchema S.stripPrefixUnderscoreIfAny
+
+data PayoutStripeWebhookRequest = PayoutStripeWebhookRequest
+  { id :: Maybe Text,
+    idempotency_key :: Maybe Text
+  }
+  deriving stock (Show, Generic)
+  deriving anyclass (FromJSON, ToJSON, ToSchema)
+
+data PayoutStripeWebhookObject
+  = ObjectPayout PayoutObject
+  | ObjectTransfer TransferObject
+  | PayoutStripeWebhookCustomObject Text Value
+  deriving (Show, Generic)
+  deriving anyclass (ToSchema)
+
+getPayoutStripeWebhookObjectType :: PayoutStripeWebhookObject -> Text
+getPayoutStripeWebhookObjectType = \case
+  ObjectPayout _ -> "payout"
+  ObjectTransfer obj -> obj._object
+  PayoutStripeWebhookCustomObject objType _val -> objType
+
+instance HideSecrets PayoutStripeWebhookObject where
+  hideSecrets = \case
+    ObjectPayout a -> ObjectPayout a
+    ObjectTransfer a -> ObjectTransfer a
+    PayoutStripeWebhookCustomObject objType _val -> PayoutStripeWebhookCustomObject objType A.Null
+
+instance ToJSON PayoutStripeWebhookObject where
+  toJSON = \case
+    ObjectPayout a -> toJSON @PayoutObject a
+    ObjectTransfer a -> toJSON @TransferObject a
+    PayoutStripeWebhookCustomObject _objType val -> val
+
+instance FromJSON PayoutStripeWebhookObject where
+  parseJSON val = flip (withObject "PayoutStripeWebhookObject") val $ \obj -> do
+    objectType :: Text <- obj .: "object"
+    case objectType of
+      "payout" -> ObjectPayout <$> parseJSON @PayoutObject val
+      "transfer" -> ObjectTransfer <$> parseJSON @TransferObject val
+      unknown -> pure $ PayoutStripeWebhookCustomObject unknown val

lib/mobility-core/src/Kernel/External/Payout/Stripe/Webhook.hs

@@ -0,0 +1,60 @@
+{-# LANGUAGE DerivingStrategies #-}
+
+module Kernel.External.Payout.Stripe.Webhook
+  ( PayoutStripeWebhookAPI,
+    payoutServiceEventWebhook,
+    RawByteString (..),
+  )
+where
+
+import qualified Data.Aeson as A
+import Kernel.External.Payment.Stripe.Types.Common (Event)
+import Kernel.External.Payment.Stripe.Webhook (RawByteString (..), verifyStripeWebhookSignature)
+import Kernel.External.Payout.Stripe.Config (StripeConfig (..))
+import qualified Kernel.External.Payout.Stripe.Types.Webhook as PayoutWh
+import Kernel.Prelude
+import Kernel.Types.Beckn.Ack
+import Kernel.Types.Error
+import Kernel.Types.HideSecrets
+import Kernel.Types.Id
+import Kernel.Utils.Common
+import Servant hiding (throwError)
+
+type PayoutStripeWebhookAPI =
+  "service" :> "stripe" :> "payout"
+    :> Header "Stripe-Signature" Text
+    :> ReqBody '[OctetStream] RawByteString
+    :> Post '[JSON] AckResponse
+
+payoutServiceEventWebhook ::
+  ( EncFlow m r,
+    HasRequestId r,
+    MonadReader r m
+  ) =>
+  StripeConfig ->
+  (Id Event -> m Bool) ->
+  (PayoutWh.PayoutStripeWebhookReq -> Text -> m AckResponse) ->
+  Maybe Text ->
+  RawByteString ->
+  m AckResponse
+payoutServiceEventWebhook payoutStripeConfig checkDuplicatedEvent serviceEventHandler mbSigHeader rawBytes = do
+  withLogTag "stripePayoutWebhook" $ do
+    let mResp = A.eitherDecode (getRawByteString rawBytes)
+    case mResp of
+      Right (resp :: PayoutWh.PayoutStripeWebhookReq) -> withLogTag ("eventId-" <> resp.id.getId) $ do
+        sigHeader <- mbSigHeader & fromMaybeM (InvalidRequest "Stripe-Signature header did not found")
+        encryptedSecret <- payoutStripeConfig.webhookEndpointSecret & fromMaybeM (InternalError "STRIPE_PAYOUT_WEBHOOK_SECRET_NOT_FOUND")
+        let tolerance = fromMaybe (Seconds 300) payoutStripeConfig.webhookToleranceSeconds
+        void $ verifyStripeWebhookSignature encryptedSecret tolerance sigHeader rawBytes
+        fork "stripe payout webhook" $ do
+          isDuplicatedEvent <- checkDuplicatedEvent resp.id
+          if not isDuplicatedEvent
+            then do
+              let respDump = encodeToText $ hideSecrets @PayoutWh.PayoutStripeWebhookReq resp
+              void $ serviceEventHandler resp respDump
+            else do
+              logInfo $ "Duplicated Stripe payout webhook event found; skipping"
+        pure Ack
+      Left err -> do
+        logInfo $ "Stripe payout webhook parsing failed: " <> show err
+        throwError $ InvalidRequest "STRIPE_PAYOUT_WEBHOOK_PARSING_FAILED"