···3636let error_to_string e =
3737 Format.asprintf "%a" pp_error e
38383939+(* Cbort codec helpers *)
4040+4141+let cbort_error_to_error e =
4242+ Invalid_cbor (Cbort.Error.to_string e)
4343+3944(* COSE Algorithms - RFC 9053 *)
40454146module Algorithm = struct
···9095 | Okp
9196 | Ec2
9297 | Symmetric
9393-9494- type crv =
9595- | P256
9696- | P384
9797- | P521
9898- | Ed25519
999810099 (* COSE key labels *)
101100 let label_kty = 1
···174173 let with_kid id t = { t with kid = Some id }
175174 let with_alg a t = { t with alg = Some a }
176175176176+ (* Helper to build CBOR map pairs *)
177177+ let int_key k = Cbort.Cbor.Int (Z.of_int k)
178178+177179 (* CBOR encoding/decoding for COSE keys *)
178178- let of_cbor _bytes =
179179- Error (Invalid_cose "COSE key parsing not yet implemented")
180180+ let of_cbor bytes =
181181+ match Cbort.decode_string Cbort.any bytes with
182182+ | Error e -> Error (cbort_error_to_error e)
183183+ | Ok cbor ->
184184+ let find_int key = Cbort.Cbor.find (int_key key) cbor in
185185+ let find_bytes key =
186186+ match find_int key with
187187+ | Some (Cbort.Cbor.Bytes s) -> Some s
188188+ | _ -> None
189189+ in
190190+ (* kid can be Text or Bytes per RFC 9052 *)
191191+ let find_kid key =
192192+ match find_int key with
193193+ | Some (Cbort.Cbor.Bytes s) -> Some s
194194+ | Some (Cbort.Cbor.Text s) -> Some s
195195+ | _ -> None
196196+ in
197197+ let get_int_value = function
198198+ | Some (Cbort.Cbor.Int z) -> Some (Z.to_int z)
199199+ | _ -> None
200200+ in
201201+ let kty_val = get_int_value (find_int label_kty) in
202202+ let crv_val = get_int_value (find_int label_crv) in
203203+ let kid = find_kid label_kid in
204204+ let alg = match get_int_value (find_int label_alg) with
205205+ | None -> None
206206+ | Some n -> (match Algorithm.of_cose_int n with Ok a -> Some a | Error _ -> None)
207207+ in
208208+ let x = find_bytes label_x in
209209+ let y = find_bytes label_y in
210210+ let d = find_bytes label_d in
211211+ let k = find_bytes label_k in
212212+ let key_data = match kty_val, crv_val, x, y, d, k with
213213+ | Some 4, _, _, _, _, Some k -> Ok (Symmetric_key { k })
214214+ | Some 1, Some 6, Some x, _, None, _ -> Ok (Ed25519_pub { x })
215215+ | Some 1, Some 6, Some x, _, Some d, _ -> Ok (Ed25519_priv { x; d })
216216+ | Some 2, Some 1, Some x, Some y, None, _ -> Ok (P256_pub { x; y })
217217+ | Some 2, Some 1, Some x, Some y, Some d, _ -> Ok (P256_priv { x; y; d })
218218+ | Some 2, Some 2, Some x, Some y, None, _ -> Ok (P384_pub { x; y })
219219+ | Some 2, Some 2, Some x, Some y, Some d, _ -> Ok (P384_priv { x; y; d })
220220+ | Some 2, Some 3, Some x, Some y, None, _ -> Ok (P521_pub { x; y })
221221+ | Some 2, Some 3, Some x, Some y, Some d, _ -> Ok (P521_priv { x; y; d })
222222+ | _ -> Error (Invalid_cose "unsupported or invalid COSE key structure")
223223+ in
224224+ Result.map (fun key_data -> { key_data; kid; alg }) key_data
180225181226 let to_cbor t =
182182- let open Cbort.Rw in
183183- let buf = Buffer.create 128 in
184184- let w = Bytesrw.Bytes.Writer.of_buffer buf in
185185- let e = make_encoder w in
227227+ let pairs = ref [] in
228228+ let add k v = pairs := (int_key k, v) :: !pairs in
229229+ let add_bytes k s = add k (Cbort.Cbor.Bytes s) in
230230+ let add_int k i = add k (Cbort.Cbor.Int (Z.of_int i)) in
186231187187- (* Count the number of map entries *)
188188- let count = ref 1 in (* kty is always present *)
189189- if Option.is_some t.kid then incr count;
190190- if Option.is_some t.alg then incr count;
232232+ (* kty - always present *)
191233 (match t.key_data with
192192- | Symmetric_key _ -> incr count (* k *)
193193- | Ed25519_pub _ -> count := !count + 2 (* crv, x *)
194194- | Ed25519_priv _ -> count := !count + 3 (* crv, x, d *)
195195- | P256_pub _ | P384_pub _ | P521_pub _ -> count := !count + 3 (* crv, x, y *)
196196- | P256_priv _ | P384_priv _ | P521_priv _ -> count := !count + 4); (* crv, x, y, d *)
197197-198198- write_map_start e !count;
199199-200200- (* kty *)
201201- write_int e label_kty;
202202- (match t.key_data with
203203- | Symmetric_key _ -> write_int e kty_symmetric
204204- | Ed25519_pub _ | Ed25519_priv _ -> write_int e kty_okp
205205- | _ -> write_int e kty_ec2);
234234+ | Symmetric_key _ -> add_int label_kty kty_symmetric
235235+ | Ed25519_pub _ | Ed25519_priv _ -> add_int label_kty kty_okp
236236+ | _ -> add_int label_kty kty_ec2);
206237207238 (* kid (optional) *)
208208- Option.iter (fun kid ->
209209- write_int e label_kid;
210210- write_bytes_header e (String.length kid);
211211- write_bytes e kid
212212- ) t.kid;
239239+ Option.iter (fun kid -> add_bytes label_kid kid) t.kid;
213240214241 (* alg (optional) *)
215215- Option.iter (fun alg ->
216216- write_int e label_alg;
217217- write_int e (Algorithm.to_cose_int alg)
218218- ) t.alg;
242242+ Option.iter (fun alg -> add_int label_alg (Algorithm.to_cose_int alg)) t.alg;
219243220244 (* Key-type specific parameters *)
221245 (match t.key_data with
222246 | Symmetric_key { k } ->
223223- write_int e label_k;
224224- write_bytes_header e (String.length k);
225225- write_bytes e k
247247+ add_bytes label_k k
226248227249 | Ed25519_pub { x } ->
228228- write_int e label_crv;
229229- write_int e crv_ed25519;
230230- write_int e label_x;
231231- write_bytes_header e (String.length x);
232232- write_bytes e x
250250+ add_int label_crv crv_ed25519;
251251+ add_bytes label_x x
233252234253 | Ed25519_priv { x; d } ->
235235- write_int e label_crv;
236236- write_int e crv_ed25519;
237237- write_int e label_x;
238238- write_bytes_header e (String.length x);
239239- write_bytes e x;
240240- write_int e label_d;
241241- write_bytes_header e (String.length d);
242242- write_bytes e d
254254+ add_int label_crv crv_ed25519;
255255+ add_bytes label_x x;
256256+ add_bytes label_d d
243257244258 | P256_pub { x; y } ->
245245- write_int e label_crv;
246246- write_int e crv_p256;
247247- write_int e label_x;
248248- write_bytes_header e (String.length x);
249249- write_bytes e x;
250250- write_int e label_y;
251251- write_bytes_header e (String.length y);
252252- write_bytes e y
259259+ add_int label_crv crv_p256;
260260+ add_bytes label_x x;
261261+ add_bytes label_y y
253262254263 | P256_priv { x; y; d } ->
255255- write_int e label_crv;
256256- write_int e crv_p256;
257257- write_int e label_x;
258258- write_bytes_header e (String.length x);
259259- write_bytes e x;
260260- write_int e label_y;
261261- write_bytes_header e (String.length y);
262262- write_bytes e y;
263263- write_int e label_d;
264264- write_bytes_header e (String.length d);
265265- write_bytes e d
264264+ add_int label_crv crv_p256;
265265+ add_bytes label_x x;
266266+ add_bytes label_y y;
267267+ add_bytes label_d d
266268267269 | P384_pub { x; y } ->
268268- write_int e label_crv;
269269- write_int e crv_p384;
270270- write_int e label_x;
271271- write_bytes_header e (String.length x);
272272- write_bytes e x;
273273- write_int e label_y;
274274- write_bytes_header e (String.length y);
275275- write_bytes e y
270270+ add_int label_crv crv_p384;
271271+ add_bytes label_x x;
272272+ add_bytes label_y y
276273277274 | P384_priv { x; y; d } ->
278278- write_int e label_crv;
279279- write_int e crv_p384;
280280- write_int e label_x;
281281- write_bytes_header e (String.length x);
282282- write_bytes e x;
283283- write_int e label_y;
284284- write_bytes_header e (String.length y);
285285- write_bytes e y;
286286- write_int e label_d;
287287- write_bytes_header e (String.length d);
288288- write_bytes e d
275275+ add_int label_crv crv_p384;
276276+ add_bytes label_x x;
277277+ add_bytes label_y y;
278278+ add_bytes label_d d
289279290280 | P521_pub { x; y } ->
291291- write_int e label_crv;
292292- write_int e crv_p521;
293293- write_int e label_x;
294294- write_bytes_header e (String.length x);
295295- write_bytes e x;
296296- write_int e label_y;
297297- write_bytes_header e (String.length y);
298298- write_bytes e y
281281+ add_int label_crv crv_p521;
282282+ add_bytes label_x x;
283283+ add_bytes label_y y
299284300285 | P521_priv { x; y; d } ->
301301- write_int e label_crv;
302302- write_int e crv_p521;
303303- write_int e label_x;
304304- write_bytes_header e (String.length x);
305305- write_bytes e x;
306306- write_int e label_y;
307307- write_bytes_header e (String.length y);
308308- write_bytes e y;
309309- write_int e label_d;
310310- write_bytes_header e (String.length d);
311311- write_bytes e d);
312312-313313- flush_encoder e;
314314- Buffer.contents buf
286286+ add_int label_crv crv_p521;
287287+ add_bytes label_x x;
288288+ add_bytes label_y y;
289289+ add_bytes label_d d);
315290316316- (* Suppress unused warnings *)
317317- let _ = (label_kty, label_kid, label_alg, label_crv, label_x, label_y, label_d, label_k)
318318- let _ = (kty_okp, kty_ec2, kty_symmetric, crv_p256, crv_p384, crv_p521, crv_ed25519)
291291+ Cbort.encode_string Cbort.any (Cbort.Cbor.Map (List.rev !pairs))
319292end
320293321294(* CWT Claims - RFC 8392 Section 3 *)
···342315 nbf : Ptime.t option;
343316 iat : Ptime.t option;
344317 cti : string option;
345345- custom : (claim_key * string) list;
318318+ custom : (claim_key * Cbort.Cbor.t) list;
346319 }
347320348321 let iss t = t.iss
···383356 let set_string_key key value t = { t with custom = (String_key key, value) :: t.custom }
384357 let build t = t
385358386386- let of_cbor _bytes =
387387- Error (Invalid_claims "Claims parsing not yet implemented")
359359+ (* Standard claim keys *)
360360+ let standard_keys = [key_iss; key_sub; key_aud; key_exp; key_nbf; key_iat; key_cti]
388361389389- let to_cbor t =
390390- let open Cbort.Rw in
391391- let buf = Buffer.create 128 in
392392- let w = Bytesrw.Bytes.Writer.of_buffer buf in
393393- let e = make_encoder w in
362362+ (* Helper to convert claim_key to CBOR *)
363363+ let claim_key_to_cbor = function
364364+ | Int_key i -> Cbort.Cbor.Int (Z.of_int i)
365365+ | String_key s -> Cbort.Cbor.Text s
394366395395- (* Count the number of map entries *)
396396- let count = ref 0 in
397397- if Option.is_some t.iss then incr count;
398398- if Option.is_some t.sub then incr count;
399399- if t.aud <> [] then incr count;
400400- if Option.is_some t.exp then incr count;
401401- if Option.is_some t.nbf then incr count;
402402- if Option.is_some t.iat then incr count;
403403- if Option.is_some t.cti then incr count;
404404- count := !count + List.length t.custom;
367367+ (* Helper to find value by integer key in CBOR map *)
368368+ let find_int_key key pairs =
369369+ let target = Cbort.Cbor.Int (Z.of_int key) in
370370+ List.find_map (fun (k, v) ->
371371+ if Cbort.Cbor.equal k target then Some v else None
372372+ ) pairs
405373406406- write_map_start e !count;
374374+ (* Helper to extract string from CBOR *)
375375+ let cbor_to_string = function
376376+ | Cbort.Cbor.Text s -> Some s
377377+ | _ -> None
407378408408- (* iss (1) *)
409409- Option.iter (fun iss ->
410410- write_int e key_iss;
411411- write_text e iss
412412- ) t.iss;
379379+ (* Helper to extract bytes from CBOR *)
380380+ let cbor_to_bytes = function
381381+ | Cbort.Cbor.Bytes s -> Some s
382382+ | _ -> None
413383414414- (* sub (2) *)
415415- Option.iter (fun sub ->
416416- write_int e key_sub;
417417- write_text e sub
418418- ) t.sub;
384384+ (* Helper to extract ptime from CBOR integer *)
385385+ let cbor_to_ptime = function
386386+ | Cbort.Cbor.Int z ->
387387+ Ptime.of_float_s (Z.to_float z)
388388+ | _ -> None
419389420420- (* aud (3) *)
421421- if t.aud <> [] then begin
422422- write_int e key_aud;
423423- if List.length t.aud = 1 then
424424- write_text e (List.hd t.aud)
425425- else begin
426426- write_array_start e (List.length t.aud);
427427- List.iter (write_text e) t.aud
428428- end
429429- end;
390390+ (* Helper to extract audience (string or array of strings) *)
391391+ let cbor_to_aud = function
392392+ | Cbort.Cbor.Text s -> Some [s]
393393+ | Cbort.Cbor.Array items ->
394394+ let strings = List.filter_map cbor_to_string items in
395395+ if List.length strings = List.length items then Some strings
396396+ else None
397397+ | _ -> None
430398431431- (* exp (4) - NumericDate as integer seconds since epoch *)
432432- Option.iter (fun exp ->
433433- write_int e key_exp;
434434- let secs = Ptime.to_float_s exp |> Float.to_int in
435435- write_int e secs
399399+ (* Decode claims from CBOR map pairs *)
400400+ let decode_from_pairs pairs =
401401+ let iss = Option.bind (find_int_key key_iss pairs) cbor_to_string in
402402+ let sub = Option.bind (find_int_key key_sub pairs) cbor_to_string in
403403+ let aud = Option.value ~default:[] (Option.bind (find_int_key key_aud pairs) cbor_to_aud) in
404404+ let exp = Option.bind (find_int_key key_exp pairs) cbor_to_ptime in
405405+ let nbf = Option.bind (find_int_key key_nbf pairs) cbor_to_ptime in
406406+ let iat = Option.bind (find_int_key key_iat pairs) cbor_to_ptime in
407407+ let cti = Option.bind (find_int_key key_cti pairs) cbor_to_bytes in
408408+ (* Collect custom claims (non-standard keys) *)
409409+ let custom = List.filter_map (fun (k, v) ->
410410+ match k with
411411+ | Cbort.Cbor.Int z ->
412412+ let i = Z.to_int z in
413413+ if List.mem i standard_keys then None
414414+ else Some (Int_key i, v)
415415+ | Cbort.Cbor.Text s -> Some (String_key s, v)
416416+ | _ -> None
417417+ ) pairs in
418418+ { iss; sub; aud; exp; nbf; iat; cti; custom }
419419+420420+ (* Encode claims to CBOR map pairs *)
421421+ let encode_to_pairs t =
422422+ let open Cbort.Cbor in
423423+ let pairs = ref [] in
424424+ let add_int k v = pairs := (Int (Z.of_int k), v) :: !pairs in
425425+ (* Standard claims *)
426426+ Option.iter (fun v -> add_int key_iss (Text v)) t.iss;
427427+ Option.iter (fun v -> add_int key_sub (Text v)) t.sub;
428428+ (match t.aud with
429429+ | [] -> ()
430430+ | [s] -> add_int key_aud (Text s)
431431+ | lst -> add_int key_aud (Array (List.map (fun s -> Text s) lst)));
432432+ Option.iter (fun v ->
433433+ add_int key_exp (Int (Z.of_float (Ptime.to_float_s v)))
436434 ) t.exp;
437437-438438- (* nbf (5) *)
439439- Option.iter (fun nbf ->
440440- write_int e key_nbf;
441441- let secs = Ptime.to_float_s nbf |> Float.to_int in
442442- write_int e secs
435435+ Option.iter (fun v ->
436436+ add_int key_nbf (Int (Z.of_float (Ptime.to_float_s v)))
443437 ) t.nbf;
444444-445445- (* iat (6) *)
446446- Option.iter (fun iat ->
447447- write_int e key_iat;
448448- let secs = Ptime.to_float_s iat |> Float.to_int in
449449- write_int e secs
438438+ Option.iter (fun v ->
439439+ add_int key_iat (Int (Z.of_float (Ptime.to_float_s v)))
450440 ) t.iat;
441441+ Option.iter (fun v -> add_int key_cti (Bytes v)) t.cti;
442442+ (* Custom claims *)
443443+ List.iter (fun (k, v) ->
444444+ pairs := (claim_key_to_cbor k, v) :: !pairs
445445+ ) t.custom;
446446+ List.rev !pairs
451447452452- (* cti (7) - byte string *)
453453- Option.iter (fun cti ->
454454- write_int e key_cti;
455455- write_bytes_header e (String.length cti);
456456- write_bytes e cti
457457- ) t.cti;
448448+ let claims_not_map_error = "claims must be a CBOR map"
458449459459- (* Custom claims *)
460460- List.iter (fun (key, value) ->
461461- (match key with
462462- | Int_key k -> write_int e k
463463- | String_key k -> write_text e k);
464464- (* Value is already CBOR-encoded, write it raw *)
465465- write_bytes e value
466466- ) t.custom;
450450+ (** Full codec for claims including custom claims *)
451451+ let codec : t Cbort.t =
452452+ Cbort.conv
453453+ (fun cbor ->
454454+ match cbor with
455455+ | Cbort.Cbor.Map pairs -> Ok (decode_from_pairs pairs)
456456+ | _ -> Error claims_not_map_error)
457457+ (fun t -> Cbort.Cbor.Map (encode_to_pairs t))
458458+ Cbort.any
467459468468- flush_encoder e;
469469- Buffer.contents buf
460460+ let of_cbor bytes =
461461+ match Cbort.decode_string codec bytes with
462462+ | Ok t -> Ok t
463463+ | Error e ->
464464+ (* Distinguish CBOR parse errors from claims structure errors *)
465465+ let msg = Cbort.Error.to_string e in
466466+ if msg = claims_not_map_error then
467467+ Error (Invalid_claims msg)
468468+ else
469469+ Error (Invalid_cbor msg)
470470471471- (* Suppress unused warnings *)
472472- let _ = (key_iss, key_sub, key_aud, key_exp, key_nbf, key_iat, key_cti)
471471+ let to_cbor t = Cbort.encode_string codec t
473472end
474473475474(* CWT Token *)
···496495let kid t = t.kid
497496let raw t = t.raw
498497499499-let parse _bytes =
500500- Error (Invalid_cbor "CWT parsing not yet implemented")
498498+(** Extract kid from header - can be Text or Bytes per RFC 9052 *)
499499+let extract_kid_from_header pairs =
500500+ let kid_key = Cbort.Cbor.Int (Z.of_int header_kid) in
501501+ List.find_map (fun (k, v) ->
502502+ if Cbort.Cbor.equal k kid_key then
503503+ match v with
504504+ | Cbort.Cbor.Bytes s -> Some s
505505+ | Cbort.Cbor.Text s -> Some s
506506+ | _ -> None
507507+ else None
508508+ ) pairs
509509+510510+(** Decode protected header to extract algorithm and kid *)
511511+let decode_protected_header bytes =
512512+ match Cbort.decode_string Cbort.any bytes with
513513+ | Error _ -> (None, None)
514514+ | Ok (Cbort.Cbor.Map pairs) ->
515515+ let alg_key = Cbort.Cbor.Int (Z.of_int header_alg) in
516516+ let alg_int = List.find_map (fun (k, v) ->
517517+ if Cbort.Cbor.equal k alg_key then
518518+ match v with
519519+ | Cbort.Cbor.Int z -> Some (Z.to_int z)
520520+ | _ -> None
521521+ else None
522522+ ) pairs in
523523+ let algorithm = Option.bind alg_int (fun n ->
524524+ match Algorithm.of_cose_int n with
525525+ | Ok alg -> Some alg
526526+ | Error _ -> None)
527527+ in
528528+ let kid = extract_kid_from_header pairs in
529529+ (algorithm, kid)
530530+ | Ok _ -> (None, None)
531531+532532+(** Extract kid from unprotected header if present *)
533533+let decode_unprotected_header cbor =
534534+ match cbor with
535535+ | Cbort.Cbor.Map pairs -> extract_kid_from_header pairs
536536+ | _ -> None
537537+538538+let parse bytes =
539539+ match Cbort.decode_string Cbort.any bytes with
540540+ | Error e -> Error (cbort_error_to_error e)
541541+ | Ok cbor ->
542542+ (* Handle optional COSE tag and extract the array *)
543543+ let cose_array = match cbor with
544544+ | Cbort.Cbor.Tag (18, arr) -> Some arr (* COSE_Sign1 *)
545545+ | Cbort.Cbor.Tag (17, arr) -> Some arr (* COSE_Mac0 *)
546546+ | Cbort.Cbor.Array _ as arr -> Some arr (* Untagged *)
547547+ | _ -> None
548548+ in
549549+ match cose_array with
550550+ | None -> Error (Invalid_cose "expected COSE_Sign1 or COSE_Mac0 structure")
551551+ | Some (Cbort.Cbor.Array [protected_bstr; unprotected; payload_bstr; sig_bstr]) ->
552552+ (* Extract byte strings *)
553553+ let protected_header = match protected_bstr with
554554+ | Cbort.Cbor.Bytes s -> Some s
555555+ | _ -> None
556556+ in
557557+ let signature = match sig_bstr with
558558+ | Cbort.Cbor.Bytes s -> Some s
559559+ | _ -> None
560560+ in
561561+ (match protected_header, signature with
562562+ | Some protected_header, Some signature ->
563563+ (* Decode protected header for algorithm and kid *)
564564+ let (algorithm, protected_kid) = decode_protected_header protected_header in
565565+ (* Decode unprotected header for kid - prefer unprotected over protected *)
566566+ let unprotected_kid = decode_unprotected_header unprotected in
567567+ let kid = match unprotected_kid with
568568+ | Some _ -> unprotected_kid
569569+ | None -> protected_kid
570570+ in
571571+ (* Decode claims from payload - handle detached payloads *)
572572+ (match payload_bstr with
573573+ | Cbort.Cbor.Null ->
574574+ (* Detached payload: not currently supported *)
575575+ Error (Invalid_cose "detached payloads are not supported")
576576+ | Cbort.Cbor.Bytes payload ->
577577+ (match Claims.of_cbor payload with
578578+ | Error e -> Error e
579579+ | Ok claims ->
580580+ Ok { claims; algorithm; kid; protected_header; signature; raw = bytes })
581581+ | _ -> Error (Invalid_cose "payload must be a byte string or null"))
582582+ | _ -> Error (Invalid_cose "invalid COSE structure fields"))
583583+ | Some (Cbort.Cbor.Array _) ->
584584+ Error (Invalid_cose "COSE structure must have exactly 4 elements")
585585+ | Some _ ->
586586+ Error (Invalid_cose "expected COSE array structure")
501587502588(* Cryptographic operations *)
503589···506592 match alg with
507593 | Algorithm.HMAC_256_64 ->
508594 let mac = Hash.SHA256.hmac_string ~key payload in
509509- String.sub (Hash.SHA256.to_raw_string mac) 0 8
595595+ Ok (String.sub (Hash.SHA256.to_raw_string mac) 0 8)
510596 | Algorithm.HMAC_256 ->
511597 let mac = Hash.SHA256.hmac_string ~key payload in
512512- Hash.SHA256.to_raw_string mac
598598+ Ok (Hash.SHA256.to_raw_string mac)
513599 | Algorithm.HMAC_384 ->
514600 let mac = Hash.SHA384.hmac_string ~key payload in
515515- Hash.SHA384.to_raw_string mac
601601+ Ok (Hash.SHA384.to_raw_string mac)
516602 | Algorithm.HMAC_512 ->
517603 let mac = Hash.SHA512.hmac_string ~key payload in
518518- Hash.SHA512.to_raw_string mac
519519- | _ -> failwith "Not an HMAC algorithm"
604604+ Ok (Hash.SHA512.to_raw_string mac)
605605+ | _ -> Error (Key_type_mismatch "Not an HMAC algorithm")
520606521607let hmac_verify alg key payload expected_mac =
522522- let computed = hmac_sign alg key payload in
523523- Eqaf.equal computed expected_mac
608608+ match hmac_sign alg key payload with
609609+ | Error _ -> false
610610+ | Ok computed -> Eqaf.equal computed expected_mac
524611525612let p256_sign ~priv payload =
526613 match Mirage_crypto_ec.P256.Dsa.priv_of_octets priv with
···566653 | Error _ -> Error (Key_type_mismatch "Invalid Ed25519 private key")
567654 | Ok priv -> Ok (Mirage_crypto_ec.Ed25519.sign ~key:priv payload)
568655656656+(** Build Sig_structure or MAC_structure for COSE operations *)
657657+let build_sig_structure ~context_string ~protected_header ~payload =
658658+ let open Cbort.Cbor in
659659+ Array [
660660+ Text context_string;
661661+ Bytes protected_header;
662662+ Bytes ""; (* external_aad = empty *)
663663+ Bytes payload;
664664+ ]
665665+ |> Cbort.encode_string Cbort.any
666666+667667+(** Expected signature/MAC length for each algorithm *)
668668+let expected_sig_length = function
669669+ | Algorithm.ES256 -> 64 (* 32 + 32 *)
670670+ | Algorithm.ES384 -> 96 (* 48 + 48 *)
671671+ | Algorithm.ES512 -> 132 (* 66 + 66 *)
672672+ | Algorithm.EdDSA -> 64
673673+ | Algorithm.HMAC_256_64 -> 8
674674+ | Algorithm.HMAC_256 -> 32
675675+ | Algorithm.HMAC_384 -> 48
676676+ | Algorithm.HMAC_512 -> 64
677677+569678let verify ~key ?allowed_algs t =
570679 (* Check algorithm is allowed *)
571680 let alg = match t.algorithm with
···582691 if not (List.mem alg allowed) then
583692 Error (Algorithm_not_allowed (Algorithm.to_string alg))
584693 else
585585- (* Build Sig_structure or MAC_structure for verification *)
586586- let sig_structure =
587587- let open Cbort.Rw in
588588- let buf = Buffer.create 128 in
589589- let w = Bytesrw.Bytes.Writer.of_buffer buf in
590590- let e = make_encoder w in
591591- write_array_start e 4;
592592- write_text e (match alg with
694694+ (* Validate signature length before attempting to parse it *)
695695+ let expected_len = expected_sig_length alg in
696696+ let actual_len = String.length t.signature in
697697+ if actual_len <> expected_len then
698698+ Error (Invalid_cose (Printf.sprintf
699699+ "signature length mismatch: expected %d, got %d" expected_len actual_len))
700700+ else
701701+ (* Build Sig_structure or MAC_structure for verification *)
702702+ let context_string = match alg with
593703 | Algorithm.HMAC_256_64 | Algorithm.HMAC_256
594704 | Algorithm.HMAC_384 | Algorithm.HMAC_512 -> "MAC0"
595595- | _ -> "Signature1");
596596- write_bytes_header e (String.length t.protected_header);
597597- write_bytes e t.protected_header;
598598- write_bytes_header e 0; (* external_aad = empty *)
705705+ | _ -> "Signature1"
706706+ in
599707 let payload = Claims.to_cbor t.claims in
600600- write_bytes_header e (String.length payload);
601601- write_bytes e payload;
602602- flush_encoder e;
603603- Buffer.contents buf
604604- in
605605- (* Verify based on algorithm *)
606606- let verified = match alg, key.Cose_key.key_data with
607607- | (Algorithm.HMAC_256_64 | Algorithm.HMAC_256
608608- | Algorithm.HMAC_384 | Algorithm.HMAC_512), Cose_key.Symmetric_key { k } ->
609609- hmac_verify alg k sig_structure t.signature
610610- | Algorithm.EdDSA, (Cose_key.Ed25519_pub { x } | Cose_key.Ed25519_priv { x; _ }) ->
611611- (match Mirage_crypto_ec.Ed25519.pub_of_octets x with
612612- | Ok pub ->
613613- Mirage_crypto_ec.Ed25519.verify ~key:pub t.signature ~msg:sig_structure
614614- | Error _ -> false)
615615- | Algorithm.ES256, (Cose_key.P256_pub { x; y } | Cose_key.P256_priv { x; y; _ }) ->
616616- (match Mirage_crypto_ec.P256.Dsa.pub_of_octets ("\x04" ^ x ^ y) with
617617- | Ok pub ->
618618- let hash = Digestif.SHA256.(digest_string sig_structure |> to_raw_string) in
619619- let r = String.sub t.signature 0 32 in
620620- let s = String.sub t.signature 32 32 in
621621- Mirage_crypto_ec.P256.Dsa.verify ~key:pub (r, s) hash
622622- | Error _ -> false)
623623- | _ -> false
624624- in
625625- if verified then Ok ()
626626- else Error Signature_mismatch
708708+ let sig_structure = build_sig_structure
709709+ ~context_string ~protected_header:t.protected_header ~payload
710710+ in
711711+ (* Verify based on algorithm - returns Result to distinguish key mismatch from sig failure *)
712712+ let verify_result = match alg, key.Cose_key.key_data with
713713+ | (Algorithm.HMAC_256_64 | Algorithm.HMAC_256
714714+ | Algorithm.HMAC_384 | Algorithm.HMAC_512), Cose_key.Symmetric_key { k } ->
715715+ if hmac_verify alg k sig_structure t.signature then Ok ()
716716+ else Error Signature_mismatch
717717+ | Algorithm.EdDSA, (Cose_key.Ed25519_pub { x } | Cose_key.Ed25519_priv { x; _ }) ->
718718+ (match Mirage_crypto_ec.Ed25519.pub_of_octets x with
719719+ | Ok pub ->
720720+ if Mirage_crypto_ec.Ed25519.verify ~key:pub t.signature ~msg:sig_structure
721721+ then Ok ()
722722+ else Error Signature_mismatch
723723+ | Error _ -> Error (Key_type_mismatch "Invalid Ed25519 public key"))
724724+ | Algorithm.ES256, (Cose_key.P256_pub { x; y } | Cose_key.P256_priv { x; y; _ }) ->
725725+ (match Mirage_crypto_ec.P256.Dsa.pub_of_octets ("\x04" ^ x ^ y) with
726726+ | Ok pub ->
727727+ let hash = Digestif.SHA256.(digest_string sig_structure |> to_raw_string) in
728728+ let r = String.sub t.signature 0 32 in
729729+ let s = String.sub t.signature 32 32 in
730730+ if Mirage_crypto_ec.P256.Dsa.verify ~key:pub (r, s) hash
731731+ then Ok ()
732732+ else Error Signature_mismatch
733733+ | Error _ -> Error (Key_type_mismatch "Invalid P-256 public key"))
734734+ | Algorithm.ES384, (Cose_key.P384_pub { x; y } | Cose_key.P384_priv { x; y; _ }) ->
735735+ (match Mirage_crypto_ec.P384.Dsa.pub_of_octets ("\x04" ^ x ^ y) with
736736+ | Ok pub ->
737737+ let hash = Digestif.SHA384.(digest_string sig_structure |> to_raw_string) in
738738+ let r = String.sub t.signature 0 48 in
739739+ let s = String.sub t.signature 48 48 in
740740+ if Mirage_crypto_ec.P384.Dsa.verify ~key:pub (r, s) hash
741741+ then Ok ()
742742+ else Error Signature_mismatch
743743+ | Error _ -> Error (Key_type_mismatch "Invalid P-384 public key"))
744744+ | Algorithm.ES512, (Cose_key.P521_pub { x; y } | Cose_key.P521_priv { x; y; _ }) ->
745745+ (match Mirage_crypto_ec.P521.Dsa.pub_of_octets ("\x04" ^ x ^ y) with
746746+ | Ok pub ->
747747+ let hash = Digestif.SHA512.(digest_string sig_structure |> to_raw_string) in
748748+ let r = String.sub t.signature 0 66 in
749749+ let s = String.sub t.signature 66 66 in
750750+ if Mirage_crypto_ec.P521.Dsa.verify ~key:pub (r, s) hash
751751+ then Ok ()
752752+ else Error Signature_mismatch
753753+ | Error _ -> Error (Key_type_mismatch "Invalid P-521 public key"))
754754+ | _ ->
755755+ Error (Key_type_mismatch
756756+ (Printf.sprintf "Key type doesn't match algorithm %s"
757757+ (Algorithm.to_string alg)))
758758+ in
759759+ verify_result
627760628761let validate ~now ?iss ?aud ?leeway t =
629762 let leeway = Option.value leeway ~default:Ptime.Span.zero in
···677810 | Error _ as e -> e
678811 | Ok () -> validate ~now ?iss ?aud ?leeway t
679812813813+(** Encode protected header as CBOR map *)
814814+let encode_protected_header algorithm =
815815+ let open Cbort.Cbor in
816816+ Map [
817817+ (Int (Z.of_int header_alg), Int (Z.of_int (Algorithm.to_cose_int algorithm)));
818818+ ]
819819+ |> Cbort.encode_string Cbort.any
820820+821821+(** Encode COSE_Sign1 or COSE_Mac0 structure *)
822822+let encode_cose_message ~cose_tag ~protected_header ~payload ~signature =
823823+ Cbort.Cbor.Tag (cose_tag, Cbort.Cbor.Array [
824824+ Cbort.Cbor.Bytes protected_header;
825825+ Cbort.Cbor.Map []; (* unprotected header - empty *)
826826+ Cbort.Cbor.Bytes payload;
827827+ Cbort.Cbor.Bytes signature;
828828+ ])
829829+ |> Cbort.encode_string Cbort.any
830830+680831let create ~algorithm ~claims ~key =
681832 (* Encode protected header *)
682682- let protected_header =
683683- let open Cbort.Rw in
684684- let buf = Buffer.create 32 in
685685- let w = Bytesrw.Bytes.Writer.of_buffer buf in
686686- let e = make_encoder w in
687687- write_map_start e 1;
688688- write_int e header_alg;
689689- write_int e (Algorithm.to_cose_int algorithm);
690690- flush_encoder e;
691691- Buffer.contents buf
692692- in
833833+ let protected_header = encode_protected_header algorithm in
693834694835 (* Build Sig_structure or MAC_structure *)
695695- let structure_name = match algorithm with
836836+ let context_string = match algorithm with
696837 | Algorithm.HMAC_256_64 | Algorithm.HMAC_256
697838 | Algorithm.HMAC_384 | Algorithm.HMAC_512 -> "MAC0"
698839 | _ -> "Signature1"
699840 in
700841 let payload = Claims.to_cbor claims in
701701- let to_be_signed =
702702- let open Cbort.Rw in
703703- let buf = Buffer.create 128 in
704704- let w = Bytesrw.Bytes.Writer.of_buffer buf in
705705- let e = make_encoder w in
706706- write_array_start e 4;
707707- write_text e structure_name;
708708- write_bytes_header e (String.length protected_header);
709709- write_bytes e protected_header;
710710- write_bytes_header e 0; (* external_aad = empty *)
711711- write_bytes_header e (String.length payload);
712712- write_bytes e payload;
713713- flush_encoder e;
714714- Buffer.contents buf
715715- in
842842+ let to_be_signed = build_sig_structure ~context_string ~protected_header ~payload in
716843717844 (* Sign or MAC *)
718845 let signature_result = match algorithm, key.Cose_key.key_data with
719846 | (Algorithm.HMAC_256_64 | Algorithm.HMAC_256
720847 | Algorithm.HMAC_384 | Algorithm.HMAC_512), Cose_key.Symmetric_key { k } ->
721721- Ok (hmac_sign algorithm k to_be_signed)
848848+ hmac_sign algorithm k to_be_signed
722849 | Algorithm.EdDSA, Cose_key.Ed25519_priv { d; _ } ->
723850 ed25519_sign ~priv:d to_be_signed
724851 | Algorithm.ES256, Cose_key.P256_priv { d; _ } ->
···735862 | Error e -> Error e
736863 | Ok signature ->
737864 (* Encode COSE_Sign1 or COSE_Mac0 structure *)
738738- let raw =
739739- let open Cbort.Rw in
740740- let buf = Buffer.create 256 in
741741- let w = Bytesrw.Bytes.Writer.of_buffer buf in
742742- let e = make_encoder w in
743743- (* Tag *)
744744- let tag = match algorithm with
745745- | Algorithm.HMAC_256_64 | Algorithm.HMAC_256
746746- | Algorithm.HMAC_384 | Algorithm.HMAC_512 -> cose_mac0_tag
747747- | _ -> cose_sign1_tag
748748- in
749749- write_type_arg e major_tag tag;
750750- write_array_start e 4;
751751- (* protected header as bstr *)
752752- write_bytes_header e (String.length protected_header);
753753- write_bytes e protected_header;
754754- (* unprotected header (empty map) *)
755755- write_map_start e 0;
756756- (* payload *)
757757- write_bytes_header e (String.length payload);
758758- write_bytes e payload;
759759- (* signature/tag *)
760760- write_bytes_header e (String.length signature);
761761- write_bytes e signature;
762762- flush_encoder e;
763763- Buffer.contents buf
865865+ let cose_tag = match algorithm with
866866+ | Algorithm.HMAC_256_64 | Algorithm.HMAC_256
867867+ | Algorithm.HMAC_384 | Algorithm.HMAC_512 -> cose_mac0_tag
868868+ | _ -> cose_sign1_tag
764869 in
870870+ let raw = encode_cose_message ~cose_tag ~protected_header ~payload ~signature in
765871 Ok {
766872 claims;
767873 algorithm = Some algorithm;
···789895 let diff = Ptime.diff exp now in
790896 if Ptime.Span.compare diff Ptime.Span.zero <= 0 then None
791897 else Some diff
792792-793793-(* Suppress unused warnings *)
794794-let _ = (cose_sign1_tag, cose_mac0_tag, header_alg, header_kid)
+17-16
lib/cwt.mli
···125125 | Ec2 (** Elliptic Curve with x,y coordinates (kty = 2) *)
126126 | Symmetric (** Symmetric key (kty = 4) *)
127127128128- (** Elliptic curve identifiers per COSE Elliptic Curves registry. *)
129129- type crv =
130130- | P256 (** NIST P-256, crv = 1 *)
131131- | P384 (** NIST P-384, crv = 2 *)
132132- | P521 (** NIST P-521, crv = 3 *)
133133- | Ed25519 (** Ed25519 for EdDSA, crv = 6 *)
128128+ (** A COSE key.
134129135135- (** A COSE key. *)
130130+ Supported key types and curves:
131131+ - Symmetric keys for HMAC algorithms
132132+ - P-256 (NIST, crv = 1) for ES256
133133+ - P-384 (NIST, crv = 2) for ES384
134134+ - P-521 (NIST, crv = 3) for ES512
135135+ - Ed25519 (crv = 6) for EdDSA *)
136136 type t
137137138138 (** {2 Constructors} *)
···254254255255 CWT supports both integer and text string keys for custom claims. *)
256256257257- val get_int_key : int -> t -> string option
258258- (** [get_int_key key claims] returns the raw CBOR value of custom claim
257257+ val get_int_key : int -> t -> Cbort.Cbor.t option
258258+ (** [get_int_key key claims] returns the CBOR value of custom claim
259259 with integer key [key]. *)
260260261261- val get_string_key : string -> t -> string option
262262- (** [get_string_key key claims] returns the raw CBOR value of custom claim
261261+ val get_string_key : string -> t -> Cbort.Cbor.t option
262262+ (** [get_string_key key claims] returns the CBOR value of custom claim
263263 with string key [key]. *)
264264265265 (** {2 Construction} *)
···291291 val set_cti : string -> builder -> builder
292292 (** Set CWT ID claim (raw bytes). *)
293293294294- val set_int_key : int -> string -> builder -> builder
294294+ val set_int_key : int -> Cbort.Cbor.t -> builder -> builder
295295 (** [set_int_key key value builder] sets a custom claim with integer key.
296296- [value] should be CBOR-encoded. *)
296296+ [value] is a CBOR value that will be serialized. *)
297297298298- val set_string_key : string -> string -> builder -> builder
298298+ val set_string_key : string -> Cbort.Cbor.t -> builder -> builder
299299 (** [set_string_key key value builder] sets a custom claim with string key.
300300- [value] should be CBOR-encoded. *)
300300+ [value] is a CBOR value that will be serialized. *)
301301302302 val build : builder -> t
303303 (** Build the claims set. *)
···314314(** {1 CWT Token} *)
315315316316type t
317317-(** A parsed CWT token (COSE_Sign1, COSE_Mac0, or COSE_Encrypt0 structure). *)
317317+(** A parsed CWT token (COSE_Sign1 or COSE_Mac0 structure).
318318+ Note: COSE_Encrypt0 is not currently supported. *)
318319319320(** {2 Parsing}
320321
+20-16
test/test_cwt.ml
···504504 let cbor = Cwt.Cose_key.to_cbor key in
505505 Alcotest.(check bool) "non-empty" true (String.length cbor > 0)
506506507507-let test_cose_key_of_cbor_not_implemented () =
508508- (* Test that of_cbor returns appropriate error for now *)
507507+let test_cose_key_of_cbor () =
508508+ (* Test that of_cbor correctly decodes a symmetric key *)
509509 let cbor = hex_to_bytes rfc_256bit_key_hex in
510510 match Cwt.Cose_key.of_cbor cbor with
511511- | Ok _ -> () (* If it succeeds, that's also fine *)
512512- | Error (Cwt.Invalid_cose msg) ->
513513- Alcotest.(check bool) "error mentions not implemented" true
514514- (String.length msg > 0)
515515- | Error e -> Alcotest.fail (Printf.sprintf "Unexpected error: %s" (Cwt.error_to_string e))
511511+ | Ok key ->
512512+ Alcotest.(check bool) "key type is symmetric" true
513513+ (Cwt.Cose_key.kty key = Cwt.Cose_key.Symmetric);
514514+ Alcotest.(check (option string)) "kid" (Some "Symmetric256") (Cwt.Cose_key.kid key)
515515+ | Error e -> Alcotest.fail (Printf.sprintf "Failed to decode key: %s" (Cwt.error_to_string e))
516516517517(* ============= CWT Encoding Tests ============= *)
518518···551551 Alcotest.(check (option string)) "iss preserved" (Some "es256-issuer") (Cwt.Claims.iss (Cwt.claims cwt))
552552 | Error e -> Alcotest.fail (Printf.sprintf "Create failed: %s" (Cwt.error_to_string e))
553553554554-let test_cwt_parse_not_implemented () =
555555- (* Test that parse returns appropriate error for now *)
554554+let test_cwt_parse_roundtrip () =
555555+ (* Test that parse correctly round-trips a created CWT *)
556556 let claims =
557557 Cwt.Claims.empty
558558- |> Cwt.Claims.set_iss "test"
558558+ |> Cwt.Claims.set_iss "test-issuer"
559559+ |> Cwt.Claims.set_sub "test-subject"
559560 |> Cwt.Claims.build
560561 in
561562 let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
···563564 | Ok cwt ->
564565 let encoded = Cwt.encode cwt in
565566 begin match Cwt.parse encoded with
566566- | Ok _ -> () (* If it succeeds, that's fine too *)
567567- | Error (Cwt.Invalid_cose msg) ->
568568- Alcotest.(check bool) "error message present" true (String.length msg > 0)
569569- | Error _ -> () (* Any error is acceptable for unimplemented function *)
567567+ | Ok parsed ->
568568+ Alcotest.(check (option string)) "iss" (Some "test-issuer") (Cwt.Claims.iss (Cwt.claims parsed));
569569+ Alcotest.(check (option string)) "sub" (Some "test-subject") (Cwt.Claims.sub (Cwt.claims parsed));
570570+ Alcotest.(check (option string)) "algorithm"
571571+ (Some "HMAC 256/256")
572572+ (Option.map Cwt.Algorithm.to_string (Cwt.algorithm parsed))
573573+ | Error e -> Alcotest.fail (Printf.sprintf "Parse failed: %s" (Cwt.error_to_string e))
570574 end
571575 | Error e -> Alcotest.fail (Printf.sprintf "Create failed: %s" (Cwt.error_to_string e))
572576···721725 Alcotest.test_case "to_cbor_symmetric" `Quick test_cose_key_to_cbor_symmetric;
722726 Alcotest.test_case "to_cbor_ed25519" `Quick test_cose_key_to_cbor_ed25519;
723727 Alcotest.test_case "to_cbor_p256" `Quick test_cose_key_to_cbor_p256;
724724- Alcotest.test_case "of_cbor_not_impl" `Quick test_cose_key_of_cbor_not_implemented;
728728+ Alcotest.test_case "of_cbor" `Quick test_cose_key_of_cbor;
725729 ];
726730 "Claims", [
727731 Alcotest.test_case "builder" `Quick test_claims_builder;
···742746 "CWT Encoding", [
743747 Alcotest.test_case "hmac" `Quick test_cwt_hmac_encoding;
744748 Alcotest.test_case "es256" `Quick test_cwt_es256_encoding;
745745- Alcotest.test_case "parse_not_impl" `Quick test_cwt_parse_not_implemented;
749749+ Alcotest.test_case "parse_roundtrip" `Quick test_cwt_parse_roundtrip;
746750 ];
747751 "Claims Validation", [
748752 Alcotest.test_case "expired" `Quick test_validate_expired_token;