Source file external.ml

module Context = struct
  type t

  external create : int -> t = "caml_secp256k1_context_create"

  external clone : t -> t = "caml_secp256k1_context_clone"

  external randomize : t -> Bigstring.t -> bool
    = "caml_secp256k1_context_randomize"
    [@@noalloc]

  let create ?(sign = true) ?(verify = true) () =
    let flags =
      1 lor (if sign then 0x100 else 0) lor if verify then 0x200 else 0
    in
    create flags

  let randomize ctx buf =
    if Bigstring.length buf < 32 then
      invalid_arg "Context.randomize: input must be at least 32 bytes long" ;
    randomize ctx buf
end

module Key = struct
  type secret

  type public

  type _ t = Sk : Bigstring.t -> secret t | Pk : Bigstring.t -> public t

  let buffer : type a. a t -> Bigstring.t = function Sk sk -> sk | Pk pk -> pk

  let secret_bytes = 32

  let public_bytes = 64

  let compressed_pk_bytes = 33

  let uncompressed_pk_bytes = 65

  let bytes : type a. a t -> int = function
    | Sk _ -> secret_bytes
    | Pk _ -> public_bytes

  let serialized_bytes : type a. ?compressed:bool -> a t -> int =
   fun ?(compressed = true) -> function
    | Sk _ -> secret_bytes
    | Pk _ -> if compressed then public_bytes + 1 else secret_bytes + 1

  let equal : type a. a t -> a t -> bool =
   fun a b ->
    match (a, b) with
    | (Sk a, Sk b) -> Bigstring.equal a b
    | (Pk a, Pk b) -> Bigstring.equal a b

  let copy : type a. a t -> a t = function
    | Sk sk -> Sk (Bigstring.copy sk)
    | Pk pk -> Pk (Bigstring.copy pk)

  external sk_negate_inplace : Context.t -> Bigstring.t -> unit
    = "caml_secp256k1_ec_seckey_negate"
    [@@noalloc]

  external sk_add_tweak_inplace :
    Context.t -> Bigstring.t -> Bigstring.t -> bool
    = "caml_secp256k1_ec_seckey_tweak_add"
    [@@noalloc]

  external sk_mul_tweak_inplace :
    Context.t -> Bigstring.t -> Bigstring.t -> bool
    = "caml_secp256k1_ec_seckey_tweak_mul"
    [@@noalloc]

  external pk_negate_inplace : Context.t -> Bigstring.t -> unit
    = "caml_secp256k1_ec_pubkey_negate"
    [@@noalloc]

  external pk_add_tweak_inplace :
    Context.t -> Bigstring.t -> Bigstring.t -> bool
    = "caml_secp256k1_ec_pubkey_tweak_add"
    [@@noalloc]

  external pk_mul_tweak_inplace :
    Context.t -> Bigstring.t -> Bigstring.t -> bool
    = "caml_secp256k1_ec_pubkey_tweak_mul"
    [@@noalloc]

  external pk_combine : Context.t -> Bigstring.t -> Bigstring.t list -> bool
    = "caml_secp256k1_ec_pubkey_combine"
    [@@noalloc]

  let negate_inplace : type a. Context.t -> a t -> unit =
   fun ctx -> function
    | Sk k -> sk_negate_inplace ctx k
    | Pk k -> pk_negate_inplace ctx k

  let negate ctx k =
    let k' = copy k in
    negate_inplace ctx k' ;
    k'

  let op_tweak :
      type a.
      string ->
      (Context.t -> Bigstring.t -> Bigstring.t -> bool) ->
      Context.t ->
      a t ->
      Bigstring.t ->
      Bigstring.t =
   fun name f ctx k buf ->
    let buflen = Bigstring.length buf in
    if buflen < 32 then invalid_arg (Printf.sprintf "Key.%s: " name) ;
    let k' = buffer (copy k) in
    if not (f ctx k' buf) then
      failwith (Printf.sprintf "Key.%s: operation failed" name) ;
    k'

  let add_tweak : type a. Context.t -> a t -> Bigstring.t -> a t =
   fun ctx k buf ->
    match k with
    | Sk _ -> Sk (op_tweak "add_tweak" sk_add_tweak_inplace ctx k buf)
    | Pk _ -> Pk (op_tweak "add_tweak" pk_add_tweak_inplace ctx k buf)

  let mul_tweak : type a. Context.t -> a t -> Bigstring.t -> a t =
   fun ctx k buf ->
    match k with
    | Sk _ -> Sk (op_tweak "mul_tweak" sk_mul_tweak_inplace ctx k buf)
    | Pk _ -> Pk (op_tweak "mul_tweak" pk_mul_tweak_inplace ctx k buf)

  external pk_parse : Context.t -> Bigstring.t -> Bigstring.t -> bool
    = "caml_secp256k1_ec_pubkey_parse"
    [@@noalloc]

  external pk_serialize : Context.t -> Bigstring.t -> Bigstring.t -> int
    = "caml_secp256k1_ec_pubkey_serialize"
    [@@noalloc]

  external pk_create : Context.t -> Bigstring.t -> Bigstring.t -> bool
    = "caml_secp256k1_ec_pubkey_create"
    [@@noalloc]

  let neuterize : type a. Context.t -> a t -> public t option =
   fun ctx -> function
    | Pk pk -> Some (Pk pk)
    | Sk sk ->
        let pk = Bigstring.create public_bytes in
        if pk_create ctx pk sk then Some (Pk pk) else None

  let neuterize_exn ctx k =
    match neuterize ctx k with
    | None -> invalid_arg "Key.neuterize_exn: invalid secret key"
    | Some pk -> pk

  let list_map_filter_opt ~f l =
    ListLabels.fold_left
      ~init:[]
      ~f:(fun a e -> match f e with None -> a | Some r -> r :: a)
      l

  let combine ctx pks =
    let nb_pks = List.length pks in
    if nb_pks = 0 || nb_pks > 1024 then None
    else
      let pk = Bigstring.create public_bytes in
      let pks =
        list_map_filter_opt
          ~f:(fun k ->
            match neuterize ctx k with None -> None | Some (Pk k) -> Some k)
          pks
      in
      if pk_combine ctx pk pks then Some (Pk pk) else None

  let combine_exn ctx pks =
    match combine ctx pks with
    | None -> invalid_arg "Key.combine_exn: sum of pks is invalid"
    | Some pk -> pk

  external verify_sk : Context.t -> Bigstring.t -> bool
    = "caml_secp256k1_ec_seckey_verify"
    [@@noalloc]

  let read_sk_exn ctx buf =
    let buflen = Bigstring.length buf in
    if buflen < secret_bytes then
      invalid_arg (Printf.sprintf "Key.read_sk: invalid buffer size %d" buflen) ;
    match verify_sk ctx buf with
    | true -> Sk Bigstring.(copy (sub buf 0 secret_bytes))
    | false -> invalid_arg "Key.read_sk: secret key is invalid"

  let read_sk ctx buf =
    try Ok (read_sk_exn ctx buf) with Invalid_argument msg -> Error msg

  let read_pk_exn ctx buf =
    let buflen = Bigstring.length buf in
    if buflen < compressed_pk_bytes then
      invalid_arg (Printf.sprintf "Key.read_pk: invalid buffer size %d" buflen) ;
    let outbuf = Bigstring.create public_bytes in
    if pk_parse ctx outbuf buf then Pk outbuf
    else invalid_arg "Key.read_pk_exn: public key is invalid"

  let read_pk ctx buf =
    try Ok (read_pk_exn ctx buf) with Invalid_argument msg -> Error msg

  let write :
      type a.
      ?compress:bool -> Context.t -> ?pos:int -> Bigstring.t -> a t -> int =
   fun ?(compress = true) ctx ?(pos = 0) buf -> function
    | Sk sk ->
        let buflen = Bigstring.length buf in
        if pos < 0 || pos > buflen - secret_bytes then
          invalid_arg "Key.write (secret): pos < 0 or pos + 32 > buflen" ;
        Bigstring.blit sk 0 buf pos secret_bytes ;
        secret_bytes
    | Pk pk ->
        let buflen = Bigstring.length buf in
        if
          pos < 0
          || (compress && pos > buflen - compressed_pk_bytes)
          || ((not compress) && pos > buflen - uncompressed_pk_bytes)
        then
          invalid_arg
            (Printf.sprintf "Key.write (public): pos=%d, buflen=%d" pos buflen) ;
        let len = if compress then 33 else 65 in
        let buf = Bigstring.sub buf pos len in
        pk_serialize ctx buf pk

  let to_bytes : type a. ?compress:bool -> Context.t -> a t -> Bigstring.t =
   fun ?(compress = true) ctx -> function
    | Sk _ as sk ->
        let buf = Bigstring.create secret_bytes in
        let _ = write ~compress ctx buf sk in
        buf
    | Pk _ as pk ->
        let buf =
          Bigstring.create (1 + if compress then secret_bytes else public_bytes)
        in
        let _ = write ~compress ctx buf pk in
        buf
end

module Sign = struct
  type plain

  type recoverable

  type _ t = P : Bigstring.t -> plain t | R : Bigstring.t -> recoverable t

  let buffer : type a. a t -> Bigstring.t = function
    | P plain -> plain
    | R recoverable -> recoverable

  let plain_bytes = 64

  let recoverable_bytes = 65

  let msg_bytes = 32

  let equal : type a. a t -> a t -> bool =
   fun a b ->
    match (a, b) with
    | (P a, P b) -> Bigstring.equal a b
    | (R a, R b) -> Bigstring.equal a b

  external parse_compact : Context.t -> Bigstring.t -> Bigstring.t -> bool
    = "caml_secp256k1_ecdsa_signature_parse_compact"
    [@@noalloc]

  external parse_der : Context.t -> Bigstring.t -> Bigstring.t -> bool
    = "caml_secp256k1_ecdsa_signature_parse_der"
    [@@noalloc]

  external serialize_compact : Context.t -> Bigstring.t -> Bigstring.t -> unit
    = "caml_secp256k1_ecdsa_signature_serialize_compact"
    [@@noalloc]

  external serialize_der : Context.t -> Bigstring.t -> Bigstring.t -> int
    = "caml_secp256k1_ecdsa_signature_serialize_der"
    [@@noalloc]

  external parse_recoverable :
    Context.t -> Bigstring.t -> Bigstring.t -> int -> bool
    = "caml_secp256k1_ecdsa_recoverable_signature_parse_compact"
    [@@noalloc]

  external serialize_recoverable :
    Context.t -> Bigstring.t -> Bigstring.t -> int
    = "caml_secp256k1_ecdsa_recoverable_signature_serialize_compact"
    [@@noalloc]

  let read_exn ctx buf =
    let buflen = Bigstring.length buf in
    if buflen < plain_bytes then
      invalid_arg (Printf.sprintf "Sign.read: invalid buffer size %d" buflen) ;
    let signature = Bigstring.create plain_bytes in
    if parse_compact ctx signature buf then P signature
    else invalid_arg "Sign.read: signature could not be parsed"

  let read ctx buf =
    try Ok (read_exn ctx buf) with Invalid_argument msg -> Error msg

  let read_der_exn ctx buf =
    let signature = Bigstring.create plain_bytes in
    if parse_der ctx signature buf then P signature
    else invalid_arg "Sign.read_der: signature could not be parsed"

  let read_der ctx buf =
    try Ok (read_der_exn ctx buf) with Invalid_argument msg -> Error msg

  let read_recoverable_exn ctx buf =
    let buflen = Bigstring.length buf in
    if buflen < recoverable_bytes then
      invalid_arg
        (Printf.sprintf "Sign.read_recoverable: invalid buffer size %d" buflen) ;
    let signature = Bigstring.create recoverable_bytes in
    let recid = int_of_char (Bigstring.get buf 64) in
    if parse_recoverable ctx signature buf recid then R signature
    else invalid_arg "Sign.read_recoverable: signature could not be parsed"

  let read_recoverable ctx buf =
    try Ok (read_recoverable_exn ctx buf)
    with Invalid_argument msg -> Error msg

  let write_exn : type a. ?der:bool -> Context.t -> Bigstring.t -> a t -> int =
   fun ?(der = false) ctx buf -> function
    | P signature -> (
        let buflen = Bigstring.length buf in
        if not der then (
          if buflen < plain_bytes then
            invalid_arg
              (Printf.sprintf "Sign.write: buffer length too small (%d)" buflen) ;
          serialize_compact ctx buf signature ;
          plain_bytes)
        else
          match serialize_der ctx buf signature with
          | 0 ->
              invalid_arg
                "Sign.write_exn: buffer too small to contain a DER signature"
          | len -> len)
    | R signature ->
        let buflen = Bigstring.length buf in
        if buflen < recoverable_bytes then
          invalid_arg
            (Printf.sprintf "Sign.write: buffer length too small (%d)" buflen) ;
        let recid = serialize_recoverable ctx buf signature in
        Bigstring.set buf 64 (char_of_int recid) ;
        recoverable_bytes

  let write ?der ctx buf signature =
    try Ok (write_exn ?der ctx buf signature)
    with Invalid_argument msg -> Error msg

  let to_bytes : type a. ?der:bool -> Context.t -> a t -> Bigstring.t =
   fun ?(der = false) ctx -> function
    | P _ as signature ->
        if der then
          let buf = Bigstring.create 72 in
          let nb_written = write_exn ~der ctx buf signature in
          Bigstring.sub buf 0 nb_written
        else
          let buf = Bigstring.create plain_bytes in
          let _nb_written = write_exn ~der ctx buf signature in
          buf
    | R _ as signature ->
        let buf = Bigstring.create recoverable_bytes in
        let _nb_written = write_exn ctx buf signature in
        buf

  external normalize : Context.t -> Bigstring.t -> Bigstring.t -> bool
    = "caml_secp256k1_ecdsa_signature_normalize"
    [@@noalloc]

  let normalize ctx (P signature) =
    let normalized_sig = Bigstring.create plain_bytes in
    if normalize ctx normalized_sig signature then Some (P normalized_sig)
    else None

  (* [sign ctx signature msg sk] *)
  external sign : Context.t -> Bigstring.t -> Bigstring.t -> Bigstring.t -> bool
    = "caml_secp256k1_ecdsa_sign"
    [@@noalloc]

  (* [verify ctx pk msg signature] *)
  external verify :
    Context.t -> Bigstring.t -> Bigstring.t -> Bigstring.t -> bool
    = "caml_secp256k1_ecdsa_verify"
    [@@noalloc]

  let check_msglen msg =
    let msglen = Bigstring.length msg in
    if msglen < msg_bytes then
      invalid_arg
        (Printf.sprintf "message is too small (%d < %d)" msglen msg_bytes)

  let sign_exn ctx buf ~sk ~msg =
    check_msglen msg ;
    let buflen = Bigstring.length buf in
    if buflen < plain_bytes then
      invalid_arg
        (Printf.sprintf "Sign.write_sign: buffer length too small (%d)" buflen) ;
    match sign ctx buf (Key.buffer sk) msg with
    | true -> ()
    | false ->
        invalid_arg
          "Sign.write_sign: the nonce generation function failed, or the \
           private key was invalid"

  let write_sign_exn ctx buf ~sk ~msg =
    let signature = Bigstring.create plain_bytes in
    sign_exn ctx signature ~sk ~msg ;
    write_exn ctx buf (P signature)

  let write_sign ctx buf ~sk ~msg =
    try Ok (write_sign_exn ctx ~sk ~msg buf)
    with Invalid_argument msg -> Error msg

  let sign_exn ctx ~sk msg =
    let signature = Bigstring.create plain_bytes in
    sign_exn ctx signature ~sk ~msg ;
    P signature

  let sign ctx ~sk msg =
    try Ok (sign_exn ctx ~sk msg) with Invalid_argument msg -> Error msg

  external sign_recoverable :
    Context.t -> Bigstring.t -> Bigstring.t -> Bigstring.t -> bool
    = "caml_secp256k1_ecdsa_sign_recoverable"
    [@@noalloc]

  let write_sign_recoverable_exn ctx ~sk ~msg buf =
    check_msglen msg ;
    let buflen = Bigstring.length buf in
    if buflen < recoverable_bytes then
      invalid_arg
        (Printf.sprintf
           "Sign.write_sign_recoverable: buffer length too small (%d)"
           buflen) ;
    if sign_recoverable ctx buf (Key.buffer sk) msg then recoverable_bytes
    else
      invalid_arg
        "Sign.write_sign_recoverable_exn: the nonce generation function \
         failed, or the private key was invalid"

  let write_sign_recoverable ctx ~sk ~msg buf =
    try Ok (write_sign_recoverable_exn ctx ~sk ~msg buf)
    with Invalid_argument msg -> Error msg

  let sign_recoverable ctx ~sk msg =
    let signature = Bigstring.create recoverable_bytes in
    match write_sign_recoverable ctx ~sk ~msg signature with
    | Error error -> Error error
    | Ok _nb_written -> Ok (R signature)

  let sign_recoverable_exn ctx ~sk msg =
    match sign_recoverable ctx ~sk msg with
    | Error msg -> invalid_arg msg
    | Ok signature -> signature

  external to_plain : Context.t -> Bigstring.t -> Bigstring.t -> unit
    = "caml_secp256k1_ecdsa_recoverable_signature_convert"
    [@@noalloc]

  let to_plain : type a. Context.t -> a t -> plain t =
   fun ctx -> function
    | P _ as signature -> signature
    | R recoverable ->
        let plain = Bigstring.create plain_bytes in
        to_plain ctx plain recoverable ;
        P plain

  let verify_plain_exn ctx ~pk msg signature =
    check_msglen msg ;
    let siglen = Bigstring.length signature in
    if siglen < plain_bytes then
      invalid_arg
        (Printf.sprintf
           "verify: signature too short (%d < %d)"
           siglen
           plain_bytes) ;
    verify ctx (Key.buffer pk) msg signature

  let verify_exn ctx ~pk ~msg ~signature =
    let (P signature) = to_plain ctx signature in
    verify_plain_exn ctx ~pk msg signature

  let verify ctx ~pk ~msg ~signature =
    try Ok (verify_exn ctx ~pk ~msg ~signature)
    with Invalid_argument msg -> Error msg

  external recover :
    Context.t -> Bigstring.t -> Bigstring.t -> Bigstring.t -> bool
    = "caml_secp256k1_ecdsa_recover"
    [@@noalloc]

  let recover_exn ctx ~signature:(R signature) msg =
    check_msglen msg ;
    let pk = Bigstring.create Key.public_bytes in
    if recover ctx pk signature msg then Key.Pk pk
    else invalid_arg "Sign.recover: pk could not be recovered"

  let recover ctx ~signature msg =
    try Ok (recover_exn ctx ~signature msg)
    with Invalid_argument msg -> Error msg
end