File : src/aws-server-push.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-server-push.adb,v 1.22 2003/03/31 16:52:18 obry Exp $

with Ada.Calendar;

with AWS.Messages;
with AWS.MIME;
with AWS.Utils;

with GNAT.Calendar.Time_IO;
with System;

package body AWS.Server.Push is

   use AWS.Net;

   function To_Holder
     (Socket      : in Net.Socket_Type'Class;
      Environment : in Client_Environment;
      Kind        : in Mode)
      return Client_Holder;

   function To_Stream (Socket : in Net.Socket_Type'Class) return Stream_Access
     renames AWS.Net.Stream_IO.Stream;

   New_Line : constant String := ASCII.CR & ASCII.LF;
   --  HTTP new line.

   Boundary : constant String := "--AWS.Push.Boundary_"
     & GNAT.Calendar.Time_IO.Image (Ada.Calendar.Clock, "%s")
     & New_Line;
   --  This is the multi-part boundary string used by AWS push server.

   -----------
   -- Count --
   -----------

   function Count (Server : in Object) return Natural is
   begin
      return Server.Count;
   end Count;

   -------------
   -- Is_Open --
   -------------

   function Is_Open (Server : in Object) return Boolean is
   begin
      return Server.Is_Open;
   end Is_Open;

   ------------
   -- Object --
   ------------

   protected body Object is

      ---------------
      -- Send_Data --
      ---------------

      procedure Send_Data
        (Holder       : in Client_Holder;
         Data         : in Client_Output_Type;
         Content_Type : in String);
      --  Send Data to a client identified by Holder.

      -----------
      -- Count --
      -----------

      function Count return Natural is
      begin
         return Table.Size (Container);
      end Count;

      -------------
      -- Is_Open --
      -------------

      function Is_Open return Boolean is
      begin
         return Open;
      end Is_Open;

      --------------
      -- Register --
      --------------

      procedure Register
        (Client_ID       : in     Client_Key;
         Holder          : in out Client_Holder;
         Close_Duplicate : in     Boolean)
      is
         Duplicate : Boolean;
      begin

         if not Open then
            Net.Stream_IO.Free (Holder.Stream, False);
            raise Closed;
         end if;

         Table.Insert (Container, Client_ID, Holder, Duplicate);

         if Duplicate then
            if Close_Duplicate then
               Unregister (Client_ID, True);
               Table.Insert (Container, Client_ID, Holder);
            else
               Net.Stream_IO.Free (Holder.Stream, False);
               raise Duplicate_Client_ID;
            end if;
         end if;

         begin
            String'Write
              (Holder.Stream,
               "HTTP/1.1 200 OK" & New_Line
                 & "Server: AWS (Ada Web Server) v"
                 & Version & New_Line
                 & Messages.Connection ("Close") & New_Line);

            if Holder.Kind = Chunked then
               String'Write
                 (Holder.Stream,
                  Messages.Transfer_Encoding ("chunked")
                    & New_Line & New_Line);

            elsif Holder.Kind = Multipart then
               String'Write
                 (Holder.Stream,
                  Messages.Content_Type
                    (MIME.Multipart_X_Mixed_Replace, Boundary)
                    & New_Line);

            else
               String'Write (Holder.Stream, New_Line);
            end if;

            Net.Stream_IO.Flush (Holder.Stream);

         exception
            when others =>
               Unregister (Client_ID, Close_Socket => False);
               raise;
         end;
      end Register;

      procedure Register
        (Client_ID         : in     Client_Key;
         Holder            : in out Client_Holder;
         Init_Data         : in     Client_Output_Type;
         Init_Content_Type : in     String;
         Close_Duplicate   : in     Boolean) is
      begin
         Register (Client_ID, Holder, Close_Duplicate);

         begin
            Send_Data (Holder, Init_Data, Init_Content_Type);
         exception
            when others =>
               Unregister (Client_ID, Close_Socket => False);
               raise;
         end;
      end Register;

      -------------
      -- Restart --
      -------------

      procedure Restart is
      begin
         Open := True;
      end Restart;

      ----------
      -- Send --
      ----------

      procedure Send
        (Data         : in     Client_Output_Type;
         Content_Type : in     String;
         Unregistered : in out Table.Table_Type)
      is

         procedure Action
           (Key          : in     Client_Key;
            Value        : in     Client_Holder;
            Order_Number : in     Positive;
            Continue     : in out Boolean);

         procedure Free
           (Key          : in     Client_Key;
            Value        : in     Client_Holder;
            Order_Number : in     Positive;
            Continue     : in out Boolean);

         ------------
         -- Action --
         ------------

         procedure Action
           (Key          : in     Client_Key;
            Value        : in     Client_Holder;
            Order_Number : in     Positive;
            Continue     : in out Boolean)
         is
            pragma Unreferenced (Order_Number);
            pragma Unreferenced (Continue);
         begin
            Send_Data (Value, Data, Content_Type);
         exception
            when Net.Socket_Error =>
               Table.Insert (Unregistered, Key, Value);
         end Action;

         ----------
         -- Free --
         ----------

         procedure Free
           (Key          : in     Client_Key;
            Value        : in     Client_Holder;
            Order_Number : in     Positive;
            Continue     : in out Boolean)
         is
            pragma Unreferenced (Value);
            pragma Unreferenced (Order_Number);
            pragma Unreferenced (Continue);
         begin
            Unregister (Key, True);
         end Free;

         procedure For_Each is new Table.Disorder_Traverse_G (Action);

         procedure Remove_Each is new Table.Disorder_Traverse_G (Free);

      begin
         For_Each (Container);
         Remove_Each (Unregistered);
      end Send;

      ---------------
      -- Send_Data --
      ---------------

      procedure Send_Data
        (Holder       : in Client_Holder;
         Data         : in Client_Output_Type;
         Content_Type : in String)
      is
         Data_To_Send : constant Stream_Output_Type
           := To_Stream_Output (Data, Holder.Environment);

      begin
         if Holder.Kind = Multipart then
            String'Write
              (Holder.Stream,
               Boundary
                 & Messages.Content_Type (Content_Type) & New_Line & New_Line);

         elsif Holder.Kind = Chunked then
            String'Write
              (Holder.Stream,
               Utils.Hex (Data_To_Send'Size / System.Storage_Unit) & New_Line);
         end if;

         Stream_Output_Type'Write (Holder.Stream, Data_To_Send);

         if Holder.Kind = Multipart then
            String'Write (Holder.Stream, New_Line & New_Line);

         elsif Holder.Kind = Chunked then
            String'Write (Holder.Stream, New_Line);
         end if;

         Net.Stream_IO.Flush (Holder.Stream);
      end Send_Data;

      -------------
      -- Send_To --
      -------------

      procedure Send_To
        (Client_ID    : in Client_Key;
         Data         : in Client_Output_Type;
         Content_Type : in String)
      is
         Holder : Client_Holder;
      begin
         Holder := Table.Value (Container, Client_ID);
         Send_Data (Holder, Data, Content_Type);

      exception
         when Table.Missing_Item_Error =>
            raise Client_Gone;

         when Net.Socket_Error =>
            Unregister (Client_ID, True);
            raise Client_Gone;
      end Send_To;

      --------------
      -- Shutdown --
      --------------

      procedure Shutdown (Close_Sockets : in Boolean) is
      begin
         Open := False;
         Unregister_Clients (Close_Sockets => Close_Sockets);
      end Shutdown;


      procedure Shutdown
        (Final_Data         : in Client_Output_Type;
         Final_Content_Type : in String)
      is
         Gone : Table.Table_Type;
      begin
         Send (Final_Data, Final_Content_Type, Gone);
         Table.Destroy (Gone);
         Shutdown (Close_Sockets => True);
      end Shutdown;

      -----------------------
      -- Shutdown_If_Empty --
      -----------------------

      procedure Shutdown_If_Empty (Open : out Boolean) is
      begin
         if Table.Size (Container) = 0 then
            Object.Open := False;
         end if;
         Shutdown_If_Empty.Open := Object.Open;
      end Shutdown_If_Empty;

      ----------------
      -- Unregister --
      ----------------

      procedure Unregister
        (Client_ID    : in Client_Key;
         Close_Socket : in Boolean)
      is
         Value : Client_Holder;
      begin
         Table.Remove (Container, Client_ID, Value);

         if Close_Socket then
            Net.Stream_IO.Shutdown (Value.Stream);
         end if;

         Net.Stream_IO.Free (Value.Stream, Close_Socket);

      exception
         when Table.Missing_Item_Error =>
            null;
      end Unregister;

      ------------------------
      -- Unregister_Clients --
      ------------------------

      procedure Unregister_Clients (Close_Sockets : in Boolean) is
      begin
         while Table.Size (Container) > 0 loop
            Unregister (Table.Min_Key (Container), Close_Sockets);
         end loop;
      end Unregister_Clients;

   end Object;

   --------------
   -- Register --
   --------------

   procedure Register
     (Server            : in out Object;
      Client_ID         : in     Client_Key;
      Socket            : in     Net.Socket_Type'Class;
      Environment       : in     Client_Environment;
      Init_Data         : in     Client_Output_Type;
      Init_Content_Type : in     String := "";
      Kind              : in     Mode := Plain;
      Close_Duplicate   : in     Boolean := False)
   is
      Holder : Client_Holder := To_Holder (Socket, Environment, Kind);
   begin
      Server.Register
        (Client_ID,
         Holder,
         Init_Data,
         Init_Content_Type,
         Close_Duplicate);
   end Register;

   procedure Register
     (Server          : in out Object;
      Client_ID       : in     Client_Key;
      Socket          : in     Net.Socket_Type'Class;
      Environment     : in     Client_Environment;
      Kind            : in     Mode               := Plain;
      Close_Duplicate : in     Boolean := False)
   is
      Holder : Client_Holder := To_Holder (Socket, Environment, Kind);
   begin
      Server.Register (Client_ID, Holder, Close_Duplicate);
   end Register;

   -------------
   -- Restart --
   -------------

   procedure Restart (Server : in out Object) is
   begin
      Server.Restart;
   end Restart;

   ----------
   -- Send --
   ----------

   procedure Send
     (Server       : in out Object;
      Data         : in     Client_Output_Type;
      Content_Type : in     String             := "")
   is
      Gone : Table.Table_Type;
   begin
      Server.Send (Data, Content_Type, Gone);
      Table.Destroy (Gone);
   end Send;

   ------------
   -- Send_G --
   ------------

   procedure Send_G
     (Server       : in out Object;
      Data         : in     Client_Output_Type;
      Content_Type : in     String             := "")
   is
      procedure Action
        (Key          : in     Client_Key;
         Value        : in     Client_Holder;
         Order_Number : in     Positive;
         Continue     : in out Boolean);

      Gone : Table.Table_Type;

      ------------
      -- Action --
      ------------

      procedure Action
        (Key          : in     Client_Key;
         Value        : in     Client_Holder;
         Order_Number : in     Positive;
         Continue     : in out Boolean)
      is
         pragma Unreferenced (Value);
         pragma Unreferenced (Order_Number);
         pragma Unreferenced (Continue);
      begin
         Client_Gone (Key);
      end Action;

      procedure For_Each is new Table.Disorder_Traverse_G (Action);

   begin
      Server.Send (Data, Content_Type, Gone);
      For_Each (Gone);
      Table.Destroy (Gone);
   end Send_G;

   -------------
   -- Send_To --
   -------------

   procedure Send_To
     (Server       : in out Object;
      Client_ID    : in     Client_Key;
      Data         : in     Client_Output_Type;
      Content_Type : in     String             := "") is
   begin
      Server.Send_To (Client_ID, Data, Content_Type);
   end Send_To;

   --------------
   -- Shutdown --
   --------------

   procedure Shutdown
     (Server        : in out Object;
      Close_Sockets : in     Boolean := True) is
   begin
      Server.Shutdown (Close_Sockets => Close_Sockets);
   end Shutdown;

   procedure Shutdown
     (Server             : in out Object;
      Final_Data         : in     Client_Output_Type;
      Final_Content_Type : in     String             := "") is
   begin
      Server.Shutdown (Final_Data, Final_Content_Type);
   end Shutdown;

   -----------------------
   -- Shutdown_If_Empty --
   -----------------------

   procedure Shutdown_If_Empty (Server : in out Object; Open : out Boolean) is
   begin
      Server.Shutdown_If_Empty (Open);
   end Shutdown_If_Empty;

   ---------------
   -- To_Holder --
   ---------------

   function To_Holder
     (Socket      : in Net.Socket_Type'Class;
      Environment : in Client_Environment;
      Kind        : in Mode)
      return Client_Holder is
   begin
      return (Kind        => Kind,
              Environment => Environment,
              Stream      => To_Stream (Socket));
   end To_Holder;

   ----------------
   -- Unregister --
   ----------------

   procedure Unregister
     (Server       : in out Object;
      Client_ID    : in     Client_Key;
      Close_Socket : in     Boolean    := True) is
   begin
      Server.Unregister (Client_ID, Close_Socket);
   end Unregister;

   ------------------------
   -- Unregister_Clients --
   ------------------------

   procedure Unregister_Clients
     (Server        : in out Object;
      Close_Sockets : in     Boolean := True) is
   begin
      Server.Unregister_Clients (Close_Sockets => Close_Sockets);
   end Unregister_Clients;

end AWS.Server.Push;