File : agpl-http-server.adb


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

--                         ADAGIO - ADALID - AENEA.                         --

--                                                                          --

--                            Copyright (C) 2003                            --

--                                 A. Mosteo.                               --

--                                                                          --

--  Authors: A. Mosteo. (adagio@mosteo.com)                                 --

--                                                                          --

--  If you have any questions in regard to this software, please address    --

--  them to the above email.                                                --

--                                                                          --

--  This program 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 program 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.          --

--                                                                          --

--  You are not allowed to use any part of this code to develop a program   --

--  whose output would be used to harass or prosecute other users of the    --

--  networks Adagio connects with. All data collected with Adagio or a tool --

--  containing Adagio code about other network users must remain            --

--  confidential and cannot be made public by any mean, nor be used to      --

--  harass or legally prosecute these users.                                --

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

--  $Id: agpl-http-server.adb,v 1.6 2004/02/24 15:26:09 Jano Exp $


with Aws.Messages;
with Aws.Mime;
with Aws.Parameters;
with Aws.Resources.Embedded;
with AWS.Response;
with AWS.Status;
with AWS.Status.Set;
use  AWS;

with Templates_parser;

with Charles.Maps.Hashed.Strings.Unbounded;
with Charles.Hash_string;

with Gnat.Os_lib;
use  Gnat;

