File : aws-response.adb


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

--                              Ada Web Server                              --

--                                                                          --

--                         Copyright (C) 2000-2003                          --

--                                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-response.adb,v 1.1 2003/10/05 19:59:58 Jano Exp $


with Ada.Strings.Fixed;
with Ada.Unchecked_Deallocation;

with AWS.Headers.Set;
with AWS.Headers.Values;
with AWS.Resources.Embedded;
with AWS.Response.Set;
with AWS.Translator;

package body AWS.Response is

   use Streams;

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

   -- Acknowledge --

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


   function Acknowledge
     (Status_Code  : in Messages.Status_Code;
      Message_Body : in String := "";
      Content_Type : in String := MIME.Text_HTML)
      return Data
   is
      Result : Data;
   begin
      Set.Status_Code (Result, Status_Code);

      if Message_Body = "" then
         Set.Mode (Result, Header);
      else
         Set.Message_Body (Result, Message_Body);
         Set.Content_Type (Result, Content_Type);
      end if;

      return Result;
   end Acknowledge;

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

   -- Adjust --

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


   procedure Adjust (Object : in out Data) is
   begin
      Object.Ref_Counter.all := Object.Ref_Counter.all + 1;
   end Adjust;

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

   -- Authenticate --

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


   function Authenticate
     (Realm : in String;
      Mode  : in Authentication_Mode := Basic;
      Stale : in Boolean             := False)
      return Data
   is
      Result : Data;
      CRLF : constant String := ASCII.CR & ASCII.LF;

      Auth_Mess : constant String
        := "<HTML><HEAD>" & CRLF
        & "<TITLE>401 Authorization Required</TITLE>" & CRLF
        & "</HEAD><BODY>" & CRLF
        & "<H1>Authorization Required</H1>" & CRLF
        & "This server could not verify that you" & CRLF
        & "are authorized to access the document you" & CRLF
        & "requested.  Either you supplied the wrong" & CRLF
        & "credentials (e.g., bad password), or your" & CRLF
        & "browser doesn't understand how to supply" & CRLF
        & "the credentials required.<P>" & CRLF
        & "</BODY></HTML>" & CRLF;
   begin
      Set.Authentication (Result, Realm, Mode, Stale);
      Set.Content_Type   (Result, AWS.MIME.Text_HTML);
      Set.Message_Body   (Result, Auth_Mess);
      return Result;
   end Authenticate;

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

   -- Authentication --

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


   function Authentication (D : in Data) return Authentication_Mode is
      use AWS.Headers;
      Auth_Values : VString_Array
        := Get_Values (D.Header, Messages.WWW_Authenticate_Token);
   begin
      if Auth_Values'Length = 1 then
         return Authentication_Mode'Value
            (Values.Get_Unnamed_Value (To_String (Auth_Values (1)), 1));
      else
         return Any;
      end if;
   end Authentication;

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

   -- Authentication_Stale --

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


   function Authentication_Stale (D : in Data) return Boolean is
      use AWS.Headers;
      Auth_Values : VString_Array
        := Get_Values (D.Header, Messages.WWW_Authenticate_Token);
   begin
      for J in Auth_Values'Range loop
         declare
            Stale_Image : constant String :=
               Values.Search (To_String (Auth_Values (J)), "stale", False);
         begin
            if Stale_Image /= "" then
               return Boolean'Value (Stale_Image);
            end if;
         end;
      end loop;
      return False;
   end Authentication_Stale;

   -----------

   -- Build --

   -----------


   function Build
     (Content_Type  : in String;
      Message_Body  : in String;
      Status_Code   : in Messages.Status_Code  := Messages.S200;
      Cache_Control : in Messages.Cache_Option := Messages.Unspecified)
      return Data
   is
      Result : Data;
   begin
      Set.Status_Code   (Result, Status_Code);
      Set.Content_Type  (Result, Content_Type);
      Set.Message_Body  (Result, Message_Body);
      Set.Cache_Control (Result, Cache_Control);
      return Result;
   end Build;

   function Build
     (Content_Type    : in String;
      UString_Message : in Strings.Unbounded.Unbounded_String;
      Status_Code     : in Messages.Status_Code  := Messages.S200;
      Cache_Control   : in Messages.Cache_Option := Messages.Unspecified)
      return Data
   is
      Result : Data;
   begin
      Set.Status_Code   (Result, Status_Code);
      Set.Content_Type  (Result, Content_Type);
      Set.Message_Body  (Result, UString_Message);
      Set.Cache_Control (Result, Cache_Control);
      return Result;
   end Build;

   function Build
     (Content_Type  : in String;
      Message_Body  : in Streams.Stream_Element_Array;
      Status_Code   : in Messages.Status_Code         := Messages.S200;
      Cache_Control : in Messages.Cache_Option        := Messages.Unspecified)
      return Data
   is
      Result : Data;
   begin
      Set.Status_Code   (Result, Status_Code);
      Set.Content_Type  (Result, Content_Type);
      Set.Message_Body  (Result, Message_Body);
      Set.Cache_Control (Result, Cache_Control);
      return Result;
   end Build;

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

   -- Cache_Control --

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


   function Cache_Control (D : in Data) return Messages.Cache_Option is
   begin
      return Messages.Cache_Option
        (Headers.Get (D.Header, Messages.Cache_Control_Token));
   end Cache_Control;

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

   -- Content_Length --

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


   function Content_Length (D : in Data) return Content_Length_Type is
   begin
      return D.Content_Length;
   end Content_Length;

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

   -- Content_Type --

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


   function Content_Type (D : in Data) return String is
   begin
      return Headers.Get (D.Header, Messages.Content_Type_Token);
   end Content_Type;

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

   -- Create_Resource --

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


   procedure Create_Resource
     (File :    out AWS.Resources.File_Type;
      D    : in     Data)
   is
      use AWS.Resources;
   begin
      case D.Mode is
         when Response.File =>
            Open (File, Filename (D), "shared=no");

         when Response.Stream =>
            Resources.Streams.Create (File, D.Stream);

         when Response.Message =>
            Embedded.Create (File, Embedded.Buffer_Access (D.Message_Body));

         when others =>
            --  Should not be called for others response modes.

            raise Constraint_Error;
      end case;
   end Create_Resource;

   -----------

   -- Empty --

   -----------


   function Empty return Data is
      Result : Data;
   begin
      Set.Status_Code  (Result, Messages.S204);
      return Result;
   end Empty;

   ----------

   -- File --

   ----------


   function File
     (Content_Type : in String;
      Filename     : in String;
      Status_Code  : in Messages.Status_Code := Messages.S200)
      return Data
   is
      Result : Data;
   begin
      Set.Status_Code  (Result, Status_Code);
      Set.Content_Type (Result, Content_Type);
      Set.Filename     (Result, Filename);
      return Result;
   exception
      when Resources.Resource_Error =>
         return Acknowledge (Messages.S404, "<p> " & Filename & " not found");
   end File;

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

   -- Filename --

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


   function Filename (D : in Data) return String is
   begin
      return To_String (D.Filename);
   end Filename;

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

   -- Finalize --

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


   procedure Finalize (Object : in out Data) is

      procedure Free is new Ada.Unchecked_Deallocation
        (Natural, Natural_Access);

   begin
      Object.Ref_Counter.all := Object.Ref_Counter.all - 1;

      if Object.Ref_Counter.all = 0 then
         Free (Object.Ref_Counter);
         Utils.Free (Object.Message_Body);

         AWS.Headers.Set.Free (Object.Header);
      end if;
   end Finalize;

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

   -- Header --

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


   function Header
     (D    : in Data;
      Name : in String;
      N    : in Positive)
      return String is
   begin
      return Headers.Get (D.Header, Name, N);
   end Header;

   function Header
     (D    : in Data;
      Name : in String)
      return String is
   begin
      return Headers.Get_Values (D.Header, Name);
   end Header;

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

   -- Initialize --

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


   procedure Initialize (Object : in out Data) is
   begin
      Object.Ref_Counter := new Natural'(1);
      AWS.Headers.Set.Reset (Object.Header);
   end Initialize;

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

   -- Location --

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


   function Location (D : in Data) return String is
   begin
      return Headers.Get (D.Header, Messages.Location_Token);
   end Location;

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

   -- Message_Body --

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


   function Message_Body (D : in Data) return String is
      use type Utils.Stream_Element_Array_Access;
   begin
      if D.Message_Body = null then
         return "";
      else
         return Translator.To_String (D.Message_Body.all);
      end if;
   end Message_Body;

   function Message_Body (D : in Data) return Unbounded_String is
      use type Utils.Stream_Element_Array_Access;
   begin
      if D.Message_Body = null then
         return Null_Unbounded_String;
      else
         return Translator.To_Unbounded_String (D.Message_Body.all);
      end if;
   end Message_Body;

   function Message_Body (D : in Data) return Streams.Stream_Element_Array is
      use type Utils.Stream_Element_Array_Access;
      No_Data : constant Streams.Stream_Element_Array := (1 .. 0 => 0);
   begin
      if D.Message_Body = null then
         return No_Data;
      else
         return D.Message_Body.all;
      end if;
   end Message_Body;

   ----------

   -- Mode --

   ----------


   function Mode (D : in Data) return Data_Mode is
   begin
      return D.Mode;
   end Mode;

   -----------

   -- Moved --

   -----------


   function Moved
     (Location : in String;
      Message  : in String := Default_Moved_Message)
      return Data
   is
      use Ada.Strings;

      Result : Data;

      function Build_Message_Body return String;
      --  Returns proper message body using Message template. It replaces _@_

      --  in Message by Location.


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

      -- Build_Message_Body --

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


      function Build_Message_Body return String is
         Start : constant Natural := Fixed.Index (Message, "_@_");
      begin
         if Start = 0 then
            return Message;
         else
            return Fixed.Replace_Slice (Message, Start, Start + 2, Location);
         end if;
      end Build_Message_Body;

      Message_Body : constant String := Build_Message_Body;

   begin
      Set.Location     (Result, Location);
      Set.Status_Code  (Result, Messages.S301);
      Set.Message_Body (Result, Message_Body);
      Set.Content_Type (Result, AWS.MIME.Text_HTML);
      return Result;
   end Moved;

   -----------

   -- Realm --

   -----------


   function Realm (D : in Data) return String is
      use Headers;
   begin
      return Values.Search
        (Header_Value   => Get (D.Header, Messages.WWW_Authenticate_Token),
         Name           => "realm",
         Case_Sensitive => False);
   end Realm;

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

   -- Send_Header --

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


   procedure Send_Header (Socket : in Net.Socket_Type'Class; D : in Data) is
   begin
      Headers.Send_Header (Socket, D.Header);
   end Send_Header;

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

   -- Socket_Taken --

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


   function Socket_Taken return Data is
      Result : Data;
   begin
      Set.Mode (Result, Socket_Taken);
      return Result;
   end Socket_Taken;

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

   -- Status_Code --

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


   function Status_Code (D : in Data) return Messages.Status_Code is
   begin
      return D.Status_Code;
   end Status_Code;

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

   -- Stream --

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


   function Stream
     (Content_Type  : in String;
      Stream_Handle : in Resources.Streams.Stream_Access;
      Stream_Size   : in Content_Length_Type   := Undefined_Length;
      Status_Code   : in Messages.Status_Code  := Messages.S200;
      Cache_Control : in Messages.Cache_Option := Messages.No_Cache)
      return Data
   is
      Result : Data;
   begin
      Set.Stream        (Result, Stream_Handle, Stream_Size);
      Set.Status_Code   (Result, Status_Code);
      Set.Content_Type  (Result, Content_Type);
      Set.Cache_Control (Result, Cache_Control);
      return Result;
   end Stream;

   ---------

   -- URL --

   ---------


   function URL (Location : in String) return Data is
      Result : Data;
   begin
      Set.Status_Code (Result, Messages.S301);
      Set.Location    (Result, Location);
      Set.Mode (Result, Header);
      return Result;
   end URL;

end AWS.Response;