generated from coulomb/repo-seed
Bernd Worsch
ce42607fca
Convert all remaining `<- paramOrNothing / param / paramOrDefault /
currentUserOrNothing` monadic binds to `let` — these functions are pure
(ImplicitParams-based) in IHP v1.5, so `<-` is a type error in an IO
do-block.
Controllers fixed:
AgentDelegations, AiGovernancePolicies, Annotations, ApiConsumers,
CollectiveProposals, DecisionRecords, DeploymentRecords,
HubCapabilityManifests, HubRoutingRules, InstitutionalKnowledge,
OutcomeCorrelations, RequirementCandidates, TypeRegistries,
WebhookSubscriptions, Widgets,
Api/V2/{Annotations,InteractionEvents,Token}
WebhookSubscriptions: remove orphaned `Right () ->` case arm that was
left inside a bare `unless` block (structural parse error).
Also carries forward all in-progress fixes from the working tree:
helpers (AgentBridge, ApiRateLimit, BottleneckDetector,
CrossHubPropagation, FrictionScore),
views (CanSelect instances, HSX lambda extraction, formFor wrappers),
env/build (envrc GHCi perms, flake.nix Tailwind + GHC resource limits,
static/app.css additional Tailwind output).
Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
107 lines
4.1 KiB
Haskell
107 lines
4.1 KiB
Haskell
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 "cryptohash-sha256" Crypto.Hash.SHA256 as 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.setRequestBodyLBS (LBS.fromStrict 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 (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
|
|
, LBS.toStrict (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)
|
|
|