package body Agpl.Http.Server is

   -- Root:

   Root        : Ustring;
   -- Server name:

   Server_name : Ustring;
   -- Style sheet:

   Style_sheet : Ustring;

   -- Auth:

   Username : Ustring;
   Password : Ustring;
   
   -- Handlers:

   type Handler_access is access Handler_object'Class;
   package Disp_tables is new Charles.Maps.Hashed.Strings.Unbounded (
      Handler_access, Charles.Hash_string, "=", "="); 
   Dispatchers : Disp_tables.Container_type;

   -- Ahead declaration

   function Dispatcher_404 (Request : in Aws.Status.Data) 
      return Aws.Response.Data;

   -- SOAP handler

   Soap_handler : Handler_function;

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

   -- Authorize --

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

   function Authorize (Request : in AWS.Status.Data) 
      return Aws.Response.Data
   is
   begin
      return Aws.Response.Authenticate (
         "You are coming from " & Aws.Status.Peername (Request) &
         ". Your papers, please:", Aws.Response.Basic);
   end Authorize;

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

   -- Check_user --

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

   function Check_user (Request : in AWS.Status.Data) return Boolean is
      User : constant String := Aws.Status.Authorization_Name (Request);
      Pwd  : constant String := Aws.Status.Authorization_Password (Request);
      Addr  :constant String := Aws.Status.Peername (Request);
   begin
      if Addr'Length < 9 or else 
         Addr (Addr'First .. Addr'First + 8) /= "127.0.0.1" 
      then
         if User /= S (Username) or else Pwd /= S (Password) then
            -- Small delay to difficult dictionary attacks:

            delay 1.0;
            return false;
         end if;
      end if;

      return true;
   end Check_user;

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

   -- Callback function --

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

   function Callback_function (Request : in AWS.Status.Data)
     return AWS.Response.Data is
     use Disp_tables;
     use Templates_parser;
     URI  : constant String := Aws.Status.URI (Request);
     I    : constant Iterator_type := Find (Dispatchers, URI);
     Path : constant String := S (Root) & URI (URI'first + 1 .. URI'last);
   begin
      if not Check_user (Request) then
         return Authorize (Request);
      end if;

      if AWS.Status.Is_SOAP(Request) then
         if Soap_handler /= null then
            return Soap_handler (Request);
         else
            raise Unimplemented;
         end if;
      else
         -- Dispatch according to the request:

         if I /= Back (Dispatchers) then
            return Get_page (Element (I).all, Request);
         elsif Os_lib.Is_regular_file (Path) or else
            Aws.Resources.Embedded.Exists (Path)
         then
            if Aws.Mime.Is_text (Aws.Mime.Content_type (Path)) then
               return Aws.Response.Build (
                  Aws.Mime.Content_type (Path), 
                  Ustring'(Parse (Path, Standard_xlats (Request))),
                  Cache_control => Aws.Messages.No_cache);
            else
               return Aws.Response.File (Aws.Mime.Content_type (Path), Path);
            end if;
         else
            return Dispatcher_404 (Request);
         end if;
      end if;
   end Callback_function;

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

   -- Register_user_pass                                                 --

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

   -- Stores an user/pass; currently only a pair is stored.

   -- The server must have started with session support.

   procedure Register_user_pass (User : in String; Pass : in String) is
   begin
      Username := U (User);
      Password := U (Pass);
   end Register_user_pass;

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

   -- Register_soap                                                      --

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

   -- Basic SOAP management: only a custom handler can be registered:

   procedure Register_soap (Handler : in Handler_function) is
   begin
      Soap_handler := Handler;
   end Register_soap;

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

   -- Register_handler                                                   --

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

   procedure Register_handler (
      URI : in String; Handler : in Handler_object'Class) is
      use Disp_tables;
   begin
      Insert (Dispatchers, URI, new Handler_object'Class'(Handler));
   end Register_handler;

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

   -- Request_Redirect                                                   --

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

   function Request_Redirect (
      From : in Aws.Status.Data; To : in String) return Aws.Response.Data 
   is
   begin
      declare
         New_req : Aws.Status.Data := From; -- To copy auth data

      begin
         Aws.Status.Set.Request (
            New_req, Aws.Status.GET, To, Aws.Http_version);
         return Agpl.Http.Server.Callback_function (New_req);
      end;
   end Request_Redirect;

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

   -- Dispatcher_404                                                     --

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

   function Dispatcher_404 (Request : in Aws.Status.Data)
      return Aws.Response.Data 
   is
      use Disp_tables;
      use Templates_parser;
      I : Iterator_type := First (Dispatchers);
      V : Vector_tag;
   begin
      while I /= Back (Dispatchers) loop
         V := V & Key (I);
         I := Succ (I);
      end loop;
      declare
         Translat : Translate_table := (
            1 => Assoc ("SERVICE", V),
            2 => Assoc ("VERSION", Server_name));
      begin
         return Aws.Response.Acknowledge (
            Aws.Messages.S404,
            String'(
               Parse (S (Root) & "err404.html", 
                  Translat & Standard_xlats (Request))),
            Aws.Mime.Text_html);
      end;
   end Dispatcher_404;

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

   -- Get_root                                                           --

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

   function Get_root return String is
   begin
      return S (Root);
   end Get_root;

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

   -- Set_root                                                           --

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

   -- Says what's the root folder to prepend to all requests

   procedure Set_root (Root : in String := "") is
   begin
      Server.Root := U (Root);
   end Set_root;

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

   -- Get_server_name                                                    --

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

   function Get_server_name return String is
   begin
      return S (Server_name);
   end Get_server_name;

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

   -- Set_server_name                                                    --

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

   -- String used for the @_VERSION_@ tag

   procedure Set_server_name (Version : in String := "") is
   begin
      Server_name := U (Version);
   end Set_server_name;

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

   -- Set_style_sheet                                                    --

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

   -- Sets the file to be used as style

   procedure Set_style_sheet (Sheet : in String := "") is
   begin
      Style_sheet := U (Sheet);
   end Set_style_sheet;

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

   -- Get_style_sheet                                                    --

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

   function Get_style_sheet return String is
   begin
      return S (Style_sheet);
   end Get_style_sheet;

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

   -- Standard_xlats                                                     --

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

   -- Replaces standard tags for all pages:

   -- VERSION <-- Get_server_name

   -- STYLE   <-- Get_style_sheet

   -- URI     <-- Uri of the request

   function Standard_xlats (Request : in Aws.Status.Data)
      return Templates_parser.Translate_table is
      use Templates_parser;
      Params : constant Aws.Parameters.List := 
         Aws.Status.Parameters (Request);
   begin
      return (
         Assoc ("STYLE",   Get_style_sheet),
         Assoc ("VERSION", Get_server_name),
         Assoc ("URI",     Aws.Status.URI (Request) & 
                           Aws.Parameters.Uri_format (Params))
         );
   end;

end Agpl.Http.Server;