gcc/ada/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, 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    use Ada.Streams;
  38
  39    Hex_Digit : constant array (Stream_Element range 0 .. 15) of Character :=
  40                  "0123456789abcdef";
  41
  42    type Fill_Buffer_Access is
  43      access procedure
  44        (M     : in out Message_State;
  45         S     : String;
  46         First : Natural;
  47         Last  : out Natural);
  48    --  A procedure to transfer data from S, starting at First, into M's block
  49    --  buffer until either the block buffer is full or all data from S has been
  50    --  consumed.
  51
  52    procedure Fill_Buffer_Copy
  53      (M     : in out Message_State;
  54       S     : String;
  55       First : Natural;
  56       Last  : out Natural);
  57    --  Transfer procedure which just copies data from S to M
  58
  59    procedure Fill_Buffer_Swap
  60      (M     : in out Message_State;
  61       S     : String;
  62       First : Natural;
  63       Last  : out Natural);
  64    --  Transfer procedure which swaps bytes from S when copying into M. S must
  65    --  have even length. Note that the swapping is performed considering pairs
  66    --  starting at S'First, even if S'First /= First (that is, if
  67    --  First = S'First then the first copied byte is always S (S'First + 1),
  68    --  and if First = S'First + 1 then the first copied byte is always
  69    --  S (S'First).
  70
  71    procedure To_String (SEA : Stream_Element_Array; S : out String);
  72    --  Return the hexadecimal representation of SEA
  73
  74    ----------------------
  75    -- Fill_Buffer_Copy --
  76    ----------------------
  77
  78    procedure Fill_Buffer_Copy
  79      (M     : in out Message_State;
  80       S     : String;
  81       First : Natural;
  82       Last  : out Natural)
  83    is
  84       Buf_String : String (M.Buffer'Range);
  85       for Buf_String'Address use M.Buffer'Address;
  86       pragma Import (Ada, Buf_String);
  87
  88       Length : constant Natural :=
  89                  Natural'Min (M.Block_Length - M.Last, S'Last - First + 1);
  90
  91    begin
  92       pragma Assert (Length > 0);
  93
  94       Buf_String (M.Last + 1 .. M.Last + Length) :=
  95         S (First .. First + Length - 1);
  96       M.Last := M.Last + Length;
  97       Last := First + Length - 1;
  98    end Fill_Buffer_Copy;
  99
 100    ----------------------
 101    -- Fill_Buffer_Swap --
 102    ----------------------
 103
 104    procedure Fill_Buffer_Swap
 105      (M     : in out Message_State;
 106       S     : String;
 107       First : Natural;
 108       Last  : out Natural)
 109    is
 110       pragma Assert (S'Length mod 2 = 0);
 111       Length : constant Natural :=
 112                   Natural'Min (M.Block_Length - M.Last, S'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 - S'First) mod 2 = 0
 118             then S (Last + 1)
 119             else S (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          S           : String;
 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
 167                        (1 .. Stream_Element_Offset (Hash_Length));
 168       begin
 169          Final (C, Hash_Bits);
 170          return MD : Message_Digest do
 171             To_String (Hash_Bits, MD);
 172          end return;
 173       end Digest;
 174
 175       function Digest (S : String) return Message_Digest is
 176          C : Context;
 177       begin
 178          Update (C, S);
 179          return Digest (C);
 180       end Digest;
 181
 182       function Digest (A : Stream_Element_Array) return Message_Digest is
 183          C : Context;
 184       begin
 185          Update (C, A);
 186          return Digest (C);
 187       end Digest;
 188
 189       -----------
 190       -- Final --
 191       -----------
 192
 193       --  Once a complete message has been processed, it is padded with one
 194       --  1 bit followed by enough 0 bits so that the last block is
 195       --  2 * Word'Size bits short of being completed. The last 2 * Word'Size
 196       --  bits are set to the message size in bits (excluding padding).
 197
 198       procedure Final
 199         (C          : Context;
 200          Hash_Bits  : out Stream_Element_Array)
 201       is
 202          FC : Context := C;
 203
 204          Zeroes : Natural;
 205          --  Number of 0 bytes in padding
 206
 207          Message_Length : Unsigned_64 := FC.M_State.Length;
 208          --  Message length in bytes
 209
 210          Size_Length : constant Natural :=
 211                          2 * Hash_State.Word'Size / 8;
 212          --  Length in bytes of the size representation
 213
 214       begin
 215          Zeroes := (Block_Length - 1 - Size_Length - FC.M_State.Last)
 216                      mod FC.M_State.Block_Length;
 217          declare
 218             Pad : String (1 .. 1 + Zeroes + Size_Length) :=
 219                     (1 => Character'Val (128), others => ASCII.NUL);
 220
 221             Index       : Natural;
 222             First_Index : Natural;
 223
 224          begin
 225             First_Index := (if Hash_Bit_Order = Low_Order_First
 226                             then Pad'Last - Size_Length + 1
 227                             else Pad'Last);
 228
 229             Index := First_Index;
 230             while Message_Length > 0 loop
 231                if Index = First_Index then
 232
 233                   --  Message_Length is in bytes, but we need to store it as
 234                   --  a bit count).
 235
 236                   Pad (Index) := Character'Val
 237                                    (Shift_Left (Message_Length and 16#1f#, 3));
 238                   Message_Length := Shift_Right (Message_Length, 5);
 239
 240                else
 241                   Pad (Index) := Character'Val (Message_Length and 16#ff#);
 242                   Message_Length := Shift_Right (Message_Length, 8);
 243                end if;
 244
 245                Index := Index +
 246                           (if Hash_Bit_Order = Low_Order_First then 1 else -1);
 247             end loop;
 248
 249             Update (FC, Pad);
 250          end;
 251
 252          pragma Assert (FC.M_State.Last = 0);
 253
 254          Hash_State.To_Hash (FC.H_State, Hash_Bits);
 255       end Final;
 256
 257       ------------
 258       -- Update --
 259       ------------
 260
 261       procedure Update
 262         (C           : in out Context;
 263          S           : String;
 264          Fill_Buffer : Fill_Buffer_Access)
 265       is
 266          Last : Natural := S'First - 1;
 267
 268       begin
 269          C.M_State.Length := C.M_State.Length + S'Length;
 270
 271          while Last < S'Last loop
 272             Fill_Buffer (C.M_State, S, Last + 1, Last);
 273
 274             if C.M_State.Last = Block_Length then
 275                Transform (C.H_State, C.M_State);
 276                C.M_State.Last := 0;
 277             end if;
 278          end loop;
 279
 280       end Update;
 281
 282       ------------
 283       -- Update --
 284       ------------
 285
 286       procedure Update (C : in out Context; Input : String) is
 287       begin
 288          Update (C, Input, Fill_Buffer_Copy'Access);
 289       end Update;
 290
 291       ------------
 292       -- Update --
 293       ------------
 294
 295       procedure Update (C : in out Context; Input : Stream_Element_Array) is
 296          S : String (1 .. Input'Length);
 297          for S'Address use Input'Address;
 298          pragma Import (Ada, S);
 299       begin
 300          Update (C, S, Fill_Buffer_Copy'Access);
 301       end Update;
 302
 303       -----------------
 304       -- Wide_Update --
 305       -----------------
 306
 307       procedure Wide_Update (C : in out Context; Input : Wide_String) is
 308          S : String (1 .. 2 * Input'Length);
 309          for S'Address use Input'Address;
 310          pragma Import (Ada, S);
 311       begin
 312          Update
 313            (C, S,
 314             (if System.Default_Bit_Order /= Low_Order_First
 315              then Fill_Buffer_Swap'Access
 316              else Fill_Buffer_Copy'Access));
 317       end Wide_Update;
 318
 319       -----------------
 320       -- Wide_Digest --
 321       -----------------
 322
 323       function Wide_Digest (W : Wide_String) return Message_Digest is
 324          C : Context;
 325       begin
 326          Wide_Update (C, W);
 327          return Digest (C);
 328       end Wide_Digest;
 329
 330    end H;
 331
 332    -------------------------
 333    -- Hash_Function_State --
 334    -------------------------
 335
 336    package body Hash_Function_State is
 337
 338       -------------
 339       -- To_Hash --
 340       -------------
 341
 342       procedure To_Hash (H : State; H_Bits : out Stream_Element_Array) is
 343          Hash_Words : constant Natural := H'Size / Word'Size;
 344          Result     : State (1 .. Hash_Words) :=
 345                         H (H'Last - Hash_Words + 1 .. H'Last);
 346
 347          R_SEA : Stream_Element_Array (1 .. Result'Size / 8);
 348          for R_SEA'Address use Result'Address;
 349          pragma Import (Ada, R_SEA);
 350
 351       begin
 352          if System.Default_Bit_Order /= Hash_Bit_Order then
 353             for J in Result'Range loop
 354                Swap (Result (J)'Address);
 355             end loop;
 356          end if;
 357
 358          --  Return truncated hash
 359
 360          pragma Assert (H_Bits'Length <= R_SEA'Length);
 361          H_Bits := R_SEA (R_SEA'First .. R_SEA'First + H_Bits'Length - 1);
 362       end To_Hash;
 363
 364    end Hash_Function_State;
 365
 366 end GNAT.Secure_Hashes;