gcc/ada/s-sechas.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                 S Y S T E M . 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 System.Secure_Hashes is
  36
  37    use Ada.Streams;
  38
  39    Hex_Digit : constant array (Stream_Element range 0 .. 15) of Character :=
  40                  ('0', '1', '2', '3', '4', '5', '6', '7',
  41                   '8', '9', 'a', 'b', 'c', 'd', 'e', 'f');
  42
  43    type Fill_Buffer_Access is
  44      access procedure
  45        (M     : in out Message_State;
  46         S     : String;
  47         First : Natural;
  48         Last  : out Natural);
  49    --  A procedure to transfer data from S into M's block buffer until either
  50    --  the block buffer is full or all data from S has been 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
  65
  66    procedure To_String (SEA : Stream_Element_Array; S : out String);
  67    --  Return the hexadecimal representation of SEA
  68
  69    ----------------------
  70    -- Fill_Buffer_Copy --
  71    ----------------------
  72
  73    procedure Fill_Buffer_Copy
  74      (M     : in out Message_State;
  75       S     : String;
  76       First : Natural;
  77       Last  : out Natural)
  78    is
  79       Buf_String : String (M.Buffer'Range);
  80       for Buf_String'Address use M.Buffer'Address;
  81       pragma Import (Ada, Buf_String);
  82       Length : constant Natural :=
  83                   Natural'Min (M.Block_Length - M.Last, S'Last - First + 1);
  84    begin
  85       pragma Assert (Length > 0);
  86
  87       Buf_String (M.Last + 1 .. M.Last + Length) :=
  88         S (First .. First + Length);
  89       M.Last := M.Last + Length;
  90       Last := First + Length - 1;
  91    end Fill_Buffer_Copy;
  92
  93    ----------------------
  94    -- Fill_Buffer_Swap --
  95    ----------------------
  96
  97    procedure Fill_Buffer_Swap
  98      (M     : in out Message_State;
  99       S     : String;
 100       First : Natural;
 101       Last  : out Natural)
 102    is
 103       Length : constant Natural :=
 104                   Natural'Min (M.Block_Length - M.Last, S'Last - First + 1);
 105    begin
 106       Last := First;
 107       while Last - First < Length loop
 108          M.Buffer (M.Last + 1 + Last - First) :=
 109             (if (Last - First) mod 2 = 0 then S (Last + 1) else S (Last - 1));
 110          Last := Last + 1;
 111       end loop;
 112       M.Last := M.Last + Length;
 113       Last := First + Length - 1;
 114    end Fill_Buffer_Swap;
 115
 116    ---------------
 117    -- To_String --
 118    ---------------
 119
 120    procedure To_String (SEA : Stream_Element_Array; S : out String) is
 121       pragma Assert (S'Length = 2 * SEA'Length);
 122    begin
 123       for J in SEA'Range loop
 124          declare
 125             S_J : constant Natural := 1 + Natural (J - SEA'First) * 2;
 126          begin
 127             S (S_J)     := Hex_Digit (SEA (J) / 16);
 128             S (S_J + 1) := Hex_Digit (SEA (J) mod 16);
 129          end;
 130       end loop;
 131    end To_String;
 132
 133    -------
 134    -- H --
 135    -------
 136
 137    package body H is
 138
 139       procedure Update
 140         (C           : in out Context;
 141          S           : String;
 142          Fill_Buffer : Fill_Buffer_Access);
 143       --  Internal common routine for all Update procedures
 144
 145       procedure Final
 146         (C         : Context;
 147          Hash_Bits : out Ada.Streams.Stream_Element_Array);
 148       --  Perform final hashing operations (data padding) and extract the
 149       --  (possibly truncated) state of C into Hash_Bits.
 150
 151       ------------
 152       -- Digest --
 153       ------------
 154
 155       function Digest (C : Context) return Message_Digest is
 156          Hash_Bits : Stream_Element_Array
 157                        (1 .. Stream_Element_Offset (Hash_Length));
 158       begin
 159          Final (C, Hash_Bits);
 160          return MD : Message_Digest do
 161             To_String (Hash_Bits, MD);
 162          end return;
 163       end Digest;
 164
 165       ------------
 166       -- Digest --
 167       ------------
 168
 169       function Digest (S : String) return Message_Digest is
 170          C : Context;
 171       begin
 172          Update (C, S);
 173          return Digest (C);
 174       end Digest;
 175
 176       ------------
 177       -- Digest --
 178       ------------
 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       -----------
 188       -- Final --
 189       -----------
 190
 191       --  Once a complete message has been processed, it is padded with one
 192       --  1 bit followed by enough 0 bits so that the last block is
 193       --  2 * Word'Size bits short of being completed. The last 2 * Word'Size
 194       --  bits are set to the message size in bits (excluding padding).
 195
 196       procedure Final
 197         (C          : Context;
 198          Hash_Bits  : out Stream_Element_Array)
 199       is
 200          FC : Context := C;
 201
 202          Zeroes : Natural;
 203          --  Number of 0 bytes in padding
 204
 205          Message_Length : Unsigned_64 := FC.M_State.Length;
 206          --  Message length in bytes
 207
 208          Size_Length : constant Natural :=
 209                          2 * Hash_State.Word'Size / 8;
 210          --  Length in bytes of the size representation
 211
 212       begin
 213          Zeroes := (Block_Length - 1 - Size_Length - FC.M_State.Last)
 214                      mod FC.M_State.Block_Length;
 215          declare
 216             Pad : String (1 .. 1 + Zeroes + Size_Length) :=
 217                     (1 => Character'Val (128), others => ASCII.NUL);
 218             Index : Natural;
 219             First_Index : Natural;
 220          begin
 221             First_Index := (if Hash_Bit_Order = Low_Order_First then
 222                               Pad'Last - Size_Length + 1
 223                             else
 224                               Pad'Last);
 225
 226             Index := First_Index;
 227             while Message_Length > 0 loop
 228                if Index = First_Index then
 229                   --  Message_Length is in bytes, but we need to store it as
 230                   --  a bit count).
 231
 232                   Pad (Index) := Character'Val
 233                                    (Shift_Left (Message_Length and 16#1f#, 3));
 234                   Message_Length := Shift_Right (Message_Length, 5);
 235                else
 236                   Pad (Index) := Character'Val (Message_Length and 16#ff#);
 237                   Message_Length := Shift_Right (Message_Length, 8);
 238                end if;
 239                Index := Index +
 240                           (if Hash_Bit_Order = Low_Order_First then 1 else -1);
 241             end loop;
 242
 243             Update (FC, Pad);
 244          end;
 245
 246          pragma Assert (FC.M_State.Last = 0);
 247
 248          Hash_State.To_Hash (FC.H_State, Hash_Bits);
 249       end Final;
 250
 251       ------------
 252       -- Update --
 253       ------------
 254
 255       procedure Update
 256         (C           : in out Context;
 257          S           : String;
 258          Fill_Buffer : Fill_Buffer_Access)
 259       is
 260          Last : Natural := S'First - 1;
 261       begin
 262          C.M_State.Length := C.M_State.Length + S'Length;
 263
 264          while Last < S'Last loop
 265             Fill_Buffer (C.M_State, S, Last + 1, Last);
 266
 267             if C.M_State.Last = Block_Length then
 268                Transform (C.H_State, C.M_State);
 269                C.M_State.Last := 0;
 270             end if;
 271          end loop;
 272
 273       end Update;
 274
 275       ------------
 276       -- Update --
 277       ------------
 278
 279       procedure Update (C : in out Context; Input : String) is
 280       begin
 281          Update (C, Input, Fill_Buffer_Copy'Access);
 282       end Update;
 283
 284       ------------
 285       -- Update --
 286       ------------
 287
 288       procedure Update (C : in out Context; Input : Stream_Element_Array) is
 289          S : String (1 .. Input'Length);
 290          for S'Address use Input'Address;
 291          pragma Import (Ada, S);
 292       begin
 293          Update (C, S, Fill_Buffer_Copy'Access);
 294       end Update;
 295
 296       -----------------
 297       -- Wide_Update --
 298       -----------------
 299
 300       procedure Wide_Update (C : in out Context; Input : Wide_String) is
 301          S : String (1 .. 2 * Input'Length);
 302          for S'Address use Input'Address;
 303          pragma Import (Ada, S);
 304       begin
 305          Update
 306            (C, S,
 307             (if System.Default_Bit_Order /= Low_Order_First
 308                then Fill_Buffer_Swap'Access
 309                else Fill_Buffer_Copy'Access));
 310       end Wide_Update;
 311
 312       -----------------
 313       -- Wide_Digest --
 314       -----------------
 315
 316       function Wide_Digest (W : Wide_String) return Message_Digest is
 317          C : Context;
 318       begin
 319          Wide_Update (C, W);
 320          return Digest (C);
 321       end Wide_Digest;
 322
 323    end H;
 324
 325    -------------------------
 326    -- Hash_Function_State --
 327    -------------------------
 328
 329    package body Hash_Function_State is
 330
 331       -------------
 332       -- To_Hash --
 333       -------------
 334
 335       procedure To_Hash (H : State; H_Bits : out Stream_Element_Array) is
 336          Hash_Words : constant Natural := H'Size / Word'Size;
 337          Result : State (1 .. Hash_Words) :=
 338                     H (H'Last - Hash_Words + 1 .. H'Last);
 339
 340          R_SEA : Stream_Element_Array (1 .. Result'Size / 8);
 341          for R_SEA'Address use Result'Address;
 342          pragma Import (Ada, R_SEA);
 343       begin
 344          if System.Default_Bit_Order /= Hash_Bit_Order then
 345             for J in Result'Range loop
 346                Swap (Result (J)'Address);
 347             end loop;
 348          end if;
 349
 350          --  Return truncated hash
 351
 352          pragma Assert (H_Bits'Length <= R_SEA'Length);
 353          H_Bits := R_SEA (R_SEA'First .. R_SEA'First + H_Bits'Length - 1);
 354       end To_Hash;
 355
 356    end Hash_Function_State;
 357
 358 end System.Secure_Hashes;