Source file opamSHA.ml

(**************************************************************************)
(*                                                                        *)
(*    Copyright 2016-2018 OCamlPro                                        *)
(*                                                                        *)
(*  All rights reserved. This file is distributed under the terms of the  *)
(*  GNU Lesser General Public License version 2.1, with the special       *)
(*  exception on linking described in the file LICENSE.                   *)
(*                                                                        *)
(**************************************************************************)

module type ConvSig = sig
  type t
  val bytes: int
  val toggle_big_endian: t -> t
end

module type BufSig = sig
  module Conv: ConvSig
  type t
  val unsafe_get: t -> int -> Conv.t
  val unsafe_set: t -> int -> Conv.t -> unit
end

module type InputSig = sig
  type src
  type t
  type chunk
  type elt

  val init: blocksize:int -> src -> t
  val close: t -> unit
  val byte_size: t -> int

  (** padded with 0, getting chunks after the end of input is allowed *)
  val get_chunk: t -> int -> chunk

  val get: chunk -> int -> elt

  (** only allowed after the end of input *)
  val set: chunk -> int -> elt -> unit

  (** only allowed after the end of input*)
  val set_byte: chunk -> int -> char -> unit
end


module Conv32 = struct
  type t = int32
  let bytes = 4
  external swap: t -> t = "%bswap_int32"
  let toggle_big_endian =
    if Sys.big_endian then fun x -> x
    else swap
end

module Conv64 = struct
  type t = int64
  let bytes = 8
  external swap: t -> t = "%bswap_int64"
  let toggle_big_endian =
    if Sys.big_endian then fun x -> x
    else swap
end

module B = Bigarray
module A = B.Array1

type bigstring = (char, B.int8_unsigned_elt, B.c_layout) A.t

module Buf_Bigstring32 = struct
  module Conv = Conv32
  type t = bigstring
  external unsafe_get: t -> int -> Conv.t = "%caml_bigstring_get32u"
  external unsafe_set: t -> int -> Conv.t -> unit = "%caml_bigstring_set32u"
end

module Buf_Bigstring64 = struct
  module Conv = Conv64
  type t = bigstring
  external unsafe_get: t -> int -> Conv.t = "%caml_bigstring_get64u"
  external unsafe_set: t -> int -> Conv.t -> unit = "%caml_bigstring_set64u"
end

module Buf_String32 = struct
  module Conv = Conv32
  type t = Bytes.t
  external unsafe_get: t -> int -> Conv.t = "%caml_string_get32u"
  external unsafe_set: t -> int -> Conv.t -> unit = "%caml_string_set32u"
end

module Buf_String64 = struct
  module Conv = Conv64
  type t = Bytes.t
  external unsafe_get: t -> int -> Conv.t = "%caml_string_get64u"
  external unsafe_set: t -> int -> Conv.t -> unit = "%caml_string_set64u"
end

module Input_file(Buf: BufSig with type t = bigstring) = struct

  type src = string (* filename *)

  type t = {
    fd: Unix.file_descr;
    blocksize: int;
    buf: Buf.t;
  }

  type chunk = Buf.t

  type elt = Buf.Conv.t

  let init ~blocksize src =
    let fd = Unix.openfile src [Unix.O_RDONLY] 0 in
    let buf = B.(array1_of_genarray (OpamCompat.Unix.map_file fd B.char c_layout false [|-1|])) in
    { fd; blocksize; buf }

  let close {fd; _} = Unix.close fd

  let byte_size {buf; _} = A.dim buf

  let get_chunk {blocksize; buf; _} i =
    let len = A.dim buf in
    let block_bytes = blocksize * Buf.Conv.bytes in
    if (i + 1) * block_bytes <= len then
      A.sub buf (i * block_bytes) (block_bytes)
    else
      let ba = A.create B.char B.c_layout (block_bytes) in
      A.fill ba '\x00';
      if i * block_bytes < len then
        A.blit
          (A.sub buf (i * block_bytes) (len mod block_bytes))
          (A.sub ba 0 (len mod block_bytes));
      ba

  let get chunk i =
    Buf.Conv.toggle_big_endian (Buf.unsafe_get chunk (i * Buf.Conv.bytes))

  let set chunk i x =
    Buf.unsafe_set chunk (i * Buf.Conv.bytes) (Buf.Conv.toggle_big_endian x)

  let set_byte chunk i c = A.unsafe_set chunk i c

end

