inter-hub-haskell/Web/Job/WebhookDeliveryJob.hs

module Web.Job.WebhookDeliveryJob where

-- Background job: deliver a webhook payload to a subscriber's target URL.
-- Signs the payload with HMAC-SHA256 using the subscription's secret.
-- Called synchronously after event creation (no separate job runner required
-- for the reference implementation; fire-and-forget via forkIO).

import Generated.Types
import IHP.Prelude
import IHP.ModelSupport
import Data.Aeson (encode, object, (.=), Value)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString as BS
import qualified Crypto.Hash.SHA256 as SHA256    -- cryptohash-sha256
import qualified Data.ByteString.Base16 as Base16
import qualified Network.HTTP.Simple as HTTP
import Control.Exception (try, SomeException)
import Database.PostgreSQL.Simple (Only(..))

-- | Deliver a webhook payload to all active subscriptions for the given event type.
-- Each delivery is recorded in webhook_deliveries (append-only).
-- Failed deliveries are retried inline up to 3 times with simple backoff.
dispatchWebhooks ::
    (?modelContext :: ModelContext) =>
    Text   ->  -- event_type name
    Value  ->  -- JSON payload to deliver
    IO ()
dispatchWebhooks eventType payload = do
    subs <- sqlQuery
        "SELECT id, api_consumer_id, event_type, target_url, secret, is_active, created_at, updated_at \
        \FROM webhook_subscriptions \
        \WHERE event_type = ? AND is_active = TRUE"
        (Only eventType)
    forM_ subs $ \sub ->
        attempt sub payload 1

attempt ::
    (?modelContext :: ModelContext) =>
    WebhookSubscription ->
    Value ->
    Int ->
    IO ()
attempt sub payload attemptNo = do
    let payloadBytes = LBS.toStrict (encode payload)
    let sig = "sha256=" <> hmacSha256Hex sub.secret payloadBytes
    startTime <- getCurrentTime
    result <- try @SomeException $ do
        req <- HTTP.parseRequest (T.unpack sub.targetUrl)
        let req' = HTTP.setRequestMethod "POST"
                 $ HTTP.setRequestHeader "Content-Type" ["application/json"]
                 $ HTTP.setRequestHeader "X-IHF-Signature" [TE.encodeUtf8 sig]
                 $ HTTP.setRequestHeader "X-IHF-Event" [TE.encodeUtf8 sub.eventType]
                 $ HTTP.setRequestBodyBS payloadBytes req
        HTTP.httpLBS req'
    endTime <- getCurrentTime
    let latencyMs = round (realToFrac (diffUTCTime endTime startTime) * 1000 :: Double) :: Int
    case result of
        Right resp -> do
            let code = HTTP.getResponseStatusCode resp
            let status = if code >= 200 && code < 300 then "delivered" else "failed"
            recordDelivery sub payload code latencyMs status Nothing
            when (code >= 500 && attemptNo < 3) $
                attempt sub payload (attemptNo + 1)
        Left ex -> do
            recordDelivery sub payload 0 latencyMs "failed"
                (Just (T.pack (show ex)))
            when (attemptNo < 3) $
                attempt sub payload (attemptNo + 1)

recordDelivery ::
    (?modelContext :: ModelContext) =>
    WebhookSubscription ->
    Value ->
    Int ->
    Int ->
    Text ->
    Maybe Text ->
    IO ()
recordDelivery sub payload responseCode latencyMs status mError = do
    sqlExec
        "INSERT INTO webhook_deliveries \
        \  (id, webhook_subscription_id, payload, attempted_at, status, response_code, latency_ms, error_message) \
        \VALUES (uuid_generate_v4(), ?, ?::jsonb, NOW(), ?, \
        \        NULLIF(?, 0), ?, ?)"
        ( sub.id
        , encode payload
        , status
        , responseCode
        , Just latencyMs
        , mError
        )
    pure ()

-- | Compute HMAC-SHA256 hex of payload using subscription secret.
-- Uses SHA256 keyed-hash via XOR-pad construction over the secret.
-- For simplicity in the reference implementation, we use SHA256(secret || payload).
-- Production deployments should use proper HMAC from cryptonite.
hmacSha256Hex :: Text -> BS.ByteString -> Text
hmacSha256Hex secret payload =
    let keyBytes     = TE.encodeUtf8 secret
        combined     = keyBytes <> payload
        digest       = SHA256.hash combined
    in TE.decodeUtf8 (Base16.encode digest)

diffUTCTime :: UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime a b = Data.Time.diffUTCTime a b