From f39e80a0b2ab7e7db89960d4bfb6ad7a665015ee Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 29 Jul 2020 18:27:12 +0200 Subject: [PATCH] Better GADT abstr. --- src-c/digestif.ml | 285 +++++++++++++++--------------------------- src-c/dune | 7 +- src-ocaml/digestif.ml | 285 +++++++++++++++--------------------------- src-ocaml/dune | 9 +- src/digestif.mli | 146 +++++++++------------- src/digestif_hash.ml | 59 --------- test/test.ml | 40 +++--- 7 files changed, 286 insertions(+), 545 deletions(-) delete mode 100644 src/digestif_hash.ml diff --git a/src-c/digestif.ml b/src-c/digestif.ml index 35ea5f9..c04c0fd 100644 --- a/src-c/digestif.ml +++ b/src-c/digestif.ml @@ -16,7 +16,6 @@ module Native = Digestif_native module By = Digestif_by module Bi = Digestif_bi module Eq = Digestif_eq -module Hash = Digestif_hash module Conv = Digestif_conv let failwith fmt = Format.ksprintf failwith fmt @@ -26,12 +25,8 @@ module type S = sig type ctx - type kind - type t - val kind : kind - val empty : ctx val init : unit -> ctx @@ -134,8 +129,6 @@ end module type Foreign = sig open Native - type kind - module Bigstring : sig val init : ctx -> unit @@ -156,13 +149,9 @@ module type Foreign = sig end module type Desc = sig - type kind - val block_size : int val digest_size : int - - val kind : kind end module Unsafe (F : Foreign) (D : Desc) = struct @@ -219,14 +208,10 @@ module Core (F : Foreign) (D : Desc) = struct type ctx = Native.ctx - type kind = F.kind - include Unsafe (F) (D) include Conv.Make (D) include Eq.Make (D) - let kind = D.kind - let get t = let t = Native.dup t in unsafe_get t |> By.unsafe_to_string @@ -364,8 +349,6 @@ end module type Foreign_BLAKE2 = sig open Native - type kind - module Bigstring : sig val update : ctx -> ba -> int -> int -> unit @@ -398,8 +381,6 @@ module Make_BLAKE2 (F : Foreign_BLAKE2) (D : Desc) = struct include Make (struct - type kind = F.kind - module Bigstring = struct let init ctx = F.Bigstring.with_outlen_and_key ctx D.digest_size Bi.empty 0 0 @@ -489,129 +470,85 @@ module Make_BLAKE2 (F : Foreign_BLAKE2) (D : Desc) = struct end end -module MD5 : S with type kind = [ `MD5 ] = +module MD5 : S = Make (Native.MD5) (struct let digest_size, block_size = (16, 64) - - type kind = [ `MD5 ] - - let kind = `MD5 end) -module SHA1 : S with type kind = [ `SHA1 ] = +module SHA1 : S = Make (Native.SHA1) (struct let digest_size, block_size = (20, 64) - - type kind = [ `SHA1 ] - - let kind = `SHA1 end) -module SHA224 : S with type kind = [ `SHA224 ] = +module SHA224 : S = Make (Native.SHA224) (struct let digest_size, block_size = (28, 64) - - type kind = [ `SHA224 ] - - let kind = `SHA224 end) -module SHA256 : S with type kind = [ `SHA256 ] = +module SHA256 : S = Make (Native.SHA256) (struct let digest_size, block_size = (32, 64) - - type kind = [ `SHA256 ] - - let kind = `SHA256 end) -module SHA384 : S with type kind = [ `SHA384 ] = +module SHA384 : S = Make (Native.SHA384) (struct let digest_size, block_size = (48, 128) - - type kind = [ `SHA384 ] - - let kind = `SHA384 end) -module SHA512 : S with type kind = [ `SHA512 ] = +module SHA512 : S = Make (Native.SHA512) (struct let digest_size, block_size = (64, 128) - - type kind = [ `SHA512 ] - - let kind = `SHA512 end) -module SHA3_224 : S with type kind = [ `SHA3_224 ] = +module SHA3_224 : S = Make (Native.SHA3_224) (struct let digest_size, block_size = (28, 144) - - type kind = [ `SHA3_224 ] - - let kind = `SHA3_224 end) -module SHA3_256 : S with type kind = [ `SHA3_256 ] = +module SHA3_256 : S = Make (Native.SHA3_256) (struct let digest_size, block_size = (32, 136) - - type kind = [ `SHA3_256 ] - - let kind = `SHA3_256 end) -module SHA3_384 : S with type kind = [ `SHA3_384 ] = +module SHA3_384 : S = Make (Native.SHA3_384) (struct let digest_size, block_size = (48, 104) - - type kind = [ `SHA3_384 ] - - let kind = `SHA3_384 end) -module SHA3_512 : S with type kind = [ `SHA3_512 ] = +module SHA3_512 : S = Make (Native.SHA3_512) (struct let digest_size, block_size = (64, 72) - - type kind = [ `SHA3_512 ] - - let kind = `SHA3_512 end) -module WHIRLPOOL : S with type kind = [ `WHIRLPOOL ] = +module WHIRLPOOL : S = Make (Native.WHIRLPOOL) (struct let digest_size, block_size = (64, 64) - - type kind = [ `WHIRLPOOL ] - - let kind = `WHIRLPOOL end) module BLAKE2B : sig - include S with type kind = [ `BLAKE2B ] + include S module Keyed : MAC with type t = t end = @@ -619,14 +556,10 @@ end = (Native.BLAKE2B) (struct let digest_size, block_size = (64, 128) - - type kind = [ `BLAKE2B ] - - let kind = `BLAKE2B end) module BLAKE2S : sig - include S with type kind = [ `BLAKE2S ] + include S module Keyed : MAC with type t = t end = @@ -634,62 +567,80 @@ end = (Native.BLAKE2S) (struct let digest_size, block_size = (32, 64) - - type kind = [ `BLAKE2S ] - - let kind = `BLAKE2S end) -module RMD160 : S with type kind = [ `RMD160 ] = +module RMD160 : S = Make (Native.RMD160) (struct let digest_size, block_size = (20, 64) - - type kind = [ `RMD160 ] - - let kind = `RMD160 end) module Make_BLAKE2B (D : sig val digest_size : int -end) : S with type kind = [ `BLAKE2B ] = struct +end) : S = struct include Make_BLAKE2 (Native.BLAKE2B) (struct let digest_size, block_size = (D.digest_size, 128) - - type kind = [ `BLAKE2B ] - - let kind = `BLAKE2B end) end module Make_BLAKE2S (D : sig val digest_size : int -end) : S with type kind = [ `BLAKE2S ] = struct +end) : S = struct include Make_BLAKE2 (Native.BLAKE2S) (struct let digest_size, block_size = (D.digest_size, 64) - - type kind = [ `BLAKE2S ] - - let kind = `BLAKE2S end) end -include Hash +type 'k hash = + | MD5 : MD5.t hash + | SHA1 : SHA1.t hash + | RMD160 : RMD160.t hash + | SHA224 : SHA224.t hash + | SHA256 : SHA256.t hash + | SHA384 : SHA384.t hash + | SHA512 : SHA512.t hash + | SHA3_224 : SHA3_224.t hash + | SHA3_256 : SHA3_256.t hash + | SHA3_384 : SHA3_384.t hash + | SHA3_512 : SHA3_512.t hash + | WHIRLPOOL : WHIRLPOOL.t hash + | BLAKE2B : BLAKE2B.t hash + | BLAKE2S : BLAKE2S.t hash + +let md5 = MD5 -type blake2b = (module S with type kind = [ `BLAKE2B ]) +let sha1 = SHA1 -type blake2s = (module S with type kind = [ `BLAKE2S ]) +let rmd160 = RMD160 -let module_of : type k. k hash -> (module S with type kind = k) = - fun hash -> - let b2b : (int, blake2b) Hashtbl.t = Hashtbl.create 13 in - let b2s : (int, blake2s) Hashtbl.t = Hashtbl.create 13 in - match hash with +let sha224 = SHA224 + +let sha256 = SHA256 + +let sha384 = SHA384 + +let sha512 = SHA512 + +let sha3_224 = SHA3_224 + +let sha3_256 = SHA3_256 + +let sha3_384 = SHA3_384 + +let sha3_512 = SHA3_512 + +let whirlpool = WHIRLPOOL + +let blake2b = BLAKE2B + +let blake2s = BLAKE2S + +let module_of : type k. k hash -> (module S with type t = k) = function | MD5 -> (module MD5) | SHA1 -> (module SHA1) | RMD160 -> (module RMD160) @@ -702,173 +653,141 @@ let module_of : type k. k hash -> (module S with type kind = k) = | SHA3_384 -> (module SHA3_384) | SHA3_512 -> (module SHA3_512) | WHIRLPOOL -> (module WHIRLPOOL) - | BLAKE2B digest_size -> ( - match Hashtbl.find b2b digest_size with - | exception Not_found -> - let m : (module S with type kind = [ `BLAKE2B ]) = - (module Make_BLAKE2B (struct - let digest_size = digest_size - end) : S - with type kind = [ `BLAKE2B ]) in - Hashtbl.replace b2b digest_size m ; - m - | m -> m) - | BLAKE2S digest_size -> - match Hashtbl.find b2s digest_size with - | exception Not_found -> - let m = - (module Make_BLAKE2S (struct - let digest_size = digest_size - end) : S - with type kind = [ `BLAKE2S ]) in - Hashtbl.replace b2s digest_size m ; - m - | m -> m - -type 'kind t = string + | BLAKE2B -> (module BLAKE2B) + | BLAKE2S -> (module BLAKE2S) + +type 'hash t = 'hash let digest_bytes : type k. k hash -> Bytes.t -> k t = fun hash buf -> let module H = (val module_of hash) in - (H.to_raw_string (H.digest_bytes buf) : H.kind t) + H.digest_bytes buf let digest_string : type k. k hash -> String.t -> k t = fun hash buf -> let module H = (val module_of hash) in - (H.to_raw_string (H.digest_string buf) : H.kind t) + H.digest_string buf let digest_bigstring : type k. k hash -> bigstring -> k t = fun hash buf -> let module H = (val module_of hash) in - (H.to_raw_string (H.digest_bigstring buf) : H.kind t) + H.digest_bigstring buf let digesti_bytes : type k. k hash -> Bytes.t iter -> k t = fun hash iter -> let module H = (val module_of hash) in - (H.to_raw_string (H.digesti_bytes iter) : H.kind t) + H.digesti_bytes iter let digesti_string : type k. k hash -> String.t iter -> k t = fun hash iter -> let module H = (val module_of hash) in - (H.to_raw_string (H.digesti_string iter) : H.kind t) + H.digesti_string iter let digesti_bigstring : type k. k hash -> bigstring iter -> k t = fun hash iter -> let module H = (val module_of hash) in - (H.to_raw_string (H.digesti_bigstring iter) : H.kind t) + H.digesti_bigstring iter let hmaci_bytes : type k. k hash -> key:string -> Bytes.t iter -> k t = fun hash ~key iter -> let module H = (val module_of hash) in - (H.to_raw_string (H.hmaci_bytes ~key iter) : H.kind t) + H.hmaci_bytes ~key iter let hmaci_string : type k. k hash -> key:string -> String.t iter -> k t = fun hash ~key iter -> let module H = (val module_of hash) in - (H.to_raw_string (H.hmaci_string ~key iter) : H.kind t) + H.hmaci_string ~key iter let hmaci_bigstring : type k. k hash -> key:string -> bigstring iter -> k t = fun hash ~key iter -> let module H = (val module_of hash) in - (H.to_raw_string (H.hmaci_bigstring ~key iter) : H.kind t) + H.hmaci_bigstring ~key iter (* XXX(dinosaure): unsafe part to avoid overhead. *) let unsafe_compare : type k. k hash -> k t -> k t -> int = fun hash a b -> let module H = (val module_of hash) in - let unsafe : 'k t -> H.t = H.of_raw_string in - H.unsafe_compare (unsafe a) (unsafe b) + H.unsafe_compare a b let equal : type k. k hash -> k t equal = fun hash a b -> let module H = (val module_of hash) in - let unsafe : 'k t -> H.t = H.of_raw_string in - H.equal (unsafe a) (unsafe b) + H.equal a b let pp : type k. k hash -> k t pp = fun hash ppf t -> let module H = (val module_of hash) in - let unsafe : 'k t -> H.t = H.of_raw_string in - H.pp ppf (unsafe t) + H.pp ppf t let consistent_of_hex : type k. k hash -> string -> k t = fun hash hex -> let module H = (val module_of hash) in - H.to_raw_string (H.consistent_of_hex hex) + H.consistent_of_hex hex let consistent_of_hex_opt : type k. k hash -> string -> k t option = fun hash hex -> let module H = (val module_of hash) in - match H.consistent_of_hex_opt hex with - | None -> None - | Some digest -> Some (H.to_raw_string digest) + H.consistent_of_hex_opt hex let of_hex : type k. k hash -> string -> k t = fun hash hex -> let module H = (val module_of hash) in - H.to_raw_string (H.of_hex hex) + H.of_hex hex let of_hex_opt : type k. k hash -> string -> k t option = fun hash hex -> let module H = (val module_of hash) in - match H.of_hex_opt hex with - | None -> None - | Some digest -> Some (H.to_raw_string digest) + H.of_hex_opt hex let to_hex : type k. k hash -> k t -> string = fun hash t -> let module H = (val module_of hash) in - let unsafe : 'k t -> H.t = H.of_raw_string in - H.to_hex (unsafe t) + H.to_hex t let of_raw_string : type k. k hash -> string -> k t = fun hash s -> let module H = (val module_of hash) in - let unsafe : H.t -> 'k t = H.to_raw_string in - unsafe (H.of_raw_string s) + H.of_raw_string s let of_raw_string_opt : type k. k hash -> string -> k t option = fun hash s -> let module H = (val module_of hash) in - let unsafe : H.t -> 'k t = H.to_raw_string in - match H.of_raw_string_opt s with - | None -> None - | Some digest -> Some (unsafe digest) + H.of_raw_string_opt s -let to_raw_string : type k. k hash -> k t -> string = fun _ t -> t +let to_raw_string : type k. k hash -> k t -> string = + fun hash t -> + let module H = (val module_of hash) in + H.to_raw_string t -let of_digest (type hash kind) - (module H : S with type t = hash and type kind = kind) (hash : H.t) : kind t - = - H.to_raw_string hash +let of_digest (type hash) (module H : S with type t = hash) (hash : H.t) : + hash t = + hash -let of_md5 hash = of_raw_string md5 (MD5.to_raw_string hash) +let of_md5 hash = hash -let of_sha1 hash = of_raw_string sha1 (SHA1.to_raw_string hash) +let of_sha1 hash = hash -let of_rmd160 hash = of_raw_string rmd160 (RMD160.to_raw_string hash) +let of_rmd160 hash = hash -let of_sha224 hash = of_raw_string sha224 (SHA224.to_raw_string hash) +let of_sha224 hash = hash -let of_sha256 hash = of_raw_string sha256 (SHA256.to_raw_string hash) +let of_sha256 hash = hash -let of_sha384 hash = of_raw_string sha384 (SHA384.to_raw_string hash) +let of_sha384 hash = hash -let of_sha512 hash = of_raw_string sha512 (SHA512.to_raw_string hash) +let of_sha512 hash = hash -let of_sha3_224 hash = of_raw_string sha3_224 (SHA3_224.to_raw_string hash) +let of_sha3_224 hash = hash -let of_sha3_256 hash = of_raw_string sha3_256 (SHA3_256.to_raw_string hash) +let of_sha3_256 hash = hash -let of_sha3_384 hash = of_raw_string sha3_384 (SHA3_384.to_raw_string hash) +let of_sha3_384 hash = hash -let of_sha3_512 hash = of_raw_string sha3_512 (SHA3_512.to_raw_string hash) +let of_sha3_512 hash = hash -let of_whirlpool hash = of_raw_string whirlpool (WHIRLPOOL.to_raw_string hash) +let of_whirlpool hash = hash -let of_blake2b hash = - of_raw_string (blake2b BLAKE2B.digest_size) (BLAKE2B.to_raw_string hash) +let of_blake2b hash = hash -let of_blake2s hash = - of_raw_string (blake2s BLAKE2S.digest_size) (BLAKE2S.to_raw_string hash) +let of_blake2s hash = hash diff --git a/src-c/dune b/src-c/dune index 3edfb93..5cb492f 100644 --- a/src-c/dune +++ b/src-c/dune @@ -3,8 +3,8 @@ (public_name digestif.c) (implements digestif) (libraries stdlib-shims bigarray-compat eqaf digestif.rakia) - (private_modules digestif_native digestif_hash digestif_eq digestif_conv - digestif_by digestif_bi) + (private_modules digestif_native digestif_eq digestif_conv digestif_by + digestif_bi) (flags (:standard -no-keep-locs))) @@ -19,6 +19,3 @@ (rule (copy# ../src/digestif_conv.ml digestif_conv.ml)) - -(rule - (copy# ../src/digestif_hash.ml digestif_hash.ml)) diff --git a/src-ocaml/digestif.ml b/src-ocaml/digestif.ml index f543f29..36f02a9 100644 --- a/src-ocaml/digestif.ml +++ b/src-ocaml/digestif.ml @@ -15,7 +15,6 @@ type 'a pp = Format.formatter -> 'a -> unit module By = Digestif_by module Bi = Digestif_bi module Eq = Digestif_eq -module Hash = Digestif_hash module Conv = Digestif_conv let failwith fmt = Format.ksprintf failwith fmt @@ -25,12 +24,8 @@ module type S = sig type ctx - type kind - type t - val kind : kind - val empty : ctx val init : unit -> ctx @@ -131,20 +126,14 @@ module type MAC = sig end module type Desc = sig - type kind - val digest_size : int val block_size : int - - val kind : kind end module type Hash = sig type ctx - type kind - val init : unit -> ctx val unsafe_feed_bytes : ctx -> By.t -> int -> int -> unit @@ -200,14 +189,10 @@ module Core (Hash : Hash) (D : Desc) = struct type ctx = Hash.ctx - type kind = Hash.kind - include Unsafe (Hash) (D) include Conv.Make (D) include Eq.Make (D) - let kind = D.kind - let get t = let t = Hash.dup t in unsafe_get t |> By.unsafe_to_string @@ -343,8 +328,6 @@ end module type Hash_BLAKE2 = sig type ctx - type kind - val with_outlen_and_bytes_key : int -> By.t -> int -> int -> ctx val unsafe_feed_bytes : ctx -> By.t -> int -> int -> unit @@ -369,8 +352,6 @@ module Make_BLAKE2 (H : Hash_BLAKE2) (D : Desc) = struct (struct type ctx = H.ctx - type kind = H.kind - let init () = H.with_outlen_and_bytes_key D.digest_size By.empty 0 0 @@ -446,129 +427,85 @@ module Make_BLAKE2 (H : Hash_BLAKE2) (D : Desc) = struct end end -module MD5 : S with type kind = [ `MD5 ] = +module MD5 : S = Make (Baijiu_md5.Unsafe) (struct let digest_size, block_size = (16, 64) - - type kind = [ `MD5 ] - - let kind = `MD5 end) -module SHA1 : S with type kind = [ `SHA1 ] = +module SHA1 : S = Make (Baijiu_sha1.Unsafe) (struct let digest_size, block_size = (20, 64) - - type kind = [ `SHA1 ] - - let kind = `SHA1 end) -module SHA224 : S with type kind = [ `SHA224 ] = +module SHA224 : S = Make (Baijiu_sha224.Unsafe) (struct let digest_size, block_size = (28, 64) - - type kind = [ `SHA224 ] - - let kind = `SHA224 end) -module SHA256 : S with type kind = [ `SHA256 ] = +module SHA256 : S = Make (Baijiu_sha256.Unsafe) (struct let digest_size, block_size = (32, 64) - - type kind = [ `SHA256 ] - - let kind = `SHA256 end) -module SHA384 : S with type kind = [ `SHA384 ] = +module SHA384 : S = Make (Baijiu_sha384.Unsafe) (struct let digest_size, block_size = (48, 128) - - type kind = [ `SHA384 ] - - let kind = `SHA384 end) -module SHA512 : S with type kind = [ `SHA512 ] = +module SHA512 : S = Make (Baijiu_sha512.Unsafe) (struct let digest_size, block_size = (64, 128) - - type kind = [ `SHA512 ] - - let kind = `SHA512 end) -module SHA3_224 : S with type kind = [ `SHA3_224 ] = +module SHA3_224 : S = Make (Baijiu_sha3_224.Unsafe) (struct let digest_size, block_size = (28, 144) - - type kind = [ `SHA3_224 ] - - let kind = `SHA3_224 end) -module SHA3_256 : S with type kind = [ `SHA3_256 ] = +module SHA3_256 : S = Make (Baijiu_sha3_256.Unsafe) (struct let digest_size, block_size = (32, 136) - - type kind = [ `SHA3_256 ] - - let kind = `SHA3_256 end) -module SHA3_384 : S with type kind = [ `SHA3_384 ] = +module SHA3_384 : S = Make (Baijiu_sha3_384.Unsafe) (struct let digest_size, block_size = (48, 104) - - type kind = [ `SHA3_384 ] - - let kind = `SHA3_384 end) -module SHA3_512 : S with type kind = [ `SHA3_512 ] = +module SHA3_512 : S = Make (Baijiu_sha3_512.Unsafe) (struct let digest_size, block_size = (64, 72) - - type kind = [ `SHA3_512 ] - - let kind = `SHA3_512 end) -module WHIRLPOOL : S with type kind = [ `WHIRLPOOL ] = +module WHIRLPOOL : S = Make (Baijiu_whirlpool.Unsafe) (struct let digest_size, block_size = (64, 64) - - type kind = [ `WHIRLPOOL ] - - let kind = `WHIRLPOOL end) module BLAKE2B : sig - include S with type kind = [ `BLAKE2B ] + include S module Keyed : MAC with type t = t end = @@ -576,14 +513,10 @@ end = (Baijiu_blake2b.Unsafe) (struct let digest_size, block_size = (64, 128) - - type kind = [ `BLAKE2B ] - - let kind = `BLAKE2B end) module BLAKE2S : sig - include S with type kind = [ `BLAKE2S ] + include S module Keyed : MAC with type t = t end = @@ -591,62 +524,80 @@ end = (Baijiu_blake2s.Unsafe) (struct let digest_size, block_size = (32, 64) - - type kind = [ `BLAKE2S ] - - let kind = `BLAKE2S end) -module RMD160 : S with type kind = [ `RMD160 ] = +module RMD160 : S = Make (Baijiu_rmd160.Unsafe) (struct let digest_size, block_size = (20, 64) - - type kind = [ `RMD160 ] - - let kind = `RMD160 end) module Make_BLAKE2B (D : sig val digest_size : int -end) : S with type kind = [ `BLAKE2B ] = struct +end) : S = struct include Make_BLAKE2 (Baijiu_blake2b.Unsafe) (struct let digest_size, block_size = (D.digest_size, 128) - - type kind = [ `BLAKE2B ] - - let kind = `BLAKE2B end) end module Make_BLAKE2S (D : sig val digest_size : int -end) : S with type kind = [ `BLAKE2S ] = struct +end) : S = struct include Make_BLAKE2 (Baijiu_blake2s.Unsafe) (struct let digest_size, block_size = (D.digest_size, 64) - - type kind = [ `BLAKE2S ] - - let kind = `BLAKE2S end) end -include Hash +type 'k hash = + | MD5 : MD5.t hash + | SHA1 : SHA1.t hash + | RMD160 : RMD160.t hash + | SHA224 : SHA224.t hash + | SHA256 : SHA256.t hash + | SHA384 : SHA384.t hash + | SHA512 : SHA512.t hash + | SHA3_224 : SHA3_224.t hash + | SHA3_256 : SHA3_256.t hash + | SHA3_384 : SHA3_384.t hash + | SHA3_512 : SHA3_512.t hash + | WHIRLPOOL : WHIRLPOOL.t hash + | BLAKE2B : BLAKE2B.t hash + | BLAKE2S : BLAKE2S.t hash + +let md5 = MD5 -type blake2b = (module S with type kind = [ `BLAKE2B ]) +let sha1 = SHA1 -type blake2s = (module S with type kind = [ `BLAKE2S ]) +let rmd160 = RMD160 -let module_of : type k. k hash -> (module S with type kind = k) = - fun hash -> - let b2b : (int, blake2b) Hashtbl.t = Hashtbl.create 13 in - let b2s : (int, blake2s) Hashtbl.t = Hashtbl.create 13 in - match hash with +let sha224 = SHA224 + +let sha256 = SHA256 + +let sha384 = SHA384 + +let sha512 = SHA512 + +let sha3_224 = SHA3_224 + +let sha3_256 = SHA3_256 + +let sha3_384 = SHA3_384 + +let sha3_512 = SHA3_512 + +let whirlpool = WHIRLPOOL + +let blake2b = BLAKE2B + +let blake2s = BLAKE2S + +let module_of : type k. k hash -> (module S with type t = k) = function | MD5 -> (module MD5) | SHA1 -> (module SHA1) | RMD160 -> (module RMD160) @@ -659,173 +610,141 @@ let module_of : type k. k hash -> (module S with type kind = k) = | SHA3_384 -> (module SHA3_384) | SHA3_512 -> (module SHA3_512) | WHIRLPOOL -> (module WHIRLPOOL) - | BLAKE2B digest_size -> ( - match Hashtbl.find b2b digest_size with - | exception Not_found -> - let m : (module S with type kind = [ `BLAKE2B ]) = - (module Make_BLAKE2B (struct - let digest_size = digest_size - end) : S - with type kind = [ `BLAKE2B ]) in - Hashtbl.replace b2b digest_size m ; - m - | m -> m) - | BLAKE2S digest_size -> - match Hashtbl.find b2s digest_size with - | exception Not_found -> - let m = - (module Make_BLAKE2S (struct - let digest_size = digest_size - end) : S - with type kind = [ `BLAKE2S ]) in - Hashtbl.replace b2s digest_size m ; - m - | m -> m - -type 'kind t = string + | BLAKE2B -> (module BLAKE2B) + | BLAKE2S -> (module BLAKE2S) + +type 'hash t = 'hash let digest_bytes : type k. k hash -> Bytes.t -> k t = fun hash buf -> let module H = (val module_of hash) in - (H.to_raw_string (H.digest_bytes buf) : H.kind t) + H.digest_bytes buf let digest_string : type k. k hash -> String.t -> k t = fun hash buf -> let module H = (val module_of hash) in - (H.to_raw_string (H.digest_string buf) : H.kind t) + H.digest_string buf let digest_bigstring : type k. k hash -> bigstring -> k t = fun hash buf -> let module H = (val module_of hash) in - (H.to_raw_string (H.digest_bigstring buf) : H.kind t) + H.digest_bigstring buf let digesti_bytes : type k. k hash -> Bytes.t iter -> k t = fun hash iter -> let module H = (val module_of hash) in - (H.to_raw_string (H.digesti_bytes iter) : H.kind t) + H.digesti_bytes iter let digesti_string : type k. k hash -> String.t iter -> k t = fun hash iter -> let module H = (val module_of hash) in - (H.to_raw_string (H.digesti_string iter) : H.kind t) + H.digesti_string iter let digesti_bigstring : type k. k hash -> bigstring iter -> k t = fun hash iter -> let module H = (val module_of hash) in - (H.to_raw_string (H.digesti_bigstring iter) : H.kind t) + H.digesti_bigstring iter let hmaci_bytes : type k. k hash -> key:string -> Bytes.t iter -> k t = fun hash ~key iter -> let module H = (val module_of hash) in - (H.to_raw_string (H.hmaci_bytes ~key iter) : H.kind t) + H.hmaci_bytes ~key iter let hmaci_string : type k. k hash -> key:string -> String.t iter -> k t = fun hash ~key iter -> let module H = (val module_of hash) in - (H.to_raw_string (H.hmaci_string ~key iter) : H.kind t) + H.hmaci_string ~key iter let hmaci_bigstring : type k. k hash -> key:string -> bigstring iter -> k t = fun hash ~key iter -> let module H = (val module_of hash) in - (H.to_raw_string (H.hmaci_bigstring ~key iter) : H.kind t) + H.hmaci_bigstring ~key iter (* XXX(dinosaure): unsafe part to avoid overhead. *) let unsafe_compare : type k. k hash -> k t -> k t -> int = fun hash a b -> let module H = (val module_of hash) in - let unsafe : 'k t -> H.t = H.of_raw_string in - H.unsafe_compare (unsafe a) (unsafe b) + H.unsafe_compare a b let equal : type k. k hash -> k t equal = fun hash a b -> let module H = (val module_of hash) in - let unsafe : 'k t -> H.t = H.of_raw_string in - H.equal (unsafe a) (unsafe b) + H.equal a b let pp : type k. k hash -> k t pp = fun hash ppf t -> let module H = (val module_of hash) in - let unsafe : 'k t -> H.t = H.of_raw_string in - H.pp ppf (unsafe t) + H.pp ppf t let of_hex : type k. k hash -> string -> k t = fun hash hex -> let module H = (val module_of hash) in - H.to_raw_string (H.of_hex hex) + H.of_hex hex let of_hex_opt : type k. k hash -> string -> k t option = fun hash hex -> let module H = (val module_of hash) in - match H.of_hex_opt hex with - | None -> None - | Some digest -> Some (H.to_raw_string digest) + H.of_hex_opt hex let consistent_of_hex : type k. k hash -> string -> k t = fun hash hex -> let module H = (val module_of hash) in - H.to_raw_string (H.consistent_of_hex hex) + H.consistent_of_hex hex let consistent_of_hex_opt : type k. k hash -> string -> k t option = fun hash hex -> let module H = (val module_of hash) in - match H.consistent_of_hex_opt hex with - | None -> None - | Some digest -> Some (H.to_raw_string digest) + H.consistent_of_hex_opt hex let to_hex : type k. k hash -> k t -> string = fun hash t -> let module H = (val module_of hash) in - let unsafe : 'k t -> H.t = H.of_raw_string in - H.to_hex (unsafe t) + H.to_hex t let of_raw_string : type k. k hash -> string -> k t = fun hash s -> let module H = (val module_of hash) in - let unsafe : H.t -> 'k t = H.to_raw_string in - unsafe (H.of_raw_string s) + H.of_raw_string s let of_raw_string_opt : type k. k hash -> string -> k t option = fun hash s -> let module H = (val module_of hash) in - let unsafe : H.t -> 'k t = H.to_raw_string in - match H.of_raw_string_opt s with - | None -> None - | Some digest -> Some (unsafe digest) + H.of_raw_string_opt s -let to_raw_string : type k. k hash -> k t -> string = fun _ t -> t +let to_raw_string : type k. k hash -> k t -> string = + fun hash t -> + let module H = (val module_of hash) in + H.to_raw_string t -let of_digest (type hash kind) - (module H : S with type t = hash and type kind = kind) (hash : H.t) : kind t - = - H.to_raw_string hash +let of_digest (type hash) (module H : S with type t = hash) (hash : H.t) : + hash t = + hash -let of_md5 hash = of_raw_string md5 (MD5.to_raw_string hash) +let of_md5 hash = hash -let of_sha1 hash = of_raw_string sha1 (SHA1.to_raw_string hash) +let of_sha1 hash = hash -let of_rmd160 hash = of_raw_string rmd160 (RMD160.to_raw_string hash) +let of_rmd160 hash = hash -let of_sha224 hash = of_raw_string sha224 (SHA224.to_raw_string hash) +let of_sha224 hash = hash -let of_sha256 hash = of_raw_string sha256 (SHA256.to_raw_string hash) +let of_sha256 hash = hash -let of_sha384 hash = of_raw_string sha384 (SHA384.to_raw_string hash) +let of_sha384 hash = hash -let of_sha512 hash = of_raw_string sha512 (SHA512.to_raw_string hash) +let of_sha512 hash = hash -let of_sha3_224 hash = of_raw_string sha3_224 (SHA3_224.to_raw_string hash) +let of_sha3_224 hash = hash -let of_sha3_256 hash = of_raw_string sha3_256 (SHA3_256.to_raw_string hash) +let of_sha3_256 hash = hash -let of_sha3_384 hash = of_raw_string sha3_384 (SHA3_384.to_raw_string hash) +let of_sha3_384 hash = hash -let of_sha3_512 hash = of_raw_string sha3_512 (SHA3_512.to_raw_string hash) +let of_sha3_512 hash = hash -let of_whirlpool hash = of_raw_string whirlpool (WHIRLPOOL.to_raw_string hash) +let of_whirlpool hash = hash -let of_blake2b hash = - of_raw_string (blake2b BLAKE2B.digest_size) (BLAKE2B.to_raw_string hash) +let of_blake2b hash = hash -let of_blake2s hash = - of_raw_string (blake2s BLAKE2S.digest_size) (BLAKE2S.to_raw_string hash) +let of_blake2s hash = hash diff --git a/src-ocaml/dune b/src-ocaml/dune index 79825be..b1733c1 100644 --- a/src-ocaml/dune +++ b/src-ocaml/dune @@ -3,9 +3,9 @@ (public_name digestif.ocaml) (implements digestif) (libraries stdlib-shims bigarray-compat eqaf) - (private_modules xor digestif_hash digestif_eq digestif_conv digestif_by - digestif_bi baijiu_whirlpool baijiu_sha1 baijiu_sha256 baijiu_sha384 - baijiu_sha224 baijiu_sha512 baijiu_sha3_224 baijiu_sha256 baijiu_sha3_384 + (private_modules xor digestif_eq digestif_conv digestif_by digestif_bi + baijiu_whirlpool baijiu_sha1 baijiu_sha256 baijiu_sha384 baijiu_sha224 + baijiu_sha512 baijiu_sha3_224 baijiu_sha256 baijiu_sha3_384 baijiu_sha3_512 baijiu_rmd160 baijiu_md5 baijiu_blake2s baijiu_blake2b) (flags (:standard -no-keep-locs))) @@ -21,6 +21,3 @@ (rule (copy# ../src/digestif_conv.ml digestif_conv.ml)) - -(rule - (copy# ../src/digestif_hash.ml digestif_hash.ml)) diff --git a/src/digestif.mli b/src/digestif.mli index 8996c0f..f56476f 100644 --- a/src/digestif.mli +++ b/src/digestif.mli @@ -24,13 +24,8 @@ module type S = sig type ctx - type kind - type t - val kind : kind - (** The kind of hash. *) - val empty : ctx (** An empty hash context. *) @@ -198,113 +193,97 @@ module type MAC = sig val macv_bigstring : key:string -> bigstring list -> t end -type kind = - [ `MD5 - | `SHA1 - | `RMD160 - | `SHA224 - | `SHA256 - | `SHA384 - | `SHA512 - | `SHA3_224 - | `SHA3_256 - | `SHA3_384 - | `SHA3_512 - | `WHIRLPOOL - | `BLAKE2B - | `BLAKE2S ] - -type 'k hash = - | MD5 : [ `MD5 ] hash - | SHA1 : [ `SHA1 ] hash - | RMD160 : [ `RMD160 ] hash - | SHA224 : [ `SHA224 ] hash - | SHA256 : [ `SHA256 ] hash - | SHA384 : [ `SHA384 ] hash - | SHA512 : [ `SHA512 ] hash - | SHA3_224 : [ `SHA3_224 ] hash - | SHA3_256 : [ `SHA3_256 ] hash - | SHA3_384 : [ `SHA3_384 ] hash - | SHA3_512 : [ `SHA3_512 ] hash - | WHIRLPOOL : [ `WHIRLPOOL ] hash - | BLAKE2B : int -> [ `BLAKE2B ] hash - | BLAKE2S : int -> [ `BLAKE2S ] hash +module MD5 : S -module MD5 : S with type kind = [ `MD5 ] +module SHA1 : S -module SHA1 : S with type kind = [ `SHA1 ] +module SHA224 : S -module SHA224 : S with type kind = [ `SHA224 ] +module SHA256 : S -module SHA256 : S with type kind = [ `SHA256 ] +module SHA384 : S -module SHA384 : S with type kind = [ `SHA384 ] +module SHA512 : S -module SHA512 : S with type kind = [ `SHA512 ] +module SHA3_224 : S -module SHA3_224 : S with type kind = [ `SHA3_224 ] +module SHA3_256 : S -module SHA3_256 : S with type kind = [ `SHA3_256 ] +module SHA3_384 : S -module SHA3_384 : S with type kind = [ `SHA3_384 ] +module SHA3_512 : S -module SHA3_512 : S with type kind = [ `SHA3_512 ] - -module WHIRLPOOL : S with type kind = [ `WHIRLPOOL ] +module WHIRLPOOL : S module BLAKE2B : sig - include S with type kind = [ `BLAKE2B ] + include S module Keyed : MAC with type t = t end module BLAKE2S : sig - include S with type kind = [ `BLAKE2S ] + include S module Keyed : MAC with type t = t end -module RMD160 : S with type kind = [ `RMD160 ] +module RMD160 : S module Make_BLAKE2B (D : sig val digest_size : int -end) : S with type kind = [ `BLAKE2B ] +end) : S module Make_BLAKE2S (D : sig val digest_size : int -end) : S with type kind = [ `BLAKE2S ] +end) : S + +type 'k hash = + | MD5 : MD5.t hash + | SHA1 : SHA1.t hash + | RMD160 : RMD160.t hash + | SHA224 : SHA224.t hash + | SHA256 : SHA256.t hash + | SHA384 : SHA384.t hash + | SHA512 : SHA512.t hash + | SHA3_224 : SHA3_224.t hash + | SHA3_256 : SHA3_256.t hash + | SHA3_384 : SHA3_384.t hash + | SHA3_512 : SHA3_512.t hash + | WHIRLPOOL : WHIRLPOOL.t hash + | BLAKE2B : BLAKE2B.t hash + | BLAKE2S : BLAKE2S.t hash -val md5 : [ `MD5 ] hash +val md5 : MD5.t hash -val sha1 : [ `SHA1 ] hash +val sha1 : SHA1.t hash -val rmd160 : [ `RMD160 ] hash +val rmd160 : RMD160.t hash -val sha224 : [ `SHA224 ] hash +val sha224 : SHA224.t hash -val sha256 : [ `SHA256 ] hash +val sha256 : SHA256.t hash -val sha384 : [ `SHA384 ] hash +val sha384 : SHA384.t hash -val sha512 : [ `SHA512 ] hash +val sha512 : SHA512.t hash -val sha3_224 : [ `SHA3_224 ] hash +val sha3_224 : SHA3_224.t hash -val sha3_256 : [ `SHA3_256 ] hash +val sha3_256 : SHA3_256.t hash -val sha3_384 : [ `SHA3_384 ] hash +val sha3_384 : SHA3_384.t hash -val sha3_512 : [ `SHA3_512 ] hash +val sha3_512 : SHA3_512.t hash -val whirlpool : [ `WHIRLPOOL ] hash +val whirlpool : WHIRLPOOL.t hash -val blake2b : int -> [ `BLAKE2B ] hash +val blake2b : BLAKE2B.t hash -val blake2s : int -> [ `BLAKE2S ] hash +val blake2s : BLAKE2S.t hash type 'kind t -val module_of : 'k hash -> (module S with type kind = 'k) +val module_of : 'k hash -> (module S with type t = 'k) val digest_bytes : 'k hash -> Bytes.t -> 'k t @@ -346,33 +325,32 @@ val of_raw_string_opt : 'k hash -> string -> 'k t option val to_raw_string : 'k hash -> 'k t -> string -val of_digest : - (module S with type t = 'hash and type kind = 'k) -> 'hash -> 'k t +val of_digest : (module S with type t = 'hash) -> 'hash -> 'hash t -val of_md5 : MD5.t -> [ `MD5 ] t +val of_md5 : MD5.t -> MD5.t t -val of_sha1 : SHA1.t -> [ `SHA1 ] t +val of_sha1 : SHA1.t -> SHA1.t t -val of_rmd160 : RMD160.t -> [ `RMD160 ] t +val of_rmd160 : RMD160.t -> RMD160.t t -val of_sha224 : SHA224.t -> [ `SHA224 ] t +val of_sha224 : SHA224.t -> SHA224.t t -val of_sha256 : SHA256.t -> [ `SHA256 ] t +val of_sha256 : SHA256.t -> SHA256.t t -val of_sha384 : SHA384.t -> [ `SHA384 ] t +val of_sha384 : SHA384.t -> SHA384.t t -val of_sha512 : SHA512.t -> [ `SHA512 ] t +val of_sha512 : SHA512.t -> SHA512.t t -val of_sha3_224 : SHA3_224.t -> [ `SHA3_224 ] t +val of_sha3_224 : SHA3_224.t -> SHA3_224.t t -val of_sha3_256 : SHA3_256.t -> [ `SHA3_256 ] t +val of_sha3_256 : SHA3_256.t -> SHA3_256.t t -val of_sha3_384 : SHA3_384.t -> [ `SHA3_384 ] t +val of_sha3_384 : SHA3_384.t -> SHA3_384.t t -val of_sha3_512 : SHA3_512.t -> [ `SHA3_512 ] t +val of_sha3_512 : SHA3_512.t -> SHA3_512.t t -val of_whirlpool : WHIRLPOOL.t -> [ `WHIRLPOOL ] t +val of_whirlpool : WHIRLPOOL.t -> WHIRLPOOL.t t -val of_blake2b : BLAKE2B.t -> [ `BLAKE2B ] t +val of_blake2b : BLAKE2B.t -> BLAKE2B.t t -val of_blake2s : BLAKE2S.t -> [ `BLAKE2S ] t +val of_blake2s : BLAKE2S.t -> BLAKE2S.t t diff --git a/src/digestif_hash.ml b/src/digestif_hash.ml deleted file mode 100644 index 8a88c29..0000000 --- a/src/digestif_hash.ml +++ /dev/null @@ -1,59 +0,0 @@ -type 'kind hash = - | MD5 : [ `MD5 ] hash - | SHA1 : [ `SHA1 ] hash - | RMD160 : [ `RMD160 ] hash - | SHA224 : [ `SHA224 ] hash - | SHA256 : [ `SHA256 ] hash - | SHA384 : [ `SHA384 ] hash - | SHA512 : [ `SHA512 ] hash - | SHA3_224 : [ `SHA3_224 ] hash - | SHA3_256 : [ `SHA3_256 ] hash - | SHA3_384 : [ `SHA3_384 ] hash - | SHA3_512 : [ `SHA3_512 ] hash - | WHIRLPOOL : [ `WHIRLPOOL ] hash - | BLAKE2B : int -> [ `BLAKE2B ] hash - | BLAKE2S : int -> [ `BLAKE2S ] hash - -and kind = - [ `MD5 - | `SHA1 - | `RMD160 - | `SHA224 - | `SHA256 - | `SHA384 - | `SHA512 - | `SHA3_224 - | `SHA3_256 - | `SHA3_384 - | `SHA3_512 - | `WHIRLPOOL - | `BLAKE2B - | `BLAKE2S ] - -let md5 = MD5 - -let sha1 = SHA1 - -let rmd160 = RMD160 - -let sha224 = SHA224 - -let sha256 = SHA256 - -let sha384 = SHA384 - -let sha512 = SHA512 - -let sha3_224 = SHA3_224 - -let sha3_256 = SHA3_256 - -let sha3_384 = SHA3_384 - -let sha3_512 = SHA3_512 - -let whirlpool = WHIRLPOOL - -let blake2b length = BLAKE2B length - -let blake2s length = BLAKE2S length diff --git a/test/test.ml b/test/test.ml index 64fec7f..f409455 100644 --- a/test/test.ml +++ b/test/test.ml @@ -25,8 +25,8 @@ let title : type a k. [ `HMAC | `Digest ] -> k Digestif.hash -> a s -> string = | Digestif.SHA3_384 -> Fmt.string ppf "sha3_384" | Digestif.SHA3_512 -> Fmt.string ppf "sha3_512" | Digestif.WHIRLPOOL -> Fmt.string ppf "whirlpool" - | Digestif.BLAKE2B _ -> Fmt.string ppf "blake2b" - | Digestif.BLAKE2S _ -> Fmt.string ppf "blake2s" in + | Digestif.BLAKE2B -> Fmt.string ppf "blake2b" + | Digestif.BLAKE2S -> Fmt.string ppf "blake2s" in let pp_input : type a. a s Fmt.t = fun ppf -> function | Bytes -> Fmt.string ppf "bytes" @@ -273,7 +273,7 @@ let results_blake2b = "4abf562dc64f4062ea59ae9b4e2061a7a6c1a75af74b3663fd05aa4437420b8deea657e395a7dbac02aef7b7d70dc8b8a8db99aa8db028961a5ee66bac22b0f0"; "69f9e4236cd0c50204e4f8b86dc1751d37cc195835e9db25c9b366f41e1d86cdeec6a8702dfed1bc0ed0d6a1e2c5af275c331ec91f884c979021fb64021915de"; ] - |> List.map (Digestif.of_hex (Digestif.blake2b Digestif.BLAKE2B.digest_size)) + |> List.map (Digestif.of_hex Digestif.blake2b) let results_rmd160 = [ @@ -293,7 +293,7 @@ let results_blake2s = "6903efd2383b13adaa985d00ca271ccb420ab8f953841081c9c15a2dfebf866c"; "b8e167de23a5f136dc26bf06da0d724ebf7310903c2f702403b66810a230d622"; ] - |> List.map (Digestif.of_hex (Digestif.blake2s Digestif.BLAKE2S.digest_size)) + |> List.map (Digestif.of_hex Digestif.blake2s) module BLAKE2 = struct let input_blake2b_file = "../blake2b.test" @@ -403,16 +403,10 @@ module BLAKE2 = struct tests let tests_blake2s = - tests - (module Digestif.BLAKE2S.Keyed) - Digestif.(blake2s BLAKE2S.digest_size) - input_blake2s_file + tests (module Digestif.BLAKE2S.Keyed) Digestif.blake2s input_blake2s_file let tests_blake2b = - tests - (module Digestif.BLAKE2B.Keyed) - Digestif.(blake2b BLAKE2B.digest_size) - input_blake2b_file + tests (module Digestif.BLAKE2B.Keyed) Digestif.blake2b input_blake2b_file end module RMD160 = struct @@ -440,7 +434,7 @@ module RMD160 = struct "9b752e45573d4b39f4dbd3323cab82bf63326bfb"; ] - let million : expect:[ `RMD160 ] Digestif.t -> unit Alcotest.test_case = + let million : expect:Digestif.RMD160.t Digestif.t -> unit Alcotest.test_case = fun ~expect -> let iter n f = let rec go = function @@ -646,13 +640,11 @@ let tests () = makes ~name:"whirlpool" bigstring Digestif.whirlpool keys_st inputs_bi results_whirlpool ); ( "blake2b", - makes ~name:"blake2b" bytes - Digestif.(blake2b BLAKE2B.digest_size) - keys_st inputs_by results_blake2b ); + makes ~name:"blake2b" bytes Digestif.blake2b keys_st inputs_by + results_blake2b ); ( "blake2b (bigstring)", - makes ~name:"blake2b" bigstring - Digestif.(blake2b BLAKE2B.digest_size) - keys_st inputs_bi results_blake2b ); + makes ~name:"blake2b" bigstring Digestif.blake2b keys_st inputs_bi + results_blake2b ); ( "rmd160", makes ~name:"rmd160" bytes Digestif.rmd160 keys_st inputs_by results_rmd160 ); @@ -660,13 +652,11 @@ let tests () = makes ~name:"rmd160" bigstring Digestif.rmd160 keys_st inputs_bi results_rmd160 ); ( "blake2s", - makes ~name:"blake2s" bytes - Digestif.(blake2s BLAKE2S.digest_size) - keys_st inputs_by results_blake2s ); + makes ~name:"blake2s" bytes Digestif.blake2s keys_st inputs_by + results_blake2s ); ( "blake2s (bigstring)", - makes ~name:"blake2s" bigstring - Digestif.(blake2s BLAKE2S.digest_size) - keys_st inputs_bi results_blake2s ); + makes ~name:"blake2s" bigstring Digestif.blake2s keys_st inputs_bi + results_blake2s ); ("blake2s (keyed, input file)", BLAKE2.tests_blake2s); ("blake2b (keyed, input file)", BLAKE2.tests_blake2b); ( "blake2s (specialization)",