module Input_string(Buf: BufSig with type t = Bytes.t) = struct

  type src = Bytes.t

  type t = {
    blocksize: int;
    buf: Bytes.t;
  }

  type chunk = {
    offset: int;
    b: Bytes.t;
  }

  type elt = Buf.Conv.t

  let init ~blocksize buf =
    { blocksize; buf }

  let close _ = ()

  let byte_size {buf; _} = Bytes.length buf

  let get_chunk {blocksize; buf} i =
    let len = Bytes.length buf in
    let block_bytes = blocksize * Buf.Conv.bytes in
    if (i + 1) * block_bytes <= len then
      { offset = i * block_bytes; b = buf }
    else
      let b = Bytes.make block_bytes '\x00' in
      if i * block_bytes < len then
        Bytes.blit buf (i * block_bytes) b 0 (len mod block_bytes);
      { offset = 0; b }

  let get {offset; b} i =
    Buf.Conv.toggle_big_endian (Buf.unsafe_get b (offset + i * Buf.Conv.bytes))

  let set {offset; b} i x =
    Buf.unsafe_set b (offset + i * Buf.Conv.bytes)
      (Buf.Conv.toggle_big_endian x)

  let set_byte {offset; b} i c = Bytes.unsafe_set b (offset + i) c

end

module Make_SHA256(I: InputSig with type elt = int32) = struct

  open Int32

  let k = [|
    0x428a2f98l; 0x71374491l; 0xb5c0fbcfl; 0xe9b5dba5l;
    0x3956c25bl; 0x59f111f1l; 0x923f82a4l; 0xab1c5ed5l;
    0xd807aa98l; 0x12835b01l; 0x243185bel; 0x550c7dc3l;
    0x72be5d74l; 0x80deb1fel; 0x9bdc06a7l; 0xc19bf174l;
    0xe49b69c1l; 0xefbe4786l; 0x0fc19dc6l; 0x240ca1ccl;
    0x2de92c6fl; 0x4a7484aal; 0x5cb0a9dcl; 0x76f988dal;
    0x983e5152l; 0xa831c66dl; 0xb00327c8l; 0xbf597fc7l;
    0xc6e00bf3l; 0xd5a79147l; 0x06ca6351l; 0x14292967l;
    0x27b70a85l; 0x2e1b2138l; 0x4d2c6dfcl; 0x53380d13l;
    0x650a7354l; 0x766a0abbl; 0x81c2c92el; 0x92722c85l;
    0xa2bfe8a1l; 0xa81a664bl; 0xc24b8b70l; 0xc76c51a3l;
    0xd192e819l; 0xd6990624l; 0xf40e3585l; 0x106aa070l;
    0x19a4c116l; 0x1e376c08l; 0x2748774cl; 0x34b0bcb5l;
    0x391c0cb3l; 0x4ed8aa4al; 0x5b9cca4fl; 0x682e6ff3l;
    0x748f82eel; 0x78a5636fl; 0x84c87814l; 0x8cc70208l;
    0x90befffal; 0xa4506cebl; 0xbef9a3f7l; 0xc67178f2l;
  |]

  let ch x y z =
    logxor (logand x y) (logand (lognot x) z)

  let maj x y z =
    logxor (logand x y) (logxor (logand x z) (logand y z))

  let sum0 x =
    logxor
      (logor (shift_right_logical x 2) (shift_left x (32 - 2)))
      (logxor (logor (shift_right_logical x 13) (shift_left x (32 - 13)))
         (logor (shift_right_logical x 22) (shift_left x (32 - 22))))

  let sum1 x =
    logxor
      (logor (shift_right_logical x 6) (shift_left x (32 - 6)))
      (logxor (logor (shift_right_logical x 11) (shift_left x (32 - 11)))
         (logor (shift_right_logical x 25) (shift_left x (32 - 25))))

  let lsig0 x =
    logxor
      (logor (shift_right_logical x 7) (shift_left x (32 - 7)))
      (logxor (logor (shift_right_logical x 18) (shift_left x (32 - 18)))
         (logor (shift_right_logical x 3) (shift_right_logical x 3)))

  let lsig1 x =
    logxor
      (logor (shift_right_logical x 17) (shift_left x (32 - 17)))
      (logxor (logor (shift_right_logical x 19) (shift_left x (32 - 19)))
         (logor (shift_right_logical x 10) (shift_right_logical x 10)))

  let sha_init = (
    0x6a09e667l, 0xbb67ae85l, 0x3c6ef372l, 0xa54ff53al,
    0x510e527fl, 0x9b05688cl, 0x1f83d9abl, 0x5be0cd19l
  )

  let hash_block =
    let warr = Array.make 64 0l in
    fun hh block ->
      for t = 0 to 15 do
        warr.(t) <- I.get block t
      done;
      for t = 16 to 63 do
        warr.(t) <-
          add
            (add (lsig1 warr.(t - 2)) warr.(t - 7))
            (add (lsig0 warr.(t - 15)) warr.(t - 16))
      done;

      let rec stir t (a, b, c, d, e, f, g, h) =
        if t >= 64 then
          let a', b', c', d', e', f', g', h' = hh in
          add a a', add b b', add c c', add d d',
          add e e', add f f', add g g', add h h'
        else
        let t1 =
          add (add h (sum1 e)) (add (add (ch e f g) k.(t)) warr.(t))
        in
        let t2 = add (sum0 a) (maj a b c) in
        stir (t + 1)
          (add t1 t2, a, b, c, add d t1, e, f, g)
      in
      stir 0 hh

  let blocksize = 16

  let hash src =
    let bs = I.init ~blocksize src in
    let nbytes = I.byte_size bs in
    let blocks = nbytes / (blocksize * 4) in
    let rem = nbytes mod (blocksize * 4) in
    let h = ref sha_init in
    for i = 0 to blocks - 1 do
      h := hash_block !h (I.get_chunk bs i)
    done;
    let lastblock = I.get_chunk bs blocks in
    I.set_byte lastblock rem '\x80';
    let lastblock =
      if rem <= 55 then lastblock else
        (h := hash_block !h lastblock;
         I.get_chunk bs (blocks + 1))
    in
    let bitsz = Int64.mul 8L (Int64.of_int nbytes) in
    I.set lastblock 14
      Int64.(to_int32 (shift_right_logical bitsz 32));
    I.set lastblock 15
      Int64.(to_int32 (logand 0xffffffffL bitsz));
    let (a, b, c, d, e, f, g, h) = hash_block !h lastblock in
    I.close bs;
    Printf.sprintf "%08lx%08lx%08lx%08lx%08lx%08lx%08lx%08lx" a b c d e f g h
