HMAC.ml

module Make (X: sig
  val block_size: int
  val hash: string -> string (* binary, not digest *)
end) = struct
  let o_pad = String.make X.block_size '\x5C'
  let i_pad = String.make X.block_size '\x36'

  let block_xor left right =
    let result = Bytes.create X.block_size in
    for i = 0 to X.block_size - 1 do
      Bytes.set result i Char.(chr (code left.[i] lxor code right.[i]))
    done;
    Bytes.unsafe_to_string result

  let block_pad key = 
    let result = Bytes.make X.block_size '\x00' in
    Bytes.blit_string key 0 result 0 (String.length key);
    Bytes.unsafe_to_string result

  let create ~key ~message = 
    let key = if String.length key > X.block_size then X.hash key else key in
    let key = if String.length key < X.block_size then block_pad key else key in 
    let o_key_pad = block_xor key o_pad in
    let i_key_pad = block_xor key i_pad in
    X.hash (o_key_pad ^ (X.hash (i_key_pad ^ message)))
end

module MD5 = Make (struct
  let block_size = 64
  let hash = Digest.string
end)

HMAC_test.ml

let (=>) left right = print_char (if left = right then '.' else 'F')

let hmac_md5 key message = Digest.to_hex (HMAC.MD5.create ~key ~message)

let repeat = String.make

module Test = struct
  hmac_md5 "key" "The quick brown fox jumps over the lazy dog"
    => "80070713463e7749b90c2dc24911e275";
  hmac_md5 (repeat 16 '\x0b') "Hi There"
    => "9294727a3638bb1c13f48ef8158bfc9d";
  hmac_md5 "Jefe" "what do ya want for nothing?"
    => "750c783e6ab0b503eaa86e310a5db738";
  hmac_md5 (repeat 16 '\xaa') (repeat 50 '\xdd')
    => "56be34521d144c88dbb8c733f0e8b3f6";
  hmac_md5 ("\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f" 
    ^ "\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19") (repeat 50 '\xcd')
    => "697eaf0aca3a3aea3a75164746ffaa79";
  hmac_md5 (repeat 16 '\x0c') "Test With Truncation"
    => "56461ef2342edc00f9bab995690efd4c";
  hmac_md5 (repeat 80 '\xaa') ("Test Using Larger Than Block-Size Key - "
    ^ "Hash Key First") 
    => "6b1ab7fe4bd7bf8f0b62e6ce61b9d0cd";
  hmac_md5 (repeat 80 '\xaa') ("Test Using Larger Than Block-Size Key and "
    ^ "Larger Than One Block-Size Data")
    => "6f630fad67cda0ee1fb1f562db3aa53e"
end