File : adagio-g2-chat_peer.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: adagio-g2-chat_peer.adb,v 1.8 2004/04/01 22:11:24 Jano Exp $


with Adagio.G2.Core;
with Adagio.G2.Packet;
with Adagio.Globals.Options;
with Adagio.GUID;
with Adagio.Misc;
with Adagio.Streams;
with Adagio.Trace;
with Adagio.Unicode;

package body Adagio.G2.Chat_peer is

   use type Packet.Object;

   Chat_timeout : Duration := 300.0;

   Away_msg : Ustring renames Globals.Options.Chat_AwayMessage;
   Log_chat : Boolean renames Globals.Options.Chat_log;

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

   -- Create                                                             --

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

   -- Creation takes a connected socket and a header object with the

   -- request already read, so our response is due.

   function Create (From : in Socket.Object; Request : in Http.Header.Set) 
      return Object_access is
      Peer : Object_access;
   begin
      if not Misc.Contains (Misc.To_lower (
         Http.Header.Get (Request, "Accept")), Chat_content_type)
      then
         raise Unknown_protocol;
      end if;

      -- Creation

      Peer := new Object;
      Peer.Socket := From;
      Peer.Link   := Socket.Stream (From);
      if not Globals.Options.Chat_enabled then
         Peer.Status := Rejecting;
      end if;
      return Peer;
   end Create;

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

   -- Id                                                                 --

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

   -- Unique id

   function Id (This : in Object) return String is
   begin
      return "CHAT/" & Socket.Image (Socket.Get_peer_name (This.Socket).Addr);
   end Id;

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

   -- Process                                                            --

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

   -- Its chance to do something.

   procedure Process (
      This    : in out Object; 
      Context : in out Connect.Peer.Context_type) 
   is
   begin
      Context.Sleep := 0.5;
      -- Check for timeout

      if Chronos.Elapsed (This.Last_reply) > Chat_timeout then
         if This.Status = Connected then
            This.Status := Timeouting;
         else
            Finalize (This);
            Context.Is_done := true;
            return;
         end if;
      end if;


      -- Check for closing:

      if not Socket.Is_alive (This.Socket) then
         Trace.Log ("G2 chat connection ended by remote party.", 
            Trace.Informative);
         Finalize (This);
         Context.Is_done := true;
         return;
      end if;

      -- Dispatch according to state:

      case This.Status is
         when Handshaking =>
            Handshake  (Object'Class (This), Context);
         when Connected =>
            Do_chat    (Object'Class (This), Context);
         when Rejecting =>
            Reject     (Object'Class (This), Context);
         when Timeouting =>
            Do_timeout (Object'Class (This), Context);
      end case;
   end Process;

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

   -- Finalize                                                           --

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

   -- Release all resources.

   procedure Finalize (This : in out Object) is
   begin
      Socket.Close (This.Socket);
   end Finalize;

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

   -- Handshake                                                          --

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

   -- Do the handshaking

   procedure Handshake (
      This    : in out Object; 
      Context : in out Connect.Peer.Context_type)
   is
      pragma Unreferenced (Context);
      procedure Stage_two is
         Response : Http.Header.Set;
      begin
         Http.Header.Set_response (Response, "CHAT/0.2 200 OK");
         Http.Header.Add (Response, "Accept",       Chat_content_type);
         Http.Header.Add (Response, "Content-Type", Chat_content_type);
         Http.Header.Add (Response, "User-Agent",   User_agent);
         begin
            Http.Header.Write (
               Response, 
               This.Link.all,
               Send_response => true,
               Send_crlf     => true);
            Trace.Log ("G2.Chat_peer.Stage_two [Sent]: " &
               Http.Header.Write (Response));
            This.Handshake_stage := Three;
         exception
            when E : Socket.Socket_error =>
               case Socket.Get_error (E) is
                  when Socket.Operation_would_block =>
                     Trace.Log ("G2.Chat_peer.Handshaking (Two): " &
                        "Headers delayed, link full", Trace.Warning);
                  when others =>
                     raise;
               end case;
            when others =>
               raise;
         end;
      end Stage_two;

      procedure Stage_three is
         Response : Http.Header.Set;
      begin
         Http.Header.Parser.Check (This.Headers, This.Socket);
         if Http.Header.Parser.Completed (This.Headers) then
            Http.Header.Parser.Get_headers (This.Headers, Response);
            Trace.Log ("G2.Chat_peer.Stage_three [Read]: " &
               Http.Header.Write (Response));
            -- Verify content-type

            if not Misc.Contains (Misc.To_lower (
               Http.Header.Get (Response, "Content-Type")), Chat_content_type)
            then
               Trace.Log ("G2.Chat_peer.Stage_three: Negotiation failed.");
               raise Unknown_protocol;
            else
               G2.Packet.Parsing.Create (
                  This.Incoming, 
                  Adagio.Streams.Stream_access (Socket.Stream (This.Socket)),
                  Core.Available_socket'Access);
               This.Handshake_stage := Four;
               Trace.Log ("G2.Chat_peer.Stage_three: Handshaking completed.");

            end if;
         end if;
      end Stage_three;

      procedure Stage_four is
         P       : Packet.Object;
         Pout    : Packet.Object;
         Paux    : Packet.Object;
         Success : Boolean;
      begin
         -- Read packets and report them

         Packet.Parsing.Check (This.Incoming, Result => P);
         if P /= Packet.Null_packet then
            Trace.Log ("CHAT<-- " & Packet.To_hex (P));

            Packet.Parsing.Trace_tree (P);
            -- Rcv UPROC

            if Packet.Is_a (P, "/UPROC") then
               This.Uproc_rcv  := true;
               This.Uprod_sent := false;
            -- Rcv UPROD

            elsif Packet.Is_a (P, "/UPROD") then
               This.Uprod_rcv  := true;
            -- Rcv CHATREQ

            elsif Packet.Is_a (P, "/CHATREQ") then
               This.Chatreq_rcv := true;
               This.Chatans_sent := false;
               This.Guid := Packet.Payload (Packet.Get_child (P, "USERGUID"));
            end if;
         end if;
         -- Send UPROC

         if false and not This.Uproc_sent then
            Pout := Packet.Create ("UPROC");
            Send_packet (This, Pout, Success);
            This.Uproc_sent := Success;
         end if;
         -- Send CHATREQ

         if not This.Chatreq_sent and false then
            Pout := Packet.Create ("CHATREQ");
            Paux := Packet.Create ("USERGUID", 
               Guid.To_char_array (Guid.My_guid));
            Packet.Add_child (Pout, Paux);
            Send_packet (This, Pout, Success);
            This.Chatreq_sent := Success;
         end if;
         -- Send UPROD

         if This.Uproc_rcv and not This.Uprod_sent then
            Pout := Core.Create_uprod;
            Send_packet (This, Pout, Success);
            This.Uprod_sent := Success;
         end if;
         -- Send CHATANS

         if This.Chatreq_rcv and not This.Chatans_sent 
         then
            Pout := Packet.Create ("CHATANS");
            Paux := Packet.Create ("USERGUID", This.Guid);
            Packet.Add_child (Pout, Paux);
            Paux := Packet.Create ("ACCEPT");
            Packet.Add_child (Pout, Paux);
            Send_packet (This, Pout, Success);
            This.Chatans_sent := Success;
         end if;
         -- Step to chat

         if This.Chatans_sent then
            This.Status := Connected;
         end if;
      end Stage_four;
   begin
      case This.Handshake_stage is
         when One =>
            raise Unimplemented;
         when Two =>
            Stage_two;
         when Three =>
            Stage_three;
         when Four =>
            Stage_four;
      end case;
   end Handshake;

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

   -- Reject                                                             --

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

   -- Do the rejections

   procedure Reject (
      This    : in out Object; 
      Context : in out Connect.Peer.Context_type)
   is
      Response : Http.Header.Set;
   begin
      Http.Header.Set_response (Response, "HTTP/1.1 404 Chat disabled");
      begin
         Http.Header.Write (
            Response, 
            This.Link.all,
            Send_response => true,
            Send_crlf => true);
         Context.Is_done := true;
         Finalize (This);
         return;
      exception
         when E : Socket.Socket_error =>
            case Socket.Get_error (E) is
               when Socket.Operation_would_block =>
                  Trace.Log ("G2.Chat_peer.Rejecting: " &
                     "Headers delayed, link full", Trace.Warning);
               when others =>
                  raise;
            end case;
         when others =>
            raise;
      end;
   end Reject;

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

   -- Do_timeout                                                         --

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

   -- Send a timeout message.

   procedure Do_timeout (
      This    : in out Object; 
      Context : in out Connect.Peer.Context_type)
   is
      Success : Boolean;
   begin
      Send_phrase (
         This, "(Automatic) Closing chat because of timeout.", Success);
      if Success then
         Context.Is_done := true;
         Finalize (This);
      end if;
   end Do_timeout;

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

   -- Do_chat                                                            --

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

   -- Normal chat workings

   procedure Do_chat (
      This    : in out Object; 
      Context : in out Connect.Peer.Context_type)
   is
      pragma Unreferenced (Context);
      Success : Boolean;
      Text    : String (1 .. 1024);
      Last    : Natural;
   begin
      if not This.Reply_sent then
         Send_phrase (This, S (Away_msg), Success);
         This.Reply_sent := Success;
      end if;
      Read_phrase (This, Text, Last);
      if Last > 0 then
         This.Reply_sent := false;
      end if;
   end Do_chat;

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

   -- Send_phrase                                                        --

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

   -- Send a text

   -- If success is false then the link is saturated; retry later.

   procedure Send_phrase (
      This    : in out Object; 
      Text    : in     String;
      Success : out    Boolean)
   is
      P : Packet.Object := Packet.Create ("CMSG");
      B : Packet.Object := Packet.Create ("BODY", Unicode.To_utf8 (Text));
   begin
      Packet.Add_child (P, B);
      Packet.Atomic_write (This.Link, P, Success);
      if Log_chat and then Success then
         Trace.Log (
            "CHAT/Me: " & Text, Trace.Informative, 
            File => S (Globals.Options.Chat_logfile));
      end if;
   end Send_phrase;

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

   -- Receive_phrase                                                     --

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

   -- Receives a phrase

   -- Will return Last = 0 if nothing read.

   -- It returns complete lines, will not break them.

   procedure Read_phrase (
      This : in out Object;
      Text :    out String;
      Last :    out Natural)
   is
      P    : Packet.Object;
      Read : Ustring;
   begin
      Packet.Parsing.Check (This.Incoming, Result => P);
      if P /= Packet.Null_packet then
         Trace.Log ("CHAT<-- " & Packet.To_hex (P));

         Packet.Parsing.Trace_tree (P);

         if Packet.Is_a (P, "/CMSG/BODY") then
            Read := U (Unicode.G2_to_string (
               Packet.Payload (Packet.Get_child (P, "BODY")),
               Packet.Big_endian (P)));
            Last := Integer'Min (ASU.Length (Read), Text'Last);
            Text (1 .. Last) := ASU.Slice (Read, 1, Last);
            if Log_chat then
               Trace.Log (
                  "CHAT/He: " & S (Read), 
                  Trace.Informative, 
                  File => S (Globals.Options.Chat_logfile));
            end if;
         end if;
      else
         Last := 0;
      end if;
   end Read_phrase;

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

   -- Send_packet                                                        --

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

   -- Tries to send a packet

   procedure Send_packet (
      This    : in out Object; 
      Packet  : in     G2.Packet.Object;
      Success : out    Boolean) is
   begin
      delay 0.1;
      G2.Packet.Write (This.Link, Packet);
      Trace.Log ("CHAT-->" & G2.Packet.To_hex (Packet));

      G2.Packet.Parsing.Trace_tree (Packet);
      Success := true;
   exception
      when E : Socket.Socket_error =>
         case Socket.Get_error (E) is
            when Socket.Operation_would_block =>
               Success := false;
            when others => 
               raise;
         end case;
   end Send_packet;

end Adagio.G2.Chat_peer;