gcc/ada/libgnat/g-sechas.adb

   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-2024, 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      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
 494 end GNAT.Secure_Hashes;