|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT LIBRARY COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- G N A T . S E C U R E _ H A S H E S --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
|
9 -- Copyright (C) 2009-2017, Free Software Foundation, Inc. --
|
|
|
10 -- --
|
|
|
11 -- GNAT is free software; you can redistribute it and/or modify it under --
|
|
|
12 -- terms of the GNU General Public License as published by the Free Soft- --
|
|
|
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
|
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
|
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
|
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
|
|
|
17 -- --
|
|
|
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
|
|
|
19 -- additional permissions described in the GCC Runtime Library Exception, --
|
|
|
20 -- version 3.1, as published by the Free Software Foundation. --
|
|
|
21 -- --
|
|
|
22 -- You should have received a copy of the GNU General Public License and --
|
|
|
23 -- a copy of the GCC Runtime Library Exception along with this program; --
|
|
|
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
|
|
25 -- <http://www.gnu.org/licenses/>. --
|
|
|
26 -- --
|
|
|
27 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
29 -- --
|
|
|
30 ------------------------------------------------------------------------------
|
|
|
31
|
|
|
32 with System; use System;
|
|
|
33 with Interfaces; use Interfaces;
|
|
|
34
|
|
|
35 package body GNAT.Secure_Hashes is
|
|
|
36
|
|
|
37 Hex_Digit : constant array (Stream_Element range 0 .. 15) of Character :=
|
|
|
38 "0123456789abcdef";
|
|
|
39
|
|
|
40 type Fill_Buffer_Access is
|
|
|
41 access procedure
|
|
|
42 (M : in out Message_State;
|
|
|
43 S : String;
|
|
|
44 First : Natural;
|
|
|
45 Last : out Natural);
|
|
|
46 -- A procedure to transfer data from S, starting at First, into M's block
|
|
|
47 -- buffer until either the block buffer is full or all data from S has been
|
|
|
48 -- consumed.
|
|
|
49
|
|
|
50 procedure Fill_Buffer_Copy
|
|
|
51 (M : in out Message_State;
|
|
|
52 S : String;
|
|
|
53 First : Natural;
|
|
|
54 Last : out Natural);
|
|
|
55 -- Transfer procedure which just copies data from S to M
|
|
|
56
|
|
|
57 procedure Fill_Buffer_Swap
|
|
|
58 (M : in out Message_State;
|
|
|
59 S : String;
|
|
|
60 First : Natural;
|
|
|
61 Last : out Natural);
|
|
|
62 -- Transfer procedure which swaps bytes from S when copying into M. S must
|
|
|
63 -- have even length. Note that the swapping is performed considering pairs
|
|
|
64 -- starting at S'First, even if S'First /= First (that is, if
|
|
|
65 -- First = S'First then the first copied byte is always S (S'First + 1),
|
|
|
66 -- and if First = S'First + 1 then the first copied byte is always
|
|
|
67 -- S (S'First).
|
|
|
68
|
|
|
69 procedure To_String (SEA : Stream_Element_Array; S : out String);
|
|
|
70 -- Return the hexadecimal representation of SEA
|
|
|
71
|
|
|
72 ----------------------
|
|
|
73 -- Fill_Buffer_Copy --
|
|
|
74 ----------------------
|
|
|
75
|
|
|
76 procedure Fill_Buffer_Copy
|
|
|
77 (M : in out Message_State;
|
|
|
78 S : String;
|
|
|
79 First : Natural;
|
|
|
80 Last : out Natural)
|
|
|
81 is
|
|
|
82 Buf_String : String (M.Buffer'Range);
|
|
|
83 for Buf_String'Address use M.Buffer'Address;
|
|
|
84 pragma Import (Ada, Buf_String);
|
|
|
85
|
|
|
86 Length : constant Natural :=
|
|
|
87 Natural'Min (M.Block_Length - M.Last, S'Last - First + 1);
|
|
|
88
|
|
|
89 begin
|
|
|
90 pragma Assert (Length > 0);
|
|
|
91
|
|
|
92 Buf_String (M.Last + 1 .. M.Last + Length) :=
|
|
|
93 S (First .. First + Length - 1);
|
|
|
94 M.Last := M.Last + Length;
|
|
|
95 Last := First + Length - 1;
|
|
|
96 end Fill_Buffer_Copy;
|
|
|
97
|
|
|
98 ----------------------
|
|
|
99 -- Fill_Buffer_Swap --
|
|
|
100 ----------------------
|
|
|
101
|
|
|
102 procedure Fill_Buffer_Swap
|
|
|
103 (M : in out Message_State;
|
|
|
104 S : String;
|
|
|
105 First : Natural;
|
|
|
106 Last : out Natural)
|
|
|
107 is
|
|
|
108 pragma Assert (S'Length mod 2 = 0);
|
|
|
109 Length : constant Natural :=
|
|
|
110 Natural'Min (M.Block_Length - M.Last, S'Last - First + 1);
|
|
|
111 begin
|
|
|
112 Last := First;
|
|
|
113 while Last - First < Length loop
|
|
|
114 M.Buffer (M.Last + 1 + Last - First) :=
|
|
|
115 (if (Last - S'First) mod 2 = 0
|
|
|
116 then S (Last + 1)
|
|
|
117 else S (Last - 1));
|
|
|
118 Last := Last + 1;
|
|
|
119 end loop;
|
|
|
120 M.Last := M.Last + Length;
|
|
|
121 Last := First + Length - 1;
|
|
|
122 end Fill_Buffer_Swap;
|
|
|
123
|
|
|
124 ---------------
|
|
|
125 -- To_String --
|
|
|
126 ---------------
|
|
|
127
|
|
|
128 procedure To_String (SEA : Stream_Element_Array; S : out String) is
|
|
|
129 pragma Assert (S'Length = 2 * SEA'Length);
|
|
|
130 begin
|
|
|
131 for J in SEA'Range loop
|
|
|
132 declare
|
|
|
133 S_J : constant Natural := 1 + Natural (J - SEA'First) * 2;
|
|
|
134 begin
|
|
|
135 S (S_J) := Hex_Digit (SEA (J) / 16);
|
|
|
136 S (S_J + 1) := Hex_Digit (SEA (J) mod 16);
|
|
|
137 end;
|
|
|
138 end loop;
|
|
|
139 end To_String;
|
|
|
140
|
|
|
141 -------
|
|
|
142 -- H --
|
|
|
143 -------
|
|
|
144
|
|
|
145 package body H is
|
|
|
146
|
|
|
147 procedure Update
|
|
|
148 (C : in out Context;
|
|
|
149 S : String;
|
|
|
150 Fill_Buffer : Fill_Buffer_Access);
|
|
|
151 -- Internal common routine for all Update procedures
|
|
|
152
|
|
|
153 procedure Final
|
|
|
154 (C : Context;
|
|
|
155 Hash_Bits : out Ada.Streams.Stream_Element_Array);
|
|
|
156 -- Perform final hashing operations (data padding) and extract the
|
|
|
157 -- (possibly truncated) state of C into Hash_Bits.
|
|
|
158
|
|
|
159 ------------
|
|
|
160 -- Digest --
|
|
|
161 ------------
|
|
|
162
|
|
|
163 function Digest (C : Context) return Message_Digest is
|
|
|
164 Hash_Bits : Stream_Element_Array
|
|
|
165 (1 .. Stream_Element_Offset (Hash_Length));
|
|
|
166 begin
|
|
|
167 Final (C, Hash_Bits);
|
|
|
168 return MD : Message_Digest do
|
|
|
169 To_String (Hash_Bits, MD);
|
|
|
170 end return;
|
|
|
171 end Digest;
|
|
|
172
|
|
|
173 function Digest (S : String) return Message_Digest is
|
|
|
174 C : Context;
|
|
|
175 begin
|
|
|
176 Update (C, S);
|
|
|
177 return Digest (C);
|
|
|
178 end Digest;
|
|
|
179
|
|
|
180 function Digest (A : Stream_Element_Array) return Message_Digest is
|
|
|
181 C : Context;
|
|
|
182 begin
|
|
|
183 Update (C, A);
|
|
|
184 return Digest (C);
|
|
|
185 end Digest;
|
|
|
186
|
|
|
187 function Digest (C : Context) return Binary_Message_Digest is
|
|
|
188 Hash_Bits : Stream_Element_Array
|
|
|
189 (1 .. Stream_Element_Offset (Hash_Length));
|
|
|
190 begin
|
|
|
191 Final (C, Hash_Bits);
|
|
|
192 return Hash_Bits;
|
|
|
193 end Digest;
|
|
|
194
|
|
|
195 function Digest (S : String) return Binary_Message_Digest is
|
|
|
196 C : Context;
|
|
|
197 begin
|
|
|
198 Update (C, S);
|
|
|
199 return Digest (C);
|
|
|
200 end Digest;
|
|
|
201
|
|
|
202 function Digest
|
|
|
203 (A : Stream_Element_Array) return Binary_Message_Digest
|
|
|
204 is
|
|
|
205 C : Context;
|
|
|
206 begin
|
|
|
207 Update (C, A);
|
|
|
208 return Digest (C);
|
|
|
209 end Digest;
|
|
|
210
|
|
|
211 -----------
|
|
|
212 -- Final --
|
|
|
213 -----------
|
|
|
214
|
|
|
215 -- Once a complete message has been processed, it is padded with one 1
|
|
|
216 -- bit followed by enough 0 bits so that the last block is 2 * Word'Size
|
|
|
217 -- bits short of being completed. The last 2 * Word'Size bits are set to
|
|
|
218 -- the message size in bits (excluding padding).
|
|
|
219
|
|
|
220 procedure Final
|
|
|
221 (C : Context;
|
|
|
222 Hash_Bits : out Stream_Element_Array)
|
|
|
223 is
|
|
|
224 FC : Context := C;
|
|
|
225
|
|
|
226 Zeroes : Natural;
|
|
|
227 -- Number of 0 bytes in padding
|
|
|
228
|
|
|
229 Message_Length : Unsigned_64 := FC.M_State.Length;
|
|
|
230 -- Message length in bytes
|
|
|
231
|
|
|
232 Size_Length : constant Natural :=
|
|
|
233 2 * Hash_State.Word'Size / 8;
|
|
|
234 -- Length in bytes of the size representation
|
|
|
235
|
|
|
236 begin
|
|
|
237 Zeroes := (Block_Length - 1 - Size_Length - FC.M_State.Last)
|
|
|
238 mod FC.M_State.Block_Length;
|
|
|
239 declare
|
|
|
240 Pad : String (1 .. 1 + Zeroes + Size_Length) :=
|
|
|
241 (1 => Character'Val (128), others => ASCII.NUL);
|
|
|
242
|
|
|
243 Index : Natural;
|
|
|
244 First_Index : Natural;
|
|
|
245
|
|
|
246 begin
|
|
|
247 First_Index := (if Hash_Bit_Order = Low_Order_First
|
|
|
248 then Pad'Last - Size_Length + 1
|
|
|
249 else Pad'Last);
|
|
|
250
|
|
|
251 Index := First_Index;
|
|
|
252 while Message_Length > 0 loop
|
|
|
253 if Index = First_Index then
|
|
|
254
|
|
|
255 -- Message_Length is in bytes, but we need to store it as
|
|
|
256 -- a bit count.
|
|
|
257
|
|
|
258 Pad (Index) := Character'Val
|
|
|
259 (Shift_Left (Message_Length and 16#1f#, 3));
|
|
|
260 Message_Length := Shift_Right (Message_Length, 5);
|
|
|
261
|
|
|
262 else
|
|
|
263 Pad (Index) := Character'Val (Message_Length and 16#ff#);
|
|
|
264 Message_Length := Shift_Right (Message_Length, 8);
|
|
|
265 end if;
|
|
|
266
|
|
|
267 Index := Index +
|
|
|
268 (if Hash_Bit_Order = Low_Order_First then 1 else -1);
|
|
|
269 end loop;
|
|
|
270
|
|
|
271 Update (FC, Pad);
|
|
|
272 end;
|
|
|
273
|
|
|
274 pragma Assert (FC.M_State.Last = 0);
|
|
|
275
|
|
|
276 Hash_State.To_Hash (FC.H_State, Hash_Bits);
|
|
|
277
|
|
|
278 -- HMAC case: hash outer pad
|
|
|
279
|
|
|
280 if C.KL /= 0 then
|
|
|
281 declare
|
|
|
282 Outer_C : Context;
|
|
|
283 Opad : Stream_Element_Array :=
|
|
|
284 (1 .. Stream_Element_Offset (Block_Length) => 16#5c#);
|
|
|
285
|
|
|
286 begin
|
|
|
287 for J in C.Key'Range loop
|
|
|
288 Opad (J) := Opad (J) xor C.Key (J);
|
|
|
289 end loop;
|
|
|
290
|
|
|
291 Update (Outer_C, Opad);
|
|
|
292 Update (Outer_C, Hash_Bits);
|
|
|
293
|
|
|
294 Final (Outer_C, Hash_Bits);
|
|
|
295 end;
|
|
|
296 end if;
|
|
|
297 end Final;
|
|
|
298
|
|
|
299 --------------------------
|
|
|
300 -- HMAC_Initial_Context --
|
|
|
301 --------------------------
|
|
|
302
|
|
|
303 function HMAC_Initial_Context (Key : String) return Context is
|
|
|
304 begin
|
|
|
305 if Key'Length = 0 then
|
|
|
306 raise Constraint_Error with "null key";
|
|
|
307 end if;
|
|
|
308
|
|
|
309 return C : Context (KL => (if Key'Length <= Key_Length'Last
|
|
|
310 then Key'Length
|
|
|
311 else Stream_Element_Offset (Hash_Length)))
|
|
|
312 do
|
|
|
313 -- Set Key (if longer than block length, first hash it)
|
|
|
314
|
|
|
315 if C.KL = Key'Length then
|
|
|
316 declare
|
|
|
317 SK : String (1 .. Key'Length);
|
|
|
318 for SK'Address use C.Key'Address;
|
|
|
319 pragma Import (Ada, SK);
|
|
|
320 begin
|
|
|
321 SK := Key;
|
|
|
322 end;
|
|
|
323
|
|
|
324 else
|
|
|
325 C.Key := Digest (Key);
|
|
|
326 end if;
|
|
|
327
|
|
|
328 -- Hash inner pad
|
|
|
329
|
|
|
330 declare
|
|
|
331 Ipad : Stream_Element_Array :=
|
|
|
332 (1 .. Stream_Element_Offset (Block_Length) => 16#36#);
|
|
|
333
|
|
|
334 begin
|
|
|
335 for J in C.Key'Range loop
|
|
|
336 Ipad (J) := Ipad (J) xor C.Key (J);
|
|
|
337 end loop;
|
|
|
338
|
|
|
339 Update (C, Ipad);
|
|
|
340 end;
|
|
|
341 end return;
|
|
|
342 end HMAC_Initial_Context;
|
|
|
343
|
|
|
344 ----------
|
|
|
345 -- Read --
|
|
|
346 ----------
|
|
|
347
|
|
|
348 procedure Read
|
|
|
349 (Stream : in out Hash_Stream;
|
|
|
350 Item : out Stream_Element_Array;
|
|
|
351 Last : out Stream_Element_Offset)
|
|
|
352 is
|
|
|
353 pragma Unreferenced (Stream, Item, Last);
|
|
|
354 begin
|
|
|
355 raise Program_Error with "Hash_Stream is write-only";
|
|
|
356 end Read;
|
|
|
357
|
|
|
358 ------------
|
|
|
359 -- Update --
|
|
|
360 ------------
|
|
|
361
|
|
|
362 procedure Update
|
|
|
363 (C : in out Context;
|
|
|
364 S : String;
|
|
|
365 Fill_Buffer : Fill_Buffer_Access)
|
|
|
366 is
|
|
|
367 Last : Natural;
|
|
|
368
|
|
|
369 begin
|
|
|
370 C.M_State.Length := C.M_State.Length + S'Length;
|
|
|
371
|
|
|
372 Last := S'First - 1;
|
|
|
373 while Last < S'Last loop
|
|
|
374 Fill_Buffer (C.M_State, S, Last + 1, Last);
|
|
|
375
|
|
|
376 if C.M_State.Last = Block_Length then
|
|
|
377 Transform (C.H_State, C.M_State);
|
|
|
378 C.M_State.Last := 0;
|
|
|
379 end if;
|
|
|
380 end loop;
|
|
|
381 end Update;
|
|
|
382
|
|
|
383 ------------
|
|
|
384 -- Update --
|
|
|
385 ------------
|
|
|
386
|
|
|
387 procedure Update (C : in out Context; Input : String) is
|
|
|
388 begin
|
|
|
389 Update (C, Input, Fill_Buffer_Copy'Access);
|
|
|
390 end Update;
|
|
|
391
|
|
|
392 ------------
|
|
|
393 -- Update --
|
|
|
394 ------------
|
|
|
395
|
|
|
396 procedure Update (C : in out Context; Input : Stream_Element_Array) is
|
|
|
397 S : String (1 .. Input'Length);
|
|
|
398 for S'Address use Input'Address;
|
|
|
399 pragma Import (Ada, S);
|
|
|
400 begin
|
|
|
401 Update (C, S, Fill_Buffer_Copy'Access);
|
|
|
402 end Update;
|
|
|
403
|
|
|
404 -----------------
|
|
|
405 -- Wide_Update --
|
|
|
406 -----------------
|
|
|
407
|
|
|
408 procedure Wide_Update (C : in out Context; Input : Wide_String) is
|
|
|
409 S : String (1 .. 2 * Input'Length);
|
|
|
410 for S'Address use Input'Address;
|
|
|
411 pragma Import (Ada, S);
|
|
|
412 begin
|
|
|
413 Update
|
|
|
414 (C, S,
|
|
|
415 (if System.Default_Bit_Order /= Low_Order_First
|
|
|
416 then Fill_Buffer_Swap'Access
|
|
|
417 else Fill_Buffer_Copy'Access));
|
|
|
418 end Wide_Update;
|
|
|
419
|
|
|
420 -----------------
|
|
|
421 -- Wide_Digest --
|
|
|
422 -----------------
|
|
|
423
|
|
|
424 function Wide_Digest (W : Wide_String) return Message_Digest is
|
|
|
425 C : Context;
|
|
|
426 begin
|
|
|
427 Wide_Update (C, W);
|
|
|
428 return Digest (C);
|
|
|
429 end Wide_Digest;
|
|
|
430
|
|
|
431 function Wide_Digest (W : Wide_String) return Binary_Message_Digest is
|
|
|
432 C : Context;
|
|
|
433 begin
|
|
|
434 Wide_Update (C, W);
|
|
|
435 return Digest (C);
|
|
|
436 end Wide_Digest;
|
|
|
437
|
|
|
438 -----------
|
|
|
439 -- Write --
|
|
|
440 -----------
|
|
|
441
|
|
|
442 procedure Write
|
|
|
443 (Stream : in out Hash_Stream;
|
|
|
444 Item : Stream_Element_Array)
|
|
|
445 is
|
|
|
446 begin
|
|
|
447 Update (Stream.C.all, Item);
|
|
|
448 end Write;
|
|
|
449
|
|
|
450 end H;
|
|
|
451
|
|
|
452 -------------------------
|
|
|
453 -- Hash_Function_State --
|
|
|
454 -------------------------
|
|
|
455
|
|
|
456 package body Hash_Function_State is
|
|
|
457
|
|
|
458 -------------
|
|
|
459 -- To_Hash --
|
|
|
460 -------------
|
|
|
461
|
|
|
462 procedure To_Hash (H : State; H_Bits : out Stream_Element_Array) is
|
|
|
463 Hash_Words : constant Natural := H'Size / Word'Size;
|
|
|
464 Result : State (1 .. Hash_Words) :=
|
|
|
465 H (H'Last - Hash_Words + 1 .. H'Last);
|
|
|
466
|
|
|
467 R_SEA : Stream_Element_Array (1 .. Result'Size / 8);
|
|
|
468 for R_SEA'Address use Result'Address;
|
|
|
469 pragma Import (Ada, R_SEA);
|
|
|
470
|
|
|
471 begin
|
|
|
472 if System.Default_Bit_Order /= Hash_Bit_Order then
|
|
|
473 for J in Result'Range loop
|
|
|
474 Swap (Result (J)'Address);
|
|
|
475 end loop;
|
|
|
476 end if;
|
|
|
477
|
|
|
478 -- Return truncated hash
|
|
|
479
|
|
|
480 pragma Assert (H_Bits'Length <= R_SEA'Length);
|
|
|
481 H_Bits := R_SEA (R_SEA'First .. R_SEA'First + H_Bits'Length - 1);
|
|
|
482 end To_Hash;
|
|
|
483
|
|
|
484 end Hash_Function_State;
|
|
|
485
|
|
|
486 end GNAT.Secure_Hashes;
|
