credential.ml 3.39 KB
Newer Older
1 2 3
(**************************************************************************)
(*                                BELENIOS                                *)
(*                                                                        *)
Stephane Glondu's avatar
Stephane Glondu committed
4
(*  Copyright © 2012-2018 Inria                                           *)
5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
(*                                                                        *)
(*  This program is free software: you can redistribute it and/or modify  *)
(*  it under the terms of the GNU Affero General Public License as        *)
(*  published by the Free Software Foundation, either version 3 of the    *)
(*  License, or (at your option) any later version, with the additional   *)
(*  exemption that compiling, linking, and/or using OpenSSL is allowed.   *)
(*                                                                        *)
(*  This program is distributed in the hope that it will be useful, but   *)
(*  WITHOUT ANY WARRANTY; without even the implied warranty of            *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU     *)
(*  Affero General Public License for more details.                       *)
(*                                                                        *)
(*  You should have received a copy of the GNU Affero General Public      *)
(*  License along with this program.  If not, see                         *)
(*  <http://www.gnu.org/licenses/>.                                       *)
(**************************************************************************)

22
open Serializable_builtin_t
23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58
open Platform
open Signatures

let digits = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
let token_length = 14
let n58 = Z.of_int 58
let n53 = Z.of_int 53

module MakeGenerate (M : RANDOM) = struct

  let get_random_digit () =
    M.bind (M.random n58) (fun x -> M.return (Z.to_int x))

  let generate_raw_token () =
    let res = Bytes.create token_length in
    let rec loop i accu =
      if i < token_length then (
        M.bind (get_random_digit ()) (fun digit ->
          Bytes.set res i digits.[digit];
          loop (i+1) Z.(n58 * accu + of_int digit)
        )
      ) else M.return (Bytes.to_string res, accu)
    in loop 0 Z.zero

  let add_checksum (raw, value) =
    let checksum = 53 - Z.(to_int (value mod n53)) in
    M.return (raw ^ String.make 1 digits.[checksum])

  let generate () =
    M.bind (generate_raw_token ()) add_checksum

end

let check x =
  String.length x = token_length + 1 &&
  let rec loop i accu =
59 60 61 62 63
    if i < token_length then
      match String.index_opt digits x.[i] with
      | Some digit -> loop (i+1) Z.(n58 * accu + of_int digit)
      | None -> None
    else Some accu
64
  in
65 66 67
  match loop 0 Z.zero, String.index_opt digits x.[token_length] with
  | Some n, Some checksum -> Z.((n + of_int checksum) mod n53 =% zero)
  | _, _ -> false
68 69 70 71 72 73 74 75 76 77 78 79 80

let remove_dashes x =
  let n = String.length x in
  let res = Buffer.create n in
  for i = 0 to n-1 do
    let c = x.[i] in
    if c <> '-' then Buffer.add_char res c;
  done;
  Buffer.contents res

module MakeDerive (G : GROUP) = struct

  let derive uuid x =
81 82 83 84 85 86 87 88 89
    let uuid = raw_string_of_uuid uuid in
    let derived =
      match Uuidm.of_string uuid with
      | Some _ -> (* old-style UUIDs *)
         let salt = remove_dashes uuid in
         pbkdf2_hex ~iterations:1000 ~salt x
      | None ->
         pbkdf2_utf8 ~iterations:1000 ~salt:uuid x
    in
90 91 92
    Z.(of_string_base 16 derived mod G.q)

end