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