------------------------------------------------------------------------------
--                                                                          --
--                           POLYORB COMPONENTS                             --
--                                                                          --
--                                  M D 5                                   --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--           Copyright (C) 2006, Free Software Foundation, Inc.             --
--                                                                          --
-- PolyORB is free software; you  can  redistribute  it and/or modify it    --
-- under terms of the  GNU General Public License as published by the  Free --
-- Software Foundation;  either version 2,  or (at your option)  any  later --
-- version. PolyORB is distributed  in the hope that it will be  useful,    --
-- but WITHOUT ANY WARRANTY;  without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public --
-- License  for more details.  You should have received  a copy of the GNU  --
-- General Public License distributed with PolyORB; see file COPYING. If    --
-- not, write to the Free Software Foundation, 51 Franklin Street, Fifth    --
-- Floor, Boston, MA 02111-1301, USA.                                       --
--                                                                          --
--
--
--
--
--
--
--
--                  PolyORB is maintained by AdaCore                        --
--                     (email: sales@adacore.com)                           --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Unchecked_Conversion;

package body MD5 is

   --  ===================================================================
   --  Authors   Rolf Ebert,
   --            Christoph Grein <Christ-Usch.Grein@T-Online.de>
   --  Version   1.1
   --  Date      16 January 1999
   --  ===================================================================
   --  This is a direct translation into Ada of the C language Reference
   --  Implementation given in the official MD5 algorithm description.
   --  It was originally written by Rolf Ebert (unknown address).
   --     -- The official description of the MD5 algorithm can be found at
   --    <ftp ://ftp.rsa.com/pub/md5.txt>
   --  License is granted by RSA Data Security, Inc. <http ://www.rsa.com>
   --  to make and use derivative works provided that such works are
   --  identified as "derived from the RSA Data Security, Inc. MD5
   --  Message-Digest Algorithm" in all material mentioning or referencing
   --  the derived work. (See the copyright notice in the official
   --  description.)
   --  ===================================================================
   --  History
   --  Author Version   Date    Reason for change
   --   R.E.    1.0  04.06.1997 Original as found in internet
   --   C.G.    1.1  16.01.1999 Minor code changes; commented to make
   --                          publication legal
   --  ===================================================================

   function Rotate_Left (Value : Word; Amount : Natural) return Word;
   function Shift_Left  (Value : Word; Amount : Natural) return Word;
   function Shift_Right (Value : Word; Amount : Natural) return Word;
   pragma Import (Intrinsic, Rotate_Left);
   pragma Import (Intrinsic, Shift_Left);
   pragma Import (Intrinsic, Shift_Right);

   -----------------------------------------------------------------------
   --  F, G, H, I are the basic MD5 functions

   function F (X, Y, Z : Word) return Word;
   function G (X, Y, Z : Word) return Word;
   function H (X, Y, Z : Word) return Word;
   function I (X, Y, Z : Word) return Word;

   function F (X, Y, Z : Word) return Word is
   begin
      return (X and Y) or ((not X) and Z);
   end F;
   pragma Inline (F);

   function G (X, Y, Z : Word) return Word is
   begin
      return (X and Z) or (Y and (not Z));
   end G;
   pragma Inline (G);

   function H (X, Y, Z : Word) return Word is
   begin
      return X xor Y xor Z;
   end H;
   pragma Inline (H);

   function I (X, Y, Z : Word) return Word is
   begin
      return Y xor (X or (not Z));
   end I;
   pragma Inline (I);

   -----------------------------------------------------------------------

   procedure FF (A          : in out Word;
                 B, C, D, X : Word;
                 S          : Natural;
                 AC         : Word);

   procedure GG (A          : in out Word;
                 B, C, D, X : Word;
                 S          : Natural;
                 AC         : Word);

   procedure HH (A          : in out Word;
                 B, C, D, X : Word;
                 S          : Natural;
                 AC         : Word);

   procedure II (A          : in out Word;
                 B, C, D, X : Word;
                 S          : Natural;
                 AC         : Word);

   procedure FF (A          : in out Word;
                 B, C, D, X : Word;
                 S          : Natural;
                 AC         : Word) is
   begin
      A := A + F (B, C, D) + X + AC;
      A := Rotate_Left (A, S) + B;
   end FF;
   pragma Inline (FF);

   procedure GG (A          : in out Word;
                 B, C, D, X : Word;
                 S          : Natural;
                 AC         : Word) is
   begin
      A := A + G (B, C, D) + X + AC;
      A := Rotate_Left (A, S) + B;
   end GG;
   pragma Inline (GG);

   procedure HH (A          : in out Word;
                 B, C, D, X : Word;
                 S          : Natural;
                 AC         : Word) is
   begin
      A := A + H (B, C, D) + X + AC;
      A := Rotate_Left (A, S) + B;
   end HH;
   pragma Inline (HH);

   procedure II (A          : in out Word;
                 B, C, D, X : Word;
                 S          : Natural;
                 AC         : Word) is
   begin
      A := A + I (B, C, D) + X + AC;
      A := Rotate_Left (A, S) + B;
   end II;
   pragma Inline (II);

   -----------------------------------------------------------------------

   procedure Encode (Output : out Byte_Array;
                     Input  : Word_Array);

   procedure Encode (Output : out Byte_Array;
                     Input  : Word_Array) is

      J : Long_Integer := Output'First;

   begin

      for I in Input'Range loop
         Output (J) := Byte (Input (I)      and 16#FF#);
         Output (J + 1) := Byte (Shift_Right (Input (I),  8) and 16#FF#);
         Output (J + 2) := Byte (Shift_Right (Input (I), 16) and 16#FF#);
         Output (J + 3) := Byte (Shift_Right (Input (I), 24) and 16#FF#);
         J := J + 4;
      end loop;

   end Encode;

   procedure Decode (Output : out Word_Array;
                     Input  : Byte_Array);

   procedure Decode (Output : out Word_Array;
                     Input  : Byte_Array) is

      J : Long_Integer := Input'First;

   begin

      for I in Output'Range loop
         Output (I) :=             Word (Input (J))      or
           Shift_Left (Word (Input (J + 1)),  8) or
           Shift_Left (Word (Input (J + 2)), 16) or
           Shift_Left (Word (Input (J + 3)), 24);
         J := J + 4;
      end loop;

   end Decode;

   -----------------------------------------------------------------------

   S11 : constant :=  7;
   S12 : constant := 12;
   S13 : constant := 17;
   S14 : constant := 22;
   S21 : constant :=  5;
   S22 : constant :=  9;
   S23 : constant := 14;
   S24 : constant := 20;
   S31 : constant :=  4;
   S32 : constant := 11;
   S33 : constant := 16;
   S34 : constant := 23;
   S41 : constant :=  6;
   S42 : constant := 10;
   S43 : constant := 15;
   S44 : constant := 21;

   procedure Transform (State : in out ABCD_State;
                        Block : Buffer_T);

   procedure Transform (State : in out ABCD_State;
                        Block : Buffer_T) is

      A : Word := State (1);
      B : Word := State (2);
      C : Word := State (3);
      D : Word := State (4);

      X : Word_Array (0 .. 15);

   begin

      Decode (X, Block);

      --  Round 1

      FF (A, B, C, D, X (0), S11, 16#D76AA478#);  --   1
      FF (D, A, B, C, X (1), S12, 16#E8C7B756#);  --   2
      FF (C, D, A, B, X (2), S13, 16#242070DB#);  --   3
      FF (B, C, D, A, X (3), S14, 16#C1BDCEEE#);  --   4
      FF (A, B, C, D, X (4), S11, 16#F57C0FAF#);  --   5
      FF (D, A, B, C, X (5), S12, 16#4787C62A#);  --   6
      FF (C, D, A, B, X (6), S13, 16#A8304613#);  --   7
      FF (B, C, D, A, X (7), S14, 16#FD469501#);  --   8
      FF (A, B, C, D, X (8), S11, 16#698098D8#);  --   9
      FF (D, A, B, C, X (9), S12, 16#8B44F7AF#);  --  10
      FF (C, D, A, B, X (10), S13, 16#FFFF5BB1#);  --  11
      FF (B, C, D, A, X (11), S14, 16#895CD7BE#);  --  12
      FF (A, B, C, D, X (12), S11, 16#6B901122#);  --  13
      FF (D, A, B, C, X (13), S12, 16#FD987193#);  --  14
      FF (C, D, A, B, X (14), S13, 16#A679438E#);  --  15
      FF (B, C, D, A, X (15), S14, 16#49B40821#);  --  16

      --  Round 2

      GG (A, B, C, D, X (1), S21, 16#F61E2562#);  --  17
      GG (D, A, B, C, X (6), S22, 16#C040B340#);  --  18
      GG (C, D, A, B, X (11), S23, 16#265E5A51#);  --  19
      GG (B, C, D, A, X (0), S24, 16#E9B6C7AA#);  --  20
      GG (A, B, C, D, X (5), S21, 16#D62F105D#);  --  21
      GG (D, A, B, C, X (10), S22, 16#02441453#);  --  22
      GG (C, D, A, B, X (15), S23, 16#D8A1E681#);  --  23
      GG (B, C, D, A, X (4), S24, 16#E7D3FBC8#);  --  24
      GG (A, B, C, D, X (9), S21, 16#21E1CDE6#);  --  25
      GG (D, A, B, C, X (14), S22, 16#C33707D6#);  --  26
      GG (C, D, A, B, X (3), S23, 16#F4D50D87#);  --  27
      GG (B, C, D, A, X (8), S24, 16#455A14ED#);  --  28
      GG (A, B, C, D, X (13), S21, 16#A9E3E905#);  --  29
      GG (D, A, B, C, X (2), S22, 16#FCEFA3F8#);  --  30
      GG (C, D, A, B, X (7), S23, 16#676F02D9#);  --  31
      GG (B, C, D, A, X (12), S24, 16#8D2A4C8A#);  --  32

      --  Round 3

      HH (A, B, C, D, X (5), S31, 16#FFFA3942#);  --  33
      HH (D, A, B, C, X (8), S32, 16#8771F681#);  --  34
      HH (C, D, A, B, X (11), S33, 16#6D9D6122#);  --  35
      HH (B, C, D, A, X (14), S34, 16#FDE5380C#);  --  36
      HH (A, B, C, D, X (1), S31, 16#A4BEEA44#);  --  37
      HH (D, A, B, C, X (4), S32, 16#4BDECFA9#);  --  38
      HH (C, D, A, B, X (7), S33, 16#F6BB4B60#);  --  39
      HH (B, C, D, A, X (10), S34, 16#BEBFBC70#);  --  40
      HH (A, B, C, D, X (13), S31, 16#289B7EC6#);  --  41
      HH (D, A, B, C, X (0), S32, 16#EAA127FA#);  --  42
      HH (C, D, A, B, X (3), S33, 16#D4EF3085#);  --  43
      HH (B, C, D, A, X (6), S34, 16#04881D05#);  --  44
      HH (A, B, C, D, X (9), S31, 16#D9D4D039#);  --  45
      HH (D, A, B, C, X (12), S32, 16#E6DB99E5#);  --  46
      HH (C, D, A, B, X (15), S33, 16#1FA27CF8#);  --  47
      HH (B, C, D, A, X (2), S34, 16#C4AC5665#);  --  48

      --  Round 4

      II (A, B, C, D, X (0), S41, 16#F4292244#);  --  49
      II (D, A, B, C, X (7), S42, 16#432AFF97#);  --  50
      II (C, D, A, B, X (14), S43, 16#AB9423A7#);  --  51
      II (B, C, D, A, X (5), S44, 16#FC93A039#);  --  52
      II (A, B, C, D, X (12), S41, 16#655B59C3#);  --  53
      II (D, A, B, C, X (3), S42, 16#8F0CCC92#);  --  54
      II (C, D, A, B, X (10), S43, 16#FFEFF47D#);  --  55
      II (B, C, D, A, X (1), S44, 16#85845DD1#);  --  56
      II (A, B, C, D, X (8), S41, 16#6FA87E4F#);  --  57
      II (D, A, B, C, X (15), S42, 16#FE2CE6E0#);  --  58
      II (C, D, A, B, X (6), S43, 16#A3014314#);  --  59
      II (B, C, D, A, X (13), S44, 16#4E0811A1#);  --  60
      II (A, B, C, D, X (4), S41, 16#F7537E82#);  --  61
      II (D, A, B, C, X (11), S42, 16#BD3AF235#);  --  62
      II (C, D, A, B, X (2), S43, 16#2AD7D2BB#);  --  63
      II (B, C, D, A, X (9), S44, 16#EB86D391#);  --  64

      State (1) := State (1) + A;
      State (2) := State (2) + B;
      State (3) := State (3) + C;
      State (4) := State (4) + D;

      --  Zeroize sensitive information.

      X := (others => 0);

   end Transform;

   -----------------------------------------------------------------------

   procedure Init (Ctx : out Context) is
   begin
      Ctx := (State  => (1 => 16#67452301#,
                         2 => 16#Efcdab89#,
                         3 => 16#98badcfe#,
                         4 => 16#10325476#),
              Count  => (others => 0),
              Buffer => (others => 0));
   end Init;

   procedure Update (Ctx : in out Context; Data : Byte_Array) is

      Index   : Long_Integer;
      Part_Len : Long_Integer;
      I       : Long_Integer;

   begin

      --  compute number of bytes mod 64
      Index := Long_Integer (Shift_Right (Ctx.Count (1), 3) and 16#3F#);

      --  update number of bits
      Ctx.Count (1) := Ctx.Count (1) + Shift_Left (Word (Data'Length), 3);
      if Ctx.Count (1) < Shift_Left (Word (Data'Length), 3) then
         Ctx.Count (2) := Ctx.Count (2) + 1;
      end if;
      Ctx.Count (2) := Ctx.Count (2) + Shift_Right (Word (Data'Length), 29);

      Part_Len := 64 - Index;

      --  Transform as many times as possible.
      if Data'Length >= Part_Len then

         Ctx.Buffer (Index + 1 .. Index + Part_Len) :=
           Data (Data'First .. Data'First + Part_Len - 1);

         Transform (Ctx.State, Ctx.Buffer);

         I := Part_Len;
         while I + 63 < Data'Length loop
            Transform (Ctx.State, Data (I + 1 .. I + 64));
            I := I + 64;
         end loop;

         Index := 0;

      else

         I := 0;

      end if;

      --  Buffer remaining input
      Ctx.Buffer (Index + 1 .. Index + Data'Length - I)
        := Data (I + 1 .. Data'Length);

   end Update;

   procedure Update (Ctx : in out Context; Data : String) is

      subtype Data_Byte_Array is Byte_Array (1 .. Data'Length);
      subtype Data_String     is String     (1 .. Data'Length);

      function String_To_Byte_Array is new Ada.Unchecked_Conversion
        (Source => Data_String,
         Target => Data_Byte_Array);

   begin

      Update (Ctx, String_To_Byte_Array (Data_String (Data)));

   end Update;

   procedure Final (Ctx : in out Context; Digest : out Fingerprint) is

      Bits      : Byte_Array (1 .. 8);
      Index     : Long_Integer;
      Pad_Length : Long_Integer;

      Padding   : constant Buffer_T := (1 => 16#80#, others => 0);

   begin

      --  save number of bits
      Encode (Bits, Ctx.Count);

      --  Pad out to 56 mod 64.
      Index := Long_Integer (Shift_Right (Ctx.Count (1), 3) and 16#3F#);
      if Index < 56 then
         Pad_Length := 56 - Index;
      else
         Pad_Length := 120 - Index;
      end if;

      Update (Ctx, Padding (1 .. Pad_Length));

      --  Append length (before padding)
      Update (Ctx, Bits);

      --  Store state in digest
      Encode (Digest, Ctx.State);

      --  Zeroize sensitive information.
      Ctx := (State  => (others => 0),
              Count  => (others => 0),
              Buffer => (others => 0));

   end Final;

   -----------------------------------------------------------------------

   Hex_Tab : constant array (0 .. 15) of Character := "0123456789abcdef";

   function Digest_From_Text (S : Digest_String) return Fingerprint is

      Digest : Fingerprint;
      Val   : Word;
      Ch    : Character;

   begin

      for I in Digest'Range loop

         Ch := S (2 * Integer (I));
         case Ch is
            when '0' .. '9' => Val
              := Character'Pos (Ch) - Character'Pos ('0');
            when 'a' .. 'f' => Val
              := Character'Pos (Ch) - Character'Pos ('a') + 10;
            when 'A' .. 'F' => Val
              := Character'Pos (Ch) - Character'Pos ('A') + 10;
            when others     => raise Malformed;
         end case;

         Val := Shift_Left (Val, 4);

         Ch := S (2 * Integer (I) + 1);
         case Ch is
            when '0' .. '9' => Val
              := Val + (Character'Pos (Ch) - Character'Pos ('0'));
            when 'a' .. 'f' => Val
              := Val + (Character'Pos (Ch) - Character'Pos ('a') + 10);
            when 'A' .. 'F' => Val
              := Val + (Character'Pos (Ch) - Character'Pos ('A') + 10);
            when others     => raise Malformed;
         end case;

         Digest (I) := Byte (Val);

      end loop;

      return Digest;

   end Digest_From_Text;

   function Digest_To_Text (A : Fingerprint) return Digest_String is

      Str : Digest_String;
      J  : Positive;

   begin

      for I in A'Range loop

         J           := 2 * Integer (I) - 1;
         Str (J)     := Hex_Tab (Natural (Shift_Right (Word (A (I)), 4)));
         Str (J + 1) := Hex_Tab (Natural (A (I) and 16#F#));

      end loop;

      return Str;

   end Digest_To_Text;

end MD5;
