← Back to branch summary

~ubuntu-branches/ubuntu/trusty/ocamlnet/trusty

« back to all changes in this revision

Viewing changes to src/netstring/netauth.ml

  • Committer: Bazaar Package Importer
  • Author(s): Stéphane Glondu
  • Date: 2011-09-02 14:12:33 UTC
  • mfrom: (18.2.3 sid)
  • Revision ID: james.westby@ubuntu.com-20110902141233-zbj0ygxb92u6gy4z
Tags: 3.4-1
http://bugs.debian.org/637147
* New upstream release
  - add a new NetcgiRequire directive to ease dependency management
    (Closes: #637147)
  - remove patches that were applied upstream:
    + Added-missing-shebang-lines-in-example-shell-scripts
    + Try-also-ocamlc-for-POSIX-threads

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/netstring/netauth.ml
 
1
(* $Id: netauth.ml 1543 2011-02-08 02:08:35Z gerd $ *)
 
2
 
 
3
let xor_s s u =
 
4
  let s_len = String.length s in
 
5
  let u_len = String.length u in
 
6
  assert(s_len = u_len);
 
7
  let x = String.create s_len in
 
8
  for k = 0 to s_len-1 do
 
9
    x.[k] <- Char.chr ((Char.code s.[k]) lxor (Char.code u.[k]))
 
10
  done;
 
11
  x
 
12
 
 
13
let hmac ~h ~b ~l ~k ~message =
 
14
  if String.length k > b then
 
15
    failwith "Netauth.hmac: key too long";
 
16
  
 
17
  let k_padded = k ^ String.make (b - String.length k) '\000' in
 
18
  let ipad = String.make b '\x36' in
 
19
  let opad = String.make b '\x5c' in
 
20
  h((xor_s k_padded opad) ^ (h ((xor_s k_padded ipad) ^ message)))
 
21
 
 
22
let add_1_complement s1 s2 =
 
23
  (* Add two bitstrings s1 and s2 (in big-endian order) with one's complement
 
24
     addition
 
25
   *)
 
26
  let l1 = String.length s1 in
 
27
  let l2 = String.length s2 in
 
28
  if l1 <> l2 then
 
29
    invalid_arg "Netauth.add_1_complement";
 
30
  let r = String.make l1 '\000' in
 
31
  let carry = ref 0 in
 
32
  for k = l1-1 downto 0 do
 
33
    let i1 = Char.code s1.[k] in
 
34
    let i2 = Char.code s2.[k] in
 
35
    let sum = i1 + i2 + !carry in
 
36
    r.[k] <- Char.chr (sum land 0xff);
 
37
    carry := if sum > 0xff then 1 else 0;
 
38
  done;
 
39
  if !carry > 0 then (
 
40
    for k = l1-1 downto 0 do
 
41
      let i = Char.code r.[k] in
 
42
      let sum = i + !carry in
 
43
      r.[k] <- Char.chr (sum land 0xff);
 
44
      carry := if sum > 0xff then 1 else 0;
 
45
    done
 
46
  );
 
47
  r
 
48
 
 
49
 
 
50
let rotate_right n s =
 
51
  (* Rotate the (big-endian) bitstring s to the right by n bits *)
 
52
  let l = String.length s in
 
53
  let b = 8 * l in  (* bit length of s *)
 
54
  let n' = n mod b in
 
55
  let n' = if n' < 0 then b+n' else n' in
 
56
  let u = String.create l in
 
57
  (* First byte-shift the string, then bit-shift the remaining 0-7 bits *)
 
58
  let bytes = n' lsr 3 in
 
59
  let bits = n' land 7 in
 
60
  String.blit s 0 u bytes (l-bytes);
 
61
  if bytes > 0 then
 
62
    String.blit s (l-bytes) u 0 bytes;
 
63
  let mask =
 
64
    match bits with
 
65
      | 0 -> 0
 
66
      | 1 -> 1
 
67
      | 2 -> 3
 
68
      | 3 -> 7 
 
69
      | 4 -> 15
 
70
      | 5 -> 31
 
71
      | 6 -> 63
 
72
      | 7 -> 127 
 
73
      | _ -> assert false in
 
74
  let carry = ref 0 in
 
75
  if bits > 0 && l > 0 then (
 
76
    for k = 0 to l-1 do
 
77
      let x = Char.code u.[k] in
 
78
      u.[k] <- Char.chr ((x lsr bits) lor (!carry lsl (8-bits)));
 
79
      carry := x land mask;
 
80
    done;
 
81
    u.[0] <- Char.chr((Char.code u.[0]) lor (!carry lsl (8-bits)));
 
82
  );
 
83
  u
 
84
 
 
85
let n_fold n s =
 
86
  (** n-fold the number given by the bitstring s. The length of the number
 
87
      is taken as the byte-length of s. n must be divisible by 8.
 
88
   *)
 
89
  if n=0 || n mod 8 <> 0 then
 
90
    invalid_arg "Netauth.n_fold";
 
91
  let p = n / 8 in
 
92
  let buf = Buffer.create (String.length s) in
 
93
  let rec add_rot u len =
 
94
    if len > 0 && len mod p = 0 then
 
95
      ()
 
96
    else (
 
97
      Buffer.add_string buf u;
 
98
      add_rot (rotate_right 13 u) (len+String.length u)
 
99
    ) in
 
100
  add_rot s 0;
 
101
  let blen = Buffer.length buf in
 
102
  let s = ref (Buffer.sub buf 0 p) in
 
103
  for k = 1 to (blen / p) - 1 do
 
104
    s := add_1_complement !s (Buffer.sub buf (k*p) p)
 
105
  done;
 
106
  !s
 
107
 
 
108
 
 
109
type key_type =
 
110
    [ `Kc | `Ke | `Ki ]
 
111
 
 
112
let k_truncate k s =
 
113
  let b = k/8 in
 
114
  String.sub s 0 b
 
115
 
 
116
let derive_key_rfc3961_simplified
 
117
      ~encrypt ~random_to_key ~block_size ~k ~usage ~key_type =
 
118
  if block_size < 40 then
 
119
    invalid_arg "Netauth.derive_key_rfc3961: bad block_size";
 
120
  if k <= 0 || k mod 8 <> 0 then
 
121
    invalid_arg "Netauth.derive_key_rfc3961: bad k";
 
122
  if usage < 0 || usage > 255 then
 
123
    invalid_arg "Netauth.derive_key_rfc3961: bad usage (only 0-255 allowed)";
 
124
  let usage_s =
 
125
    String.make 3 '\000' ^ String.make 1 (Char.chr usage) ^
 
126
      (match key_type with
 
127
         | `Kc -> "\x99"
 
128
         | `Ke -> "\xaa"
 
129
         | `Ki -> "\x55"
 
130
      ) in
 
131
  let usage_exp = n_fold block_size usage_s in
 
132
  let kbuf = Buffer.create 80 in
 
133
  let ki = ref (encrypt usage_exp) in
 
134
  Buffer.add_string kbuf !ki;
 
135
  while 8*(Buffer.length kbuf) < k do
 
136
    ki := encrypt !ki;
 
137
    Buffer.add_string kbuf !ki
 
138
  done;
 
139
  let derived_random = k_truncate k (Buffer.contents kbuf) in
 
140
  random_to_key derived_random