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-2021, 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 32with System; use System; 33with Interfaces; use Interfaces; 34 35package 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 not null access procedure 42 (M : in out Message_State; 43 SEA : Stream_Element_Array; 44 First : Stream_Element_Offset; 45 Last : out Stream_Element_Offset); 46 -- A procedure to transfer data from SEA, 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 SEA : Stream_Element_Array; 53 First : Stream_Element_Offset; 54 Last : out Stream_Element_Offset); 55 -- Transfer procedure which just copies data from S to M 56 57 procedure Fill_Buffer_Swap 58 (M : in out Message_State; 59 SEA : Stream_Element_Array; 60 First : Stream_Element_Offset; 61 Last : out Stream_Element_Offset); 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 SEA : Stream_Element_Array; 79 First : Stream_Element_Offset; 80 Last : out Stream_Element_Offset) 81 is 82 Buf_SEA : Stream_Element_Array (M.Buffer'Range); 83 for Buf_SEA'Address use M.Buffer'Address; 84 pragma Import (Ada, Buf_SEA); 85 86 Length : constant Stream_Element_Offset := 87 Stream_Element_Offset'Min 88 (M.Block_Length - M.Last, SEA'Last - First + 1); 89 90 begin 91 pragma Assert (Length > 0); 92 93 Buf_SEA (M.Last + 1 .. M.Last + Length) := 94 SEA (First .. First + Length - 1); 95 M.Last := M.Last + Length; 96 Last := First + Length - 1; 97 end Fill_Buffer_Copy; 98 99 ---------------------- 100 -- Fill_Buffer_Swap -- 101 ---------------------- 102 103 procedure Fill_Buffer_Swap 104 (M : in out Message_State; 105 SEA : Stream_Element_Array; 106 First : Stream_Element_Offset; 107 Last : out Stream_Element_Offset) 108 is 109 pragma Assert (SEA'Length mod 2 = 0); 110 Length : constant Stream_Element_Offset := 111 Stream_Element_Offset'Min 112 (M.Block_Length - M.Last, SEA'Last - First + 1); 113 begin 114 Last := First; 115 while Last - First < Length loop 116 M.Buffer (M.Last + 1 + Last - First) := 117 (if (Last - SEA'First) mod 2 = 0 118 then SEA (Last + 1) 119 else SEA (Last - 1)); 120 Last := Last + 1; 121 end loop; 122 M.Last := M.Last + Length; 123 Last := First + Length - 1; 124 end Fill_Buffer_Swap; 125 126 --------------- 127 -- To_String -- 128 --------------- 129 130 procedure To_String (SEA : Stream_Element_Array; S : out String) is 131 pragma Assert (S'Length = 2 * SEA'Length); 132 begin 133 for J in SEA'Range loop 134 declare 135 S_J : constant Natural := 1 + Natural (J - SEA'First) * 2; 136 begin 137 S (S_J) := Hex_Digit (SEA (J) / 16); 138 S (S_J + 1) := Hex_Digit (SEA (J) mod 16); 139 end; 140 end loop; 141 end To_String; 142 143 ------- 144 -- H -- 145 ------- 146 147 package body H is 148 149 procedure Update 150 (C : in out Context; 151 SEA : Stream_Element_Array; 152 Fill_Buffer : Fill_Buffer_Access); 153 -- Internal common routine for all Update procedures 154 155 procedure Final 156 (C : Context; 157 Hash_Bits : out Ada.Streams.Stream_Element_Array); 158 -- Perform final hashing operations (data padding) and extract the 159 -- (possibly truncated) state of C into Hash_Bits. 160 161 ------------ 162 -- Digest -- 163 ------------ 164 165 function Digest (C : Context) return Message_Digest is 166 Hash_Bits : Stream_Element_Array (1 .. Hash_Length); 167 begin 168 Final (C, Hash_Bits); 169 return MD : Message_Digest do 170 To_String (Hash_Bits, MD); 171 end return; 172 end Digest; 173 174 function Digest (S : String) return Message_Digest is 175 C : Context; 176 begin 177 Update (C, S); 178 return Digest (C); 179 end Digest; 180 181 function Digest (A : Stream_Element_Array) return Message_Digest is 182 C : Context; 183 begin 184 Update (C, A); 185 return Digest (C); 186 end Digest; 187 188 function Digest (C : Context) return Binary_Message_Digest is 189 Hash_Bits : Stream_Element_Array (1 .. 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 : Stream_Element_Count; 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 Stream_Element_Count := 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 : Stream_Element_Array (1 .. 1 + Zeroes + Size_Length) := 241 [1 => 128, others => 0]; 242 243 Index : Stream_Element_Offset; 244 First_Index : Stream_Element_Offset; 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) := Stream_Element 259 (Shift_Left (Message_Length and 16#1f#, 3)); 260 Message_Length := Shift_Right (Message_Length, 5); 261 262 else 263 Pad (Index) := Stream_Element (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 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 SEA : Stream_Element_Array; 365 Fill_Buffer : Fill_Buffer_Access) 366 is 367 First, Last : Stream_Element_Offset; 368 369 begin 370 if SEA'Length = 0 then 371 return; 372 end if; 373 374 C.M_State.Length := C.M_State.Length + SEA'Length; 375 376 First := SEA'First; 377 loop 378 Fill_Buffer (C.M_State, SEA, First, Last); 379 380 if C.M_State.Last = Block_Length then 381 Transform (C.H_State, C.M_State); 382 C.M_State.Last := 0; 383 end if; 384 385 exit when Last = SEA'Last; 386 First := Last + 1; 387 end loop; 388 end Update; 389 390 ------------ 391 -- Update -- 392 ------------ 393 394 procedure Update (C : in out Context; Input : Stream_Element_Array) is 395 begin 396 Update (C, Input, Fill_Buffer_Copy'Access); 397 end Update; 398 399 ------------ 400 -- Update -- 401 ------------ 402 403 procedure Update (C : in out Context; Input : String) is 404 pragma Assert (Input'Length <= Stream_Element_Offset'Last); 405 SEA : Stream_Element_Array (1 .. Input'Length); 406 for SEA'Address use Input'Address; 407 pragma Import (Ada, SEA); 408 begin 409 Update (C, SEA, Fill_Buffer_Copy'Access); 410 end Update; 411 412 ----------------- 413 -- Wide_Update -- 414 ----------------- 415 416 procedure Wide_Update (C : in out Context; Input : Wide_String) is 417 SEA : Stream_Element_Array (1 .. 2 * Input'Length); 418 for SEA'Address use Input'Address; 419 pragma Import (Ada, SEA); 420 begin 421 Update 422 (C, SEA, 423 (if System.Default_Bit_Order /= Low_Order_First 424 then Fill_Buffer_Swap'Access 425 else Fill_Buffer_Copy'Access)); 426 end Wide_Update; 427 428 ----------------- 429 -- Wide_Digest -- 430 ----------------- 431 432 function Wide_Digest (W : Wide_String) return Message_Digest is 433 C : Context; 434 begin 435 Wide_Update (C, W); 436 return Digest (C); 437 end Wide_Digest; 438 439 function Wide_Digest (W : Wide_String) return Binary_Message_Digest is 440 C : Context; 441 begin 442 Wide_Update (C, W); 443 return Digest (C); 444 end Wide_Digest; 445 446 ----------- 447 -- Write -- 448 ----------- 449 450 procedure Write 451 (Stream : in out Hash_Stream; 452 Item : Stream_Element_Array) 453 is 454 begin 455 Update (Stream.C.all, Item); 456 end Write; 457 458 end H; 459 460 ------------------------- 461 -- Hash_Function_State -- 462 ------------------------- 463 464 package body Hash_Function_State is 465 466 ------------- 467 -- To_Hash -- 468 ------------- 469 470 procedure To_Hash (H : State; H_Bits : out Stream_Element_Array) is 471 Hash_Words : constant Stream_Element_Offset := H'Size / Word'Size; 472 Result : State (1 .. Hash_Words) := 473 H (H'Last - Hash_Words + 1 .. H'Last); 474 475 R_SEA : Stream_Element_Array (1 .. Result'Size / 8); 476 for R_SEA'Address use Result'Address; 477 pragma Import (Ada, R_SEA); 478 479 begin 480 if System.Default_Bit_Order /= Hash_Bit_Order then 481 for J in Result'Range loop 482 Swap (Result (J)'Address); 483 end loop; 484 end if; 485 486 -- Return truncated hash 487 488 pragma Assert (H_Bits'Length <= R_SEA'Length); 489 H_Bits := R_SEA (R_SEA'First .. R_SEA'First + H_Bits'Length - 1); 490 end To_Hash; 491 492 end Hash_Function_State; 493 494end GNAT.Secure_Hashes; 495