File : src/aws-messages.adb


------------------------------------------------------------------------------
--                              Ada Web Server                              --
--                                                                          --
--                         Copyright (C) 2000-2002                          --
--                               ACT-Europe                                 --
--                                                                          --
--  Authors: Dmitriy Anisimkov - Pascal Obry                                --
--                                                                          --
--  This library is free software; you can redistribute it and/or modify    --
--  it under the terms of the GNU General Public License as published by    --
--  the Free Software Foundation; either version 2 of the License, or (at   --
--  your option) any later version.                                         --
--                                                                          --
--  This library is distributed in the hope that it will be useful, but     --
--  WITHOUT ANY WARRANTY; without even the implied warranty of              --
--  MERCHANTABILITY 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       --
--  along with this library; if not, write to the Free Software Foundation, --
--  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.          --
--                                                                          --
--  As a special exception, if other files instantiate generics from this   --
--  unit, or you link this unit with other files to produce an executable,  --
--  this  unit  does not  by itself cause  the resulting executable to be   --
--  covered by the GNU General Public License. This exception does not      --
--  however invalidate any other reasons why the executable file  might be  --
--  covered by the  GNU Public License.                                     --
------------------------------------------------------------------------------

--  $Id: aws-messages.adb,v 1.28 2002/12/25 16:40:36 anisimko Exp $

with Ada.Characters.Handling;
with Ada.Exceptions;

with AWS.Utils;

