Stripe API client for OCaml
Add ocaml-stripe: Stripe API client for SaaS billing
Covers customers, products, prices, subscriptions, checkout sessions,
billing portal, and webhook signature verification (HMAC-SHA256).
11 tests: webhook signature validation (valid, wrong secret, tampered,
old timestamp, missing timestamp, multiple signatures) + JSON codec
round-trips for all resource types.
Built for ssa.space subscription billing.
+84
-83
+46
-76
lib/stripe.ml
+46
-76
lib/stripe.ml
···
24
24
}
25
25
26
26
let pp_error ppf e =
27
-
Format.fprintf ppf "Stripe error %d (%s): %s [%s]"
27
+
Fmt.pf ppf "Stripe error %d (%s): %s [%s]"
28
28
e.status e.error_type e.message e.code
29
29
30
30
exception Stripe_error of error
···
44
44
45
45
(* {1 Common types} *)
46
46
47
-
type metadata = (string * string) list
47
+
module Smap = Map.Make (String)
48
48
49
-
let metadata_jsont =
50
-
Jsont.Object.map Fun.id
51
-
|> Jsont.Object.keep_unknown Jsont.string
52
-
~enc:(fun md -> List.to_seq md)
53
-
|> Jsont.Object.finish
49
+
type metadata = string Smap.t
50
+
51
+
let metadata_jsont = Jsont.Object.as_string_map Jsont.string
54
52
55
53
(* {1 HTTP helpers} *)
56
54
57
-
let auth_headers cfg =
58
-
[ ("Authorization", "Bearer " ^ cfg.secret_key) ]
55
+
let auth cfg = Requests.Auth.bearer ~token:cfg.secret_key
59
56
60
-
let post cfg path body =
61
-
let url = base_url ^ path in
62
-
let resp =
63
-
Requests.post cfg.session url
64
-
~headers:(auth_headers cfg)
65
-
~body:(Requests.Body.form body)
66
-
in
57
+
let check_response resp =
67
58
let status = Requests.Response.status_code resp in
68
59
let text = Requests.Response.text resp in
69
60
if status >= 400 then begin
···
77
68
end;
78
69
text
79
70
71
+
let post cfg path body =
72
+
let url = base_url ^ path in
73
+
Requests.post cfg.session url ~auth:(auth cfg)
74
+
~body:(Requests.Body.form body)
75
+
|> check_response
76
+
80
77
let get cfg path params =
81
-
let query =
82
-
match params with
83
-
| [] -> ""
84
-
| ps ->
85
-
"?" ^ String.concat "&"
86
-
(List.map (fun (k, v) ->
87
-
Printf.sprintf "%s=%s" k v) ps)
88
-
in
89
-
let url = base_url ^ path ^ query in
90
-
let resp = Requests.get cfg.session url ~headers:(auth_headers cfg) in
91
-
let status = Requests.Response.status_code resp in
92
-
let text = Requests.Response.text resp in
93
-
if status >= 400 then begin
94
-
let err =
95
-
match Jsont_bytesrw.decode_string error_wrapper_jsont text with
96
-
| Ok e -> { e with status }
97
-
| Error _ -> { error_type = "api_error"; message = text;
98
-
code = ""; status }
99
-
in
100
-
raise (Stripe_error err)
101
-
end;
102
-
text
78
+
let url = base_url ^ path in
79
+
Requests.get cfg.session url ~auth:(auth cfg) ~params
80
+
|> check_response
103
81
104
82
let delete cfg path =
105
83
let url = base_url ^ path in
106
-
let resp = Requests.delete cfg.session url ~headers:(auth_headers cfg) in
107
-
let status = Requests.Response.status_code resp in
108
-
let text = Requests.Response.text resp in
109
-
if status >= 400 then begin
110
-
let err =
111
-
match Jsont_bytesrw.decode_string error_wrapper_jsont text with
112
-
| Ok e -> { e with status }
113
-
| Error _ -> { error_type = "api_error"; message = text;
114
-
code = ""; status }
115
-
in
116
-
raise (Stripe_error err)
117
-
end;
118
-
text
84
+
Requests.delete cfg.session url ~auth:(auth cfg)
85
+
|> check_response
119
86
120
87
let decode jsont text =
121
88
match Jsont_bytesrw.decode_string jsont text with
122
89
| Ok v -> v
123
-
| Error e -> failwith (Format.asprintf "Stripe JSON decode: %s" e)
90
+
| Error e -> Fmt.failwith "Stripe JSON decode: %s" e
124
91
125
92
let list_jsont item_jsont =
126
93
Jsont.Object.map (fun data has_more -> (data, has_more))
···
142
109
}
143
110
144
111
let pp ppf c =
145
-
Format.fprintf ppf "customer(%s, %s, %s)" c.id c.email c.name
112
+
Fmt.pf ppf "customer(%s, %s, %s)" c.id c.email c.name
146
113
147
114
let jsont =
148
115
Jsont.Object.map (fun id email name metadata created ->
···
152
119
~enc:(fun c -> c.email)
153
120
|> Jsont.Object.mem "name" Jsont.string ~dec_absent:""
154
121
~enc:(fun c -> c.name)
155
-
|> Jsont.Object.mem "metadata" metadata_jsont ~dec_absent:[]
122
+
|> Jsont.Object.mem "metadata" metadata_jsont ~dec_absent:Smap.empty
156
123
~enc:(fun c -> c.metadata)
157
124
|> Jsont.Object.mem "created" Jsont.int ~dec_absent:0
158
125
~enc:(fun c -> c.created)
···
164
131
@ (match name with Some n -> [ ("name", n) ] | None -> [])
165
132
@ (match metadata with
166
133
| Some md ->
167
-
List.map (fun (k, v) ->
168
-
(Printf.sprintf "metadata[%s]" k, v)) md
134
+
Smap.fold (fun k v acc ->
135
+
(Fmt.str "metadata[%s]" k, v) :: acc) md []
169
136
| None -> [])
170
137
in
171
138
post cfg "/customers" body |> decode jsont
···
194
161
}
195
162
196
163
let pp ppf p =
197
-
Format.fprintf ppf "product(%s, %s)" p.id p.name
164
+
Fmt.pf ppf "product(%s, %s)" p.id p.name
198
165
199
166
let jsont =
200
167
Jsont.Object.map (fun id name active metadata ->
···
203
170
|> Jsont.Object.mem "name" Jsont.string ~enc:(fun p -> p.name)
204
171
|> Jsont.Object.mem "active" Jsont.bool ~dec_absent:true
205
172
~enc:(fun p -> p.active)
206
-
|> Jsont.Object.mem "metadata" metadata_jsont ~dec_absent:[]
173
+
|> Jsont.Object.mem "metadata" metadata_jsont ~dec_absent:Smap.empty
207
174
~enc:(fun p -> p.metadata)
208
175
|> Jsont.Object.finish
209
176
···
212
179
[ ("name", name) ]
213
180
@ (match metadata with
214
181
| Some md ->
215
-
List.map (fun (k, v) ->
216
-
(Printf.sprintf "metadata[%s]" k, v)) md
182
+
Smap.fold (fun k v acc ->
183
+
(Fmt.str "metadata[%s]" k, v) :: acc) md []
217
184
| None -> [])
218
185
in
219
186
post cfg "/products" body |> decode jsont
···
249
216
}
250
217
251
218
let pp ppf p =
252
-
Format.fprintf ppf "price(%s, %d %s)" p.id p.unit_amount p.currency
219
+
Fmt.pf ppf "price(%s, %d %s)" p.id p.unit_amount p.currency
253
220
254
221
let jsont =
255
222
Jsont.Object.map (fun id product unit_amount currency recurring active ->
···
295
262
}
296
263
297
264
let pp ppf s =
298
-
Format.fprintf ppf "subscription(%s, %s, %s)" s.id s.customer s.status
265
+
Fmt.pf ppf "subscription(%s, %s, %s)" s.id s.customer s.status
299
266
300
267
let jsont =
301
268
Jsont.Object.map (fun id customer status current_period_start
···
311
278
~enc:(fun s -> s.current_period_end)
312
279
|> Jsont.Object.mem "cancel_at_period_end" Jsont.bool ~dec_absent:false
313
280
~enc:(fun s -> s.cancel_at_period_end)
314
-
|> Jsont.Object.mem "metadata" metadata_jsont ~dec_absent:[]
281
+
|> Jsont.Object.mem "metadata" metadata_jsont ~dec_absent:Smap.empty
315
282
~enc:(fun s -> s.metadata)
316
283
|> Jsont.Object.finish
317
284
···
321
288
("items[0][price]", price) ]
322
289
@ (match metadata with
323
290
| Some md ->
324
-
List.map (fun (k, v) ->
325
-
(Printf.sprintf "metadata[%s]" k, v)) md
291
+
Smap.fold (fun k v acc ->
292
+
(Fmt.str "metadata[%s]" k, v) :: acc) md []
326
293
| None -> [])
327
294
in
328
295
post cfg "/subscriptions" body |> decode jsont
···
348
315
}
349
316
350
317
let pp ppf c =
351
-
Format.fprintf ppf "checkout(%s, %s)" c.id c.status
318
+
Fmt.pf ppf "checkout(%s, %s)" c.id c.status
352
319
353
320
let jsont =
354
321
Jsont.Object.map (fun id url customer subscription status ->
···
385
352
}
386
353
387
354
let pp ppf p =
388
-
Format.fprintf ppf "portal(%s)" p.id
355
+
Fmt.pf ppf "portal(%s)" p.id
389
356
390
357
let jsont =
391
358
Jsont.Object.map (fun id url -> { id; url })
···
412
379
}
413
380
414
381
let pp_event ppf e =
415
-
Format.fprintf ppf "event(%s, %s)" e.id e.event_type
382
+
Fmt.pf ppf "event(%s, %s)" e.id e.event_type
416
383
417
384
let event_jsont =
418
385
Jsont.Object.map (fun id event_type created data ->
···
447
414
448
415
let tolerance_seconds = 300 (* 5 minutes *)
449
416
417
+
let err_no_timestamp = Error "missing timestamp in Stripe-Signature header"
418
+
let err_invalid_timestamp = Error "invalid timestamp"
419
+
let err_timestamp_old age = Error (Fmt.str "timestamp too old (%ds)" age)
420
+
let err_signature_mismatch = Error "signature mismatch"
421
+
450
422
let verify_signature ~secret ~payload ~signature =
451
423
match parse_signature_header signature with
452
-
| None, _ -> Error "missing timestamp in Stripe-Signature header"
424
+
| None, _ -> err_no_timestamp
453
425
| Some ts, sigs ->
454
426
let signed_payload = ts ^ "." ^ payload in
455
427
let expected = compute_hmac ~secret ~payload:signed_payload in
456
428
if List.exists (fun s -> String.equal s expected) sigs then begin
457
429
match int_of_string_opt ts with
458
-
| None -> Error "invalid timestamp"
430
+
| None -> err_invalid_timestamp
459
431
| Some t ->
460
432
let now = int_of_float (Unix.gettimeofday ()) in
461
-
if abs (now - t) > tolerance_seconds then
462
-
Error (Printf.sprintf "timestamp too old (%ds)" (abs (now - t)))
463
-
else
464
-
decode event_jsont payload |> Result.ok
433
+
let age = abs (now - t) in
434
+
if age > tolerance_seconds then err_timestamp_old age
435
+
else decode event_jsont payload |> Result.ok
465
436
end
466
-
else
467
-
Error "signature mismatch"
437
+
else err_signature_mismatch
468
438
end
+32
-1
lib/stripe.mli
+32
-1
lib/stripe.mli
···
24
24
25
25
(** {1 Common Types} *)
26
26
27
-
type metadata = (string * string) list
27
+
module Smap : Map.S with type key = string
28
+
(** String map for metadata. *)
29
+
30
+
type metadata = string Smap.t
28
31
(** Key-value metadata attached to Stripe objects. *)
29
32
30
33
(** {1 Customers} *)
···
39
42
}
40
43
41
44
val pp : t Fmt.t
45
+
(** Pretty-print a customer. *)
46
+
42
47
val jsont : t Jsont.t
48
+
(** JSON codec for customers. *)
43
49
44
50
val create : config -> email:string -> ?name:string ->
45
51
?metadata:metadata -> unit -> t
···
64
70
}
65
71
66
72
val pp : t Fmt.t
73
+
(** Pretty-print a product. *)
74
+
67
75
val jsont : t Jsont.t
76
+
(** JSON codec for products. *)
68
77
69
78
val create : config -> name:string -> ?metadata:metadata -> unit -> t
79
+
(** Create a product. *)
80
+
70
81
val retrieve : config -> string -> t
82
+
(** [retrieve config product_id] fetches a product. *)
71
83
end
72
84
73
85
(** {1 Prices} *)
···
88
100
}
89
101
90
102
val pp : t Fmt.t
103
+
(** Pretty-print a price. *)
104
+
91
105
val jsont : t Jsont.t
106
+
(** JSON codec for prices. *)
92
107
93
108
val create : config -> product:string -> unit_amount:int ->
94
109
currency:string -> ?interval:string -> ?interval_count:int ->
95
110
unit -> t
111
+
(** Create a price. *)
96
112
end
97
113
98
114
(** {1 Subscriptions} *)
···
109
125
}
110
126
111
127
val pp : t Fmt.t
128
+
(** Pretty-print a subscription. *)
129
+
112
130
val jsont : t Jsont.t
131
+
(** JSON codec for subscriptions. *)
113
132
114
133
val create : config -> customer:string -> price:string ->
115
134
?metadata:metadata -> unit -> t
135
+
(** Create a subscription. *)
116
136
117
137
val retrieve : config -> string -> t
138
+
(** [retrieve config subscription_id] fetches a subscription. *)
118
139
119
140
val cancel : config -> string -> t
120
141
(** Cancel at period end. *)
···
132
153
}
133
154
134
155
val pp : t Fmt.t
156
+
(** Pretty-print a checkout session. *)
157
+
135
158
val jsont : t Jsont.t
159
+
(** JSON codec for checkout sessions. *)
136
160
137
161
val create : config -> customer:string -> price:string ->
138
162
success_url:string -> cancel_url:string -> unit -> t
···
148
172
}
149
173
150
174
val pp : t Fmt.t
175
+
(** Pretty-print a portal session. *)
176
+
151
177
val jsont : t Jsont.t
178
+
(** JSON codec for portal sessions. *)
152
179
153
180
val create : config -> customer:string -> return_url:string -> t
154
181
(** Create a billing portal session for self-service management. *)
···
165
192
}
166
193
167
194
val pp_event : event Fmt.t
195
+
(** Pretty-print a webhook event. *)
196
+
168
197
val event_jsont : event Jsont.t
198
+
(** JSON codec for webhook events. *)
169
199
170
200
val verify_signature : secret:string -> payload:string ->
171
201
signature:string -> (event, string) result
···
188
218
}
189
219
190
220
val pp_error : error Fmt.t
221
+
(** Pretty-print a Stripe API error. *)
191
222
192
223
exception Stripe_error of error
193
224
(** Raised on API errors (4xx/5xx responses). *)
+6
-6
test/test_stripe.ml
+6
-6
test/test_stripe.ml
···
16
16
let sample_event_json =
17
17
{|{"id":"evt_test_123","type":"customer.subscription.updated","created":1735732800,"data":{"object":{"id":"sub_test_456","status":"active"}}}|}
18
18
19
-
let make_signature ~secret ~timestamp ~payload =
19
+
let signature ~secret ~timestamp ~payload =
20
20
let signed_payload = Printf.sprintf "%d.%s" timestamp payload in
21
21
let sig_hex =
22
22
Digestif.SHA256.hmac_string ~key:secret signed_payload
···
28
28
let valid_signature () =
29
29
let timestamp = int_of_float (Unix.gettimeofday ()) in
30
30
let sig_header =
31
-
make_signature ~secret:webhook_secret ~timestamp
31
+
signature ~secret:webhook_secret ~timestamp
32
32
~payload:sample_event_json
33
33
in
34
34
match
···
46
46
let wrong_secret () =
47
47
let timestamp = int_of_float (Unix.gettimeofday ()) in
48
48
let sig_header =
49
-
make_signature ~secret:"whsec_wrong_key" ~timestamp
49
+
signature ~secret:"whsec_wrong_key" ~timestamp
50
50
~payload:sample_event_json
51
51
in
52
52
match
···
62
62
let tampered_payload () =
63
63
let timestamp = int_of_float (Unix.gettimeofday ()) in
64
64
let sig_header =
65
-
make_signature ~secret:webhook_secret ~timestamp
65
+
signature ~secret:webhook_secret ~timestamp
66
66
~payload:sample_event_json
67
67
in
68
68
match
···
78
78
let old_timestamp () =
79
79
let old_timestamp = int_of_float (Unix.gettimeofday ()) - 600 in
80
80
let sig_header =
81
-
make_signature ~secret:webhook_secret ~timestamp:old_timestamp
81
+
signature ~secret:webhook_secret ~timestamp:old_timestamp
82
82
~payload:sample_event_json
83
83
in
84
84
match
···
132
132
Alcotest.(check string) "name" "Test User" c.name;
133
133
Alcotest.(check int) "created" 1735732800 c.created;
134
134
Alcotest.(check bool) "metadata plan"
135
-
true (List.assoc_opt "plan" c.metadata = Some "pro")
135
+
true (Stripe.Smap.find_opt "plan" c.metadata = Some "pro")
136
136
137
137
let subscription_json =
138
138
{|{"id":"sub_test_456","customer":"cus_test_123","status":"active","current_period_start":1735732800,"current_period_end":1738411200,"cancel_at_period_end":false,"metadata":{},"object":"subscription"}|}