├── dune-project ├── .gitignore ├── tests ├── dune ├── bench.ml ├── x509.ml └── test.ml ├── src ├── dune ├── asn_cache.mli ├── asn_writer.mli ├── asn_oid.mli ├── asn_cache.ml ├── asn_writer.ml ├── asn.ml ├── asn_random.ml ├── asn_oid.ml ├── asn_core.ml ├── asn_prim.ml ├── asn_combinators.ml ├── asn.mli └── asn_ber_der.ml ├── README.md ├── LICENSE.md ├── asn1-combinators.opam └── CHANGES.md /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.2) 2 | (name asn1-combinators) 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | tmp 3 | *~ 4 | \.\#* 5 | \#*# 6 | *.install 7 | *.native 8 | *.byte 9 | .merlin 10 | 11 | gmon.out 12 | rondom 13 | lambda 14 | -------------------------------------------------------------------------------- /tests/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name x509) 3 | (modules x509) 4 | (libraries asn1-combinators)) 5 | 6 | (test 7 | (name test) 8 | (modules test) 9 | (libraries x509 alcotest ohex)) 10 | 11 | (executable 12 | (name bench) 13 | (modules bench) 14 | (libraries asn1-combinators x509 unix)) 15 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name asn1_combinators) 3 | (public_name asn1-combinators) 4 | (synopsis "Embed typed ASN.1 grammars in OCaml") 5 | (libraries ptime) 6 | (wrapped false) 7 | (private_modules asn_oid asn_cache asn_writer asn_prim asn_core asn_random 8 | asn_combinators asn_ber_der)) 9 | 10 | -------------------------------------------------------------------------------- /src/asn_cache.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2017 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | type 'a var 5 | 6 | val variant : unit -> 'a var 7 | 8 | module Make (KV: sig 9 | type 'a k and 'a v 10 | val mapv : ('a -> 'b) -> 'a v -> 'b v 11 | end): sig 12 | type t 13 | val create : unit -> t 14 | val intern : t -> 'a var -> 'a KV.k -> 'a KV.v -> 'a KV.v 15 | end 16 | -------------------------------------------------------------------------------- /src/asn_writer.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2014-2017 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | val lex_compare : string -> string -> int 5 | 6 | type t 7 | 8 | val immediate : int -> (int -> bytes -> unit) -> t 9 | 10 | val len : t -> int 11 | val empty : t 12 | val (<+>) : t -> t -> t 13 | val append : t -> t -> t 14 | val concat : t list -> t 15 | 16 | val of_list : int list -> t 17 | val of_octets : string -> t 18 | val of_byte : int -> t 19 | 20 | val to_octets : t -> string 21 | val to_writer : t -> int * (bytes -> unit) 22 | 23 | -------------------------------------------------------------------------------- /src/asn_oid.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2014-2017 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | type t = private Oid of int * int * int list 5 | 6 | val compare : t -> t -> int 7 | val equal : t -> t -> bool 8 | val hash : t -> int 9 | val seeded_hash : int -> t -> int 10 | 11 | val base : int -> int -> t 12 | val base_opt : int -> int -> t option 13 | val (<|) : t -> int -> t 14 | val (<||) : t -> int list -> t 15 | 16 | val to_nodes : t -> int * int * int list 17 | val of_nodes : int -> int -> int list -> t option 18 | val pp : Format.formatter -> t -> unit 19 | val of_string : string -> t option 20 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # asn1-combinators — Embed typed ASN.1 grammars in OCaml 2 | 3 | %%VERSION%% 4 | 5 | asn1-combinators is a library for expressing ASN.1 in OCaml. Skip the notation 6 | part of ASN.1, and embed the abstract syntax directly in the language. These 7 | abstract syntax representations can be used for parsing, serialization, or 8 | random testing. 9 | 10 | The only ASN.1 encodings currently supported are BER and DER. 11 | 12 | asn1-combinators is distributed under the ISC license. 13 | 14 | ## Documentation 15 | 16 | `asn.mli`, [online][doc]. 17 | 18 | [doc]: https://mirleft.github.io/ocaml-asn1-combinators/doc 19 | 20 | [![Build Status](https://travis-ci.org/mirleft/ocaml-asn1-combinators.svg?branch=master)](https://travis-ci.org/mirleft/ocaml-asn1-combinators) 21 | 22 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014-2016 David Kaloper Meršinjak 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /src/asn_cache.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2014-2017 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | type dyn = .. 5 | type 'a var = ('a -> dyn) * (dyn -> 'a option) 6 | 7 | let variant (type a) () = 8 | let module M = struct type dyn += K of a end in 9 | (fun x -> M.K x), (function M.K x -> Some x | _ -> None) 10 | let inj = fst and prj = snd 11 | 12 | module Make (KV: sig 13 | type 'a k and 'a v 14 | val mapv : ('a -> 'b) -> 'a v -> 'b v 15 | end) = 16 | struct 17 | type k = K : 'a KV.k -> k 18 | type t = (k, dyn KV.v) Hashtbl.t 19 | let create () = Hashtbl.create 7 20 | let prj_ var d = match prj var d with Some x -> x | _ -> assert false 21 | let intern t var k v = 22 | let k = K k in 23 | try Hashtbl.find t k |> KV.mapv (prj_ var) with Not_found -> 24 | KV.mapv (inj var) v |> Hashtbl.add t k ; v 25 | end 26 | -------------------------------------------------------------------------------- /asn1-combinators.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | authors: "David Kaloper Meršinjak" 3 | maintainer: "David Kaloper Meršinjak " 4 | homepage: "https://github.com/mirleft/ocaml-asn1-combinators" 5 | doc: "https://mirleft.github.io/ocaml-asn1-combinators/doc" 6 | license: "ISC" 7 | dev-repo: "git+https://github.com/mirleft/ocaml-asn1-combinators.git" 8 | bug-reports: "https://github.com/mirleft/ocaml-asn1-combinators/issues" 9 | synopsis: "Embed typed ASN.1 grammars in OCaml" 10 | build: [ ["dune" "subst"] {dev} 11 | ["dune" "build" "-p" name "-j" jobs ] 12 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] 13 | depends: [ 14 | "ocaml" {>="4.13.0"} 15 | "dune" {>= "1.2.0"} 16 | "ptime" {>= "0.8.6"} 17 | "alcotest" {with-test & >= "0.8.1"} 18 | "ohex" {with-test & >= "0.2.0"} 19 | ] 20 | description: """ 21 | asn1-combinators is a library for expressing ASN.1 in OCaml. Skip the notation 22 | part of ASN.1, and embed the abstract syntax directly in the language. These 23 | abstract syntax representations can be used for parsing, serialization, or 24 | random testing. 25 | 26 | The only ASN.1 encodings currently supported are BER and DER. 27 | """ 28 | x-maintenance-intent: [ "(latest)" ] 29 | -------------------------------------------------------------------------------- /src/asn_writer.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2014-2017 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | let lex_compare cs1 cs2 = 5 | let (s1, s2) = String.(length cs1, length cs2) in 6 | let rec go i lim = 7 | if i = lim then 8 | compare s1 s2 9 | else 10 | match compare (String.get_uint8 cs1 i) (String.get_uint8 cs2 i) with 11 | | 0 -> go (succ i) lim 12 | | n -> n in 13 | go 0 (min s1 s2) 14 | 15 | type t = int * (int -> bytes -> unit) 16 | 17 | let immediate n f = (n, f) 18 | 19 | let len (n, _) = n 20 | 21 | let empty = (0, (fun _ _ -> ())) 22 | 23 | let (<+>) (l1, w1) (l2, w2) = 24 | let w off buf = 25 | ( w1 off buf ; w2 (off + l1) buf ) in 26 | (l1 + l2, w) 27 | 28 | let append = (<+>) 29 | 30 | let rec concat = function 31 | | [] -> empty 32 | | w::ws -> w <+> concat ws 33 | 34 | let of_list lst = 35 | let open List in 36 | let w off buf = 37 | iteri (fun i -> Bytes.set_uint8 buf (off + i)) lst in 38 | (length lst, w) 39 | 40 | let of_octets str = 41 | let n = String.length str in 42 | (n, fun off buf -> Bytes.blit_string str 0 buf off n) 43 | 44 | let of_byte b = (1, fun off buf -> Bytes.set_uint8 buf off b) 45 | 46 | let to_octets (n, w) = 47 | let buf = Bytes.create n in 48 | w 0 buf; 49 | Bytes.unsafe_to_string buf 50 | 51 | let to_writer (n, w) = (n, fun buf -> w 0 buf) 52 | 53 | -------------------------------------------------------------------------------- /tests/bench.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2014-2017 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | let measure f = 5 | let t1 = Sys.time () in 6 | let res = f () in 7 | let t2 = Sys.time () in 8 | Printf.printf "[time] %.03f s\n%!" (t2 -. t1) ; 9 | res 10 | 11 | let time ?(iter=1) f = 12 | let rec go = function 13 | | 1 -> f () 14 | | n -> ignore (f ()) ; go (pred n) in 15 | measure @@ fun () -> go iter 16 | 17 | let read filename = 18 | let fd = Unix.(openfile filename [O_RDONLY] 0) in 19 | Fun.protect ~finally:(fun () -> Unix.close fd) 20 | (fun () -> 21 | let chunk_size = 2048 in 22 | let rec read acc = 23 | let buf = Bytes.create chunk_size in 24 | let r = Unix.read fd buf 0 chunk_size in 25 | if r = chunk_size then 26 | read (buf :: acc) 27 | else 28 | Bytes.sub buf 0 r :: acc 29 | |> List.rev 30 | |> List.map Bytes.unsafe_to_string 31 | |> String.concat "" 32 | in 33 | read []) 34 | 35 | let bench_certs filename = 36 | let cs = read filename in 37 | let rec bench n cs = 38 | if String.length cs = 0 then n else 39 | match Asn.decode X509.cert_ber cs with 40 | | Ok (_, cs) -> bench (succ n) cs 41 | | Error e -> invalid_arg (Format.asprintf "%a" Asn.pp_error e) in 42 | time ~iter:1 @@ fun () -> 43 | let n = bench 0 cs in 44 | Printf.printf "parsed %d certs.\n%!" n 45 | 46 | let _ = bench_certs "./rondom/certs.bin" 47 | -------------------------------------------------------------------------------- /src/asn.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2014-2017 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | open Result 5 | 6 | module Core = Asn_core 7 | module OID = Asn_oid 8 | 9 | exception Ambiguous_syntax = Core.Ambiguous_syntax 10 | 11 | type error = Core.error 12 | let pp_error = Core.pp_error 13 | 14 | module S = struct 15 | type 'a t = 'a Core.asn 16 | type 'a element = 'a Core.element 17 | type 'a sequence = 'a Core.sequence 18 | include Asn_combinators 19 | let (error, parse_error) = Core.(error, parse_error) 20 | end 21 | 22 | type 'a t = 'a S.t 23 | type oid = OID.t 24 | 25 | type encoding = { 26 | mk_decoder : 'a. 'a t -> string -> 'a * string; 27 | mk_encoder : 'a. 'a t -> 'a -> Asn_writer.t 28 | } 29 | 30 | let ber = { 31 | mk_decoder = Asn_ber_der.R.compile_ber ; 32 | mk_encoder = Asn_ber_der.W.ber_to_writer ; 33 | } 34 | 35 | let der = { 36 | mk_decoder = Asn_ber_der.R.compile_der ; 37 | mk_encoder = Asn_ber_der.W.der_to_writer ; 38 | } 39 | 40 | type 'a codec = 41 | Codec of (string -> ('a * string)) * ('a -> Asn_writer.t) 42 | 43 | let codec { mk_encoder ; mk_decoder } asn = 44 | let () = Core.validate asn in 45 | Codec (mk_decoder asn, mk_encoder asn) 46 | 47 | let encode (Codec (_, enc)) a = 48 | Asn_writer.to_octets (enc a) 49 | 50 | let encode_into (Codec (_, enc)) a = 51 | Asn_writer.to_writer (enc a) 52 | 53 | let decode (Codec (dec, _)) b = 54 | try Ok (dec b) with Core.Parse_error err -> Error err 55 | 56 | let random = Asn_random.r_asn 57 | -------------------------------------------------------------------------------- /src/asn_random.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2014-2017 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | open Asn_core 5 | open Asn_prim 6 | 7 | let replicate n f a = 8 | let rec loop acc n = 9 | if n <= 0 then acc else loop (f a :: acc) (pred n) in 10 | loop [] n 11 | 12 | let r_prim : type a. a prim -> a = function 13 | 14 | | Bool -> Boolean.random () 15 | | Int -> Integer.random () 16 | | Bits -> Bits.random () 17 | | Octets -> Octets.random () 18 | | Null -> () 19 | | OID -> OID.random () 20 | | CharString -> Gen_string.random () 21 | 22 | let rec r_element : type a. a element -> a = function 23 | 24 | | Required (_, asn) -> r_asn asn 25 | | Optional (_, asn) -> 26 | if Random.int 3 = 0 then None 27 | else Some (r_asn asn) 28 | 29 | and r_seq : type a. a sequence -> a = function 30 | 31 | | Last e -> r_element e 32 | | Pair (e, es) -> (r_element e, r_seq es) 33 | 34 | and r_seq_of : type a. a asn -> a list = fun asn -> 35 | 36 | replicate Random.(int 10) r_asn asn 37 | 38 | and r_asn : type a. a asn -> a = function 39 | 40 | | Iso (f, _, None, asn) -> f @@ r_asn asn 41 | | Iso (_, _, Some rnd, _) -> rnd () 42 | 43 | | Fix (f, _) as fix -> r_asn (f fix) 44 | 45 | | Sequence asns -> r_seq asns 46 | | Set asns -> r_seq asns 47 | | Sequence_of asn -> r_seq_of asn 48 | | Set_of asn -> r_seq_of asn 49 | 50 | | Choice (asn1, asn2) -> 51 | if Random.bool () then L (r_asn asn1) else R (r_asn asn2) 52 | 53 | | Implicit (_, asn) -> r_asn asn 54 | | Explicit (_, asn) -> r_asn asn 55 | 56 | | Prim p -> r_prim p 57 | -------------------------------------------------------------------------------- /src/asn_oid.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2014-2017 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | (* XXX 5 | * OIDs being just ints means not being able to represent the full range. 6 | * Rarely used in practice, but maybe switch to bignums. 7 | *) 8 | type t = Oid of int * int * int list 9 | 10 | let invalid_arg fmt = Format.ksprintf invalid_arg fmt 11 | 12 | let (<|) (Oid (v1, v2, vs)) vn = 13 | if vn < 0 then invalid_arg "OID.(<|): negative component: %d" vn; 14 | Oid (v1, v2, vs @ [vn]) 15 | 16 | let (<||) (Oid (v1, v2, vs)) vs' = 17 | let f v = if v < 0 then invalid_arg "OID.(<||): negative component: %d" v in 18 | List.iter f vs; 19 | Oid (v1, v2, vs @ vs') 20 | 21 | let base v1 v2 = 22 | match v1 with 23 | | 0|1 when v2 >= 0 && v2 < 40 -> Oid (v1, v2, []) 24 | | 2 when v2 >= 0 -> Oid (v1, v2, []) 25 | | _ -> invalid_arg "OID.base: out of range: %d.%d" v1 v2 26 | 27 | let base_opt v1 v2 = try Some (base v1 v2) with Invalid_argument _ -> None 28 | 29 | let to_nodes (Oid (v1, v2, vs)) = (v1, v2, vs) 30 | 31 | let of_nodes n1 n2 ns = 32 | try Some (base n1 n2 <|| ns) with Invalid_argument _ -> None 33 | 34 | let pp ppf (Oid (v1, v2, vs)) = 35 | Format.fprintf ppf "%d.%d%a" v1 v2 36 | (fun ppf -> List.iter (Format.fprintf ppf ".%d")) vs 37 | 38 | let of_string s = 39 | let rec go ic = 40 | if Scanf.Scanning.end_of_input ic then [] else 41 | Scanf.bscanf ic ".%d%r" go (fun n ns -> n :: ns) in 42 | try Scanf.sscanf s "%d.%d%r" go of_nodes 43 | with End_of_file | Scanf.Scan_failure _ -> None 44 | 45 | let compare (Oid (v1, v2, vs)) (Oid (v1', v2', vs')) = 46 | let rec cmp (xs: int list) ys = match (xs, ys) with 47 | | ([], []) -> 0 48 | | ([], _ ) -> -1 49 | | (_ , []) -> 1 50 | | (x::xs, y::ys) -> match compare x y with 0 -> cmp xs ys | r -> r in 51 | match compare v1 v1' with 52 | | 0 -> ( match compare v2 v2' with 0 -> cmp vs vs' | r -> r ) 53 | | r -> r 54 | 55 | let equal o1 o2 = compare o1 o2 = 0 56 | 57 | let seeded_hash seed (Oid (v1, v2, vs)) = 58 | Hashtbl.(List.fold_left seeded_hash (seeded_hash (seeded_hash seed v1) v2) vs) 59 | 60 | let hash o = seeded_hash 0 o 61 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## v0.3.2 (2024-09-04) 2 | * Drop OCaml < 4.13 support (#45 @hannesm) 3 | 4 | ## v0.3.1 (2024-05-08) 5 | * Introduce Asn.S.unsigned_integer - useful for e.g. ECDSA signatures where the 6 | user code expects an unsigned integer and shouldn't worry about the ASN.1 7 | encoding (#44 @reynir @hannesm) 8 | * Provide custom random generators for int and unsigned_integer 9 | (#44 @hannesm @reynir) 10 | 11 | ## v0.3.0 (2024-03-14) 12 | * BUGFIX: utctime 50 should be 1950 (not 2050) (#39 @reynir) 13 | * drop zarith dependency, Asn.S.integer is now a Cstruct.t (#42 @hannesm) 14 | * drop cstruct dependency, use string instead (#43 @hannesm) 15 | this changes the allocation discipline, and while benchmarking the decoding 16 | of certificates takes less time now, there may be performance differences 17 | (since now String.sub is used which allocates and copies data) 18 | 19 | ## v0.2.6 (2021-08-04) 20 | * Use Cstruct.length instead of Cstruct.len, drop OCaml <4.08 support, 21 | remove bigarray-compat and stdlib-shims dependencies (#37 by @hannesm) 22 | 23 | ## v0.2.5 (2021-03-05) 24 | * Fix an integer overflow in the length field on 32 bit architectures 25 | (#36 by @hannesm) 26 | 27 | ## v0.2.4 (2020-11-05) 28 | * OCaml 4.12 support (#35 by @kit-ty-kate, @hannesm) 29 | 30 | ## v0.2.3 (2020-09-28) 31 | * adapt to cstruct 6.0.0 API changes (#34 by @dinosaure) 32 | 33 | ## v0.2.2 (2020-01-29) 34 | * packaging improvements: add lower bound to dune dependency, improve test 35 | invocation, remove version from dune-project 36 | (reported by @kit-ty-kate in ocaml/opam-repository#15757 fixed by @hannesm) 37 | 38 | ## v0.2.1 (2020-01-28) 39 | * disallow various constructs as suggested by ITU-T Rec X.690 (by @pqwy) 40 | * redundant OID component forms (X.690 8.20.2) 41 | * redundant integer forms (X.690 8.3.2) 42 | * empty integer (X.690 8.3.1, reported in #23 by @emillon) 43 | * constructed strings in DER 44 | * deeper implict -> explicit over choice (follow-up to v0.2.0 entry, by @pqwy) 45 | * handle long-form length overflow (reported in #24 by @emillon, fixed by @pqwy) 46 | * disallow primitive with indefinite length (introduced in the bugfix above, 47 | reported by @emillon, fixed in #32 by @hannesm) 48 | * disallow nonsensical bitstring unused values (X690 8.6.2, reported in #26 49 | by @NathanReb, fixed by @pqwy) 50 | * fix non-continuous bit_string_flags (X680 22.6, reported in #25 by @wiml, 51 | fixed by @pqwy) 52 | * use Alcotest instead of oUnit for unit tests (by @pqwy) 53 | * use dune as build system (by @pqwy, superseeds #22) 54 | * use bigarray-compat (#27 by @TheLortex) and stdlib-shims (#29 by @XVilka) 55 | * raise lower bound to OCaml 4.05.0 (#31 by @hannesm) 56 | 57 | ## v0.2.0 (2017-11-13) 58 | * `OID`s are now fully abstract, with a simpler interface. 59 | * `OID`s have custom comparison and hasing. 60 | * `Time` is gone in favor of `Ptime`. 61 | * `IMPLICIT` silently becomes `EXPLICIT` when necessary. 62 | * Parse errors are reported through `Result`. 63 | * Syntaxes now live in their own module, `Asn.S`. 64 | * Rewrote the parser; no new features, but looks nicer from a distance. 65 | * Various performance improvements. 66 | * Documented the interface. 67 | 68 | ## v0.1.3 (2016-11-12) 69 | * relicense to ISC 70 | * drop oasis 71 | * fix a bug in tests on 32 bit 72 | 73 | ## v0.1.2 (2015-05-02) 74 | * cstruct-1.6.0 compatibility 75 | 76 | ## v0.1.1 (2014-10-30) 77 | * stricter decoding of ints in BER/DER tags and OIDs 78 | * performance improvements 79 | 80 | ## v0.1.0 (2014-07-08): 81 | * initial (beta) release 82 | -------------------------------------------------------------------------------- /src/asn_core.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2014-2017 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | module OID = Asn_oid 5 | 6 | let id x = x 7 | let const x _ = x 8 | let (&.) f g x = f (g x) 9 | 10 | let opt def = function Some x -> x | _ -> def 11 | 12 | type 'a endo = 'a -> 'a 13 | 14 | type ('a, 'b) sum = L of 'a | R of 'b 15 | 16 | let (strf, pf) = Format.(asprintf, fprintf) 17 | let kstrf k fmt = 18 | Format.(kfprintf (fun _ -> flush_str_formatter () |> k) str_formatter fmt) 19 | 20 | let invalid_arg fmt = Format.ksprintf invalid_arg fmt 21 | 22 | let pp_list ~sep pp ppf xs = 23 | let rec go ppf = function 24 | | [] -> () 25 | | [x] -> pp ppf x 26 | | x::xs -> pf ppf "%a%a@ " pp x sep (); go ppf xs in 27 | pf ppf "@[%a@]" go xs 28 | 29 | let pp_dump_list pp ppf xs = 30 | let sep ppf () = Format.pp_print_string ppf "," in 31 | pf ppf "[@[%a@]]" (pp_list ~sep pp) xs 32 | 33 | let pp_octets ppf buf = 34 | let f ppf buf = 35 | for i = 0 to String.length buf - 1 do 36 | if i mod 8 = 0 && i > 0 then pf ppf "@ "; 37 | pf ppf "%02x" (String.get_uint8 buf i) 38 | done in 39 | pf ppf "@[%a@]" f buf 40 | 41 | module Tag = struct 42 | 43 | type t = 44 | | Universal of int 45 | | Application of int 46 | | Context_specific of int 47 | | Private of int 48 | 49 | let compare t1 t2 = match (t1, t2) with 50 | | (Universal a, Universal b) 51 | | (Application a, Application b) 52 | | (Context_specific a, Context_specific b) 53 | | (Private a, Private b) -> compare a b 54 | | (Universal _, _) 55 | | (Application _, (Context_specific _ | Private _)) 56 | | (Context_specific _, Private _) -> -1 57 | | _ -> 1 58 | 59 | let equal t1 t2 = match (t1, t2) with 60 | | (Universal a, Universal b) 61 | | (Application a, Application b) 62 | | (Context_specific a, Context_specific b) 63 | | (Private a, Private b) -> a = b 64 | | _ -> false 65 | 66 | let pp ppf tag = 67 | let (name, n) = match tag with 68 | | Universal n -> ("UNIVERSAL", n) 69 | | Application n -> ("APPLICATION", n) 70 | | Context_specific n -> ("CONTEXT", n) 71 | | Private n -> ("PRIVATE", n) in 72 | pf ppf "%s %d" name n 73 | 74 | end 75 | 76 | type tag = Tag.t 77 | type tags = Tag.t list 78 | 79 | module Generic = struct 80 | 81 | type t = 82 | | Cons of tag * t list 83 | | Prim of tag * string 84 | 85 | let tag = function Cons (t, _) -> t | Prim (t, _) -> t 86 | 87 | let pp_form_name ppf fsym = 88 | Format.pp_print_string ppf @@ match fsym with 89 | `Cons -> "Constructed" | `Prim -> "Primitive" | `Both -> "ANY" 90 | 91 | let pp_tag ppf g = 92 | let form = match g with Cons _ -> `Cons | Prim _ -> `Prim in 93 | pf ppf "(%a %a)" pp_form_name form Tag.pp (tag g) 94 | end 95 | 96 | 97 | type bits = int * string 98 | 99 | type 'a rand = unit -> 'a 100 | 101 | type _ asn = 102 | 103 | | Iso : ('a -> 'b) * ('b -> 'a) * 'b rand option * 'a asn -> 'b asn 104 | | Fix : ('a asn -> 'a asn) * 'a Asn_cache.var -> 'a asn 105 | 106 | | Sequence : 'a sequence -> 'a asn 107 | | Sequence_of : 'a asn -> 'a list asn 108 | | Set : 'a sequence -> 'a asn 109 | | Set_of : 'a asn -> 'a list asn 110 | | Choice : 'a asn * 'b asn -> ('a, 'b) sum asn 111 | 112 | | Implicit : tag * 'a asn -> 'a asn 113 | | Explicit : tag * 'a asn -> 'a asn 114 | 115 | | Prim : 'a prim -> 'a asn 116 | 117 | and _ element = 118 | 119 | | Required : string option * 'a asn -> 'a element 120 | | Optional : string option * 'a asn -> 'a option element 121 | 122 | and _ sequence = 123 | 124 | | Last : 'a element -> 'a sequence 125 | | Pair : 'a element * 'b sequence -> ('a * 'b) sequence 126 | 127 | and _ prim = 128 | 129 | | Bool : bool prim 130 | | Int : string prim 131 | | Bits : bits prim 132 | | Octets : string prim 133 | | Null : unit prim 134 | | OID : OID.t prim 135 | | CharString : string prim 136 | 137 | 138 | let label = opt "" 139 | 140 | let seq_tag = Tag.Universal 0x10 141 | and set_tag = Tag.Universal 0x11 142 | 143 | let tag_of_p : type a. a prim -> tag = 144 | let open Tag in function 145 | | Bool -> Universal 0x01 146 | | Int -> Universal 0x02 147 | | Bits -> Universal 0x03 148 | | Octets -> Universal 0x04 149 | | Null -> Universal 0x05 150 | | OID -> Universal 0x06 151 | | CharString -> Universal 0x1d 152 | 153 | 154 | let rec tag_set : type a. a asn -> tags = function 155 | 156 | | Iso (_, _, _, asn) -> tag_set asn 157 | | Fix (f, _) as fix -> tag_set (f fix) 158 | 159 | | Sequence _ -> [ seq_tag ] 160 | | Sequence_of _ -> [ seq_tag ] 161 | | Set _ -> [ set_tag ] 162 | | Set_of _ -> [ set_tag ] 163 | | Choice (asn1, asn2) -> tag_set asn1 @ tag_set asn2 164 | 165 | | Implicit (t, _) -> [ t ] 166 | | Explicit (t, _) -> [ t ] 167 | 168 | | Prim p -> [ tag_of_p p ] 169 | 170 | let rec tag : type a. a -> a asn -> tag = fun a -> function 171 | 172 | | Iso (_, g, _, asn) -> tag (g a) asn 173 | | Fix _ as fix -> tag a fix 174 | | Sequence _ -> seq_tag 175 | | Sequence_of _ -> seq_tag 176 | | Set _ -> set_tag 177 | | Set_of _ -> set_tag 178 | | Choice (a1, a2) -> (match a with L a' -> tag a' a1 | R b' -> tag b' a2) 179 | | Implicit (t, _) -> t 180 | | Explicit (t, _) -> t 181 | | Prim p -> tag_of_p p 182 | 183 | 184 | type error = [ `Parse of string ] (* XXX finer-grained *) 185 | 186 | let pp_error ppf (`Parse err) = pf ppf "Parse error: %s" err 187 | 188 | exception Ambiguous_syntax 189 | exception Parse_error of error 190 | 191 | let error err = raise (Parse_error err) 192 | let parse_error fmt = kstrf (fun s -> error (`Parse s)) fmt 193 | 194 | (* Check tag ambiguity. 195 | * XXX: Would be _epic_ to move this to the type-checker. 196 | *) 197 | 198 | module FSet = struct 199 | type f = Fn : ('a -> 'b) -> f 200 | include Set.Make ( struct 201 | type t = f 202 | (* XXX collisions *) 203 | let compare (Fn f1) (Fn f2) = Hashtbl.(compare (hash f1) (hash f2)) 204 | end ) 205 | let mem f s = mem (Fn f) s 206 | and add f s = add (Fn f) s 207 | end 208 | 209 | let validate asn = 210 | 211 | let rec check : type a. ?tag:tag -> FSet.t -> a asn -> unit = 212 | fun ?tag fs -> function 213 | | Iso (_, _, _, a) -> check ?tag fs a 214 | | Fix (f, _) as fix -> 215 | if not (FSet.mem f fs) then check ?tag FSet.(add f fs) (f fix) 216 | 217 | | Sequence s -> disjoint_seq s ; check_s fs s 218 | | Set s -> disjoint (seq_tags s) ; check_s fs s 219 | | Sequence_of a -> check fs a 220 | | Set_of a -> check fs a 221 | 222 | | Choice (a1, a2) -> 223 | disjoint [tag_set a1; tag_set a2] ; check fs a1 ; check fs a2 224 | 225 | | Implicit (t, a) -> check ~tag:t fs a 226 | | Explicit (_, a) -> check fs a 227 | | Prim _ -> () 228 | 229 | and check_s : type a. FSet.t -> a sequence -> unit = fun fs -> function 230 | | Last (Required (_, a)) -> check fs a 231 | | Last (Optional (_, a)) -> check fs a 232 | | Pair (Required (_, a), s) -> check fs a ; check_s fs s 233 | | Pair (Optional (_, a), s) -> check fs a ; check_s fs s 234 | 235 | and seq_tags : type a. a sequence -> tags list = function 236 | | Last (Required (_, a)) -> [tag_set a] 237 | | Last (Optional (_, a)) -> [tag_set a] 238 | | Pair (Required (_, a), s) -> tag_set a :: seq_tags s 239 | | Pair (Optional (_, a), s) -> tag_set a :: seq_tags s 240 | 241 | and disjoint_seq : type a. a sequence -> unit = fun s -> 242 | let f1 : type a. tags list -> a element -> tags list = fun tss -> function 243 | | Required (_, a) -> disjoint (tag_set a :: tss) ; [] 244 | | Optional (_, a) -> disjoint (tag_set a :: tss) ; tag_set a :: tss in 245 | let rec f2 : type a. tags list -> a sequence -> unit = fun tss -> function 246 | | Last e -> ignore (f1 tss e) 247 | | Pair (e, s) -> f2 (f1 tss e) s in 248 | f2 [] s 249 | 250 | and disjoint tss = 251 | let rec go = function 252 | | t::u::_ when Tag.equal t u -> raise Ambiguous_syntax 253 | | _::ts -> go ts 254 | | _ -> () in 255 | go List.(sort Tag.compare @@ concat tss) in 256 | 257 | check FSet.empty asn 258 | -------------------------------------------------------------------------------- /src/asn_prim.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2014-2017 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | open Asn_core 5 | 6 | module Writer = Asn_writer 7 | 8 | module type Prim = sig 9 | type t 10 | val of_octets : string -> t 11 | val to_writer : t -> Writer.t 12 | val random : unit -> t 13 | end 14 | 15 | module type Prim_s = sig 16 | include Prim 17 | val random : ?size:int -> unit -> t 18 | val concat : t list -> t 19 | val length : t -> int 20 | end 21 | 22 | let rec replicate_l n f = 23 | if n < 1 then [] else f () :: replicate_l (pred n) f 24 | 25 | let max_r_int = (1 lsl 30) - 1 26 | 27 | let random_int () = Random.int max_r_int 28 | 29 | let random_int_r a b = a + Random.int (b - a) 30 | 31 | let random_size = function 32 | | Some size -> size 33 | | None -> Random.int 20 34 | 35 | let random_string ?size ~chars:(lo, hi) () = 36 | String.init (random_size size) 37 | (fun _ -> Char.chr (random_int_r lo hi)) 38 | 39 | module Int64 = struct 40 | 41 | include Int64 42 | 43 | let ( + ) = add 44 | and ( - ) = sub 45 | and ( * ) = mul 46 | and ( / ) = div 47 | and (lsl) = shift_left 48 | and (lsr) = shift_right_logical 49 | and (asr) = shift_right 50 | and (lor) = logor 51 | and (land) = logand 52 | 53 | let max_p_int = Int64.of_int Stdlib.max_int 54 | 55 | let to_nat_checked i64 = 56 | if i64 < 0L || i64 > max_p_int then None else Some (to_int i64) 57 | 58 | end 59 | 60 | module Boolean : Prim with type t = bool = struct 61 | 62 | type t = bool 63 | 64 | let of_octets buf = 65 | if String.length buf = 1 then 66 | (* XXX DER check *) 67 | String.get_uint8 buf 0 <> 0x00 68 | else parse_error "BOOLEAN: %a" pp_octets buf 69 | 70 | let to_writer b = Writer.of_byte (if b then 0xff else 0x00) 71 | 72 | let random = Random.bool 73 | end 74 | 75 | module Null : Prim with type t = unit = struct 76 | 77 | type t = unit 78 | 79 | let of_octets buf = 80 | if String.length buf <> 0 then 81 | parse_error "NULL: %a" pp_octets buf 82 | 83 | let to_writer () = Writer.empty 84 | 85 | let random () = () 86 | end 87 | 88 | module Integer : Prim_s with type t = string = struct 89 | 90 | type t = string 91 | 92 | let of_octets buf = 93 | match String.length buf with 94 | | 0 -> parse_error "INTEGER: length 0" 95 | | 1 -> buf 96 | | _ -> 97 | let w0 = String.get_uint16_be buf 0 in 98 | match w0 land 0xff80 with 99 | | 0x0000 | 0xff80 -> parse_error "INTEGER: redundant form" 100 | | _ -> buf 101 | 102 | let to_writer = Writer.of_octets 103 | 104 | (* we produce integers that fit into an int *) 105 | let random ?size () = 106 | let rec one () = 107 | let buf = random_string ?size ~chars:(0, 256) () in 108 | match String.length buf with 109 | | 0 -> one () 110 | | 1 -> buf 111 | | _ -> 112 | match String.get_uint16_be buf 0 land 0xff80 with 113 | | 0x0000 | 0xff80 -> one () 114 | | _ -> buf 115 | in 116 | one () 117 | 118 | let concat = String.concat "" 119 | 120 | let length = String.length 121 | 122 | end 123 | 124 | module Gen_string : Prim_s with type t = string = struct 125 | 126 | type t = string 127 | 128 | let of_octets x = x 129 | 130 | let to_writer = Writer.of_octets 131 | 132 | let random ?size () = 133 | random_string ?size ~chars:(32, 127) () 134 | 135 | let (concat, length) = String.(concat "", length) 136 | end 137 | 138 | module Octets : Prim_s with type t = string = struct 139 | 140 | type t = string 141 | 142 | let of_octets buf = buf 143 | 144 | let to_writer = Writer.of_octets 145 | 146 | let random ?size () = 147 | random_string ?size ~chars:(0, 256) () 148 | 149 | let concat = String.concat "" 150 | 151 | let length = String.length 152 | 153 | end 154 | 155 | module Bits : sig 156 | 157 | include Prim_s with type t = bits 158 | 159 | val to_array : t -> bool array 160 | val of_array : bool array -> t 161 | 162 | end = 163 | struct 164 | 165 | type t = int * string 166 | 167 | let of_octets buf = 168 | let n = String.length buf in 169 | if n = 0 then parse_error "BITS" else 170 | let unused = String.get_uint8 buf 0 in 171 | if n = 1 && unused > 0 || unused > 7 then parse_error "BITS" else 172 | unused, Octets.of_octets (String.sub buf 1 (String.length buf - 1)) 173 | 174 | let to_writer (unused, buf) = 175 | let size = String.length buf in 176 | let write off buf' = 177 | Bytes.set_uint8 buf' off unused; 178 | Bytes.blit_string buf 0 buf' (off + 1) size in 179 | Writer.immediate (size + 1) write 180 | 181 | let to_array (unused, cs) = 182 | Array.init (String.length cs * 8 - unused) @@ fun i -> 183 | let byte = (String.get_uint8 cs (i / 8)) lsl (i mod 8) in 184 | byte land 0x80 = 0x80 185 | 186 | let (|<) n = function 187 | | true -> (n lsl 1) lor 1 188 | | false -> (n lsl 1) 189 | 190 | let of_array arr = 191 | let buf = Bytes.create ((Array.length arr + 7) / 8) in 192 | match 193 | Array.fold_left 194 | (fun (n, acc, i) bit -> 195 | if n = 8 then 196 | ( Bytes.set_uint8 buf i acc ; (1, 0 |< bit, i + 1) ) 197 | else (n + 1, acc |< bit, i)) 198 | (0, 0, 0) 199 | arr 200 | with 201 | | (0, _acc, _) -> (0, Bytes.unsafe_to_string buf) 202 | | (n, acc, i) -> 203 | Bytes.set_uint8 buf i (acc lsl (8 - n)); 204 | (8 - n, Bytes.unsafe_to_string buf) 205 | 206 | let random ?size () = (0, Octets.random ?size ()) 207 | 208 | let concat bufs = 209 | let (unused, bufs') = 210 | let rec go = function 211 | | [] -> (0, []) 212 | | [(u, buf)] -> (u, [buf]) 213 | | (_, buf)::bufs -> let (u, bufs') = go bufs in (u, buf::bufs') in 214 | go bufs in 215 | (unused, String.concat "" bufs') 216 | 217 | and length (unused, buf) = String.length buf - unused 218 | 219 | end 220 | 221 | module OID = struct 222 | 223 | open Asn_oid 224 | 225 | let uint64_chain buf i n = 226 | let rec go acc buf i = function 227 | 0 -> parse_error "OID: unterminated component" 228 | | n -> 229 | match String.get_uint8 buf i with 230 | 0x80 when acc = 0L -> parse_error "OID: redundant form" 231 | | b -> 232 | let lo = b land 0x7f in 233 | let acc = Int64.(logor (shift_left acc 7) (of_int lo)) in 234 | if b < 0x80 then (acc, i + 1) else go acc buf (i + 1) (n - 1) in 235 | if n < 1 then parse_error "OID: 0 length component" else 236 | go 0L buf i (min n 8) 237 | 238 | let int_chain buf i n = 239 | let (n, i) = uint64_chain buf i n in 240 | match Int64.to_nat_checked n with 241 | Some n -> (n, i) | _ -> parse_error "OID: component out of range" 242 | 243 | let of_octets buf = 244 | let rec components buf i = function 245 | 0 -> [] 246 | | n -> let (c, i') = int_chain buf i n in 247 | c :: components buf i' (n + i - i') in 248 | match String.length buf with 249 | 0 -> parse_error "OID: 0 length" 250 | | n -> 251 | let (b1, i) = int_chain buf 0 n in 252 | let v1 = b1 / 40 and v2 = b1 mod 40 in 253 | match base_opt v1 v2 with 254 | Some b -> b <|| components buf i (n - i) 255 | | None -> parse_error "OID: invalid base" 256 | 257 | let to_writer = fun (Oid (v1, v2, vs)) -> 258 | let cons x = function [] -> [x] | xs -> x lor 0x80 :: xs in 259 | let rec component xs x = 260 | if x < 0x80 then cons x xs 261 | else component (cons (x land 0x7f) xs) (x lsr 7) 262 | and values = function 263 | | [] -> Writer.empty 264 | | v::vs -> Writer.(of_list (component [] v) <+> values vs) in 265 | Writer.(of_byte (v1 * 40 + v2) <+> values vs) 266 | 267 | let random () = 268 | Random.( base (int 3) (int 40) <|| replicate_l (int 10) random_int ) 269 | end 270 | 271 | module Time = struct 272 | 273 | let ps_per_ms = 1_000_000_000L 274 | 275 | let pp_tz ppf = function 276 | | 0 -> pf ppf "Z" 277 | | tz -> pf ppf "%c%02d%02d" 278 | (if tz < 0 then '+' else '-') 279 | (abs tz / 3600) ((abs tz mod 3600) / 60) 280 | 281 | (* DER-times must be UTC-normalised. If TZ comes this way, a DER flag must too. *) 282 | 283 | let pp_utc_time ppf t = 284 | let ((y, m, d), ((hh, mm, ss), tz)) = Ptime.to_date_time ~tz_offset_s:0 t in 285 | pf ppf "%02d%02d%02d%02d%02d%02d%a" (y mod 100) m d hh mm ss pp_tz tz 286 | 287 | let pp_gen_time ppf t = 288 | let ((y, m, d), ((hh, mm, ss), tz)) = 289 | Ptime.to_date_time ~tz_offset_s:0 t in 290 | let pp_frac ppf t = match Ptime.(frac_s t |> Span.to_d_ps) with 291 | | (_, 0L) -> () 292 | | (_, f) -> pf ppf ".%03Ld" Int64.(f / ps_per_ms) in 293 | pf ppf "%04d%02d%02d%02d%02d%02d%a%a" y m d hh mm ss pp_frac t pp_tz tz 294 | 295 | let of_utc_time = Format.asprintf "%a" pp_utc_time 296 | and of_gen_time = Format.asprintf "%a" pp_gen_time 297 | 298 | let catch pname f s = try f s with 299 | | End_of_file -> parse_error "%s: unexpected end: %s" pname s 300 | | Scanf.Scan_failure _ -> parse_error "%s: invalid format: %s" pname s 301 | 302 | (* XXX get rid of Scanf. 303 | * - width specifiers are max-width only 304 | * - %u is too lexically relaxed *) 305 | 306 | let tz ic = 307 | try Scanf.bscanf ic "%1[+-]%2u%2u%!" @@ fun sgn h m -> 308 | (match sgn with "-" -> -1 | _ -> 1) * (3600 * h + 60 * m) 309 | with _ -> Scanf.bscanf ic "Z" 0 310 | 311 | let utc_time_of_string = catch "UTCTime" @@ fun s -> 312 | Scanf.sscanf s "%2u%2u%2u%2u%2u%r%r%!" 313 | (fun ic -> try Scanf.bscanf ic "%2u" id with _ -> 0) tz @@ 314 | fun y m d hh mm ss tz -> 315 | let y = (if y >= 50 then 1900 else 2000) + y in 316 | let dt = ((y, m, d), ((hh, mm, ss), tz)) in 317 | match Ptime.of_date_time dt with 318 | Some t -> t | _ -> parse_error "UTCTime: out of range: %s" s 319 | 320 | let gen_time_of_string = catch "GeneralizedTime" @@ fun s -> 321 | let m_s_f ic = 322 | try Scanf.bscanf ic "%2u%r" (fun ic -> 323 | try Scanf.bscanf ic "%2u%r" (fun ic -> 324 | try Scanf.bscanf ic ".%3u" @@ fun ms -> Int64.(of_int ms * ps_per_ms) 325 | with _ -> 0L) @@ fun ss ms -> ss, ms 326 | with _ -> 0, 0L) @@ fun mm ssms -> mm, ssms 327 | with _ -> 0, (0, 0L) in 328 | Scanf.sscanf s "%4u%2u%2u%2u%r%r%!" m_s_f (fun ic -> try tz ic with _ -> 0) @@ 329 | fun y m d hh (mm, (ss, ps)) tz -> 330 | let dt = ((y, m, d), ((hh, mm, ss), tz)) in match 331 | match Ptime.of_date_time dt with 332 | Some t -> Ptime.(Span.v (0, ps) |> add_span t) | _ -> None 333 | with Some t -> t | _ -> parse_error "GeneralizedTime: out of range: %s" s 334 | 335 | let date y m d = Ptime.of_date (y, m, d) |> Option.get 336 | 337 | let r_date ~start ~fin = 338 | let dd, dps = match Ptime.(diff fin start |> Span.to_d_ps) with 339 | | (dd, 0L) -> Random.(int dd, int64 86_400_000_000_000_000L) 340 | | (dd, dps) -> Random.(int (dd + 1), int64 dps) in 341 | Ptime.(Span.(v Random.(int (dd + 1), int64 dps)) |> add_span start) |> Option.get 342 | 343 | let utc_random () = 344 | Ptime.truncate ~frac_s:0 @@ 345 | r_date ~start:(date 1950 1 1) ~fin:(date 2049 12 31) 346 | 347 | let gen_random () = 348 | Ptime.truncate ~frac_s:3 @@ 349 | r_date ~start:(date 0000 1 1) ~fin:(date 9999 12 31) 350 | end 351 | -------------------------------------------------------------------------------- /src/asn_combinators.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2014-2017 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | open Asn_core 5 | module Prim = Asn_prim 6 | 7 | module Int = struct 8 | type t = int 9 | let compare (a: t) b = compare a b 10 | let equal (a: t) b = a = b 11 | end 12 | 13 | type cls = [ `Universal | `Application | `Private ] 14 | 15 | let fix f = Fix (f, Asn_cache.variant ()) 16 | 17 | let map ?random f g asn = Iso (f, g, random, asn) 18 | 19 | let to_tag id = function 20 | | Some `Application -> Tag.Application id 21 | | Some `Private -> Tag.Private id 22 | | Some `Universal -> Tag.Universal id 23 | | None -> Tag.Context_specific id 24 | 25 | let explicit ?cls id asn = Explicit (to_tag id cls, asn) 26 | let rec implicit : type a. ?cls:cls -> int -> a asn -> a asn = 27 | fun ?cls id -> function 28 | Fix (f, _) as asn -> implicit ?cls id (f asn) 29 | | Iso (f, g, r, asn) -> Iso (f, g, r, implicit ?cls id asn) 30 | | Choice (_, _) as asn -> explicit ?cls id asn 31 | | asn -> Implicit (to_tag id cls, asn) 32 | 33 | let bool = Prim Bool 34 | and integer = Prim Int 35 | and octet_string = Prim Octets 36 | and null = Prim Null 37 | and oid = Prim OID 38 | and character_string = Prim CharString 39 | 40 | let string tag = implicit ~cls:`Universal tag character_string 41 | 42 | let utf8_string = string 0x0c 43 | let numeric_string = string 0x12 44 | and printable_string = string 0x13 45 | and teletex_string = string 0x14 46 | and videotex_string = string 0x15 47 | and ia5_string = string 0x16 48 | and graphic_string = string 0x19 49 | and visible_string = string 0x1a 50 | and general_string = string 0x1b 51 | and universal_string = string 0x1c 52 | and bmp_string = string 0x1e 53 | 54 | let (utc_time, generalized_time) = 55 | let open Asn_prim.Time in 56 | let time ~random tag (f, g) = 57 | map ~random f g @@ 58 | implicit ~cls:`Universal tag character_string in 59 | time ~random:utc_random 0x17 (utc_time_of_string, of_utc_time), 60 | time ~random:gen_random 0x18 (gen_time_of_string, of_gen_time) 61 | 62 | let int = 63 | let f str = 64 | match String.length str with 65 | | 0 -> 0 66 | | 1 -> String.get_int8 str 0 67 | | 2 -> String.get_int16_be str 0 68 | | 3 -> String.get_int16_be str 0 lsl 8 + String.get_uint8 str 2 69 | | 4 -> 70 | let v = String.get_int32_be str 0 in 71 | if Sys.word_size = 32 && (v > Int32.of_int max_int || v < Int32.of_int min_int) then 72 | parse_error "INTEGER: int overflow: %a" pp_octets str 73 | else 74 | Int32.to_int v 75 | | 5 -> 76 | if Sys.word_size = 32 then 77 | parse_error "INTEGER: int overflow: %a" pp_octets str 78 | else 79 | let v = Int32.to_int (String.get_int32_be str 0) in 80 | v lsl 8 + String.get_uint8 str 4 81 | | 6 -> 82 | if Sys.word_size = 32 then 83 | parse_error "INTEGER: int overflow: %a" pp_octets str 84 | else 85 | let v = Int32.to_int (String.get_int32_be str 0) in 86 | v lsl 16 + String.get_uint16_be str 4 87 | | 7 -> 88 | if Sys.word_size = 32 then 89 | parse_error "INTEGER: int overflow: %a" pp_octets str 90 | else 91 | let v = Int32.to_int (String.get_int32_be str 0) in 92 | v lsl 24 + (String.get_uint16_be str 4) lsl 8 + String.get_uint8 str 6 93 | | 8 -> 94 | let v = String.get_int64_be str 0 in 95 | if Sys.word_size = 32 || (v > Int64.of_int max_int || v < Int64.of_int min_int) then 96 | parse_error "INTEGER: int overflow: %a" pp_octets str 97 | else 98 | Int64.to_int v 99 | | _ -> parse_error "INTEGER: int overflow: %a" pp_octets str 100 | and g i = 101 | let i64 = Int64.of_int i in 102 | if i >= -0x80 && i <= 0x7F then 103 | let b = Bytes.create 1 in 104 | Bytes.set_int8 b 0 i; 105 | Bytes.unsafe_to_string b 106 | else if i >= -0x8000 && i <= 0x7FFF then 107 | let b = Bytes.create 2 in 108 | Bytes.set_int16_be b 0 i; 109 | Bytes.unsafe_to_string b 110 | else if i >= -0x80_0000 && i <= 0x7F_FFFF then 111 | let b = Bytes.create 3 in 112 | Bytes.set_int16_be b 0 (i lsr 8); 113 | Bytes.set_uint8 b 2 (i land 0xff); 114 | Bytes.unsafe_to_string b 115 | else if i64 >= -0x8000_0000L && i64 <= 0x7FFF_FFFFL then 116 | let b = Bytes.create 4 in 117 | Bytes.set_int32_be b 0 (Int32.of_int i); 118 | Bytes.unsafe_to_string b 119 | else if i64 >= -0x80_0000_0000L && i64 <= 0x7F_FFFF_FFFFL then 120 | let b = Bytes.create 5 in 121 | Bytes.set_int32_be b 0 (Int32.of_int (i lsr 8)); 122 | Bytes.set_uint8 b 4 (i land 0xFF); 123 | Bytes.unsafe_to_string b 124 | else if i64 >= -0x8000_0000_0000L && i64 <= 0x7FFF_FFFF_FFFFL then 125 | let b = Bytes.create 6 in 126 | Bytes.set_int32_be b 0 (Int32.of_int (i lsr 16)); 127 | Bytes.set_uint16_be b 4 (i land 0xFFFF); 128 | Bytes.unsafe_to_string b 129 | else if i64 >= -0x80_0000_0000_0000L && i64 <= 0x7F_FFFF_FFFF_FFFFL then 130 | let b = Bytes.create 7 in 131 | Bytes.set_int32_be b 0 (Int32.of_int (i lsr 24)); 132 | Bytes.set_uint16_be b 4 ((i land 0xFFFF00) lsr 8); 133 | Bytes.set_uint8 b 6 (i land 0xFF); 134 | Bytes.unsafe_to_string b 135 | else 136 | let b = Bytes.create 8 in 137 | Bytes.set_int64_be b 0 i64; 138 | Bytes.unsafe_to_string b 139 | in 140 | let random () = 141 | let rec go () = 142 | let buf = Prim.Integer.random ~size:(Sys.word_size / 8) () in 143 | (* OCaml integer are only 31 / 63 bit *) 144 | try f buf with 145 | | Parse_error _ -> go () 146 | in 147 | go () 148 | in 149 | map ~random f g integer 150 | 151 | let unsigned_integer = 152 | let f str = 153 | let l = String.length str in 154 | if l > 0 then 155 | let fst = String.get_uint8 str 0 in 156 | if fst > 0x7F then 157 | parse_error "unsigned integer < 0" 158 | else if fst = 0x00 then 159 | String.sub str 1 (l - 1) 160 | else 161 | str 162 | else 163 | str 164 | and g str = 165 | let l = String.length str in 166 | let rec strip0 off = 167 | if l - off >= 2 && 168 | String.get_uint8 str off = 0x00 && 169 | String.get_uint8 str (off + 1) < 0x80 170 | then 171 | strip0 (off + 1) 172 | else if off = 0 then 173 | str 174 | else 175 | String.sub str off (l - off) 176 | in 177 | let str' = strip0 0 in 178 | if String.length str' = 0 || String.get_uint8 str' 0 > 0x7F then 179 | "\x00" ^ str' 180 | else 181 | str' 182 | in 183 | let random () = 184 | let rec go () = 185 | let buf = Prim.Integer.random () in 186 | try f buf with 187 | | Parse_error _ -> go () 188 | in 189 | go () 190 | in 191 | map ~random f g integer 192 | 193 | let enumerated f g = map f g @@ implicit ~cls:`Universal 0x0a int 194 | 195 | let bit_string = Prim.Bits.(map to_array of_array (Prim Bits)) 196 | and bit_string_octets = 197 | let f = function 198 | | 0, buf -> buf 199 | | clip, buf -> 200 | let n = String.length buf in 201 | let last = String.get_uint8 buf (n - 1) in 202 | let buf' = Bytes.of_string buf 203 | and last = last land (lnot (1 lsl clip - 1)) in 204 | Bytes.set_uint8 buf' (n - 1) last; 205 | Bytes.unsafe_to_string buf' 206 | in 207 | map f (fun cs -> (0, cs)) (Prim Bits) 208 | 209 | let bit_string_flags (type a) (xs : (int * a) list) = 210 | let cmp = compare in (* XXX yes... *) 211 | let module M1 = Map.Make (struct type t = a let compare = cmp end) in 212 | let module M2 = Map.Make (Int) in 213 | let aix, ixa = 214 | List.fold_left (fun (m1, m2) (i, x) -> M1.add x i m1, M2.add i x m2) 215 | (M1.empty, M2.empty) xs in 216 | let n = match M2.max_binding_opt ixa with Some (x, _) -> x + 1 | _ -> 0 in 217 | let f bits = 218 | let r = ref [] in 219 | bits |> Array.iteri (fun i -> function 220 | | false -> () 221 | | true -> try r := M2.find i ixa :: !r with Not_found -> ()); 222 | List.sort cmp !r 223 | and g es = 224 | let arr = Array.make n false in 225 | let register e = try arr.(M1.find e aix) <- true with Not_found -> () in 226 | List.iter register es; 227 | arr 228 | in 229 | map f g bit_string 230 | 231 | 232 | let single a = Last a 233 | and ( @) a b = Pair (a, b) 234 | and (-@) a b = Pair (a, Last b) 235 | and optional ?label a = Optional (label, a) 236 | and required ?label a = Required (label, a) 237 | 238 | let product2 fn a b = fn @@ a @ single b 239 | 240 | let product3 fn a b c = 241 | map (fun (a, (b, c)) -> (a, b, c)) 242 | (fun (a, b, c) -> (a, (b, c))) 243 | (fn @@ a @ b @ single c) 244 | 245 | let product4 fn a b c d = 246 | map (fun (a, (b, (c, d))) -> (a, b, c, d)) 247 | (fun (a, b, c, d) -> (a, (b, (c, d)))) 248 | (fn @@ a @ b @ c @ single d) 249 | 250 | let product5 fn a b c d e = 251 | map (fun (a, (b, (c, (d, e)))) -> (a, b, c, d, e)) 252 | (fun (a, b, c, d, e) -> (a, (b, (c, (d, e))))) 253 | (fn @@ a @ b @ c @ d @ single e) 254 | 255 | let product6 fn a b c d e f = 256 | map (fun (a, (b, (c, (d, (e, f))))) -> (a, b, c, d, e, f)) 257 | (fun (a, b, c, d, e, f) -> (a, (b, (c, (d, (e, f)))))) 258 | (fn @@ a @ b @ c @ d @ e @ single f) 259 | 260 | 261 | let sequence seq = Sequence seq 262 | 263 | let sequence2 a b = product2 sequence a b 264 | and sequence3 a b c = product3 sequence a b c 265 | and sequence4 a b c d = product4 sequence a b c d 266 | and sequence5 a b c d e = product5 sequence a b c d e 267 | and sequence6 a b c d e f = product6 sequence a b c d e f 268 | 269 | let sequence_of asn = Sequence_of asn 270 | 271 | let set seq = Set seq 272 | 273 | let set2 a b = product2 set a b 274 | and set3 a b c = product3 set a b c 275 | and set4 a b c d = product4 set a b c d 276 | and set5 a b c d e = product5 set a b c d e 277 | and set6 a b c d e f = product6 set a b c d e f 278 | 279 | let set_of asn = Set_of asn 280 | 281 | let choice a b = Choice (a, b) 282 | 283 | let choice2 a b = 284 | map (function L a -> `C1 a | R b -> `C2 b) 285 | (function `C1 a -> L a | `C2 b -> R b) 286 | (choice a b) 287 | 288 | let choice3 a b c = 289 | map (function L (L a) -> `C1 a | L (R b) -> `C2 b | R c -> `C3 c) 290 | (function `C1 a -> L (L a) | `C2 b -> L (R b) | `C3 c -> R c) 291 | (choice (choice a b) c) 292 | 293 | let choice4 a b c d = 294 | map (function | L (L a) -> `C1 a | L (R b) -> `C2 b 295 | | R (L c) -> `C3 c | R (R d) -> `C4 d) 296 | (function | `C1 a -> L (L a) | `C2 b -> L (R b) 297 | | `C3 c -> R (L c) | `C4 d -> R (R d)) 298 | (choice (choice a b) (choice c d)) 299 | 300 | let choice5 a b c d e = 301 | map (function | L (L (L a)) -> `C1 a | L (L (R b)) -> `C2 b 302 | | L (R c) -> `C3 c 303 | | R (L d) -> `C4 d | R (R e) -> `C5 e) 304 | (function | `C1 a -> L (L (L a)) | `C2 b -> L (L (R b)) 305 | | `C3 c -> L (R c) 306 | | `C4 d -> R (L d) | `C5 e -> R (R e)) 307 | (choice (choice (choice a b) c) (choice d e)) 308 | 309 | let choice6 a b c d e f = 310 | map (function | L (L (L a)) -> `C1 a | L (L (R b)) -> `C2 b 311 | | L (R c) -> `C3 c 312 | | R (L (L d)) -> `C4 d | R (L (R e)) -> `C5 e 313 | | R (R f) -> `C6 f) 314 | (function | `C1 a -> L (L (L a)) | `C2 b -> L (L (R b)) 315 | | `C3 c -> L (R c) 316 | | `C4 d -> R (L (L d)) | `C5 e -> R (L (R e)) 317 | | `C6 f -> R (R f)) 318 | (choice (choice (choice a b) c) (choice (choice d e) f)) 319 | -------------------------------------------------------------------------------- /tests/x509.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2014-2017 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | open Asn 5 | open Asn.S 6 | 7 | type tBSCertificate = { 8 | version : [ `V1 | `V2 | `V3 ] ; 9 | serial : string ; 10 | signature : OID.t ; 11 | issuer : (OID.t * string) list list ; 12 | validity : Ptime.t * Ptime.t ; 13 | subject : (OID.t * string) list list ; 14 | pk_info : OID.t * string ; 15 | issuer_id : string option ; 16 | subject_id : string option ; 17 | extensions : (OID.t * bool * string) list option 18 | } 19 | 20 | type certificate = { 21 | tbs_cert : tBSCertificate ; 22 | signature_algo : OID.t ; 23 | signature : string 24 | } 25 | 26 | let def x = function None -> x | Some y -> y 27 | 28 | let def' x = fun y -> if y = x then None else Some y 29 | 30 | let extensions = 31 | let extension = 32 | map (fun (oid, b, v) -> (oid, def false b, v)) 33 | (fun (oid, b, v) -> (oid, def' false b, v)) @@ 34 | sequence3 35 | (required ~label:"id" oid) 36 | (optional ~label:"critical" bool) (* default false *) 37 | (required ~label:"value" octet_string) 38 | in 39 | sequence_of extension 40 | 41 | let directory_name = 42 | map (function | `C1 s -> s | `C2 s -> s | `C3 s -> s 43 | | `C4 s -> s | `C5 s -> s | `C6 s -> s) 44 | (function s -> `C1 s) 45 | @@ 46 | choice6 47 | printable_string utf8_string 48 | (* The following three could probably be ommited. 49 | * See rfc5280 section 4.1.2.4. *) 50 | teletex_string universal_string bmp_string 51 | (* is this standard? *) 52 | ia5_string 53 | 54 | let name = 55 | let attribute_tv = 56 | sequence2 57 | (required ~label:"attr type" oid) 58 | (* This is ANY according to rfc5280. *) 59 | (required ~label:"attr value" directory_name) in 60 | let rd_name = set_of attribute_tv in 61 | let rdn_sequence = sequence_of rd_name in 62 | rdn_sequence (* A vacuous choice, in the standard. *) 63 | 64 | let algorithmIdentifier = 65 | map (fun (oid, _) -> oid) (fun oid -> (oid, None)) 66 | @@ 67 | sequence2 68 | (required ~label:"algorithm" oid) 69 | (* This is ANY according to rfc5280 *) 70 | (optional ~label:"params" null) 71 | 72 | let version = 73 | map (function 2 -> `V2 | 3 -> `V3 | _ -> `V1) 74 | (function `V2 -> 2 | `V3 -> 3 | _ -> 1) 75 | int 76 | 77 | let certificateSerialNumber = integer 78 | 79 | let time = 80 | map (function `C1 t -> t | `C2 t -> t) (fun t -> `C2 t) 81 | (choice2 utc_time generalized_time) 82 | 83 | let validity = 84 | sequence2 85 | (required ~label:"not before" time) 86 | (required ~label:"not after" time) 87 | 88 | let subjectPublicKeyInfo = 89 | sequence2 90 | (required ~label:"algorithm" algorithmIdentifier) 91 | (required ~label:"subjectPK" bit_string_octets) 92 | 93 | let uniqueIdentifier = bit_string_octets 94 | 95 | let tBSCertificate = 96 | let f = fun (a, (b, (c, (d, (e, (f, (g, (h, (i, j))))))))) -> 97 | { version = def `V1 a ; serial = b ; 98 | signature = c ; issuer = d ; 99 | validity = e ; subject = f ; 100 | pk_info = g ; issuer_id = h ; 101 | subject_id = i ; extensions = j } 102 | 103 | and g = fun 104 | { version = a ; serial = b ; 105 | signature = c ; issuer = d ; 106 | validity = e ; subject = f ; 107 | pk_info = g ; issuer_id = h ; 108 | subject_id = i ; extensions = j } -> 109 | (def' `V1 a, (b, (c, (d, (e, (f, (g, (h, (i, j))))))))) 110 | in 111 | 112 | map f g @@ 113 | sequence @@ 114 | (optional ~label:"version" @@ explicit 0 version) (* default v1 *) 115 | @ (required ~label:"serialNumber" @@ certificateSerialNumber) 116 | @ (required ~label:"signature" @@ algorithmIdentifier) 117 | @ (required ~label:"issuer" @@ name) 118 | @ (required ~label:"validity" @@ validity) 119 | @ (required ~label:"subject" @@ name) 120 | @ (required ~label:"subjectPKInfo" @@ subjectPublicKeyInfo) 121 | (* if present, version is v2 or v3 *) 122 | @ (optional ~label:"issuerUID" @@ implicit 1 uniqueIdentifier) 123 | (* if present, version is v2 or v3 *) 124 | @ (optional ~label:"subjectUID" @@ implicit 2 uniqueIdentifier) 125 | (* v3 if present *) 126 | -@ (optional ~label:"extensions" @@ explicit 3 extensions) 127 | 128 | let certificate = 129 | 130 | let f (a, b, c) = 131 | { tbs_cert = a ; signature_algo = b ; signature = c } 132 | 133 | and g { tbs_cert = a ; signature_algo = b ; signature = c } = 134 | (a, b, c) in 135 | 136 | map f g @@ 137 | sequence3 138 | (required ~label:"tbsCertificate" tBSCertificate) 139 | (required ~label:"signatureAlgorithm" algorithmIdentifier) 140 | (required ~label:"signatureValue" bit_string_octets) 141 | 142 | let cert_ber, cert_der = 143 | (codec ber certificate, codec der certificate) 144 | 145 | 146 | let examples = [ 147 | "3082062030820408a003020102 0203020acd300d06092a864886 148 | f70d0101050500305431143012 060355040a130b434163657274 149 | 20496e632e311e301c06035504 0b1315687474703a2f2f777777 150 | 2e4341636572742e6f7267311c 301a0603550403131343416365 151 | 727420436c617373203320526f 6f74301e170d31333039303431 152 | 35343333395a170d3135303930 343135343333395a3069310b30 153 | 09060355040613024445311030 0e0603550408130748616d6275 154 | 72673110300e06035504071307 48616d627572673121301f0603 155 | 55040a13184368616f7320436f 6d707574657220436c75622065 156 | 2e562e31133011060355040313 0a7777772e6363632e64653082 157 | 0222300d06092a864886f70d01 010105000382020f003082020a 158 | 0282020100b867422b9bec4548 8639b5e86d7b8848beec017328 159 | 59f6e96a2e63846237169fa933 61a5294bb9bffb936f64195ba0 160 | c75a81d6d900207c447baa466d b5aa2ddb758207388b1f74499e 161 | c070bbc09b5076c2c8d7296362 0416d7e6aa47abac84aee26b17 162 | 596853a90cb27c5a57f066f6ed 3b29d878e9a1e7e3199d953fe0 163 | bd364b24af59e9ff87c4ded1f3 6598747680d95ccfb52090e7cf 164 | 517cf450edd8364259837019bc c336eaafebb4f5fed770981c05 165 | 88fa44de4d425f78bc12bcfab8 cade0a8a2d09d83401490dc143 166 | bd813c6054c5b009e98d382544 f948a9fe77403e134274cea8ba 167 | 851e5037b00a3a075226676aea acc9064e5987c1b96534af2e91 168 | 96442462a40a02b66aabe22a9d b1b6af1babec2c5556fc53725e 169 | 1659f4a810a7a4b1b2deca5bef 1cd986f10a0f3945768f708f5d 170 | cd0ce3974f9ea0c27961b14304 28de8fefabd4f21658c2d02d60 171 | 037360cef1b9939ae33be90671 4094a1cc4c0d3edac2426dfdc3 172 | 5af18e79ea94fec4e014755809 05313ff6e22482f9b0eb3f30fb 173 | f0d9df5954e3bb44095a559f39 ef054ed3452e17aa2fc877c683 174 | 2cde17dc56f5306f125f839307 d2f01d706efacd691bd131ff89 175 | f5ec89d7502cb5c7dfc1d15530 c32e7df56eddfe341d264c8291 176 | 75957f729f4175b44af54da20d 60bdadde11ce0c0a970713b9e1 177 | 9886432a9471a188c58ca5fb45 5b1e821b57d900a34b99020301 178 | 0001a381e53081e2300c060355 1d130101ff04023000300e0603 179 | 551d0f0101ff0404030203a830 340603551d25042d302b06082b 180 | 0601050507030206082b060105 0507030106096086480186f842 181 | 0401060a2b0601040182370a03 03303306082b06010505070101 182 | 04273025302306082b06010505 0730018617687474703a2f2f6f 183 | 6373702e6361636572742e6f72 672f30380603551d1f0431302f 184 | 302da02ba0298627687474703a 2f2f63726c2e6361636572742e 185 | 6f72672f636c617373332d7265 766f6b652e63726c301d060355 186 | 1d1104163014820a7777772e63 63632e646582066363632e6465 187 | 300d06092a864886f70d010105 0500038202010085e6700b89e3 188 | 7917899556187be487bed8e5ce 563eaaf527c01e8808cf3dbd8a 189 | 24b8a7a83d075a460e4e97df44 261f3a9c3986d5903bda265a31 190 | e152b7fef5cb951605770417d8 c53d6b238592bc166523ea43c4 191 | 2689bfc02e36e66320999d2807 13117e7209f03668c2d84f610b 192 | 0c1e0d53281fa03bbe46b5c378 e3a4f7ecf46b4e2414be366f71 193 | 5881b37f9a0e9262e48dd8fc4b 18bbfb710418f9564ffa692419 194 | ab9d2a029c5895a48f46ad7120 3cdfbf47739308b1b6336fe579 195 | 4bf1f5bdecc141ddc22e9052af 87427dbebb2e3b16372d771f4a 196 | cdeec993d1e7081437ae67f9d3 f8ebfab96d15571337323e16be 197 | 879c65b34278314e75e54222cc 089bdbb3fe3dc7ef793c7e994d 198 | acb58712cc97504d6fc2740758 3f1853f9bd635c2d792fa63fc0 199 | 0a20e4083a57106b3ed90d39a4 a9d4e3680fab5bc0917afc11bc 200 | 85114d189d893a82184f5832c9 72af0d67911c6c5917f77e1c54 201 | a3fe7cb8d1b675e9d327711f9d 21eb321652ea11397525e74fa3 202 | 3b6cb24480f180a0ae3a7e9897 d73b9834bda98d4cdcf226bc77 203 | 2f94c9603db78aed0eb23b4cf0 d80a9b35953b09e9b9235f42ab 204 | b4ee46e35400405a403b4bedf6 4c0a884400e83c314eaba4f031 205 | 1dae70b25e33d0475661b8acee 57425f8d39858fa9bafb5443fa 206 | 030e303bee0843be66e2f46957 68d5a7f5114de83c8c7e0b543b 207 | d905b092eec7229685bf4ffe"; 208 | 209 | "308204763082035ea003020102 020843b5eedccc2793ee300d06 210 | 092a864886f70d010105050030 49310b30090603550406130255 211 | 5331133011060355040a130a47 6f6f676c6520496e6331253023 212 | 0603550403131c476f6f676c65 20496e7465726e657420417574 213 | 686f72697479204732301e170d 3134303132393134303533375a 214 | 170d3134303532393030303030 305a3068310b30090603550406 215 | 13025553311330110603550408 0c0a43616c69666f726e696131 216 | 16301406035504070c0d4d6f75 6e7461696e2056696577311330 217 | 11060355040a0c0a476f6f676c 6520496e633117301506035504 218 | 030c0e7777772e676f6f676c65 2e636f6d30820122300d06092a 219 | 864886f70d0101010500038201 0f003082010a0282010100a478 220 | 79a679863bb8c311c4a835e0d3 f1f3316d0ff566508d9be05750 221 | 6200fc02e4627c0f9faafc6270 4922ed37754ab678ce57670236 222 | c04be7c2d1e4238bc7e8253a2c ae45e0420bf976cd3ef2553776 223 | 8a155e8a9e99e24a52287323f8 7eedc7f5dbceffec46cc23945a 224 | 0c150f4c79991de0ed937f1751 8b01ad2f779c80aae150d4031c 225 | b604ab06492da5f7046f9787e1 7430e682e4397110ca9ffa6a75 226 | 812a02ac455448da9b08dc5164 81b1696a4a7dfb7c8f6cfcc643 227 | 0b37ccc33e8085e14cad134bd2 8276637715741c620d576a8c64 228 | be006e6a214cff02cbc734bdc9 12c6b9e4e4ab305b9b08f0b360 229 | 330054b2b38aa657e46db97347 bfaa1d1b48ae3f0203010001a3 230 | 8201413082013d301d0603551d 250416301406082b0601050507 231 | 030106082b0601050507030230 190603551d1104123010820e77 232 | 77772e676f6f676c652e636f6d 306806082b0601050507010104 233 | 5c305a302b06082b0601050507 3002861f687474703a2f2f706b 234 | 692e676f6f676c652e636f6d2f 47494147322e637274302b0608 235 | 2b06010505073001861f687474 703a2f2f636c69656e7473312e 236 | 676f6f676c652e636f6d2f6f63 7370301d0603551d0e04160414 237 | 7520ead1f9b9b734d5e9e4358a aee864c6732ba4300c0603551d 238 | 130101ff04023000301f060355 1d230418301680144add06161b 239 | bcf668b576f581b6bb621aba5a 812f30170603551d200410300e 240 | 300c060a2b06010401d6790205 0130300603551d1f0429302730 241 | 25a023a021861f687474703a2f 2f706b692e676f6f676c652e63 242 | 6f6d2f47494147322e63726c30 0d06092a864886f70d01010505 243 | 0003820101003a8fda0f284e64 fc55f9b1b2d8e29ef1b2796d9d 244 | d1c3375a32ce66fcf9c9a47ba5 bf7851ec63483ecd4794056df3 245 | 6f410c06735758d4c207569521 c4467bc1940c30270334973100 246 | 5e062b0d6faf649f6ba7b52ed1 6e52fcdfef07efced1b0b797b9 247 | c6a1af7902a1ceb5a137a62341 c4238dce0ed548b851033490c4 248 | d70aac1e475979c9cd4b6f4867 24a92b6b24af7ac7eea5246cfd 249 | 659336c5bec9c5532a770094b8 89bf7ee313ebeb91907d48bff2 250 | f828495bcecb9637ad3fd4dc2b 48f6d3e80d26536064e5eb82c3 251 | c496bc744198993287823c891e 66cacdeb35dcdfc1375f17525b 252 | d39e311a89f417bc98fdca9a9c 3075053e392ac08d474b26f589 253 | 1b61"; 254 | 255 | "30820263308201cc020900cb6c 4e844b58a1d4300d06092a8648 256 | 86f70d01010505003076310b30 09060355040613024155311330 257 | 1106035504080c0a536f6d652d 53746174653121301f06035504 258 | 0a0c18496e7465726e65742057 69646769747320507479204c74 259 | 643115301306035504030c0c59 4f5552204e414d452121213118 260 | 301606092a864886f70d010901 16096d65406261722e6465301e 261 | 170d3134303231373232303834 355a170d313530323137323230 262 | 3834355a3076310b3009060355 04061302415531133011060355 263 | 04080c0a536f6d652d53746174 653121301f060355040a0c1849 264 | 6e7465726e6574205769646769 747320507479204c7464311530 265 | 1306035504030c0c594f555220 4e414d45212121311830160609 266 | 2a864886f70d01090116096d65 406261722e646530819f300d06 267 | 092a864886f70d010101050003 818d0030818902818100b64048 268 | dee6bc21943da2ab5eb6f8d837 007f417c0fe33492c3aa2f553e 269 | 4d5e31434689c26f2be68e00d2 88b0e3abf6fe118845d9498985 270 | 12f192cbe49fd5b0831f01cb2d 274db3a638f5befb3ce81ab6b5 271 | 59393444044fedd6ca154f76bf bd525608bb550a39bbd2ed12e6 272 | d71f9f84ba21aa5e2180150267 1aab049af8640da10203010001 273 | 300d06092a864886f70d010105 0500038181008a38669a48969d 274 | c947296d442d7f032082d2db21 e5374cdd6ef6e7cc1da0fde511 275 | ed3c5252f0a673dc689fdc5fca cc1b85dfe22b7bef2adb56b537 276 | 32e9811063794d6e239f8fa267 215ba7a4d3dce505e799ec5c38 277 | cd1c16ee75e0d5a46b8f4c8e82 650561539a84305df19a5a241b 278 | e555f870834e094d41cf9f74b3 342e8345"; 279 | ] 280 | -------------------------------------------------------------------------------- /src/asn.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2014-2017 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | (** Embed typed ASN.1 grammars in OCaml 5 | 6 | Skip the notation part of Abstract Syntax Notation, and embed the abstract 7 | syntax directly in OCaml. 8 | 9 | {b References} 10 | {ul 11 | {- ITU-T. {{:http://handle.itu.int/11.1002/1000/12479}Abstract Syntax Notation One (ASN.1): Specification of basic notation}. ITU-T X.680 | ISO/IEC 8824-1, 2015} 12 | {- ITU-T. {{:http://handle.itu.int/11.1002/1000/12483 }ASN.1 encoding rules: Specification of Basic Encoding Rules (BER), Canonical Encoding Rules (CER) and Distinguished Encoding Rules (DER)}. ITU-T X.690 | ISO/IEC 8825-1, 2015}} 13 | 14 | {e %%VERSION%% — {{:%%PKG_HOMEPAGE%% }homepage}} *) 15 | 16 | (** {1 Object identifiers} *) 17 | 18 | type oid 19 | (** ASN.1 [OBJECT IDENTIFIER]. *) 20 | 21 | (** Object identifiers. 22 | 23 | Magic numbers in a suit and tie. Their consulting fee is astronomical. *) 24 | module OID : sig 25 | 26 | (** {1 Object identifiers} *) 27 | 28 | type t = oid 29 | (** OIDs are conceptually a sequence of non-negative integers, called 30 | {e nodes}. 31 | 32 | Every OID has at least two nodes. *) 33 | 34 | val equal : t -> t -> bool 35 | val compare : t -> t -> int 36 | val hash : t -> int 37 | val seeded_hash : int -> t -> int 38 | 39 | (** {1 Construction} *) 40 | 41 | val base : int -> int -> t 42 | (** [base n1 n2] is the OID [n1.n2]. 43 | 44 | Either [n1] is [[0..1]] and [n2] is [[0..39]] (inclusive), or [n1] is [2] 45 | and [n2] is non-negative. 46 | 47 | @raise Invalid_argument if the components are out of range. *) 48 | 49 | val (<|) : t -> int -> t 50 | (** [oid <| n] is the OID [oid.n]. 51 | 52 | @raise Invalid_argument if [n] is negative. *) 53 | 54 | val (<||) : t -> int list -> t 55 | (** [oid <|| ns] is the old [oid.n1.n2. ...] if [ns] is [[n1; n2; ...]]. 56 | 57 | @raise Invalid_argument if any of [ns] is negative. *) 58 | 59 | (** {1 Conversion} *) 60 | 61 | val to_nodes : t -> int * int * int list 62 | (** [to_nodes oid] are the nodes this [oid] consists of. Every OID has at 63 | least two nodes; the rest are collected in the list. *) 64 | 65 | val of_nodes : int -> int -> int list -> t option 66 | (** [of_nodes n1 n2 ns] is the oid [n1.n2.ns...], or [None], if any of the 67 | components are out of range. See {{!base}[base]} and {{!(<|)}[<|]}. *) 68 | 69 | val pp : Format.formatter -> t -> unit 70 | (** [pp ppf oid] pretty-prints [oid] on [ppf] as dotted-decimal. *) 71 | 72 | val of_string : string -> t option 73 | (** [of_string s] is the OID represented by [s], or [None], if [s] is not 74 | dotted-decimal or the components are out of range. *) 75 | end 76 | 77 | 78 | (** {1 ASN.1 Abstract Syntax} *) 79 | 80 | type 'a t 81 | (** Abstract syntax of values of type ['a]. *) 82 | 83 | 84 | (** ASN.1 Abstract Syntax. 85 | 86 | This module is the OCaml term-level analogue of ASN.1's surface notation. 87 | 88 | It provides a ground type {{!S.t}['a t]} representing typed abstract syntax, 89 | a suite of primitives that correspond to ASN.1 primitives, and a suite of 90 | combinators that correspond to the combining structures of ASN.1. 91 | 92 | ASN.1 naming and modules are not supported; these are provided by the host 93 | language instead. *) 94 | module S : sig 95 | 96 | (** {1 ASN.1 Abstract Syntax} *) 97 | 98 | (** ['a t] denotes a particular structure of data, irrespective of any 99 | encoding, that is represented by ['a] in OCaml. *) 100 | type nonrec 'a t = 'a t 101 | 102 | (** {1 Basic combinators} *) 103 | 104 | val fix : ('a t -> 'a t) -> 'a t 105 | (** [fix fasn] is the fixpoint, allowing [fasn] to construct a syntax that 106 | refers to itself. *) 107 | 108 | val map : ?random:(unit -> 'b) -> ('a -> 'b) -> ('b -> 'a) -> 'a t -> 'b t 109 | (** [map ?random f g asn] creates a derived syntax that encodes and decodes 110 | like [asn], but uses [f] to project and [g] to inject. 111 | 112 | [~random] is a function that generates random samples of ['b]. Defaults to 113 | [f a] where [a] is a random ['a]. *) 114 | 115 | (** {1 Tags} *) 116 | 117 | type cls = [ `Universal | `Application | `Private ] 118 | (** ASN.1 tag CLASS. *) 119 | 120 | val implicit : ?cls:cls -> int -> 'a t -> 'a t 121 | (** [implicit ?cls n asn] is the ASN.1 [IMPLICIT] construct, changing the tag 122 | of [asn] to [(cls, n)]. 123 | 124 | [n] is the tag value. 125 | 126 | [~cls] is the class. Defaults to [CONTEXT SPECIFIC]. 127 | 128 | {b Note} [implicit] implicitly becomes [explicit] when applied to nodes 129 | that cannot be made [IMPLICIT], like [CHOICE]. This is consistent with 130 | X.608 (see [31.2.7]) in case of a bare tag, and with the common practice 131 | in case of a tag marked as [IMPLICIT]. *) 132 | 133 | val explicit : ?cls:cls -> int -> 'a t -> 'a t 134 | (** [explicit ?cls n asn] is the ASN.1 [EXPLICIT] construct, changing the tag 135 | of [asn] to [(cls, n)]. 136 | 137 | [n] is the tag value. 138 | 139 | [~cls] is the class. Defaults to [CONTEXT SPECIFIC]. *) 140 | 141 | (** {1 Combining constructs} 142 | 143 | These look like 144 | {[sequence @@ 145 | (required ~label:"l1" asn1) 146 | @ (optional ~label:"l2" asn2) 147 | @ (required ~label:"l3" asn3) 148 | -@ (optional ~label:"l4" asn4)]} 149 | or 150 | {[choice3 asn1 asn2 asn3]} *) 151 | 152 | type 'a element 153 | (** An [element] is a single slot in a {{!sequence}[sequence]}. *) 154 | 155 | val required : ?label:string -> 'a t -> 'a element 156 | (** [required ?label asn] is a regular sequence element. 157 | 158 | [~label] is the name of the element. *) 159 | 160 | val optional : ?label:string -> 'a t -> 'a option element 161 | (** [optional ?label asn] is a sequence element marked with the 162 | ASN.1 [OPTIONAL] keyword. 163 | 164 | [~label] is the name of the element. *) 165 | 166 | type 'a sequence 167 | (** A [sequence] is the body of a multi-field ASN.1 construct, like 168 | [SEQUENCE] and [SET]. *) 169 | 170 | val single : 'a element -> 'a sequence 171 | (** [single e] is the singleton sequence containing just [e]. *) 172 | 173 | val ( @ ) : 'a element -> 'b sequence -> ('a * 'b) sequence 174 | (** [e @ seq] extends [seq] by prepending [e]. *) 175 | 176 | val ( -@ ) : 'a element -> 'b element -> ('a * 'b) sequence 177 | (** [e -@ e1] is [e @ single e1] *) 178 | 179 | val sequence : 'a sequence -> 'a t 180 | (** [sequence seq] is the ASN.1 [SEQUENCE] construct, with the body [seq]. *) 181 | 182 | val sequence_of : 'a t -> 'a list t 183 | (** [sequence_of] is the ASN.1 [SEQUENCE OF] construct. *) 184 | 185 | val sequence2 : 'a element -> 'b element -> ('a * 'b) t 186 | (** [sequence2 e1 e2] is [sequence (e1 -@ e2)]. Other [sequenceN] functions 187 | are analogous. *) 188 | 189 | val sequence3 : 190 | 'a element -> 191 | 'b element -> 'c element -> ('a * 'b * 'c) t 192 | 193 | val sequence4 : 194 | 'a element -> 195 | 'b element -> 196 | 'c element -> 'd element -> ('a * 'b * 'c * 'd) t 197 | 198 | val sequence5 : 199 | 'a element -> 200 | 'b element -> 201 | 'c element -> 202 | 'd element -> 'e element -> ('a * 'b * 'c * 'd * 'e) t 203 | 204 | val sequence6 : 205 | 'a element -> 206 | 'b element -> 207 | 'c element -> 208 | 'd element -> 209 | 'e element -> 210 | 'f element -> ('a * 'b * 'c * 'd * 'e * 'f) t 211 | 212 | val set : 'a sequence -> 'a t 213 | (** [seq seq] is the ASN.1 [SET] construct, with the body [seq]. *) 214 | 215 | val set_of : 'a t -> 'a list t 216 | (** [set_of asn] is the ASN.1 [SET OF] construct. *) 217 | 218 | val set2 : 'a element -> 'b element -> ('a * 'b) t 219 | (** [set2 e1 e2] is [set (e1 -@ e2)]. Other [setN] functions are analogous. *) 220 | 221 | val set3 : 222 | 'a element -> 223 | 'b element -> 'c element -> ('a * 'b * 'c) t 224 | 225 | val set4 : 226 | 'a element -> 227 | 'b element -> 228 | 'c element -> 'd element -> ('a * 'b * 'c * 'd) t 229 | 230 | val set5 : 231 | 'a element -> 232 | 'b element -> 233 | 'c element -> 234 | 'd element -> 'e element -> ('a * 'b * 'c * 'd * 'e) t 235 | 236 | val set6 : 237 | 'a element -> 238 | 'b element -> 239 | 'c element -> 240 | 'd element -> 241 | 'e element -> 242 | 'f element -> ('a * 'b * 'c * 'd * 'e * 'f) t 243 | 244 | val choice2 : 245 | 'a t -> 'b t -> [ `C1 of 'a | `C2 of 'b ] t 246 | (** [choice2 asn1 asn2] is the ASN.1 [CHOICE] construct, choosing between 247 | [asn1] and [asn2]. Other [choiceN] functions are analogous. 248 | 249 | Larger [CHOICE] can be obtained by nesting [choice] variants. 250 | 251 | {b Note} [CHOICE] containing elements with the same tag yields an illegal 252 | syntax. This will be detected by {!codec}. *) 253 | 254 | val choice3 : 255 | 'a t -> 'b t -> 'c t 256 | -> [ `C1 of 'a | `C2 of 'b | `C3 of 'c ] t 257 | 258 | val choice4 : 259 | 'a t -> 'b t -> 'c t -> 'd t 260 | -> [ `C1 of 'a | `C2 of 'b | `C3 of 'c | `C4 of 'd ] t 261 | 262 | val choice5 : 263 | 'a t -> 'b t -> 'c t -> 'd t -> 'e t 264 | -> [ `C1 of 'a | `C2 of 'b | `C3 of 'c | `C4 of 'd | `C5 of 'e ] t 265 | 266 | val choice6 : 267 | 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t 268 | -> [ `C1 of 'a | `C2 of 'b | `C3 of 'c | `C4 of 'd | `C5 of 'e | `C6 of 'f ] t 269 | 270 | (** {1 Primitives} *) 271 | 272 | val bool : bool t 273 | (** [bool] is ASN.1 [BOOLEAN]. *) 274 | 275 | val integer : string t 276 | (** [integer] is ASN.1 [INTEGER]. The representation is a [string]. Be aware 277 | these are two's complement signed integers, in order to encode a positive 278 | number where the first bit is set (i.e. 128 = [0x80]), you have to prepend 279 | a 0 byte: [0x00 0x80]. Otherwise it ([0x80]) will be decoded as -128. See 280 | {!unsigned_integer} for automated two's complement transformations. *) 281 | 282 | val bit_string : bool array t 283 | (** [bit_string] is ASN.1 [BIT STRING]. *) 284 | 285 | val bit_string_octets : string t 286 | (** [bit_string_octets] is ASN.1 [BIT STRING], represented as [string], and 287 | padded with 0-bits up to the next full octet. *) 288 | 289 | val octet_string : string t 290 | (** [octet_string] is ASN.1 [OCTET STRING]. *) 291 | 292 | val null : unit t 293 | (** [null] is ASN.1 [NULL]. *) 294 | 295 | val oid : oid t 296 | (** [oid] is ASN.1 [OBJECT IDENTIFIER]. *) 297 | 298 | val enumerated : (int -> 'a) -> ('a -> int) -> 'a t 299 | (** [enumerated f g] is ASN.1 [ENUMERATED], with [f] projecting from, and [g] 300 | injecting into an [int]. 301 | 302 | The full [INTEGER] range is {i not} supported. *) 303 | 304 | val generalized_time : Ptime.t t 305 | (** [generalized_time] is ASN.1 [GeneralizedTime]. *) 306 | 307 | val utc_time : Ptime.t t 308 | (** [utc_time] is ASN.1 [UTCTime]. 309 | 310 | Representable years are 1950–2049. *) 311 | 312 | (** {2 String primitives} 313 | 314 | Various ASN.1 stringy types. 315 | 316 | {b Note} Presently, no conversion or validation is performed on strings. 317 | They differ only in tags. *) 318 | 319 | val utf8_string : string t 320 | val numeric_string : string t 321 | val printable_string : string t 322 | val teletex_string : string t 323 | val videotex_string : string t 324 | val ia5_string : string t 325 | val graphic_string : string t 326 | val visible_string : string t 327 | val general_string : string t 328 | val universal_string : string t 329 | val bmp_string : string t 330 | 331 | (** {2 Additional primitives} *) 332 | 333 | val int : int t 334 | (** [int] is ASN.1 [INTEGER], projected into an OCaml [int]. *) 335 | 336 | val unsigned_integer : string t 337 | (** [unsigned_integer] is ASN.1 [INTEGER], where the necessary two's 338 | complement transformations are already applied. That is, it represents 339 | unsigned integers encoded as ASN.1 (signed) [INTEGER]s. Negative ASN.1 340 | [INTEGER]s are rejected with a parse error. *) 341 | 342 | val bit_string_flags : (int * 'a) list -> 'a list t 343 | (** [bit_string_flags xs] is ASN.1 [BIT STRING], represented as a collection 344 | of values. 345 | 346 | [xs] is a list of [(bit, x)], where bit [bit] denotes the presence of [x]. *) 347 | 348 | (** {1 Errors} *) 349 | 350 | (* XXX repeats *) 351 | val error : [ `Parse of string ] -> 'a 352 | (** [error err] aborts parsing with the {{!error}[error]} [err]. 353 | 354 | Aborting the parse is useful, for example, in the [f] argument to 355 | {{!map}[map]}. *) 356 | 357 | val parse_error : ('a, Format.formatter, unit, 'b) format4 -> 'a 358 | (** [parse_error fmt ...] aborts parsing with the message produced by using 359 | [fmt] to format arguments [...]. *) 360 | end 361 | 362 | (** {1 Encoding formats} *) 363 | 364 | type encoding 365 | 366 | val ber : encoding 367 | (** [ber] is ASN.1 Basic Encoding Rules (BER). *) 368 | 369 | val der : encoding 370 | (** [der] is ASN.1 Distinguished Encoding Rules (DER). *) 371 | 372 | 373 | (** {1 Encoding and decoding} *) 374 | 375 | type 'a codec 376 | 377 | exception Ambiguous_syntax 378 | 379 | val codec : encoding -> 'a t -> 'a codec 380 | (** [codec enc asn] represents the syntax [asn] encoded under the rules [enc]. 381 | 382 | This function performs work up-front, and is generally expected to be called 383 | in the static context on statically known syntaxes. 384 | 385 | @raise Ambiguous_syntax if [asn] contains [CHOICE] constructs over 386 | sub-syntaxes with the same tags. *) 387 | 388 | val encode : 'a codec -> 'a -> string 389 | (** [encode codec x] is the encoding of [x], using [codec]. *) 390 | 391 | val encode_into : 'a codec -> 'a -> (int * (bytes -> unit)) 392 | (** [encode_into codec x] is the pair [(n, f)], where [n] is the length of [x] 393 | encoded with [codec], and [f] is a function that will write the encoded [x] 394 | to the first [n] bytes of the provided [bytes]. *) 395 | 396 | type error = [ `Parse of string ] 397 | (** Parse errors. *) 398 | 399 | val pp_error : Format.formatter -> error -> unit 400 | (** [pp_error ppf err] pretty-prints [err] on [ppf]. *) 401 | 402 | val decode : 'a codec -> string -> ('a * string, error) result 403 | (** [decode codec cs] is the pair [(x, cs')], where [x] is the result of 404 | decoding the prefix of [cs] with [codec] and [cs'] are the trailing bytes, 405 | or an {!error}. *) 406 | 407 | (** {1 Misc} *) 408 | 409 | val random : 'a t -> 'a 410 | (** [random asn] is a random inhabitant of ['a]. *) 411 | -------------------------------------------------------------------------------- /tests/test.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2014-2019 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | let octets = Alcotest.testable Ohex.pp String.equal 5 | let err = Alcotest.testable Asn.pp_error (fun (`Parse _) (`Parse _) -> true) 6 | let dec t = Alcotest.(result (pair t octets) err) 7 | let testable ?(pp = fun ppf _ -> Fmt.pf ppf "*shrug*") ?(cmp = (=)) () = 8 | Alcotest.testable pp cmp 9 | 10 | let pp_e ppf = function 11 | | #Asn.error as e -> Asn.pp_error ppf e 12 | | `Leftover b -> Format.fprintf ppf "Leftover: %a" Ohex.pp b 13 | 14 | type 'a cmp = 'a -> 'a -> bool 15 | 16 | type case_eq = 17 | CEQ : string * 'a Alcotest.testable * 'a Asn.t * ('a * string) list -> case_eq 18 | 19 | let case_eq name ?pp ?cmp asn examples = 20 | CEQ (name, testable ?pp ?cmp (), asn, examples) 21 | 22 | type case = C : string * 'a Asn.t * string list -> case 23 | 24 | let case name asn examples = C (name, asn, examples) 25 | 26 | let accepts_eq name enc cases = 27 | let tests = cases |> List.map @@ fun (CEQ (name, alc, asn, xs)) -> 28 | let codec = Asn.codec enc asn 29 | and t = dec alc in 30 | let f () = xs |> List.iter @@ fun (exp, s) -> 31 | Alcotest.check t name (Ok (exp, "")) (Asn.decode codec (Ohex.decode s)) in 32 | (name, `Quick, f) in 33 | (name, tests) 34 | 35 | let rejects name enc cases = 36 | let tests = cases |> List.map @@ fun (C (name, asn, ss)) -> 37 | let codec = Asn.codec enc asn 38 | and t = dec (testable ()) in 39 | let f () = ss |> List.iter @@ fun s -> 40 | Alcotest.check t name (Error (`Parse "...")) 41 | (Asn.decode codec (Ohex.decode s)) in 42 | (name, `Quick, f) in 43 | (name, tests) 44 | 45 | let accepts name enc cases = 46 | let tests = cases |> List.map @@ fun (C (name, asn, ss)) -> 47 | let f () = ss |> List.iter @@ fun s -> 48 | match Asn.(decode (codec enc asn)) (Ohex.decode s) with 49 | Ok (_, t) -> 50 | Alcotest.check octets "no remainder" "" t 51 | | Error e -> 52 | Alcotest.failf "decode failed with: %a" pp_e e in 53 | (name, `Quick, f) in 54 | (name, tests) 55 | 56 | let inverts1 ?(iters = 1000) name enc cases = 57 | let tests = cases |> List.map @@ fun (CEQ (name, alc, asn, _)) -> 58 | let codec = Asn.codec enc asn and t = dec alc in 59 | let f () = 60 | for _ = 1 to iters do 61 | let x = Asn.random asn in 62 | Alcotest.check t "invert" (Ok (x, "")) 63 | (Asn.decode codec (Asn.encode codec x)) 64 | done in 65 | (name, `Quick, f) in 66 | (name, tests) 67 | 68 | let time ?(frac=0) dtz = 69 | Ptime.(add_span (of_date_time dtz |> Option.get) 70 | (Span.v (0, Int64.(mul (of_int frac) 1_000_000_000L))) |> Option.get) 71 | 72 | let cases = [ 73 | 74 | case_eq "bool" Asn.S.bool [ 75 | false, "010100" ; 76 | true , "0101ff" 77 | ]; 78 | 79 | case_eq "integer" ~pp:Ohex.pp ~cmp:String.equal Asn.S.integer [ 80 | 81 | "\x00", "0201 00"; 82 | "\x7f", "0201 7f"; 83 | "\x80", "0201 80"; 84 | "\xff", "0201 ff"; 85 | 86 | "\x00\x80", "0202 0080"; 87 | "\x7f\xff", "0202 7fff"; 88 | "\x80\x00", "0202 8000"; 89 | "\xff\x7f", "0202 ff7f"; 90 | 91 | "\x00\x80\x00", "0203 008000"; 92 | "\x00\xff\xff", "0203 00ffff"; 93 | "\x80\x00\x00", "0203 800000"; 94 | "\xff\x7f\xff", "0203 ff7fff"; 95 | 96 | "\x00\x80\x00\x00", "0204 00800000"; 97 | "\x7f\xff\xff\xff", "0204 7fffffff"; 98 | "\x80\x00\x00\x00", "0204 80000000"; 99 | "\xff\x7f\xff\xff", "0204 ff7fffff"; 100 | 101 | "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", "020c 00800000 00000000 00000000"; 102 | "\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff", "020c 00ffffff ffffffff ffffffff"; 103 | "\x00\xff\xff\xff\x7f\xff\xff\xff\xff\xff\xff\xff", "020c 00ffffff 7fffffff ffffffff"; 104 | "\x00\xff\xff\xff\xff\xff\xff\xff\x7f\xff\xff\xff", "020c 00ffffff ffffffff 7fffffff"; 105 | "\x80\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff", "020c 80ffffff ffffffff ffffffff"; 106 | "\xff\x7f\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff", "020c ff7fffff ffffffff ffffffff"; 107 | ]; 108 | 109 | case_eq "unsigned_integer" ~pp:Ohex.pp ~cmp:String.equal Asn.S.unsigned_integer [ 110 | "", "0201 00"; 111 | "\x01", "0201 01"; 112 | "\x80", "0202 0080"; 113 | ]; 114 | 115 | case_eq "int" ~pp:Format.pp_print_int ~cmp:Int.equal Asn.S.int ([ 116 | 0, "020100"; 117 | 127, "02017F"; 118 | 128, "02020080"; 119 | 256, "02020100"; 120 | -128, "020180"; 121 | -129, "0202FF7F"; 122 | 1073741823 (* 0x3FFFFFFF *), "02043FFFFFFF"; 123 | -1073741824, "0204C0000000"; 124 | ] @ (if Sys.word_size = 64 then 125 | [ Int64.to_int 4294967295L, "020500FFFFFFFF"; 126 | Int64.to_int 4611686018427387903L, "02083FFFFFFFFFFFFFFF"; 127 | Int64.to_int (-4611686018427387904L), "0208C000000000000000"; 128 | ] 129 | else 130 | []) 131 | ); 132 | 133 | case_eq "null" Asn.S.null [ 134 | (), "0500"; 135 | (), "058100" 136 | ]; 137 | 138 | case_eq "singleton seq" 139 | Asn.S.(sequence (single @@ required bool)) 140 | [ true, "30030101ff"; 141 | true, "30800101ff0000" ; ]; 142 | 143 | case_eq "rename stack" 144 | Asn.S.(implicit 1 @@ implicit 2 @@ explicit 3 @@ implicit 4 @@ int) 145 | [ 42, "a18084012a0000"; 146 | 42, "a10384012a" ]; 147 | 148 | case_eq "sequence with implicits" 149 | Asn.S.(sequence3 150 | (required int) 151 | (required @@ implicit 1 bool) 152 | (required bool)) 153 | 154 | [ (42, false, true), "3009 02012a 810100 0101ff"; 155 | (42, false, true), "3080 02012a 810100 0101ff 0000" ]; 156 | 157 | case_eq "sequence with optional and explicit fields" 158 | Asn.S.(sequence3 159 | (required @@ implicit 1 int) 160 | (optional @@ explicit 2 bool) 161 | (optional @@ implicit 3 bool)) 162 | 163 | [ (255, Some true, Some false), 164 | "300c 810200ff a203 0101f0 830100" ; 165 | (255, Some true, Some false), 166 | "3080 810200ff a203 0101f0 830100 0000"; 167 | (255, Some true, Some false), 168 | "3080 810200ff a280 0101f0 0000 830100 0000" ]; 169 | 170 | case_eq "sequence with missing optional and choice fields" 171 | Asn.S.(sequence3 (required @@ choice2 bool int) 172 | (optional @@ choice2 bool int) 173 | (optional @@ explicit 0 174 | @@ choice2 int (implicit 1 int))) 175 | 176 | [ (`C1 true, None, None), "30030101ff" ; 177 | (`C1 false, Some (`C2 42), None), "3006 010100 02012a"; 178 | (`C1 true, None, Some (`C1 42)), "3008 0101ff a003 02012a" ; 179 | (`C2 (-2), Some (`C2 42), Some (`C2 42)), "300b 0201fe 02012a a003 81012a"; 180 | (`C2 (-3), None, Some (`C2 42)), "300a 0201fd a080 81012a0000"; 181 | (`C2 (-4), None, Some (`C1 42)), "3080 0201fc a080 02012a0000 0000" ]; 182 | 183 | case_eq "sequence with sequence" 184 | Asn.S.(sequence2 185 | (required @@ 186 | sequence2 187 | (optional @@ implicit 1 bool) 188 | (optional bool)) 189 | (required bool)) 190 | 191 | [ ((Some true, Some false), true), "300b 3006 8101ff 010100 0101ff"; 192 | ((None, Some false), true), "3008 3003 010100 0101ff"; 193 | ((Some true, None), true), "3008 3003 8101ff 0101ff" ; 194 | ((Some true, None), true), "3080 3080 8101ff 0000 0101ff 0000"; 195 | ((None, None), true), "3007308000000101ff"; 196 | ((None, None), true), "300530000101ff" ]; 197 | 198 | case_eq "sequence_of choice" 199 | Asn.S.(sequence2 200 | (required @@ 201 | sequence_of 202 | (choice2 bool (implicit 0 bool))) 203 | (required @@ bool)) 204 | 205 | [ ([`C2 true; `C2 false; `C1 true], true), 206 | "300e 3009 8001ff 800100 0101ff 0101ff"; 207 | ([`C2 true; `C2 false; `C1 true], true), 208 | "3080 3080 8001ff 800100 0101ff 0000 0101ff 0000" ]; 209 | 210 | case_eq "sets" 211 | Asn.S.(set4 (required @@ implicit 1 bool) 212 | (required @@ implicit 2 bool) 213 | (required @@ implicit 3 int ) 214 | (optional @@ implicit 4 int )) 215 | 216 | [ (true, false, 42, None), "3109 8101ff 820100 83012a"; 217 | (true, false, 42, Some (-1)), "310c 820100 8401ff 8101ff 83012a"; 218 | (true, false, 42, None), "3109 820100 83012a 8101ff"; 219 | (true, false, 42, Some 15), "310c 83012a 820100 8101ff 84010f"; 220 | (true, false, 42, None), "3180 820100 83012a 8101ff 0000"; 221 | (true, false, 42, Some 15), "3180 83012a 820100 8101ff 84010f 0000" ]; 222 | 223 | case_eq "set or seq" 224 | Asn.S.(choice2 (set2 (optional int ) (optional bool)) 225 | (sequence2 (optional int ) (optional bool))) 226 | 227 | [ (`C1 (None, Some true)), "3103 0101ff"; 228 | (`C1 (Some 42, None)), "3103 02012a"; 229 | (`C1 (Some 42, Some true)), "3106 0101ff 02012a"; 230 | (`C2 (None, Some true)), "3003 0101ff"; 231 | (`C2 (Some 42, None)), "3003 02012a"; 232 | (`C2 (Some 42, Some true)), "3006 02012a 0101ff" ]; 233 | 234 | case_eq 235 | "large tag" 236 | Asn.S.(implicit 6666666 bool) 237 | [ true , "9f8396f32a01ff"; 238 | false, "9f8396f32a0100"; 239 | ]; 240 | 241 | 242 | case_eq 243 | "recursive encoding" 244 | Asn.S.( 245 | fix @@ fun list -> 246 | map (function `C1 () -> [] | `C2 (x, xs) -> x::xs) 247 | (function [] -> `C1 () | x::xs -> `C2 (x, xs)) @@ 248 | choice2 null (sequence2 (required bool) (required list))) 249 | 250 | [ [], "0500" ; 251 | [true], "3005 0101ff 0500" ; 252 | [true; false; true], 253 | "300f 0101ff 300a 010100 3005 0101ff 0500"; 254 | [false; true; false], 255 | "3080 010100 3080 0101ff 3080 010100 0500 0000 0000 0000"; 256 | [false; true; false], 257 | "3080 010100 3080 0101ff 3080 010100 0500 0000 0000 0000" ]; 258 | 259 | case_eq "ia5 string" Asn.S.ia5_string 260 | 261 | [ "abc", "1603616263"; 262 | "abcd", "360a 160161 160162 16026364"; 263 | "abcd", "3680 160161 160162 16026364 0000"; 264 | "abcd", "3680 3606 160161 160162 16026364 0000"; 265 | "test1@rsa.com", "160d7465737431407273 612e636f6d"; 266 | "test1@rsa.com", "16810d 7465737431407273612e636f6d" ; 267 | "test1@rsa.com", "3613 16057465737431 160140 16077273612e636f6d" ]; 268 | 269 | case_eq "bit string" Asn.S.bit_string 270 | 271 | ( let example = 272 | [| false; true; true; false; true; true; true; false; false; 273 | true; false; true; true; true; false; true; true; true |] in 274 | 275 | [ example, "0304066e5dc0"; 276 | example, "0304066e5de0"; 277 | example, "038104066e5dc0"; 278 | example, "2309 0303006e5d 030206c0" ] ); 279 | 280 | case_eq "bit flags" 281 | (Asn.S.bit_string_flags [(2, `A); (4, `C); (8, `B); (10, `E); (12, `D)]) 282 | 283 | [ [`A; `B; `C], "030304ffdf"; 284 | [`A; `B; `C; `D], "030303ffdf"; ]; 285 | 286 | ( let open Asn.OID in 287 | 288 | let rsa = base 1 2 <| 840 <| 113549 in 289 | 290 | case_eq "oid" Asn.S.oid [ 291 | 292 | ( rsa ), "06062a864886f70d"; 293 | ( rsa <| 1 <| 7 <| 2 ), "06092a864886f70d010702"; 294 | ( rsa <| 1 <| 7 <| 1 ), "06092a864886f70d010701"; 295 | ( base 1 3 <| 14 <| 3 <| 2 <| 26 ), "06052b0e03021a"; 296 | ( base 2 5 <| 4 <| 3 ), "0603550403"; 297 | ( base 2 5 <| 29 <| 15 ), "0603551d0f"; 298 | ( base 1 2 <| 99999 ), "06042a868d1f"; 299 | ] ); 300 | 301 | case_eq "octets" Asn.S.octet_string [ 302 | Ohex.decode "0123456789abcdef", "0408 0123456789abcdef" ; 303 | Ohex.decode "0123456789abcdef", "048108 0123456789abcdef"; 304 | Ohex.decode "0123456789abcdef", "240c 040401234567 040489abcdef" ]; 305 | 306 | case_eq "utc time" ~cmp:Ptime.equal ~pp:Ptime.pp Asn.S.utc_time [ 307 | 308 | ( time ((1991, 5, 6), ((23, 45, 40), 0)), 309 | "170d393130353036 3233343534305a" ) ; 310 | ( time ((1991, 5, 6), ((16, 45, 40), -7 * 3600)), 311 | "1711393130353036 313634353430 2D30373030" ); 312 | ( time ((1991, 5, 6), ((16, 45, 0), 9000)), 313 | "170f393130353036 31363435 2b30323330"); 314 | ( time ((1950, 5, 6), ((23, 45, 40), 0)), 315 | "170d353030353036 3233343534305a" ) ; 316 | 317 | ] ; 318 | 319 | case_eq "generalized time" ~cmp:Ptime.equal ~pp:(Ptime.pp_human ~frac_s:3 ()) Asn.S.generalized_time [ 320 | 321 | ( time ((1991, 5, 6), ((16, 0, 0), 0)), 322 | "180a3139393130353036 3136"); 323 | ( time ((1991, 5, 6), ((16, 0, 0), 0)), 324 | "180b3139393130353036 31365a "); 325 | ( time ((1991, 5, 6), ((16, 0, 0), 15 * 60)), 326 | "180f3139393130353036 3136 2b30303135"); 327 | ( time ((1991, 5, 6), ((16, 45, 0), 15 * 60)), 328 | "18113139393130353036 31363435 2b30303135"); 329 | ( time ((1991, 5, 6), ((16, 45, 40), -15 * 60)), 330 | "18133139393130353036 313634353430 2d30303135"); 331 | ( time ~frac:001 ((1991, 5, 6), ((16, 45, 40), -(10 * 3600 + 10 * 60))), 332 | "18173139393130353036 313634353430 2e303031 2d31303130"); 333 | ( Ptime.min, 334 | "18173030303030313031 303030303030 2e303030 2b30303030"); 335 | ( Ptime.(truncate ~frac_s:3 max), 336 | "18173939393931323331 323335393539 2e393939 2b30303030"); 337 | ( time ~frac:766 ((0452, 05, 15), ((00, 30, 56), 0)), 338 | "18133034353230353135 303033303536 2e3736365a"); 339 | ( time ~frac:234 ((0452, 05, 15), ((00, 30, 56), 0)), 340 | "18133034353230353135 303033303536 2e3233345a"); 341 | ] ; 342 | 343 | ] 344 | 345 | let anticases = [ 346 | 347 | (* thx @alpha-60 *) 348 | case "tag overflow" Asn.S.bool 349 | [ "1f a080 8080 8080 8080 8001 01ff" ]; 350 | 351 | case "leading zero" Asn.S.(implicit 127 bool) 352 | [ "9f807f01ff" ]; 353 | 354 | case "length overflow" Asn.S.bool 355 | [ "01 88 8000000000000001 ff" ] ; 356 | 357 | case "oid overflow" Asn.S.oid 358 | [ "06 0b 2a bfffffffffffffffff7f" ] ; 359 | 360 | case "empty integer" Asn.S.integer [ "0200" ]; 361 | 362 | case "redundant int form" Asn.S.integer [ 363 | "02020000"; "0202007f"; "0202ff80"; "0202ffff"; 364 | "0203000000"; "0203007fff"; "0203ff8000"; "0203ffffff"; 365 | ]; 366 | 367 | case "redundant oid form" Asn.S.oid 368 | [ "06028001"; "06032a8001" ]; 369 | 370 | case "length overflow" Asn.S.integer 371 | [ "02890100000000000000012a" ]; 372 | 373 | case "silly bit strings" Asn.S.bit_string 374 | [ "0300"; "030101"; "030208ff" ]; 375 | 376 | case "null with indefinite length" Asn.S.null 377 | [ "0580"; "058000"; "05800000" ]; 378 | 379 | case "32 bit length overflow" 380 | Asn.S.(sequence2 (required integer) (required integer)) 381 | [ "30850100000006020180020180" ]; 382 | 383 | ] @ (if Sys.word_size = 32 then 384 | [ case "int overflow" Asn.S.int 385 | [ "02047FFFFFFF" ; "020440000000" ; 386 | "02050080000000" ; "0204BFFFFFFF" ] ] 387 | else 388 | [ case "int overflow" Asn.S.int 389 | [ "02087FFFFFFFFFFFFFFF" ; "02084000000000000000" ; 390 | "0209008000000000000000" ; "0208BFFFFFFFFFFFFFFF" ] ]) 391 | 392 | 393 | let der_anticases = [ 394 | case "constructed string 1" Asn.S.octet_string 395 | [ "2400"; "24 06 04 04 46 55 43 4b" ]; 396 | 397 | case "constructed string 2" Asn.S.utf8_string 398 | [ "2c00"; "2c060c044655434b" ]; 399 | 400 | case "expanded length" Asn.S.integer 401 | [ "0281012a" ]; 402 | 403 | case "redundant length" Asn.S.octet_string 404 | [ "048200ff" ^ 405 | Format.asprintf "%a" Ohex.pp (String.init 0xff (fun _ -> '\xaa')) ]; 406 | ] 407 | 408 | let certs = List.map (fun s -> case "cert" X509.certificate [s]) X509.examples 409 | 410 | let () = Alcotest.run ~and_exit:false "BER" [ 411 | accepts_eq "value samples" Asn.ber cases; 412 | rejects "- BER antisamples" Asn.ber anticases; 413 | accepts "+ DER antisamples" Asn.ber der_anticases; 414 | accepts "certs" Asn.ber certs; 415 | inverts1 "inv" Asn.ber cases; 416 | (* invert certs *) 417 | ] 418 | 419 | let () = Alcotest.run "DER" [ 420 | (* accepts_eq "value samples" Asn.der cases; *) 421 | rejects "- BER antisamples" Asn.der anticases; 422 | rejects "- DER antisamples" Asn.der der_anticases; 423 | accepts "certs" Asn.der certs; 424 | inverts1 "inv" Asn.der cases; 425 | (* invert certs *) 426 | (* injectivity *) 427 | ] 428 | -------------------------------------------------------------------------------- /src/asn_ber_der.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2014-2017 David Kaloper Meršinjak. All rights reserved. 2 | See LICENSE.md. *) 3 | 4 | open Asn_core 5 | 6 | module Prim = Asn_prim 7 | module Writer = Asn_writer 8 | module Int64 = Prim.Int64 9 | 10 | 11 | let (@?) oa a = match oa with Some x -> x | None -> a 12 | 13 | module Seq = struct 14 | 15 | type 'r f = { f : 'a. 'a -> 'a asn -> 'r -> 'r } 16 | 17 | let rec fold_with_value : type a. 'r f -> 'r -> a -> a sequence -> 'r 18 | = fun f r a -> function 19 | | Last (Required (_, asn)) -> f.f a asn r 20 | | Last (Optional (_, asn)) -> 21 | ( match a with None -> r | Some a' -> f.f a' asn r ) 22 | | Pair (Required (_, asn), asns) -> 23 | let (a1, a2) = a in f.f a1 asn (fold_with_value f r a2 asns) 24 | | Pair (Optional (_, asn), asns) -> 25 | match a with 26 | | (None , a2) -> fold_with_value f r a2 asns 27 | | (Some a1, a2) -> f.f a1 asn (fold_with_value f r a2 asns) 28 | end 29 | 30 | module R = struct 31 | 32 | module G = Generic 33 | 34 | type config = { strict : bool } 35 | 36 | type coding = 37 | | Primitive of int 38 | | Constructed of int 39 | | Constructed_indefinite 40 | 41 | module Header = struct 42 | 43 | let error cs fmt = 44 | parse_error ("Header: at %a: " ^^ fmt) pp_octets cs 45 | 46 | let ck_redundant cs cfg (n : int) limit = 47 | if cfg.strict && n < limit then error cs "redundant form" 48 | 49 | let big_tag ~off cs = 50 | let rec go acc = function 51 | | 8 -> error cs "big tag: too long" 52 | | i -> 53 | let b = String.get_uint8 cs (off + i) in 54 | let x = Int64.of_int (b land 0x7f) in 55 | match (Int64.(acc lsl 7 + x), b land 0x80) with 56 | | (0L, _) -> error cs "big tag: leading 0" 57 | | (acc, 0) -> 58 | ( match Int64.to_nat_checked acc with 59 | | Some x -> (x, succ i) 60 | | None -> error cs "big tag: overflow: %Li" acc) 61 | | (acc, _) -> go acc (succ i) in 62 | go 0L 0 63 | 64 | let big_len ~off cfg cs = function 65 | | 0 -> error cs "empty length" 66 | | n -> 67 | let rec f cs i = function 68 | | 0 -> 0L 69 | | n -> match String.get_uint8 cs (off + i) with 70 | | 0 when cfg.strict -> error cs "redundant length" 71 | | 0 -> f cs (i + 1) (n - 1) 72 | | _ when n > 8 -> error cs "length overflow" 73 | | x -> g (Int64.of_int x) cs (i + 1) (n - 1) 74 | and g acc cs i = function 75 | | 0 -> acc 76 | | n -> 77 | let v = String.get_uint8 cs (off + i) in 78 | let acc = Int64.(acc lsl 8 + of_int v) in 79 | g acc cs (i + 1) (n - 1) 80 | in 81 | match f cs 0 n |> Int64.to_nat_checked with 82 | | Some x -> x 83 | | None -> error cs "length overflow" 84 | 85 | let parse cfg cs off = 86 | let t0 = String.get_uint8 cs off in 87 | let tag_v, off_len = 88 | match t0 land 0x1f with 89 | | 0x1f -> 90 | let (n, i) = big_tag ~off:(off + 1) cs in 91 | ck_redundant cs cfg n 0x1f; 92 | n, i + 1 93 | | x -> x, 1 94 | in 95 | let l0 = String.get_uint8 cs (off + off_len) in 96 | let lbody = l0 land 0x7f in 97 | let len, off_end = 98 | if l0 <= 0x80 then 99 | lbody, off_len + 1 100 | else 101 | let n = big_len ~off:(off + off_len + 1) cfg cs lbody in 102 | ck_redundant cs cfg n 0x7f; 103 | n, off_len + 1 + lbody 104 | in 105 | let tag = match t0 land 0xc0 with 106 | | 0x00 -> Tag.Universal tag_v 107 | | 0x40 -> Tag.Application tag_v 108 | | 0x80 -> Tag.Context_specific tag_v 109 | | _ -> Tag.Private tag_v 110 | and coding = 111 | (* according to layman's guide to a subset of ASN.1, BER, and DER, there 112 | are three possibilities in BER (DER restricts this further): 113 | - (a) primitive + definitive length 114 | - (b) constructed + definitive length 115 | - (c) constructed + indefinite length *) 116 | match t0 land 0x20, l0 with 117 | | 0, 0x80 -> error cs "primitive and indefinite length" 118 | | 0, _ -> Primitive len 119 | | _, 0x80 -> Constructed_indefinite 120 | | _ -> Constructed len 121 | in 122 | tag, off + off_end, coding 123 | end 124 | 125 | module Gen = struct 126 | let eof1 off cs = String.length cs - off = 0 127 | and eof2 off cs = String.get_uint16_be cs off = 0 128 | 129 | let split_off cs off n = 130 | let k = off + n in 131 | String.sub cs off n, k 132 | 133 | let rec children cfg eof acc cs off = 134 | if eof off cs then 135 | List.rev acc, off 136 | else 137 | let g, off' = node cfg cs off in 138 | children cfg eof (g::acc) cs off' 139 | 140 | and node cfg cs off = 141 | let (tag, off, coding) = Header.parse cfg cs off in 142 | match coding with 143 | | Primitive n -> 144 | let hd, off = split_off cs off n in 145 | G.Prim (tag, hd), off 146 | | Constructed n -> 147 | let hd, off = split_off cs off n in 148 | let gs, _ = children cfg eof1 [] hd 0 in 149 | G.Cons (tag, gs), off 150 | | Constructed_indefinite when cfg.strict -> 151 | parse_error "Constructed indefinite form" 152 | | Constructed_indefinite -> 153 | let gs, off = children cfg eof2 [] cs off in 154 | G.Cons (tag, gs), off + 2 155 | 156 | let parse cfg cs = 157 | try node cfg cs 0 with Invalid_argument msg -> 158 | parse_error "Unexpected EOF (msg %s): %a" msg pp_octets cs 159 | end 160 | 161 | 162 | module TM = Map.Make (Tag) 163 | 164 | module Cache = Asn_cache.Make ( struct 165 | type 'a k = 'a asn endo 166 | type 'a v = G.t -> 'a 167 | let mapv = (&.) 168 | end ) 169 | 170 | let err_type ?(form=`Both) t g = 171 | parse_error "Type mismatch: expected: (%a %a) got: %a" 172 | G.pp_form_name form Tag.pp t G.pp_tag g 173 | 174 | let primitive t f = function 175 | | G.Prim (t1, bs) when Tag.equal t t1 -> f bs 176 | | g -> err_type ~form:`Prim t g 177 | 178 | let constructed t f = function 179 | | G.Cons (t1, gs) when Tag.equal t t1 -> f gs 180 | | g -> err_type ~form:`Cons t g 181 | 182 | let string_like (type a) c t (module P : Prim.Prim_s with type t = a) = 183 | let rec p = function 184 | | G.Prim (t1, bs) when Tag.equal t t1 -> P.of_octets bs 185 | | G.Cons (t1, gs) when Tag.equal t t1 && not c.strict -> 186 | P.concat (List.map p gs) 187 | | g -> err_type t g in 188 | p 189 | 190 | let c_prim : type a. config -> tag -> a prim -> G.t -> a = fun c tag -> function 191 | | Bool -> primitive tag Prim.Boolean.of_octets 192 | | Int -> primitive tag Prim.Integer.of_octets 193 | | Bits -> string_like c tag (module Prim.Bits) 194 | | Octets -> string_like c tag (module Prim.Octets) 195 | | Null -> primitive tag Prim.Null.of_octets 196 | | OID -> primitive tag Prim.OID.of_octets 197 | | CharString -> string_like c tag (module Prim.Gen_string) 198 | 199 | let peek asn = 200 | match tag_set asn with 201 | | [tag] -> fun g -> Tag.equal (G.tag g) tag 202 | | tags -> fun g -> 203 | let tag = G.tag g in List.exists (fun t -> Tag.equal t tag) tags 204 | 205 | type opt = Cache.t * config 206 | 207 | let rec c_asn : type a. a asn -> opt:opt -> G.t -> a = fun asn ~opt -> 208 | 209 | let rec go : type a. ?t:tag -> a asn -> G.t -> a = fun ?t -> function 210 | | Iso (f, _, _, a) -> f &. go ?t a 211 | | Fix (fa, var) as fix -> 212 | let p = lazy (go ?t (fa fix)) in 213 | Cache.intern (fst opt) var fa @@ fun g -> Lazy.force p g 214 | | Sequence s -> constructed (t @? seq_tag) (c_seq s ~opt) 215 | | Sequence_of a -> constructed (t @? seq_tag) (List.map (c_asn a ~opt)) 216 | | Set s -> constructed (t @? set_tag) (c_set s ~opt) 217 | | Set_of a -> constructed (t @? set_tag) (List.map (c_asn a ~opt)) 218 | | Implicit (t0, a) -> go ~t:(t @? t0) a 219 | | Explicit (t0, a) -> constructed (t @? t0) (c_explicit a ~opt) 220 | | Choice (a1, a2) -> 221 | let (p1, p2) = (c_asn a1 ~opt, c_asn a2 ~opt) 222 | and accepts1 = peek a1 in 223 | fun g -> if accepts1 g then L (p1 g) else R (p2 g) 224 | | Prim p -> c_prim (snd opt) (t @? tag_of_p p) p in 225 | 226 | go asn 227 | 228 | and c_explicit : type a. a asn -> opt:opt -> G.t list -> a = fun a ~opt -> 229 | 230 | let p = c_asn a ~opt in function 231 | | [g] -> p g 232 | | gs -> parse_error "EXPLICIT: sequence: %a" (pp_dump_list G.pp_tag) gs 233 | 234 | and c_seq : type a. a sequence -> opt:opt -> G.t list -> a = fun s ~opt -> 235 | 236 | let rec seq : type a. a sequence -> G.t list -> a = function 237 | | Pair (e, s) -> 238 | let (p1, p2) = (element e, c_seq s ~opt) in 239 | fun gs -> let (r, gs') = p1 gs in (r, p2 gs') 240 | | Last e -> 241 | let p = element e in fun gs -> 242 | match p gs with (a, []) -> a | (_, gs) -> 243 | parse_error "SEQUENCE: trailing: %a" (pp_dump_list G.pp_tag) gs 244 | 245 | and element : type a. a element -> G.t list -> a * G.t list = function 246 | | Required (lbl, a) -> 247 | let p = c_asn a ~opt in (function 248 | | g::gs -> (p g, gs) 249 | | [] -> parse_error "SEQUENCE: missing required: %s" (label lbl)) 250 | | Optional (_, a) -> 251 | let (p, accepts) = (c_asn a ~opt, peek a) in 252 | function | g::gs when accepts g -> (Some (p g), gs) 253 | | gs -> (None, gs) 254 | in seq s 255 | 256 | and c_set : type a. a sequence -> opt:opt -> G.t list -> a = fun s ~opt -> 257 | 258 | let module P = struct 259 | 260 | module C = Asn_core 261 | 262 | type 'a or_missing = Found of 'a | Miss of string option 263 | 264 | type _ element = 265 | | Required : 'a or_missing -> 'a element 266 | | Optional : 'a or_missing -> 'a option element 267 | 268 | type _ sequence = 269 | | Last : 'a element -> 'a sequence 270 | | Pair : 'a element * 'b sequence -> ('a * 'b) sequence 271 | 272 | let rec of_sequence : type a. a C.sequence -> a sequence = function 273 | | C.Last (C.Required (lbl, _)) -> Last (Required (Miss lbl)) 274 | | C.Last (C.Optional (lbl, _)) -> Last (Optional (Miss lbl)) 275 | | C.Pair (C.Required (lbl, _), t) -> Pair (Required (Miss lbl), of_sequence t) 276 | | C.Pair (C.Optional (lbl, _), t) -> Pair (Optional (Miss lbl), of_sequence t) 277 | 278 | let to_tuple = 279 | let rec element : type a. a element -> a = function 280 | | Required (Miss lbl) -> parse_error "SET: missing required: %s" (label lbl) 281 | | Required (Found a ) -> a 282 | | Optional (Miss _ ) -> None 283 | | Optional (Found a ) -> Some a 284 | and seq : type a. a sequence -> a = function 285 | | Last e -> element e 286 | | Pair (e, tl) -> (element e, seq tl) in 287 | seq 288 | 289 | let found_r a = Required (Found a) 290 | and found_o a = Optional (Found a) 291 | end in 292 | 293 | let put r = function P.Pair (_, tl) -> P.Pair (r, tl) | _ -> assert false 294 | and wrap f = function P.Pair (e, tl) -> P.Pair (e, f tl) | _ -> assert false in 295 | 296 | let rec element : type a. a element -> tags * (G.t -> a P.element) = function 297 | | Required (_, a) -> (tag_set a, P.found_r &. c_asn a ~opt) 298 | | Optional (_, a) -> (tag_set a, P.found_o &. c_asn a ~opt) 299 | 300 | and seq : 301 | type a b. (a P.sequence endo -> b P.sequence endo) 302 | -> a sequence -> (tags * (G.t -> b P.sequence endo)) list = 303 | fun k -> function 304 | | Last e -> 305 | let (tags, p) = element e in 306 | [(tags, (fun e' -> k (fun _ -> P.Last e')) &. p)] 307 | | Pair (e, tl) -> 308 | let (tags, p) = element e in 309 | (tags, k &. put &. p) :: seq (k &. wrap) tl in 310 | 311 | let parsers = 312 | List.fold_right (fun (tags, p) -> 313 | List.fold_right (fun tag -> TM.add tag p) tags) 314 | (seq id s) TM.empty in 315 | 316 | let rec step acc ps = function 317 | | [] -> P.to_tuple acc 318 | | g::gs -> 319 | let p = 320 | try TM.find (G.tag g) ps 321 | with Not_found -> parse_error "SET: unexpected: %a" G.pp_tag g in 322 | step (p g acc) (TM.remove (G.tag g) ps) gs in 323 | 324 | step (P.of_sequence s) parsers 325 | 326 | let (compile_ber, compile_der) = 327 | let compile cfg asn = 328 | let p = c_asn asn ~opt:(Cache.create (), cfg) in 329 | fun cs -> 330 | let g, off = Gen.parse cfg cs in 331 | let remaining = 332 | if String.length cs - off = 0 then 333 | "" 334 | else 335 | String.sub cs off (String.length cs - off) 336 | in 337 | p g, remaining 338 | in 339 | (fun asn -> compile { strict = false } asn), 340 | (fun asn -> compile { strict = true } asn) 341 | 342 | end 343 | 344 | module W = struct 345 | 346 | let (<+>) = Writer.(<+>) 347 | 348 | let e_big_tag tag = 349 | let cons x = function [] -> [x] | xs -> (x lor 0x80)::xs in 350 | let rec loop acc = function 351 | | 0 -> acc 352 | | n -> loop (cons (n land 0x7f) acc) (n lsr 7) in 353 | loop [] tag 354 | 355 | let e_big_length length = 356 | let rec loop acc = function 357 | | 0 -> acc 358 | | n -> loop (n land 0xff :: acc) (n lsr 8) in 359 | loop [] length 360 | 361 | let e_header tag mode len = 362 | 363 | let (klass, tagn) = 364 | let open Tag in 365 | match tag with 366 | | Universal n -> (0x00, n) 367 | | Application n -> (0x40, n) 368 | | Context_specific n -> (0x80, n) 369 | | Private n -> (0xc0, n) in 370 | 371 | let constructed = match mode with 372 | | `Primitive -> 0x00 373 | | `Constructed -> 0x20 in 374 | 375 | ( if tagn < 0x1f then 376 | Writer.of_byte (klass lor constructed lor tagn) 377 | else 378 | Writer.of_byte (klass lor constructed lor 0x1f) <+> 379 | Writer.of_list (e_big_tag tagn) ) 380 | <+> 381 | ( if len <= 0x7f then 382 | Writer.of_byte len 383 | else 384 | let body = Writer.of_list (e_big_length len) in 385 | Writer.of_byte (0x80 lor Writer.len body) <+> body ) 386 | 387 | 388 | type conf = { der : bool } 389 | 390 | let e_constructed tag body = 391 | e_header tag `Constructed (Writer.len body) <+> body 392 | 393 | let e_primitive tag body = 394 | e_header tag `Primitive (Writer.len body) <+> body 395 | 396 | let assert_length ?constr f a = match constr with 397 | | None -> () 398 | | Some n -> 399 | let n' = f a in 400 | if n <> n' then invalid_arg "Encode: length: expected %d, got %d" n n' 401 | 402 | let rec encode : type a. conf -> tag option -> a -> a asn -> Writer.t 403 | = fun conf tag a -> function 404 | 405 | | Iso (_, g, _, asn) -> encode conf tag (g a) asn 406 | 407 | | Fix (fa, _) as fix -> encode conf tag a (fa fix) 408 | 409 | | Sequence asns -> 410 | e_constructed (tag @? seq_tag) (e_seq conf a asns) 411 | 412 | | Sequence_of asn -> (* size/stack? *) 413 | e_constructed (tag @? seq_tag) @@ 414 | Writer.concat (List.map (fun e -> encode conf None e asn) a) 415 | 416 | | Set asns -> 417 | let h_sorted conf a asns = 418 | let fn = { Seq.f = fun a asn xs -> 419 | ( Asn_core.tag a asn, encode conf None a asn ) :: xs } in 420 | Writer.concat @@ 421 | List.map snd @@ 422 | List.sort (fun (t1, _) (t2, _) -> compare t1 t2) @@ 423 | Seq.fold_with_value fn [] a asns 424 | in 425 | e_constructed (tag @? set_tag) @@ 426 | if conf.der then h_sorted conf a asns else e_seq conf a asns 427 | 428 | | Set_of asn -> 429 | let ws = List.map (fun e -> encode conf None e asn) a in 430 | let body = 431 | Writer.concat @@ 432 | if conf.der then 433 | List.( ws |> map Writer.to_octets 434 | |> sort Writer.lex_compare 435 | |> map Writer.of_octets ) 436 | else ws 437 | in 438 | e_constructed (tag @? set_tag) body 439 | 440 | | Choice (asn1, asn2) -> 441 | ( match a with 442 | | L a' -> encode conf tag a' asn1 443 | | R b' -> encode conf tag b' asn2 ) 444 | 445 | | Implicit (t, asn) -> 446 | encode conf (Some (tag @? t)) a asn 447 | 448 | | Explicit (t, asn) -> 449 | e_constructed (tag @? t) (encode conf None a asn) 450 | 451 | | Prim p -> e_prim tag a p 452 | 453 | and e_seq : type a. conf -> a -> a sequence -> Writer.t = fun conf -> 454 | let f = { Seq.f = fun e asn w -> encode conf None e asn <+> w } in 455 | Seq.fold_with_value f Writer.empty 456 | 457 | and e_prim : type a. tag option -> a -> a prim -> Writer.t = fun tag a prim -> 458 | let encode = e_primitive 459 | (match tag with Some x -> x | None -> tag_of_p prim) in 460 | let encode_s (type a) ?length a (module P : Prim.Prim_s with type t = a) = 461 | assert_length ?constr:length P.length a; 462 | encode (P.to_writer a) in 463 | match prim with 464 | | Bool -> encode @@ Prim.Boolean.to_writer a 465 | | Int -> encode @@ Prim.Integer.to_writer a 466 | | Bits -> encode @@ Prim.Bits.to_writer a 467 | | Octets -> encode_s a (module Prim.Octets) 468 | | Null -> encode @@ Prim.Null.to_writer a 469 | | OID -> encode @@ Prim.OID.to_writer a 470 | | CharString -> encode @@ Prim.Gen_string.to_writer a 471 | 472 | 473 | let ber_to_writer asn a = encode { der = false } None a asn 474 | 475 | let der_to_writer asn a = encode { der = true } None a asn 476 | 477 | end 478 | --------------------------------------------------------------------------------