package body AWS.Messages is

   type String_Access is access constant String;

   subtype Status_Code_Image is String (1 .. 3);

   S100_Message : aliased constant String := "Continue";
   S101_Message : aliased constant String := "Switching Protocols";
   S200_Message : aliased constant String := "OK";
   S201_Message : aliased constant String := "Create";
   S202_Message : aliased constant String := "Accepted";
   S203_Message : aliased constant String := "Non-Authoritative Information";
   S204_Message : aliased constant String := "No Content";
   S205_Message : aliased constant String := "Reset Content";
   S206_Message : aliased constant String := "Partial Content";
   S300_Message : aliased constant String := "Multiple Choices";
   S301_Message : aliased constant String := "Moved Permanently";
   S302_Message : aliased constant String := "Found";
   S303_Message : aliased constant String := "See Other";
   S304_Message : aliased constant String := "Not Modified";
   S305_Message : aliased constant String := "Use Proxy";
   S307_Message : aliased constant String := "Temporary Redirect";
   S400_Message : aliased constant String := "Bad Request";
   S401_Message : aliased constant String := "Unauthorized";
   S402_Message : aliased constant String := "Payment Required";
   S403_Message : aliased constant String := "Forbidden";
   S404_Message : aliased constant String := "Not Found";
   S405_Message : aliased constant String := "Method Not Allowed";
   S406_Message : aliased constant String := "Not Acceptable";
   S407_Message : aliased constant String := "Proxy Authentification Required";
   S408_Message : aliased constant String := "Request Time-out";
   S409_Message : aliased constant String := "Conflict";
   S410_Message : aliased constant String := "Gone";
   S411_Message : aliased constant String := "Length Required";
   S412_Message : aliased constant String := "Precondition Failed";
   S413_Message : aliased constant String := "Request Entity Too Large";
   S414_Message : aliased constant String := "Request-URI Too Large";
   S415_Message : aliased constant String := "Unsupported Media Type";
   S416_Message : aliased constant String := "Requestd range not satisfiable";
   S417_Message : aliased constant String := "Expectation Failed";
   S500_Message : aliased constant String := "Internal Server Error";
   S501_Message : aliased constant String := "Not Implemented";
   S502_Message : aliased constant String := "Bad Gateway";
   S503_Message : aliased constant String := "Service Unavailable";
   S504_Message : aliased constant String := "Gateway Time-out";
   S505_Message : aliased constant String := "HTTP Version not supported";

   type Status_Data is record
      Code          : Status_Code_Image;
      Reason_Phrase : String_Access;
   end record;

   Status_Messages : constant array (Status_Code) of Status_Data
     := (S100 => ("100", S100_Message'Access),
         S101 => ("101", S101_Message'Access),
         S200 => ("200", S200_Message'Access),
         S201 => ("201", S201_Message'Access),
         S202 => ("202", S202_Message'Access),
         S203 => ("203", S203_Message'Access),
         S204 => ("204", S204_Message'Access),
         S205 => ("205", S205_Message'Access),
         S206 => ("206", S206_Message'Access),
         S300 => ("300", S300_Message'Access),
         S301 => ("301", S301_Message'Access),
         S302 => ("302", S302_Message'Access),
         S303 => ("303", S303_Message'Access),
         S304 => ("304", S304_Message'Access),
         S305 => ("305", S305_Message'Access),
         S307 => ("307", S307_Message'Access),
         S400 => ("400", S400_Message'Access),
         S401 => ("401", S401_Message'Access),
         S402 => ("402", S402_Message'Access),
         S403 => ("403", S403_Message'Access),
         S404 => ("404", S404_Message'Access),
         S405 => ("405", S405_Message'Access),
         S406 => ("406", S406_Message'Access),
         S407 => ("407", S407_Message'Access),
         S408 => ("408", S408_Message'Access),
         S409 => ("409", S409_Message'Access),
         S410 => ("410", S410_Message'Access),
         S411 => ("411", S411_Message'Access),
         S412 => ("412", S412_Message'Access),
         S413 => ("413", S413_Message'Access),
         S414 => ("414", S414_Message'Access),
         S415 => ("415", S415_Message'Access),
         S416 => ("416", S416_Message'Access),
         S417 => ("417", S417_Message'Access),
         S500 => ("500", S500_Message'Access),
         S501 => ("501", S501_Message'Access),
         S502 => ("502", S502_Message'Access),
         S503 => ("503", S503_Message'Access),
         S504 => ("504", S504_Message'Access),
         S505 => ("505", S505_Message'Access));

   Month_Name : constant array (Calendar.Month_Number) of String (1 .. 3)
     := ("Jan", "Feb", "Mar", "Apr", "May", "Jun",
         "Jul", "Aug", "Sep", "Oct", "Nov", "Dec");

   HD : constant String := ": ";
   --  Header delimiter with space for well formatting.

   ---------------------
   -- Accept_Language --
   ---------------------

   function Accept_Language (Mode : in String) return String is
   begin
      return Accept_Language_Token & HD & Mode;
   end Accept_Language;

   -----------------
   -- Accept_Type --
   -----------------

   function Accept_Type (Mode : in String) return String is
   begin
      return Accept_Token & HD & Mode;
   end Accept_Type;

   -------------------
   -- Authorization --
   -------------------

   function Authorization (Mode, Password : in String) return String is
   begin
      return Authorization_Token & HD & Mode & ' ' & Password;
   end Authorization;

   -------------------
   -- Cache_Control --
   -------------------

   function Cache_Control (Option : in Cache_Option) return String is
   begin
      return Cache_Control_Token & HD & String (Option);
   end Cache_Control;

   ----------------
   -- Connection --
   ----------------

   function Connection (Mode : in String) return String is
   begin
      return Connection_Token & HD & Mode;
   end Connection;

   -------------------------
   -- Content_Disposition --
   -------------------------

   function Content_Disposition
     (Format   : in String;
      Name     : in String;
      Filename : in String)
      return String is
   begin
      if Filename = "" then
         return Content_Disposition_Token & HD & Format
           & "; name=""" & Name & '"';
      else
         return Content_Disposition_Token & HD & Format
           & "; name=""" & Name & """; filename=""" & Filename & '"';
      end if;
   end Content_Disposition;

   --------------------
   -- Content_Length --
   --------------------

   function Content_Length (Size : in Natural) return String is
   begin
      return Content_Length_Token & HD & Utils.Image (Size);
   end Content_Length;

   ------------------
   -- Content_Type --
   ------------------

   function Content_Type
     (Format   : in String;
      Boundary : in String := "")
      return String is
   begin
      if Boundary = "" then
         return Content_Type_Token & HD & Format;

      else
         return Content_Type_Token & HD & Format & "; boundary=" & Boundary;
      end if;
   end Content_Type;

   ------------
   -- Cookie --
   ------------

   function Cookie (Value : in String) return String is
   begin
      return Cookie_Token & HD & Value;
   end Cookie;

   --------------------
   -- Does_Not_Match --
   --------------------

   function Does_Not_Match (Str, Pattern : in String) return Boolean is
      use Ada.Characters;
      U_Str     : constant String := Handling.To_Upper (Str);
      U_Pattern : constant String := Handling.To_Upper (Pattern);
   begin
      return Pattern'Length > Str'Length
        or else U_Str (1 .. Pattern'Length) /= U_Pattern;
   end Does_Not_Match;

   ----------
   -- Host --
   ----------

   function Host (Name : in String) return String is
   begin
      return Host_Token & HD & Name;
   end Host;

   -----------
   -- Image --
   -----------

   function Image (S : in Status_Code) return String is
   begin
      return Status_Messages (S).Code;
   end Image;

   -------------------
   -- Last_Modified --
   -------------------

   function Last_Modified (Date : in Calendar.Time) return String is
   begin
      return Last_Modified_Token & HD & To_HTTP_Date (Date);
   end Last_Modified;

   --------------
   -- Location --
   --------------

   function Location (URL : in String) return String is
   begin
      return Location_Token & HD & URL;
   end Location;

   -----------
   -- Match --
   -----------

   function Match (Str, Pattern : in String) return Boolean is
      use Ada.Characters;
      U_Str     : constant String := Handling.To_Upper (Str);
      U_Pattern : constant String := Handling.To_Upper (Pattern);
   begin
      return Pattern'Length <= Str'Length
        and then U_Str (1 .. Pattern'Length) = U_Pattern;
   end Match;

   -------------------------
   -- Proxy_Authorization --
   -------------------------

   function Proxy_Authorization (Mode, Password : in String) return String is
   begin
      return Proxy_Authorization_Token & HD & Mode & ' ' & Password;
   end Proxy_Authorization;

   ----------------------
   -- Proxy_Connection --
   ----------------------

   function Proxy_Connection (Mode : in String) return String is
   begin
      return Proxy_Connection_Token & HD & Mode;
   end Proxy_Connection;

   -------------------
   -- Reason_Phrase --
   -------------------

   function Reason_Phrase (S : in Status_Code) return String is
   begin
      return Status_Messages (S).Reason_Phrase.all;
   end Reason_Phrase;

   ----------------
   -- SOAPAction --
   ----------------

   function SOAPAction (URI : in String) return String is
   begin
      return SOAPAction_Token & HD & '"' & URI & '"';
   end SOAPAction;

   -----------------
   -- Status_Line --
   -----------------

   function Status_Line (Code : in Status_Code) return String is
   begin
      return HTTP_Version & ' '
        & Status_Messages (Code).Code & ' '
        & Status_Messages (Code).Reason_Phrase.all;
   end Status_Line;

   ------------------
   -- To_HTTP_Date --
   ------------------

   function To_HTTP_Date (Time : in Calendar.Time) return String is

      function Truncation (S : in Calendar.Day_Duration) return Natural;
      --  returns the integral value of S.

      function Image (V : in Natural) return String;
      --  returns V image without the leading space and with leading zero if
      --  only one digit

      function Weekday (Date : in Calendar.Time) return String;
      --  returns the weekday as a 3 letters string for the Date.

      -----------
      -- Image --
      -----------

      function Image (V : in Natural) return String is
         V_Image : constant String := Natural'Image (V);
      begin
         if V_Image'Length = 2 then
            --  only one digit add a leading zero
            return '0' & V_Image (2 .. V_Image'Last);
         else
            return V_Image (2 .. V_Image'Last);
         end if;
      end Image;

      ----------------
      -- Truncation --
      ----------------

      function Truncation (S : in Calendar.Day_Duration) return Natural is
      begin
         if S = 0.0 then
            return 0;
         else
            return Natural (S - 0.5);
         end if;
      end Truncation;

      -------------
      -- Weekday --
      -------------

      function Weekday (Date : in Calendar.Time) return String is

         Day_Names : constant array (Integer range 0 .. 6) of String (1 .. 3)
           := ("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat");

         C         : Integer;
         Y         : Integer := Calendar.Year (Date);
         M         : Integer := Calendar.Month (Date);
         D         : constant Integer := Calendar.Day (Date);

      begin
         --  Calculate day of week by using Zeller's congruence
         if M < 3 then
            Y := Y - 1;
            M := M + 10;
         else
            M := M - 2;
         end if;

         C := Y / 100;     --  first two digits of Year
         Y := Y mod 100;   --  last two digits of Year

         return Day_Names (((26 * M - 2) / 10
                            + D
                            + Y
                            + Y / 4
                            + C / 4
                            - 2 * C) mod 7);
      end Weekday;

      Day  : constant String  := Image (Calendar.Day (Time));
      Mon  : constant String  := Month_Name (Calendar.Month (Time));
      Year : constant String  := Image (Calendar.Year (Time));

      Secs : constant Natural := Truncation (Calendar.Seconds (Time));

      Tmp  : constant Natural := Secs mod 3600;

      H    : constant String  := Image (Secs / 3600);
      M    : constant String  := Image (Tmp / 60);
      S    : constant String  := Image (Tmp mod 60);
   begin
      return Weekday (Time) & ", " & Day & ' ' & Mon & ' ' & Year & ' '
        & H & ':' & M & ':' & S & " GMT";
   end To_HTTP_Date;

   -------------
   -- To_Time --
   -------------

   function To_Time (HTTP_Date : in String) return Calendar.Time is

      function Month_Number
        (Month_Name : in String)
         return Calendar.Month_Number;
      --  returns the month number given a 3 letter month name.

      F : constant Positive := HTTP_Date'First;

      ------------------
      -- Month_Number --
      ------------------

      function Month_Number
        (Month_Name : in String)
         return Calendar.Month_Number is
      begin
         for I in Calendar.Month_Number loop
            if Month_Name = Messages.Month_Name (I) then
               return I;
            end if;
         end loop;

         Exceptions.Raise_Exception
           (Constraint_Error'Identity,
            "Month_Number: Wrong Month name (" & Month_Name & ')');
      end Month_Number;

   begin
      return Calendar.Time_Of
        (Year    => Calendar.Year_Number'Value (HTTP_Date (F + 12 .. F + 15)),
         Month   => Month_Number (HTTP_Date (F + 8 .. F + 10)),
         Day     => Calendar.Day_Number'Value (HTTP_Date (F + 5 .. F + 6)),
         Seconds => Calendar.Day_Duration
         (Natural'Value (HTTP_Date (F + 17 .. F + 18)) * 3600
          + Natural'Value (HTTP_Date (F + 20 .. F + 21)) * 60
          + Natural'Value (HTTP_Date (F + 23 .. F + 24))));
   end To_Time;

   -----------------------
   -- Transfer_Encoding --
   -----------------------

   function Transfer_Encoding (Encoding : in String) return String is
   begin
      return Transfer_Encoding_Token & HD & Encoding;
   end Transfer_Encoding;

   ----------------
   -- User_Agent --
   ----------------

   function User_Agent (Name : in String) return String is
   begin
      return User_Agent_Token & HD & Name;
   end User_Agent;

   ----------------------
   -- Www_Authenticate --
   ----------------------

   function WWW_Authenticate (Realm : in String) return String is
   begin
      return WWW_Authenticate_Token & HD & "Basic realm=""" & Realm & """";
   end WWW_Authenticate;

   function WWW_Authenticate
     (Realm : in String;
      Nonce : in String;
      Stale : in Boolean)
      return String is
   begin
      return WWW_Authenticate_Token & HD
        & "Digest qop=""auth"", realm=""" & Realm
        & """, stale=""" & Boolean'Image (Stale)
        & """, nonce=""" & Nonce & """";
   end WWW_Authenticate;

end AWS.Messages;