gcc/ada/g-sha1.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --                           G N A T . S H A 1                              --
   6 --                                                                          --
   7 --                                B o d y                                   --
   8 --                                                                          --
   9 --                     Copyright (C) 2002-2006, AdaCore                     --
  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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 --  Note: the code for this unit is derived from GNAT.MD5
  35
  36 with Ada.Unchecked_Conversion;
  37
  38 package body GNAT.SHA1 is
  39
  40    use Interfaces;
  41
  42    Padding : constant String :=
  43      (1 => Character'Val (16#80#), 2 .. 64 => ASCII.NUL);
  44
  45    Hex_Digit : constant array (Unsigned_32 range 0 .. 15) of Character :=
  46      ('0', '1', '2', '3', '4', '5', '6', '7',
  47       '8', '9', 'a', 'b', 'c', 'd', 'e', 'f');
  48    --  Look-up table for each hex digit of the Message-Digest.
  49    --  Used by function Digest (Context).
  50
  51    type Sixteen_Words is array (Natural range 0 .. 15)
  52      of Interfaces.Unsigned_32;
  53    --  Sixteen 32-bit words, converted from block of 64 characters.
  54    --  Used in procedure Decode and Transform.
  55
  56    procedure Decode (Block : String; X : out Sixteen_Words);
  57    --  Convert a String of 64 characters into 16 32-bit numbers
  58
  59    --  The following functions are the four elementary components of each
  60    --  of the four round groups (0 .. 19, 20 .. 39, 40 .. 59, and 60 .. 79)
  61    --  defined in RFC 3174.
  62
  63    function F0 (B, C, D : Unsigned_32) return Unsigned_32;
  64    pragma Inline (F0);
  65
  66    function F1 (B, C, D : Unsigned_32) return Unsigned_32;
  67    pragma Inline (F1);
  68
  69    function F2 (B, C, D : Unsigned_32) return Unsigned_32;
  70    pragma Inline (F2);
  71
  72    function F3 (B, C, D : Unsigned_32) return Unsigned_32;
  73    pragma Inline (F3);
  74
  75    procedure Transform (Ctx : in out Context; Block : String);
  76    --  Process one block of 64 characters
  77
  78    ------------
  79    -- Decode --
  80    ------------
  81
  82    procedure Decode (Block : String; X : out Sixteen_Words) is
  83       Cur : Positive := Block'First;
  84
  85    begin
  86       pragma Assert (Block'Length = 64);
  87
  88       for Index in X'Range loop
  89          X (Index) :=
  90            Unsigned_32 (Character'Pos (Block (Cur + 3))) +
  91            Shift_Left (Unsigned_32 (Character'Pos (Block (Cur + 2))), 8) +
  92            Shift_Left (Unsigned_32 (Character'Pos (Block (Cur + 1))), 16) +
  93            Shift_Left (Unsigned_32 (Character'Pos (Block (Cur))), 24);
  94          Cur := Cur + 4;
  95       end loop;
  96    end Decode;
  97
  98    ------------
  99    -- Digest --
 100    ------------
 101
 102    function Digest (C : Context) return Message_Digest is
 103       Result : Message_Digest;
 104
 105       Cur : Natural := 1;
 106       --  Index in Result where the next character will be placed
 107
 108       Last_Block : String (1 .. 64);
 109
 110       C1 : Context := C;
 111
 112       procedure Convert (X : Unsigned_32);
 113       --  Put the contribution of one of the five H words of the Context in
 114       --  Result. Increments Cur.
 115
 116       -------------
 117       -- Convert --
 118       -------------
 119
 120       procedure Convert (X : Unsigned_32) is
 121          Y : Unsigned_32 := X;
 122       begin
 123          for J in 1 .. 8 loop
 124             Y := Rotate_Left (Y, 4);
 125             Result (Cur) := Hex_Digit (Y and Unsigned_32'(16#0F#));
 126             Cur := Cur + 1;
 127          end loop;
 128       end Convert;
 129
 130    --  Start of processing for Digest
 131
 132    begin
 133       --  Process characters in the context buffer, if any
 134
 135       pragma Assert (C.Last /= C.Buffer'Last);
 136       Last_Block (1 .. C.Last) := C.Buffer (1 .. C.Last);
 137
 138       if C.Last > 55 then
 139          Last_Block (C.Last + 1 .. 64) := Padding (1 .. 64 - C.Last);
 140          Transform (C1, Last_Block);
 141          Last_Block := (others => ASCII.NUL);
 142
 143       else
 144          Last_Block (C.Last + 1 .. 56) := Padding (1 .. 56 - C.Last);
 145       end if;
 146
 147       --  Add the input length (as stored in the context) as 8 characters
 148
 149       Last_Block (57 .. 64) := (others => ASCII.NUL);
 150
 151       declare
 152          L   : Unsigned_64 := Unsigned_64 (C.Length) * 8;
 153          Idx : Positive := 64;
 154       begin
 155          while L > 0 loop
 156             Last_Block (Idx) := Character'Val (L and 16#Ff#);
 157             L := Shift_Right (L, 8);
 158             Idx := Idx - 1;
 159          end loop;
 160       end;
 161
 162       Transform (C1, Last_Block);
 163
 164       Convert (C1.H (0));
 165       Convert (C1.H (1));
 166       Convert (C1.H (2));
 167       Convert (C1.H (3));
 168       Convert (C1.H (4));
 169       return Result;
 170    end Digest;
 171
 172    function Digest (S : String) return Message_Digest is
 173       C : Context;
 174    begin
 175       Update (C, S);
 176       return Digest (C);
 177    end Digest;
 178
 179    function Digest
 180      (A : Ada.Streams.Stream_Element_Array) return Message_Digest
 181    is
 182       C : Context;
 183    begin
 184       Update (C, A);
 185       return Digest (C);
 186    end Digest;
 187
 188    --------
 189    -- F0 --
 190    --------
 191
 192    function F0
 193      (B, C, D : Interfaces.Unsigned_32) return Interfaces.Unsigned_32
 194    is
 195    begin
 196       return (B and C) or ((not B) and D);
 197    end F0;
 198
 199    --------
 200    -- F1 --
 201    --------
 202
 203    function F1
 204      (B, C, D : Interfaces.Unsigned_32) return Interfaces.Unsigned_32
 205    is
 206    begin
 207       return B xor C xor D;
 208    end F1;
 209
 210    --------
 211    -- F2 --
 212    --------
 213
 214    function F2
 215      (B, C, D : Interfaces.Unsigned_32) return Interfaces.Unsigned_32
 216    is
 217    begin
 218       return (B and C) or (B and D) or (C and D);
 219    end F2;
 220
 221    --------
 222    -- F3 --
 223    --------
 224
 225    function F3
 226      (B, C, D : Interfaces.Unsigned_32) return Interfaces.Unsigned_32
 227      renames F1;
 228
 229    ---------------
 230    -- Transform --
 231    ---------------
 232
 233    procedure Transform
 234      (Ctx   : in out Context;
 235       Block : String)
 236    is
 237       W : array (0 .. 79) of Interfaces.Unsigned_32;
 238
 239       A, B, C, D, E, Temp : Interfaces.Unsigned_32;
 240
 241    begin
 242       pragma Assert (Block'Length = 64);
 243
 244       --  a. Divide data block into sixteen words
 245
 246       Decode (Block, Sixteen_Words (W (0 .. 15)));
 247
 248       --  b. Prepare working block of 80 words
 249
 250       for T in 16 .. 79 loop
 251
 252          --  W(t) = S^1(W(t-3) XOR W(t-8) XOR W(t-14) XOR W(t-16))
 253
 254          W (T) := Rotate_Left
 255            (W (T - 3) xor W (T - 8) xor W (T - 14) xor W (T - 16), 1);
 256
 257       end loop;
 258
 259       --  c. Set up transformation variables
 260
 261       A := Ctx.H (0);
 262       B := Ctx.H (1);
 263       C := Ctx.H (2);
 264       D := Ctx.H (3);
 265       E := Ctx.H (4);
 266
 267       --  d. For each of the 80 rounds, compute:
 268
 269       --  TEMP = S^5(A) + f(t;B,C,D) + E + W(t) + K(t);
 270       --  E = D;  D = C;  C = S^30(B);  B = A; A = TEMP;
 271
 272       for T in 0 .. 19 loop
 273          Temp := Rotate_Left (A, 5) + F0 (B, C, D) + E + W (T) + 16#5A827999#;
 274          E := D; D := C; C := Rotate_Left (B, 30); B := A; A := Temp;
 275       end loop;
 276
 277       for T in 20 .. 39 loop
 278          Temp := Rotate_Left (A, 5) + F1 (B, C, D) + E + W (T) + 16#6ED9EBA1#;
 279          E := D; D := C; C := Rotate_Left (B, 30); B := A; A := Temp;
 280       end loop;
 281
 282       for T in 40 .. 59 loop
 283          Temp := Rotate_Left (A, 5) + F2 (B, C, D) + E + W (T) + 16#8F1BBCDC#;
 284          E := D; D := C; C := Rotate_Left (B, 30); B := A; A := Temp;
 285       end loop;
 286
 287       for T in 60 .. 79 loop
 288          Temp := Rotate_Left (A, 5) + F3 (B, C, D) + E + W (T) + 16#CA62C1D6#;
 289          E := D; D := C; C := Rotate_Left (B, 30); B := A; A := Temp;
 290       end loop;
 291
 292       --  e. Update context:
 293       --  H0 = H0 + A, H1 = H1 + B, H2 = H2 + C, H3 = H3 + D, H4 = H4 + E
 294
 295       Ctx.H (0) := Ctx.H (0) + A;
 296       Ctx.H (1) := Ctx.H (1) + B;
 297       Ctx.H (2) := Ctx.H (2) + C;
 298       Ctx.H (3) := Ctx.H (3) + D;
 299       Ctx.H (4) := Ctx.H (4) + E;
 300    end Transform;
 301
 302    ------------
 303    -- Update --
 304    ------------
 305
 306    procedure Update
 307      (C     : in out Context;
 308       Input : String)
 309    is
 310       Inp : constant String := C.Buffer (1 .. C.Last) & Input;
 311       Cur : Positive := Inp'First;
 312
 313    begin
 314       C.Length := C.Length + Input'Length;
 315
 316       while Cur + 63 <= Inp'Last loop
 317          Transform (C, Inp (Cur .. Cur + 63));
 318          Cur := Cur + 64;
 319       end loop;
 320
 321       C.Last := Inp'Last - Cur + 1;
 322       C.Buffer (1 .. C.Last) := Inp (Cur .. Inp'Last);
 323    end Update;
 324
 325    procedure Update
 326      (C     : in out Context;
 327       Input : Ada.Streams.Stream_Element_Array)
 328    is
 329       subtype Stream_Array is Ada.Streams.Stream_Element_Array (Input'Range);
 330       subtype Stream_String is
 331         String (1 + Integer (Input'First) .. 1 + Integer (Input'Last));
 332
 333       function To_String is new Ada.Unchecked_Conversion
 334         (Stream_Array, Stream_String);
 335
 336       String_Input : constant String := To_String (Input);
 337    begin
 338       Update (C, String_Input);
 339    end Update;
 340
 341    -----------------
 342    -- Wide_Digest --
 343    -----------------
 344
 345    function Wide_Digest (W : Wide_String) return Message_Digest is
 346       C : Context;
 347    begin
 348       Wide_Update (C, W);
 349       return Digest (C);
 350    end Wide_Digest;
 351
 352    -----------------
 353    -- Wide_Update --
 354    -----------------
 355
 356    procedure Wide_Update
 357      (C     : in out Context;
 358       Input : Wide_String)
 359    is
 360       String_Input : String (1 .. 2 * Input'Length);
 361       Cur          : Positive := 1;
 362
 363    begin
 364       for Index in Input'Range loop
 365          String_Input (Cur) :=
 366            Character'Val
 367             (Unsigned_32 (Wide_Character'Pos (Input (Index))) and 16#FF#);
 368          Cur := Cur + 1;
 369          String_Input (Cur) :=
 370            Character'Val
 371            (Shift_Right (Unsigned_32 (Wide_Character'Pos (Input (Index))), 8)
 372             and 16#FF#);
 373          Cur := Cur + 1;
 374       end loop;
 375
 376       Update (C, String_Input);
 377    end Wide_Update;
 378
 379 end GNAT.SHA1;