end

module Make_SHA512(I: InputSig with type elt = int64) = struct

  open Int64

  let k = [|
    0x428a2f98d728ae22L; 0x7137449123ef65cdL;
    0xb5c0fbcfec4d3b2fL; 0xe9b5dba58189dbbcL;
    0x3956c25bf348b538L; 0x59f111f1b605d019L;
    0x923f82a4af194f9bL; 0xab1c5ed5da6d8118L;
    0xd807aa98a3030242L; 0x12835b0145706fbeL;
    0x243185be4ee4b28cL; 0x550c7dc3d5ffb4e2L;
    0x72be5d74f27b896fL; 0x80deb1fe3b1696b1L;
    0x9bdc06a725c71235L; 0xc19bf174cf692694L;
    0xe49b69c19ef14ad2L; 0xefbe4786384f25e3L;
    0x0fc19dc68b8cd5b5L; 0x240ca1cc77ac9c65L;
    0x2de92c6f592b0275L; 0x4a7484aa6ea6e483L;
    0x5cb0a9dcbd41fbd4L; 0x76f988da831153b5L;
    0x983e5152ee66dfabL; 0xa831c66d2db43210L;
    0xb00327c898fb213fL; 0xbf597fc7beef0ee4L;
    0xc6e00bf33da88fc2L; 0xd5a79147930aa725L;
    0x06ca6351e003826fL; 0x142929670a0e6e70L;
    0x27b70a8546d22ffcL; 0x2e1b21385c26c926L;
    0x4d2c6dfc5ac42aedL; 0x53380d139d95b3dfL;
    0x650a73548baf63deL; 0x766a0abb3c77b2a8L;
    0x81c2c92e47edaee6L; 0x92722c851482353bL;
    0xa2bfe8a14cf10364L; 0xa81a664bbc423001L;
    0xc24b8b70d0f89791L; 0xc76c51a30654be30L;
    0xd192e819d6ef5218L; 0xd69906245565a910L;
    0xf40e35855771202aL; 0x106aa07032bbd1b8L;
    0x19a4c116b8d2d0c8L; 0x1e376c085141ab53L;
    0x2748774cdf8eeb99L; 0x34b0bcb5e19b48a8L;
    0x391c0cb3c5c95a63L; 0x4ed8aa4ae3418acbL;
    0x5b9cca4f7763e373L; 0x682e6ff3d6b2b8a3L;
    0x748f82ee5defb2fcL; 0x78a5636f43172f60L;
    0x84c87814a1f0ab72L; 0x8cc702081a6439ecL;
    0x90befffa23631e28L; 0xa4506cebde82bde9L;
    0xbef9a3f7b2c67915L; 0xc67178f2e372532bL;
    0xca273eceea26619cL; 0xd186b8c721c0c207L;
    0xeada7dd6cde0eb1eL; 0xf57d4f7fee6ed178L;
    0x06f067aa72176fbaL; 0x0a637dc5a2c898a6L;
    0x113f9804bef90daeL; 0x1b710b35131c471bL;
    0x28db77f523047d84L; 0x32caab7b40c72493L;
    0x3c9ebe0a15c9bebcL; 0x431d67c49c100d4cL;
    0x4cc5d4becb3e42b6L; 0x597f299cfc657e2aL;
    0x5fcb6fab3ad6faecL; 0x6c44198c4a475817L;
  |]

  let rotate x n = logor (shift_right_logical x n) (shift_left x (64 - n))

  let ch x y z = logxor (logand x y) (logand (lognot x) z)

  let maj x y z = logxor (logand x y) (logxor (logand x z) (logand y z))

  let sum0 x = logxor (rotate x 28) (logxor (rotate x 34) (rotate x 39))

  let sum1 x = logxor (rotate x 14) (logxor (rotate x 18) (rotate x 41))

  let lsig0 x =
    logxor (rotate x 1) (logxor (rotate x 8) (shift_right_logical x 7))

  let lsig1 x =
    logxor (rotate x 19) (logxor (rotate x 61) (shift_right_logical x 6))

  let sha_init = (
    0x6a09e667f3bcc908L, 0xbb67ae8584caa73bL,
    0x3c6ef372fe94f82bL, 0xa54ff53a5f1d36f1L,
    0x510e527fade682d1L, 0x9b05688c2b3e6c1fL,
    0x1f83d9abfb41bd6bL, 0x5be0cd19137e2179L
  )

  let hash_block =
    let warr = Array.make 80 0L in
    fun hh block ->
      for t = 0 to 15 do
        warr.(t) <- I.get block t
      done;
      for t = 16 to 79 do
        warr.(t) <-
          add
            (add (lsig1 warr.(t - 2)) warr.(t - 7))
            (add (lsig0 warr.(t - 15)) warr.(t - 16))
      done;

      let rec stir t (a, b, c, d, e, f, g, h) =
        if t >= 80 then
          let a', b', c', d', e', f', g', h' = hh in
          add a a', add b b', add c c', add d d',
          add e e', add f f', add g g', add h h'
        else
        let t1 =
          add (add h (sum1 e)) (add (add (ch e f g) k.(t)) warr.(t))
        in
        let t2 = add (sum0 a) (maj a b c) in
        stir (t + 1)
          (add t1 t2, a, b, c, add d t1, e, f, g)
      in
      stir 0 hh

  let blocksize = 16

  let hash src =
    let bs = I.init ~blocksize src in
    let nbytes = I.byte_size bs in
    let blocks = nbytes / (blocksize * 8) in
    let rem = nbytes mod (blocksize * 8) in
    let h = ref sha_init in
    for i = 0 to blocks - 1 do
      h := hash_block !h (I.get_chunk bs i)
    done;
    let lastblock = I.get_chunk bs blocks in
    I.set_byte lastblock rem '\x80';
    let lastblock =
      if rem <= 111 then lastblock else
        (h := hash_block !h lastblock;
         I.get_chunk bs (blocks+1))
    in
    (* We assume sz fits in 61 bits... *)
    let bitsz = Int64.mul 8L (Int64.of_int nbytes) in
    I.set lastblock 15 bitsz;
    let (a, b, c, d, e, f, g, h) = hash_block !h lastblock in
    I.close bs;
    Printf.sprintf "%016Lx%016Lx%016Lx%016Lx%016Lx%016Lx%016Lx%016Lx"
      a b c d e f g h

end

module SHA256_file = Make_SHA256 (Input_file(Buf_Bigstring32))
module SHA512_file = Make_SHA512 (Input_file(Buf_Bigstring64))
module SHA256_string = Make_SHA256 (Input_string(Buf_String32))
module SHA512_string = Make_SHA512 (Input_string(Buf_String64))

let sha256_file = SHA256_file.hash
let sha512_file = SHA512_file.hash
let hash_file = function
  | `SHA256 -> sha256_file
  | `SHA512 -> sha512_file

let sha256_bytes = SHA256_string.hash
let sha512_bytes = SHA512_string.hash
let hash_bytes = function
  | `SHA256 -> sha256_bytes
  | `SHA512 -> sha512_bytes

let sha256 = sha256_file
let sha512 = sha512_file
let hash = hash_file