------------------------------------------------------------------------------ -- -- -- GNOGA - The GNU Omnificent GUI for Ada -- -- -- -- G N O G A . S E R V E R . C O N N E C I O N -- -- -- -- B o d y -- -- -- -- -- -- Copyright (C) 2014 David Botton -- -- -- -- This library is free software; you can redistribute it and/or modify -- -- it under terms of the GNU General Public License as published by the -- -- Free Software Foundation; either version 3, 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. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are -- -- granted additional permissions described in the GCC Runtime Library -- -- Exception, version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- -- 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. -- -- -- -- For more information please go to http://www.gnoga.com -- ------------------------------------------------------------------------------ with Ada.Streams; with Ada.Directories; with Ada.Strings; with Ada.Unchecked_Deallocation; with Ada.Exceptions; with Ada.Containers.Ordered_Maps; with Ada.Text_IO; with Ada.Streams.Stream_IO; with GNAT.Sockets.Server; use GNAT.Sockets.Server; with GNAT.Sockets.Connection_State_Machine.HTTP_Server; use GNAT.Sockets.Connection_State_Machine.HTTP_Server; with Gnoga.Server.Mime; with Gnoga.Application; with Gnoga.Server.Connection.Common; use Gnoga.Server.Connection.Common; with Gnoga.Server.Template_Parser.Simple; with Strings_Edit.Quoted; with Strings_Edit.Streams; package body Gnoga.Server.Connection is use type Gnoga.Types.Pointer_to_Connection_Data_Class; On_Connect_Event : Connect_Event := null; On_Post_Event : Post_Event := null; On_Post_Request_Event : Post_Request_Event := null; On_Post_File_Event : Post_File_Event := null; Exit_Application_Requested : Boolean := False; function Global_Gnoga_Client_Factory (Listener : access Connections_Server'Class; Request_Length : Positive; Input_Size : Buffer_Length; Output_Size : Buffer_Length) return Connection_Ptr; -- Passed to Gnoga.Server.Connection.Common.Gnoga_Client_Factory -- This allows a common HTTP client for secure and insecure connections -- and when desired the secure libraries connection need not be linked in. ------------------------------------------------------------------------- -- Private Types ------------------------------------------------------------------------- protected type String_Buffer is procedure Buffering (Value : Boolean); function Buffering return Boolean; procedure Add (S : in String); -- Add to end of buffer procedure Preface (S : in String); -- Preface to buffer function Get return String; -- Retrieve buffer procedure Get_And_Clear (S : out String); -- Retrieve and clear buffer function Length return Natural; -- Size of buffer procedure Clear; -- Clear buffer private Is_Buffering : Boolean := False; Buffer : String; end String_Buffer; task type Watchdog_Type is entry Start; entry Stop; end Watchdog_Type; type Watchdog_Access is access Watchdog_Type; Watchdog : Watchdog_Access := null; -- Keep alive and check connection status ------------------------------------------------------------------------- -- HTTP Server Setup for Gnoga_HTTP_Server ------------------------------------------------------------------------- -- Gnoga_HTTP_Content -- -- Per http connection data type Gnoga_HTTP_Client; type Socket_Type is access all Gnoga_HTTP_Client; type Gnoga_HTTP_Content is new Content_Source with record Socket : Socket_Type := null; Connection_Type : Gnoga_Connection_Type := HTTP; Connection_Path : String; FS : Ada.Streams.Stream_IO.File_Type; Input_Overflow : String_Buffer; Buffer : String_Buffer; Finalized : Boolean := False; Text : aliased Strings_Edit.Streams.String_Stream (500); end record; overriding function Get (Source : access Gnoga_HTTP_Content) return Standard.String; -- Handle long polling method pragma Warnings (Off); procedure Write (Stream : access Ada.Streams.Root_Stream_Type'Class; Item : in Gnoga_HTTP_Content); for Gnoga_HTTP_Content'Write use Write; pragma Warnings (On); -- Gnoga_HTTP_Factory -- -- Creates Gnoga_HTTP_Client objects on incoming connections -- from Gnoga_HTTP_Connection type Gnoga_HTTP_Factory (Request_Length : Positive; Input_Size : Buffer_Length; Output_Size : Buffer_Length; Max_Connections : Positive) is new Connections_Factory with null record; overriding function Create (Factory : access Gnoga_HTTP_Factory; Listener : access Connections_Server'Class; From : GNAT.Sockets.Sock_Addr_Type) return Connection_Ptr; -- Gnoga_HTTP_Connection -- type Gnoga_HTTP_Connection is new GNAT.Sockets.Server.Connections_Server with null record; overriding function Get_Server_Address (Listener : Gnoga_HTTP_Connection) return GNAT.Sockets.Sock_Addr_Type; -- Set the listening host if was set in Initialize overriding procedure Create_Socket (Listener : in out Gnoga_HTTP_Connection; Socket : in out GNAT.Sockets.Socket_Type; Address : GNAT.Sockets.Sock_Addr_Type); -- Create socket with exception handler -- Gnoga_HTTP_Client -- type Gnoga_HTTP_Client is new HTTP_Client with record Content : aliased Gnoga_HTTP_Content; end record; -- type Socket_Type is access all Gnoga_HTTP_Client; overriding procedure Finalize (Client : in out Gnoga_HTTP_Client); -- Handle browser crashes or webkit abrupt closes overriding function Get_Name (Client : Gnoga_HTTP_Client) return Standard.String; overriding procedure Do_Get (Client : in out Gnoga_HTTP_Client); overriding procedure Do_Post (Client : in out Gnoga_HTTP_Client); overriding procedure Body_Received (Client : in out Gnoga_HTTP_Client; Content : in out CGI_Keys.Table'Class); overriding procedure Body_Received (Client : in out Gnoga_HTTP_Client; Content : in out Ada.Streams.Root_Stream_Type'Class); overriding procedure Do_Body (Client : in out Gnoga_HTTP_Client); overriding procedure Do_Head (Client : in out Gnoga_HTTP_Client); overriding function WebSocket_Open (Client : access Gnoga_HTTP_Client) return WebSocket_Accept; overriding procedure WebSocket_Initialize (Client : in out Gnoga_HTTP_Client); overriding procedure WebSocket_Received_Part (Client : in out Gnoga_HTTP_Client; Message : in Standard.String); overriding procedure WebSocket_Received (Client : in out Gnoga_HTTP_Client; Message : in Standard.String); overriding procedure WebSocket_Closed (Client : in out Gnoga_HTTP_Client; Status : in WebSocket_Status; Message : in Standard.String); overriding procedure WebSocket_Error (Client : in out Gnoga_HTTP_Client; Error : in Ada.Exceptions.Exception_Occurrence); ------------------------------------------------------------------------- -- Connection Helpers ------------------------------------------------------------------------- pragma Warnings (Off); procedure Start_Long_Polling_Connect (Client : in out Gnoga_HTTP_Client; ID : out Gnoga.Types.Connection_ID); -- Start a long polling connection alternative to websocket pragma Warnings (On); function Buffer_Add (ID : Gnoga.Types.Connection_ID; Script : String) return Boolean; -- If buffering add Script to the buffer for ID and return true, if not -- buffering return false; procedure Dispatch_Message (Message : in String); -- Dispatch an incoming message from browser to event system ----------------------- -- Gnoga_HTTP_Server -- ----------------------- Server_Wait : Connection_Holder_Type; task type Gnoga_HTTP_Server_Type is entry Start; entry Stop; end Gnoga_HTTP_Server_Type; type Gnoga_HTTP_Server_Access is access Gnoga_HTTP_Server_Type; Gnoga_HTTP_Server : Gnoga_HTTP_Server_Access := null; task body Gnoga_HTTP_Server_Type is begin accept Start; declare Factory : aliased Gnoga_HTTP_Factory (Request_Length => Max_HTTP_Request_Length, Input_Size => Max_HTTP_Input_Chunk, Output_Size => Max_HTTP_Output_Chunk, Max_Connections => Max_HTTP_Connections); begin if Verbose_Output then Gnoga.Log ("HTTP Server Started"); -- Trace_On (Factory => Factory, -- Received => Trace_Any, -- Sent => Trace_Any); end if; if not Secure_Server then declare Server : Gnoga_HTTP_Connection (Factory'Access, Server_Port); pragma Unreferenced (Server); begin accept Stop; end; else if not Secure_Only then declare Server1 : Gnoga_HTTP_Connection (Factory'Access, Server_Port); pragma Unreferenced (Server1); Server2 : Gnoga_HTTP_Connection (Gnoga.Server.Connection.Common.Gnoga_Secure_Factory.all, Secure_Port); pragma Unreferenced (Server2); begin accept Stop; end; else declare Server : Gnoga_HTTP_Connection (Gnoga.Server.Connection.Common.Gnoga_Secure_Factory.all, Secure_Port); pragma Unreferenced (Server); begin accept Stop; end; end if; end if; Server_Wait.Release; if Verbose_Output then Gnoga.Log ("HTTP Server Stopping"); end if; end; end Gnoga_HTTP_Server_Type; ------------ -- Create -- ------------ function Global_Gnoga_Client_Factory (Listener : access Connections_Server'Class; Request_Length : Positive; Input_Size : Buffer_Length; Output_Size : Buffer_Length) return Connection_Ptr is Socket : constant Socket_Type := new Gnoga_HTTP_Client (Listener => Listener.all'Unchecked_Access, Request_Length => Request_Length, Input_Size => Input_Size, Output_Size => Output_Size); begin Socket.Content.Socket := Socket; return Connection_Ptr (Socket); end Global_Gnoga_Client_Factory; overriding function Create (Factory : access Gnoga_HTTP_Factory; Listener : access Connections_Server'Class; From : GNAT.Sockets.Sock_Addr_Type) return Connection_Ptr is pragma Unreferenced (From); begin return Gnoga.Server.Connection.Common.Gnoga_Client_Factory (Listener => Listener.all'Unchecked_Access, Request_Length => Factory.Request_Length, Input_Size => Factory.Input_Size, Output_Size => Factory.Output_Size); end Create; ------------------------- -- Get_Server_Address -- ------------------------- overriding function Get_Server_Address (Listener : Gnoga_HTTP_Connection) return GNAT.Sockets.Sock_Addr_Type is use GNAT.Sockets; use type String; Address : Sock_Addr_Type; Host : constant String := (if Server_Host = "localhost" then UXString'("127.0.0.1") else Server_Host); begin if Host = "" then Address.Addr := Any_Inet_Addr; else Address.Addr := Inet_Addr (To_UTF_8 (Host)); end if; Address.Port := Listener.Port; return Address; end Get_Server_Address; -------------------- -- Create_Socket -- -------------------- overriding procedure Create_Socket (Listener : in out Gnoga_HTTP_Connection; Socket : in out GNAT.Sockets.Socket_Type; Address : GNAT.Sockets.Sock_Addr_Type) is use type GNAT.Sockets.Socket_Type; begin Create_Socket (Connections_Server (Listener), Socket, Address); exception when Error : others => Gnoga.Log (Error); if Socket /= GNAT.Sockets.No_Socket then begin GNAT.Sockets.Shutdown_Socket (Socket); exception when others => null; end; begin GNAT.Sockets.Close_Socket (Socket); exception when others => null; end; Socket := GNAT.Sockets.No_Socket; end if; Stop; end Create_Socket; -------------- -- Get_Name -- -------------- overriding function Get_Name (Client : Gnoga_HTTP_Client) return Standard.String is pragma Unreferenced (Client); begin return To_UTF_8 (Gnoga.HTTP_Server_Name); end Get_Name; ----------------- -- Do_Get_Head -- ----------------- procedure Do_Get_Head (Client : in out Gnoga_HTTP_Client; Get : in Boolean); procedure Do_Get_Head (Client : in out Gnoga_HTTP_Client; Get : in Boolean) is use Strings_Edit.Quoted; Status : Status_Line renames Get_Status_Line (Client); function Adjust_Name return String; function Adjust_Name return String is function Start_Path return String; function After_Start_Path return String; File_Name : constant String := From_UTF_8 (UTF_8_Character_Array (Status.File)); function Start_Path return String is Q : constant Integer := Index (File_Name, "/"); begin if Q = 0 then return ""; else return File_Name.Slice (File_Name.First, Q - 1); end if; end Start_Path; function After_Start_Path return String is Q : constant Integer := Index (File_Name, "/"); begin if Q = 0 then return File_Name; else return File_Name.Slice (Q + 1, File_Name.Last); end if; end After_Start_Path; Start : constant String := Start_Path; Path_Adjusted_Name : constant String := After_Start_Path; begin if File_Name = "gnoga_ajax" then return File_Name; elsif Start = "" and File_Name = "" then return Gnoga.Server.HTML_Directory & Boot_HTML; elsif Start = "js" then return Gnoga.Server.JS_Directory & Path_Adjusted_Name; elsif Start = "css" then return Gnoga.Server.CSS_Directory & Path_Adjusted_Name; elsif Start = "img" then return Gnoga.Server.IMG_Directory & Path_Adjusted_Name; else if Ada.Directories.Exists (Standard.String (To_UTF_8 (Gnoga.Server.HTML_Directory & File_Name))) then return Gnoga.Server.HTML_Directory & File_Name; else return Gnoga.Server.HTML_Directory & Boot_HTML; end if; end if; end Adjust_Name; function Image is new UXStrings.Conversions.Scalar_Image (Status_Line_Type); begin case Status.Kind is when None => if Verbose_Output then Gnoga.Log ("Requested: Kind: " & Image (Status.Kind) & ", Query: " & From_UTF_8 (UTF_8_Character_Array (Status.Query))); Gnoga.Log ("Reply: Not found"); end if; Reply_Text (Client, 404, "Not found", "Not found"); when File => if Verbose_Output then Gnoga.Log ("Requested: Kind: " & Image (Status.Kind) & ", File: " & From_UTF_8 (UTF_8_Character_Array (Status.File)) & ", Query: " & From_UTF_8 (UTF_8_Character_Array (Status.Query))); end if; Client.Content.Connection_Path := From_UTF_8 (UTF_8_Character_Array (Status.File)); Send_Status_Line (Client, 200, "OK"); Send_Date (Client); Send (Client, Standard.String (To_UTF_8 ("Cache-Control: no-cache, no-store, must-revalidate" & Gnoga.Server.Connection.Common.CRLF))); Send (Client, Standard.String (To_UTF_8 ("Pragma: no-cache" & Gnoga.Server.Connection.Common.CRLF))); Send (Client, Standard.String (To_UTF_8 ("Expires: 0" & Gnoga.Server.Connection.Common.CRLF))); Send_Connection (Client, Persistent => True); Send_Server (Client); declare F : constant String := Adjust_Name; M : constant String := Gnoga.Server.Mime.Mime_Type (F); begin if F = "gnoga_ajax" then Send_Body (Client, "", Get); declare MH : constant String := "?m="; Q : constant Integer := Index (From_UTF_8 (UTF_8_Character_Array (Status.Query)), MH, Going => Ada.Strings.Forward); Message : constant String := From_UTF_8 (UTF_8_Character_Array (Status.Query (Q + MH.Length .. Status.Query'Last))); begin Dispatch_Message (Message); end; else if M = "text/html" then Client.Content.Finalized := False; declare ID : Gnoga.Types.Connection_ID; F : String := Gnoga.Server.Template_Parser.Simple.Load_View (Adjust_Name); begin if Gnoga.Application.Favicon /= Null_UXString and Index (F, "") > 0 and Index (F, "favicon.ico") > 0 then String_Replace (Source => F, Pattern => "favicon.ico", Replacement => Gnoga.Application.Favicon); end if; if Index (F, "/js/ajax.js") > 0 then Client.Content.Connection_Type := Long_Polling; Client.Content.Buffer.Add (F); Send_Body (Client, Client.Content'Access, Get); Start_Long_Polling_Connect (Client, ID); elsif Index (F, "/js/auto.js") > 0 then Client.Content.Connection_Type := Long_Polling; Start_Long_Polling_Connect (Client, ID); String_Replace (Source => F, Pattern => "@@Connection_ID@@", Replacement => Image (ID)); Client.Content.Buffer.Add (F); Send_Body (Client, Client.Content'Access, Get); else Client.Content.Connection_Type := HTTP; Client.Content.Buffer.Add (F); Send_Body (Client, Client.Content'Access, Get); end if; end; else Send_Content_Type (Client, Standard.String (To_UTF_8 (M))); declare use Ada.Streams.Stream_IO; begin if Is_Open (Client.Content.FS) then Close (Client.Content.FS); end if; Open (Client.Content.FS, In_File, Standard.String (To_UTF_8 (F)), Form => "shared=no"); Send_Body (Client, Stream (Client.Content.FS), Get); end; end if; end if; if Verbose_Output then Gnoga.Log ("Reply: " & F & " (" & M & ')'); end if; exception when Ada.Text_IO.Name_Error => if Verbose_Output then Gnoga.Log ("Reply: Not found"); end if; Reply_Text (Client, 404, "Not found", "No file " & Quote (Status.File) & " found"); end; when URI => if Verbose_Output then Gnoga.Log ("Requested: Kind: " & Image (Status.Kind) & ", Path: " & From_UTF_8 (UTF_8_Character_Array (Status.Path)) & ", Query: " & From_UTF_8 (UTF_8_Character_Array (Status.Query))); Gnoga.Log ("Reply: Not found"); end if; Reply_Text (Client, 404, "Not found", "No URI " & Quote (Status.Path) & " found"); end case; exception when E : others => Log ("Do_Get_Head Error"); Log (From_UTF_8 (Ada.Exceptions.Exception_Information (E))); end Do_Get_Head; ------------ -- Do_Get -- ------------ overriding procedure Do_Get (Client : in out Gnoga_HTTP_Client) is begin Do_Get_Head (Client, True); end Do_Get; ------------- -- Do_Post -- ------------- overriding procedure Do_Post (Client : in out Gnoga_HTTP_Client) is begin Do_Get_Head (Client, True); end Do_Post; ------------------- -- Body_Received -- ------------------- overriding procedure Body_Received (Client : in out Gnoga_HTTP_Client; Content : in out CGI_Keys.Table'Class) is pragma Unreferenced (Content); Status : Status_Line renames Get_Status_Line (Client); Parameters : Gnoga.Types.Data_Map_Type; begin if On_Post_Event /= null and Status.Kind = File then for i in 1 .. Client.Get_CGI_Size loop Parameters.Insert (From_UTF_8 (UTF_8_Character_Array (Client.Get_CGI_Key (i))), From_UTF_8 (UTF_8_Character_Array (Client.Get_CGI_Value (i)))); end loop; On_Post_Event (From_UTF_8 (UTF_8_Character_Array (Status.File & Status.Query)), Parameters); end if; end Body_Received; ------------------- -- Body_Received -- ------------------- overriding procedure Body_Received (Client : in out Gnoga_HTTP_Client; Content : in out Ada.Streams.Root_Stream_Type'Class) is pragma Unreferenced (Content); Status : Status_Line renames Get_Status_Line (Client); Disposition : constant String := From_UTF_8 (UTF_8_Character_Array (Client.Get_Multipart_Header (Content_Disposition_Header))); Field_ID : constant String := "name="""; n : constant Natural := Index (Disposition, Field_ID); Eq : constant Natural := Index (Disposition, """", n + Field_ID.Length); Field_Name : constant String := Disposition.Slice (n + Field_ID.Length, Eq - 1); Content_Type : constant String := From_UTF_8 (UTF_8_Character_Array (Client.Get_Multipart_Header (Content_Type_Header))); Parameters : Gnoga.Types.Data_Map_Type; begin if On_Post_Event /= null and Status.Kind = File and Content_Type = "" then Parameters.Insert (Field_Name, From_UTF_8 (UTF_8_Character_Array (Client.Content.Text.Get))); On_Post_Event (From_UTF_8 (UTF_8_Character_Array (Status.File & Status.Query)), Parameters); end if; end Body_Received; ------------- -- Do_Post -- ------------- overriding procedure Do_Body (Client : in out Gnoga_HTTP_Client) is use Ada.Streams.Stream_IO; Status : Status_Line renames Get_Status_Line (Client); Param_List : String; Content_Type : constant String := From_UTF_8 (UTF_8_Character_Array (Client.Get_Header (Content_Type_Header))); Disposition : constant String := From_UTF_8 (UTF_8_Character_Array (Client.Get_Multipart_Header (Content_Disposition_Header))); begin -- Gnoga.Log ("Content_Type: " & Content_Type & ", Disposition: " & Disposition); if On_Post_Request_Event /= null then On_Post_Request_Event (From_UTF_8 (UTF_8_Character_Array (Status.File & Status.Query)), Param_List); end if; if Content_Type = "application/x-www-form-urlencoded" then Client.Receive_Body (Standard.String (To_UTF_8 (Param_List))); end if; if Index (Content_Type, "multipart/form-data") = Content_Type.First then if Index (Disposition, "form-data") = Disposition.First then declare Field_ID : constant String := "name="""; File_ID : constant String := "filename="""; n : constant Natural := Index (Disposition, Field_ID); f : constant Natural := Index (Disposition, File_ID); begin if n /= 0 then declare Eq : constant Natural := Index (Disposition, """", n + Field_ID.Length); Field_Name : constant String := Disposition.Slice (n + Field_ID.Length, Eq - 1); begin if Index (Param_List, Field_Name) > 0 then if f /= 0 then declare Eq : constant Natural := Index (Disposition, """", f + File_ID.Length); File_Name : constant String := Disposition.Slice (f + File_ID.Length, Eq - 1); begin if On_Post_File_Event = null then Gnoga.Log ("Attempt to upload file without an On_Post_File_Event set"); else if Is_Open (Client.Content.FS) then Close (Client.Content.FS); end if; Create (Client.Content.FS, Out_File, Standard.String (To_UTF_8 (Gnoga.Server.Upload_Directory & File_Name & ".tmp")), "Text_Translation=No"); Receive_Body (Client, Stream (Client.Content.FS)); On_Post_File_Event (From_UTF_8 (UTF_8_Character_Array (Status.File & Status.Query)), File_Name, File_Name & ".tmp"); end if; end; else Client.Content.Text.Rewind; Client.Receive_Body (Client.Content.Text'Access); end if; end if; end; end if; end; end if; end if; exception when E : others => Log ("Do_Body Error"); Log (From_UTF_8 (Ada.Exceptions.Exception_Information (E))); end Do_Body; ------------- -- Do_Head -- ------------- overriding procedure Do_Head (Client : in out Gnoga_HTTP_Client) is begin Do_Get_Head (Client, False); end Do_Head; ------------------------------------------------------------------------- -- Gnoga Server Connection Methods ------------------------------------------------------------------------- ---------------- -- Initialize -- ---------------- procedure Initialize (Host : in String := ""; Port : in Integer := 8_080; Boot : in String := "boot.html"; Verbose : in Boolean := True) is function Image is new UXStrings.Conversions.Integer_Image (GNAT.Sockets.Port_Type); begin Verbose_Output := Verbose; Boot_HTML := Boot; Server_Port := GNAT.Sockets.Port_Type (Port); Server_Host := Host; if Verbose then Write_To_Console ("Gnoga :" & Gnoga.Version); Write_To_Console ("Application root :" & Application_Directory); Write_To_Console ("Executable at :" & Executable_Directory); Write_To_Console ("HTML root :" & HTML_Directory); Write_To_Console ("Upload directory :" & Upload_Directory); Write_To_Console ("Templates root :" & Templates_Directory); Write_To_Console ("/js at :" & JS_Directory); Write_To_Console ("/css at :" & CSS_Directory); Write_To_Console ("/img at :" & IMG_Directory); if not Secure_Only then Write_To_Console ("Boot file :" & Boot); Write_To_Console ("HTTP listen on :" & Host & ":" & Image (Server_Port)); end if; if Secure_Server then Write_To_Console ("HTTPS listen on :" & Host & ":" & Image (Secure_Port)); end if; end if; Watchdog := new Watchdog_Type; Watchdog.Start; end Initialize; --------- -- Run -- --------- procedure Run is begin Gnoga_HTTP_Server := new Gnoga_HTTP_Server_Type; Gnoga_HTTP_Server.Start; Server_Wait.Hold; Exit_Application_Requested := True; end Run; ------------------- -- Shutting_Down -- ------------------- function Shutting_Down return Boolean is begin return Exit_Application_Requested; end Shutting_Down; ---------------------------- -- Connection_Holder_Type -- ---------------------------- protected body Connection_Holder_Type is entry Hold when not Connected is begin null; -- Semaphore does not reset itself to a blocking state. -- This ensures that if Released before Hold that Hold -- will not block and connection will be released. -- It also allows for On_Connect Handler to not have to use -- Connection.Hold unless there is a desire code such as to -- clean up after a connection is ended. end Hold; procedure Release is begin Connected := False; end Release; end Connection_Holder_Type; type Connection_Holder_Access is access all Connection_Holder_Type; package Connection_Holder_Maps is new Ada.Containers.Ordered_Maps (Gnoga.Types.Unique_ID, Connection_Holder_Access); package Connection_Data_Maps is new Ada.Containers.Ordered_Maps (Gnoga.Types.Unique_ID, Gnoga.Types.Pointer_to_Connection_Data_Class); --------------------- -- Event_Task_Type -- --------------------- task type Event_Task_Type (TID : Gnoga.Types.Connection_ID); type Event_Task_Access is access all Event_Task_Type; procedure Free_Event_Task is new Ada.Unchecked_Deallocation (Event_Task_Type, Event_Task_Access); package Event_Task_Maps is new Ada.Containers.Ordered_Maps (Gnoga.Types.Unique_ID, Event_Task_Access); ------------------------ -- Connection Manager -- ------------------------ package Socket_Maps is new Ada.Containers.Ordered_Maps (Gnoga.Types.Connection_ID, Socket_Type); -- Socket Maps are used for the Connection Manager to map connection IDs -- to web sockets. protected Connection_Manager is procedure Add_Connection (Socket : in Socket_Type; New_ID : out Gnoga.Types.Connection_ID); -- Adds Socket to managed Connections and generates a New_ID. procedure Start_Connection (New_ID : in Gnoga.Types.Connection_ID); -- Start event task on connection procedure Swap_Connection (New_ID : in Gnoga.Types.Connection_ID; Old_ID : in Gnoga.Types.Connection_ID); -- Reconnect old connection procedure Add_Connection_Holder (ID : in Gnoga.Types.Connection_ID; Holder : in Connection_Holder_Access); -- Adds a connection holder to the connection -- Can only be one at any given time. procedure Add_Connection_Data (ID : in Gnoga.Types.Connection_ID; Data : in Gnoga.Types.Pointer_to_Connection_Data_Class); -- Adds data to be associated with connection function Connection_Data (ID : in Gnoga.Types.Connection_ID) return Gnoga.Types.Pointer_to_Connection_Data_Class; -- Returns the Connection_Data associated with ID procedure Delete_Connection_Holder (ID : in Gnoga.Types.Connection_ID); -- Delete connection holder procedure Delete_Connection (ID : in Gnoga.Types.Connection_ID); -- Delete Connection with ID. -- Releases connection holder if present. procedure Finalize_Connection (ID : in Gnoga.Types.Connection_ID); -- Mark Connection with ID for deletion. function Valid (ID : in Gnoga.Types.Connection_ID) return Boolean; -- Return True if ID is in connection map. procedure First (ID : out Gnoga.Types.Connection_ID); -- Return first ID if ID is in connection map else 0. procedure Next (ID : out Gnoga.Types.Connection_ID); -- Return next ID if ID is in connection map else 0. function Connection_Socket (ID : in Gnoga.Types.Connection_ID) return Socket_Type; -- Return the Socket_Type associated with ID -- Raises Connection_Error if ID is not Valid function Find_Connection_ID (Socket : Socket_Type) return Gnoga.Types.Connection_ID; -- Find the Connection_ID related to Socket. procedure Delete_All_Connections; -- Called by Stop to close down server function Active_Connections return Ada.Containers.Count_Type; -- Returns the number of active connections private Socket_Count : Gnoga.Types.Connection_ID := 0; Connection_Holder_Map : Connection_Holder_Maps.Map; Connection_Data_Map : Connection_Data_Maps.Map; Event_Task_Map : Event_Task_Maps.Map; Socket_Map : Socket_Maps.Map; Shadow_Socket_Map : Socket_Maps.Map; Current_Socket : Socket_Maps.Cursor := Socket_Maps.No_Element; end Connection_Manager; protected body Connection_Manager is procedure Add_Connection (Socket : in Socket_Type; New_ID : out Gnoga.Types.Connection_ID) is begin Socket_Count := Socket_Count + 1; New_ID := Socket_Count; Socket_Map.Insert (New_ID, Socket); end Add_Connection; procedure Start_Connection (New_ID : in Gnoga.Types.Connection_ID) is begin Event_Task_Map.Insert (New_ID, new Event_Task_Type (New_ID)); end Start_Connection; procedure Swap_Connection (New_ID : in Gnoga.Types.Connection_ID; Old_ID : in Gnoga.Types.Connection_ID) is begin if Socket_Map.Contains (Old_ID) then declare Old_Socket : constant Socket_Type := Socket_Map.Element (Old_ID); New_Socket : constant Socket_Type := Socket_Map.Element (New_ID); begin New_Socket.Content.Connection_Path := Old_Socket.Content.Connection_Path; Socket_Map.Replace (Old_ID, New_Socket); Socket_Map.Replace (New_ID, Old_Socket); Old_Socket.Content.Finalized := True; end; else raise Connection_Error with "Old connection ID " & To_ASCII (Image (Old_ID)) & " already gone"; end if; end Swap_Connection; procedure Add_Connection_Holder (ID : in Gnoga.Types.Connection_ID; Holder : in Connection_Holder_Access) is begin Connection_Holder_Map.Insert (ID, Holder); end Add_Connection_Holder; procedure Delete_Connection_Holder (ID : in Gnoga.Types.Connection_ID) is begin if Connection_Holder_Map.Contains (ID) then Connection_Holder_Map.Delete (ID); end if; end Delete_Connection_Holder; procedure Add_Connection_Data (ID : in Gnoga.Types.Connection_ID; Data : in Gnoga.Types.Pointer_to_Connection_Data_Class) is begin Connection_Data_Map.Include (ID, Data); end Add_Connection_Data; function Connection_Data (ID : in Gnoga.Types.Connection_ID) return Gnoga.Types.Pointer_to_Connection_Data_Class is begin if Connection_Data_Map.Contains (ID) then return Connection_Data_Map.Element (ID); else return null; end if; end Connection_Data; procedure Delete_Connection (ID : in Gnoga.Types.Connection_ID) is begin if (ID > 0) then Gnoga.Log ("Deleting connection ID " & Image (ID)); if Connection_Holder_Map.Contains (ID) then Connection_Holder_Map.Element (ID).Release; Connection_Holder_Map.Delete (ID); end if; if Connection_Data_Map.Contains (ID) then Connection_Data_Map.Delete (ID); end if; if Socket_Map.Contains (ID) then Socket_Map.Delete (ID); end if; if Event_Task_Map.Contains (ID) then declare E : Event_Task_Access := Event_Task_Map.Element (ID); begin Free_Event_Task (E); Event_Task_Map.Delete (ID); end; end if; end if; exception when E : others => Log ("Delete_Connection error on ID " & Image (ID)); Log (From_UTF_8 (Ada.Exceptions.Exception_Information (E))); end Delete_Connection; procedure Finalize_Connection (ID : in Gnoga.Types.Connection_ID) is begin if (ID > 0) and Socket_Map.Contains (ID) then if Verbose_Output then Gnoga.Log ("Finalizing connection ID " & Image (ID)); end if; Socket_Map.Element (ID).Content.Finalized := True; end if; end Finalize_Connection; function Valid (ID : in Gnoga.Types.Connection_ID) return Boolean is begin return Socket_Map.Contains (ID); end Valid; procedure First (ID : out Gnoga.Types.Connection_ID) is use type Socket_Maps.Cursor; begin Shadow_Socket_Map := Socket_Map; Current_Socket := Shadow_Socket_Map.First; if Current_Socket /= Socket_Maps.No_Element then ID := Socket_Maps.Key (Current_Socket); else ID := 0; end if; end First; procedure Next (ID : out Gnoga.Types.Connection_ID) is use type Socket_Maps.Cursor; begin Current_Socket := Socket_Maps.Next (Current_Socket); if Current_Socket /= Socket_Maps.No_Element then ID := Socket_Maps.Key (Current_Socket); else ID := 0; end if; end Next; function Connection_Socket (ID : in Gnoga.Types.Connection_ID) return Socket_Type is use type Socket_Maps.Cursor; Connection_Cursor : constant Socket_Maps.Cursor := Socket_Map.Find (ID); begin if Connection_Cursor = Socket_Maps.No_Element then Log ("Error Connection_Socket ID " & Image (ID) & " not found in connection map. "); raise Connection_Error with "Connection ID " & To_ASCII (Image (ID)) & " not found in connection map. " & "Connection most likely was previously closed."; else return Socket_Maps.Element (Connection_Cursor); end if; end Connection_Socket; function Find_Connection_ID (Socket : Socket_Type) return Gnoga.Types.Connection_ID is use type Socket_Maps.Cursor; Cursor : Socket_Maps.Cursor := Socket_Map.First; begin while Cursor /= Socket_Maps.No_Element loop if Socket_Maps.Element (Cursor) = Socket then return Socket_Maps.Key (Cursor); else Socket_Maps.Next (Cursor); end if; end loop; return Gnoga.Types.No_Connection; end Find_Connection_ID; procedure Delete_All_Connections is procedure Do_Delete (C : in Socket_Maps.Cursor); procedure Do_Delete (C : in Socket_Maps.Cursor) is begin Delete_Connection (Socket_Maps.Key (C)); end Do_Delete; begin -- Socket_Map.Iterate (Do_Delete'Access); -- provoque PROGRAM_ERROR -- Message: Gnoga.Server.Connection.Socket_Maps.Tree_Operations. -- Delete_Node_Sans_Free: attempt to tamper with cursors -- (container is busy) while not Socket_Map.Is_Empty loop Do_Delete (Socket_Map.First); end loop; end Delete_All_Connections; function Active_Connections return Ada.Containers.Count_Type is begin return Socket_Map.Length; end Active_Connections; end Connection_Manager; task body Event_Task_Type is Connection_Holder : aliased Connection_Holder_Type; ID : Gnoga.Types.Connection_ID; begin ID := TID; -- Insure that TID is retained even if task is "deleted" Connection_Manager.Add_Connection_Holder (ID, Connection_Holder'Unchecked_Access); begin delay 0.3; -- Give time to finish handshaking Execute_Script (ID, "gnoga['Connection_ID']=" & Image (ID)); Execute_Script (ID, "TRUE=true"); Execute_Script (ID, "FALSE=false"); -- By setting the variable TRUE and FALSE it is possible to set -- a property or attribute with Boolean'Image which will result -- in TRUE or FALSE not the case sensitive true or false -- expected. On_Connect_Event (ID, Connection_Holder'Unchecked_Access); exception when E : Connection_Error => -- Browser was closed by user Log ("Error browser was closed by user ID " & Image (ID)); Log (From_UTF_8 (Ada.Exceptions.Exception_Information (E))); Connection_Holder.Release; when E : others => Connection_Holder.Release; Log ("Error on Connection ID " & Image (ID)); Log (From_UTF_8 (Ada.Exceptions.Exception_Information (E))); end; Connection_Manager.Delete_Connection_Holder (ID); Connection_Manager.Finalize_Connection (ID); -- Insure cleanup even if socket not closed by external connection exception when E : others => Log ("Connection Manager Error Connection ID " & Image (ID)); Log (From_UTF_8 (Ada.Exceptions.Exception_Information (E))); end Event_Task_Type; -------------- -- Watchdog -- -------------- task body Watchdog_Type is procedure Ping (ID : in Gnoga.Types.Connection_ID); procedure Ping (ID : in Gnoga.Types.Connection_ID) is Socket : Socket_Type := Connection_Manager.Connection_Socket (ID); begin if Socket.Content.Finalized then if Verbose_Output then Gnoga.Log ("Ping on Finalized ID " & Image (ID)); end if; Connection_Manager.Delete_Connection (ID); Socket.Shutdown; elsif Socket.Content.Connection_Type = Long_Polling then if Verbose_Output then Gnoga.Log ("Ping on long polling ID " & Image (ID)); end if; Execute_Script (ID, "0"); elsif Socket.Content.Connection_Type = WebSocket then if Verbose_Output then Gnoga.Log ("Ping on websocket ID " & Image (ID)); end if; Socket.WebSocket_Send ("0"); end if; exception when E : Storage_Error => Gnoga.Log ("Invalid socket, Deleting ID " & Image (ID)); Log (From_UTF_8 (Ada.Exceptions.Exception_Information (E))); Connection_Manager.Delete_Connection (ID); when E : others => Log ("Ping error on ID " & Image (ID)); Log (From_UTF_8 (Ada.Exceptions.Exception_Information (E))); if Socket.Content.Connection_Type = Long_Polling then Gnoga.Log ("Long polling error closing ID " & Image (ID)); Socket.Content.Finalized := True; Socket.Shutdown; else begin delay 3.0; Socket := Connection_Manager.Connection_Socket (ID); Socket.WebSocket_Send ("0"); exception when E : others => Log ("Watchdog closed connection ID " & Image (ID)); Log (From_UTF_8 (Ada.Exceptions.Exception_Information (E))); begin Connection_Manager.Delete_Connection (ID); exception when E : others => Log ("Watchdog ping error ID " & Image (ID)); Log (From_UTF_8 (Ada.Exceptions.Exception_Information (E))); end; end; end if; end Ping; begin accept Start; loop declare ID : Gnoga.Types.Connection_ID; begin Connection_Manager.First (ID); while ID /= 0 loop Ping (ID); Connection_Manager.Next (ID); end loop; exception when E : others => Log ("Watchdog error on websocket ID " & Image (ID)); Log (From_UTF_8 (Ada.Exceptions.Exception_Information (E))); end; select accept Stop; exit; or delay 60.0; end select; end loop; end Watchdog_Type; --------------------------- -- Message Queue Manager -- --------------------------- No_Object : exception; function "=" (Left, Right : Gnoga.Gui.Base.Pointer_To_Base_Class) return Boolean; -- Properly identify equivalent objects function "=" (Left, Right : Gnoga.Gui.Base.Pointer_To_Base_Class) return Boolean is begin return Left.Unique_ID = Right.Unique_ID; end "="; package Object_Maps is new Ada.Containers.Ordered_Maps (Gnoga.Types.Unique_ID, Gnoga.Gui.Base.Pointer_To_Base_Class); protected Object_Manager is function Get_Object (ID : Gnoga.Types.Unique_ID) return Gnoga.Gui.Base.Pointer_To_Base_Class; procedure Insert (ID : in Gnoga.Types.Unique_ID; Object : in Gnoga.Gui.Base.Pointer_To_Base_Class); procedure Delete (ID : Gnoga.Types.Unique_ID); private Object_Map : Object_Maps.Map; end Object_Manager; protected body Object_Manager is function Get_Object (ID : Gnoga.Types.Unique_ID) return Gnoga.Gui.Base.Pointer_To_Base_Class is begin if Object_Map.Contains (ID) then return Object_Map.Element (ID); else raise No_Object with "ID " & To_ASCII (Image (ID)); end if; end Get_Object; procedure Insert (ID : in Gnoga.Types.Unique_ID; Object : in Gnoga.Gui.Base.Pointer_To_Base_Class) is begin Object_Map.Insert (Key => ID, New_Item => Object); end Insert; procedure Delete (ID : Gnoga.Types.Unique_ID) is begin if Object_Map.Contains (ID) then Object_Map.Delete (ID); end if; end Delete; end Object_Manager; -------------------- -- WebSocket_Open -- -------------------- overriding function WebSocket_Open (Client : access Gnoga_HTTP_Client) return WebSocket_Accept is Status : Status_Line renames Get_Status_Line (Client.all); F : constant String := From_UTF_8 (UTF_8_Character_Array (Status.File)); begin if F /= "gnoga" then Gnoga.Log ("Invalid URL for Websocket: " & F); declare Reason : constant String := "Invalid URL"; begin return (Accepted => False, Length => Reason.Length, Code => 400, Reason => Standard.String (To_UTF_8 (Reason))); end; end if; Client.Content.Connection_Type := WebSocket; if On_Connect_Event /= null then return (Accepted => True, Length => 0, Size => Max_Websocket_Message, Duplex => True, Chunked => True, Protocols => ""); else Gnoga.Log ("No Connection event set."); declare Reason : constant String := "No connection event set"; begin return (Accepted => False, Length => Reason.Length, Code => 400, Reason => Standard.String (To_UTF_8 (Reason))); end; end if; end WebSocket_Open; -------------------------- -- WebSocket_Initialize -- -------------------------- overriding procedure WebSocket_Initialize (Client : in out Gnoga_HTTP_Client) is Status : Status_Line renames Get_Status_Line (Client); F : constant String := From_UTF_8 (UTF_8_Character_Array (Status.Query)); S : constant Socket_Type := Client'Unchecked_Access; ID : Gnoga.Types.Connection_ID := Gnoga.Types.No_Connection; function Get_Old_ID return String; function Get_Old_ID return String is C : constant String := "Old_ID="; I : constant Integer := Index (F, C); begin if I > 0 then return F.Slice (I + C.Length, F.Last); else return ""; end if; end Get_Old_ID; Old_ID : constant String := Get_Old_ID; begin Connection_Manager.Add_Connection (Socket => S, New_ID => ID); if Old_ID /= "" and Old_ID /= "undefined" then if Verbose_Output then Gnoga.Log ("Swapping websocket connection ID " & Image (ID) & " <=> " & Old_ID); end if; begin Connection_Manager.Swap_Connection (ID, Value (Old_ID)); exception when E : Connection_Error => Gnoga.Log ("Connection error ID " & Image (ID)); Gnoga.Log (From_UTF_8 (Ada.Exceptions.Exception_Message (E))); Client.Content.Finalized := True; Connection_Manager.Delete_Connection (ID); Gnoga.Log ("Connection aborted ID " & Image (ID)); end; else Connection_Manager.Start_Connection (ID); if Verbose_Output then Gnoga.Log ("New connection ID " & Image (ID)); end if; end if; exception when E : others => Gnoga.Log ("Open error ID " & Image (ID)); Gnoga.Log (From_UTF_8 (Ada.Exceptions.Exception_Information (E))); end WebSocket_Initialize; ---------------------- -- WebSocket_Closed -- ---------------------- overriding procedure WebSocket_Closed (Client : in out Gnoga_HTTP_Client; Status : in WebSocket_Status; Message : in Standard.String) is pragma Unreferenced (Status); S : constant Socket_Type := Client'Unchecked_Access; ID : constant Gnoga.Types.Connection_ID := Connection_Manager.Find_Connection_ID (S); begin if ID /= Gnoga.Types.No_Connection then S.Content.Finalized := True; if Verbose_Output then if Message /= "" then Gnoga.Log ("Websocket connection closed ID " & Image (ID) & " with message : " & From_UTF_8 (Message)); else Gnoga.Log ("Websocket connection closed ID " & Image (ID)); end if; end if; Connection_Manager.Delete_Connection (ID); end if; end WebSocket_Closed; --------------------- -- WebSocket_Error -- --------------------- overriding procedure WebSocket_Error (Client : in out Gnoga_HTTP_Client; Error : in Ada.Exceptions.Exception_Occurrence) is S : constant Socket_Type := Client'Unchecked_Access; ID : constant Gnoga.Types.Connection_ID := Connection_Manager.Find_Connection_ID (S); begin S.Content.Finalized := True; Gnoga.Log ("Connection error ID " & Image (ID) & " with message : " & From_ASCII (Ada.Exceptions.Exception_Information (Error))); -- If not reconnected by next watchdog ping connection will be deleted. end WebSocket_Error; -------------------------------- -- Start_Long_Polling_Connect -- -------------------------------- procedure Start_Long_Polling_Connect (Client : in out Gnoga_HTTP_Client; ID : out Gnoga.Types.Connection_ID) is S : constant Socket_Type := Client'Unchecked_Access; begin Connection_Manager.Add_Connection (Socket => S, New_ID => ID); Connection_Manager.Start_Connection (ID); if Verbose_Output then Gnoga.Log ("New long polling connection ID " & Image (ID)); end if; end Start_Long_Polling_Connect; -------------------- -- Script_Manager -- -------------------- protected type Script_Holder_Type is entry Hold; procedure Release (Result : in String); function Result return String; private Connected : Boolean := True; Script_Result : String; end Script_Holder_Type; protected body Script_Holder_Type is entry Hold when not Connected is begin null; -- Semaphore does not reset itself to a blocking state. -- This ensures that if Released before Hold that Hold -- will not block and connection will be released. end Hold; procedure Release (Result : in String) is begin Connected := False; Script_Result := Result; end Release; function Result return String is begin return Script_Result; end Result; end Script_Holder_Type; type Script_Holder_Access is access all Script_Holder_Type; package Script_Holder_Maps is new Ada.Containers.Ordered_Maps (Gnoga.Types.Unique_ID, Script_Holder_Access); protected type Script_Manager_Type is procedure Add_Script_Holder (ID : out Gnoga.Types.Unique_ID; Holder : in Script_Holder_Access); -- Adds a script holder to wait for script execution to end -- and return results; procedure Delete_Script_Holder (ID : in Gnoga.Types.Unique_ID); -- Delete script holder procedure Release_Hold (ID : in Gnoga.Types.Unique_ID; Result : in String); -- Delete connection hold with ID. private Script_Holder_Map : Script_Holder_Maps.Map; Script_ID : Gnoga.Types.Unique_ID := 0; end Script_Manager_Type; protected body Script_Manager_Type is procedure Add_Script_Holder (ID : out Gnoga.Types.Connection_ID; Holder : in Script_Holder_Access) is begin Script_ID := Script_ID + 1; Script_Holder_Map.Insert (Script_ID, Holder); ID := Script_ID; end Add_Script_Holder; procedure Delete_Script_Holder (ID : in Gnoga.Types.Connection_ID) is begin Script_Holder_Map.Delete (ID); end Delete_Script_Holder; procedure Release_Hold (ID : in Gnoga.Types.Unique_ID; Result : in String) is begin if Script_Holder_Map.Contains (ID) then Script_Holder_Map.Element (ID).Release (Result); end if; end Release_Hold; end Script_Manager_Type; Script_Manager : Script_Manager_Type; ----------------------------- -- WebSocket_Received_Part -- ----------------------------- overriding procedure WebSocket_Received_Part (Client : in out Gnoga_HTTP_Client; Message : in Standard.String) is begin Client.Content.Input_Overflow.Add (From_UTF_8 (UTF_8_Character_Array (Message))); end WebSocket_Received_Part; ------------------------ -- WebSocket_Received -- ------------------------ overriding procedure WebSocket_Received (Client : in out Gnoga_HTTP_Client; Message : in Standard.String) is Full_Message : constant String := Client.Content.Input_Overflow.Get & From_UTF_8 (UTF_8_Character_Array (Message)); begin Client.Content.Input_Overflow.Clear; if Full_Message = "0" then return; end if; Dispatch_Message (Full_Message); exception when E : others => Log ("Websocket Message Error"); Log (From_UTF_8 (Ada.Exceptions.Exception_Information (E))); end WebSocket_Received; ---------------------- -- Dispatch_Message -- ---------------------- task type Dispatch_Task_Type (Object : Gnoga.Gui.Base.Pointer_To_Base_Class) is entry Start (Event : in String; Data : in String; ID : in Gnoga.Types.Unique_ID); end Dispatch_Task_Type; type Dispatch_Task_Access is access all Dispatch_Task_Type; procedure Free_Dispatch_Task is new Ada.Unchecked_Deallocation (Dispatch_Task_Type, Dispatch_Task_Access); package Dispatch_Task_Maps is new Ada.Containers.Ordered_Maps (Gnoga.Types.Unique_ID, Dispatch_Task_Access); protected Dispatch_Task_Objects is procedure Add_Dispatch_Task (ID : in Gnoga.Types.Unique_ID; Dispatch_Task : in Dispatch_Task_Access); function Object (ID : Gnoga.Types.Unique_ID) return Dispatch_Task_Access; procedure Delete_Dispatch_Task (ID : in Gnoga.Types.Unique_ID); private Dispatch_Task_Map : Dispatch_Task_Maps.Map; end Dispatch_Task_Objects; protected body Dispatch_Task_Objects is procedure Add_Dispatch_Task (ID : in Gnoga.Types.Unique_ID; Dispatch_Task : in Dispatch_Task_Access) is begin Dispatch_Task_Map.Insert (ID, Dispatch_Task); end Add_Dispatch_Task; function Object (ID : Gnoga.Types.Unique_ID) return Dispatch_Task_Access is begin return Dispatch_Task_Map.Element (ID); end Object; procedure Delete_Dispatch_Task (ID : in Gnoga.Types.Unique_ID) is Dummy_T : Dispatch_Task_Access := Dispatch_Task_Map.Element (ID); begin Free_Dispatch_Task (Dummy_T); -- http://adacore.com/developers/development-log/NF-65-H911-007-gnat -- This will cause Dummy_T to free upon task termination. Dispatch_Task_Map.Delete (ID); end Delete_Dispatch_Task; end Dispatch_Task_Objects; task body Dispatch_Task_Type is E : String; D : String; I : Gnoga.Types.Unique_ID; begin accept Start (Event : in String; Data : in String; ID : in Gnoga.Types.Unique_ID) do E := Event; D := Data; I := ID; end Start; Object.Flush_Buffer; declare Continue : Boolean; Event : constant String := E; Data : constant String := D; begin Object.Fire_On_Message (Event, Data, Continue); if Continue then Object.On_Message (Event, Data); end if; end; Object.Flush_Buffer; Dispatch_Task_Objects.Delete_Dispatch_Task (I); exception when E : others => Log ("Dispatch Error"); Log (From_UTF_8 (Ada.Exceptions.Exception_Information (E))); end Dispatch_Task_Type; procedure Dispatch_Message (Message : in String) is begin if Message (Message.First) = 'S' then declare P1 : constant Integer := Index (Source => Message, Pattern => "|"); UID : constant String := Message.Slice (Message.First + 1, (P1 - 1)); Result : constant String := Message.Slice ((P1 + 1), Message.Last); begin Script_Manager.Release_Hold (Value (UID), Result); end; else declare P1 : constant Integer := Index (Source => Message, Pattern => "|"); P2 : constant Integer := Index (Source => Message, Pattern => "|", From => P1 + 1); UID : constant String := Message.Slice (Message.First, (P1 - 1)); Event : constant String := Message.Slice ((P1 + 1), (P2 - 1)); Event_Data : constant String := Message.Slice ((P2 + 1), Message.Last); Object : constant Gnoga.Gui.Base.Pointer_To_Base_Class := Object_Manager.Get_Object (Value (UID)); New_ID : Gnoga.Types.Unique_ID; begin New_Unique_ID (New_ID); Dispatch_Task_Objects.Add_Dispatch_Task (New_ID, new Dispatch_Task_Type (Object)); Dispatch_Task_Objects.Object (New_ID).Start (Event, Event_Data, New_ID); end; end if; exception when E : No_Object => Log ("Request to dispatch message to non-existant object"); Log (From_UTF_8 (Ada.Exceptions.Exception_Information (E))); return; when E : others => Log ("Dispatch Message Error"); Log (From_UTF_8 (Ada.Exceptions.Exception_Information (E))); end Dispatch_Message; ------------------- -- String_Buffer -- ------------------- protected body String_Buffer is procedure Buffering (Value : Boolean) is begin Is_Buffering := Value; end Buffering; function Buffering return Boolean is begin return Is_Buffering; end Buffering; procedure Add (S : in String) is use type String; begin Buffer := Buffer & S; end Add; procedure Preface (S : in String) is use type String; begin Buffer := S & Buffer; end Preface; function Length return Natural is begin return Buffer.Length; end Length; function Get return String is begin return Buffer; end Get; procedure Get_And_Clear (S : out String) is begin S := Buffer; Buffer := Null_UXString; end Get_And_Clear; procedure Clear is begin Buffer := Null_UXString; end Clear; end String_Buffer; ---------------- -- Buffer_Add -- ---------------- function Buffer_Add (ID : Gnoga.Types.Connection_ID; Script : String) return Boolean is Socket : constant Socket_Type := Connection_Manager.Connection_Socket (ID); begin if Socket.Content.Buffer.Buffering then if Socket.Content.Buffer.Length + Script.Length >= Max_Buffer_Length then Flush_Buffer (ID); end if; if Socket.Content.Connection_Type = WebSocket then Socket.Content.Buffer.Add (Script & Gnoga.Server.Connection.Common.CRLF); elsif Socket.Content.Connection_Type = Long_Polling then Socket.Content.Buffer.Add (""); else Gnoga.Log ("Buffer_Add called on unsupported connection type."); end if; return True; else return False; end if; end Buffer_Add; ----------------------- -- Buffer_Connection -- ----------------------- function Buffer_Connection (ID : Gnoga.Types.Connection_ID) return Boolean is Socket : constant Socket_Type := Connection_Manager.Connection_Socket (ID); begin return Socket.Content.Buffer.Buffering; end Buffer_Connection; procedure Buffer_Connection (ID : in Gnoga.Types.Connection_ID; Value : in Boolean) is Socket : constant Socket_Type := Connection_Manager.Connection_Socket (ID); begin if Value = False then Flush_Buffer (ID); end if; Socket.Content.Buffer.Buffering (Value); end Buffer_Connection; ------------------ -- Flush_Buffer -- ------------------ procedure Flush_Buffer (ID : in Gnoga.Types.Connection_ID) is Socket : Socket_Type; begin if Connection_Manager.Valid (ID) then Socket := Connection_Manager.Connection_Socket (ID); if Socket.Content.Buffer.Buffering and Socket.Content.Connection_Type = WebSocket then Socket.Content.Buffer.Buffering (False); Execute_Script (ID, Socket.Content.Buffer.Get); Socket.Content.Buffer.Clear; Socket.Content.Buffer.Buffering (True); elsif Socket.Content.Connection_Type = Long_Polling then Socket.Unblock_Send; end if; end if; exception when E : Connection_Error => -- Connection already closed. Log ("Connection ID " & Image (ID) & " already closed."); Log (From_UTF_8 (Ada.Exceptions.Exception_Information (E))); when E : others => Log ("Flush_Buffer error on ID " & Image (ID)); Log (From_UTF_8 (Ada.Exceptions.Exception_Information (E))); end Flush_Buffer; ------------------- -- Buffer_Append -- ------------------- procedure Buffer_Append (ID : in Gnoga.Types.Connection_ID; Value : in String) is Socket : constant Socket_Type := Connection_Manager.Connection_Socket (ID); begin Socket.Content.Buffer.Add (Value); end Buffer_Append; -------------------- -- Execute_Script -- -------------------- procedure Execute_Script (ID : in Gnoga.Types.Connection_ID; Script : in String) is procedure Try_Execute; procedure Try_Execute is Socket : constant Socket_Type := Connection_Manager.Connection_Socket (ID); begin if Socket.Content.Connection_Type = Long_Polling then Socket.Content.Buffer.Add (""); if not Socket.Content.Buffer.Buffering then Socket.Unblock_Send; end if; elsif Socket.Content.Connection_Type = WebSocket then Socket.WebSocket_Send (Standard.String (To_UTF_8 (Script))); end if; exception when E : Ada.Text_IO.End_Error => Log ("Error Try_Execute ID " & Image (ID)); Log (From_UTF_8 (Ada.Exceptions.Exception_Information (E))); raise Connection_Error with "Socket Closed before execute of : " & To_UTF_8 (Script); when E : others => Log ("Error Try_Execute ID " & Image (ID)); Log (From_UTF_8 (Ada.Exceptions.Exception_Information (E))); raise Connection_Error with "Socket Error during execute of : " & To_UTF_8 (Script); end Try_Execute; begin if Connection_Manager.Valid (ID) and Script /= "" then if not Buffer_Add (ID, Script) then Try_Execute; end if; end if; exception when E : others => Log ("Error Execute_Script ID " & Image (ID)); Log (From_UTF_8 (Ada.Exceptions.Exception_Information (E))); delay 2.0; Try_Execute; end Execute_Script; function Execute_Script (ID : in Gnoga.Types.Connection_ID; Script : in String) return String is function Try_Execute return String; function Try_Execute return String is Script_Holder : aliased Script_Holder_Type; begin declare Script_ID : Gnoga.Types.Unique_ID; Socket : constant Socket_Type := Connection_Manager.Connection_Socket (ID); begin Script_Manager.Add_Script_Holder (ID => Script_ID, Holder => Script_Holder'Unchecked_Access); declare Message : constant String := "ws.send (" & """S" & Image (Script_ID) & "|""+" & "eval (""" & Script & """)" & ");"; begin if Socket.Content.Connection_Type = Long_Polling then Socket.Content.Buffer.Add (""); Socket.Unblock_Send; elsif Socket.Content.Connection_Type = WebSocket then Socket.WebSocket_Send (Standard.String (To_UTF_8 (Message))); end if; select delay Script_Time_Out; -- Timeout for browser answer Script_Manager.Delete_Script_Holder (Script_ID); raise Script_Error with "Timeout error, no browser response for: " & To_UTF_8 (Message); then abort Script_Holder.Hold; end select; end; declare Result : constant String := Script_Holder.Result; begin Script_Manager.Delete_Script_Holder (Script_ID); return Result; end; end; exception when E : Ada.Text_IO.End_Error => Log ("Error Try_Execute ID " & Image (ID)); Log (From_UTF_8 (Ada.Exceptions.Exception_Information (E))); raise Connection_Error with "Socket Closed before execute of : " & To_UTF_8 (Script); when E : others => Log ("Error Try_Execute ID " & Image (ID)); Log (From_UTF_8 (Ada.Exceptions.Exception_Information (E))); raise Connection_Error with "Socket Error during execute of : " & To_UTF_8 (Script); end Try_Execute; begin begin if Connection_Manager.Valid (ID) then Flush_Buffer (ID); return Try_Execute; else raise Connection_Error with "Invalid ID " & To_ASCII (Image (ID)); end if; exception when E : others => Log ("Error Execute_Script ID " & Image (ID)); Log (From_UTF_8 (Ada.Exceptions.Exception_Information (E))); begin delay 2.0; return Try_Execute; exception when E : others => Log ("Error Execute_Script after retrying ID " & Image (ID)); Log (From_UTF_8 (Ada.Exceptions.Exception_Information (E))); Close (ID); raise Connection_Error with "Invalid ID " & To_ASCII (Image (ID)); end; end; end Execute_Script; --------------------- -- Connection_Data -- --------------------- procedure Connection_Data (ID : in Gnoga.Types.Connection_ID; Data : access Gnoga.Types.Connection_Data_Type'Class) is begin Connection_Manager.Add_Connection_Data (ID, Gnoga.Types.Pointer_to_Connection_Data_Class (Data)); end Connection_Data; function Connection_Data (ID : in Gnoga.Types.Connection_ID) return Gnoga.Types.Pointer_to_Connection_Data_Class is begin return Connection_Manager.Connection_Data (ID); end Connection_Data; ------------------------ -- On_Connect_Handler -- ------------------------ procedure On_Connect_Handler (Event : in Connect_Event) is begin On_Connect_Event := Event; end On_Connect_Handler; --------------------- -- Connection_Type -- --------------------- function Connection_Type (ID : Gnoga.Types.Connection_ID) return Gnoga_Connection_Type is Socket : constant Socket_Type := Connection_Manager.Connection_Socket (ID); begin return Socket.Content.Connection_Type; exception when E : Connection_Error => Log ("Error Connection_Type on ID " & Image (ID)); Log (From_UTF_8 (Ada.Exceptions.Exception_Information (E))); return None; end Connection_Type; --------------------- -- Connection_Path -- --------------------- function Connection_Path (ID : Gnoga.Types.Connection_ID) return String is Socket : constant Socket_Type := Connection_Manager.Connection_Socket (ID); S : constant String := Socket.Content.Connection_Path; begin if Socket.Content.Connection_Type = Long_Polling then return S; else if S = "" then Socket.Content.Connection_Path := Left_Trim_Slashes (Execute_Script (ID, "window.location.pathname")); return Socket.Content.Connection_Path; else return S; end if; end if; exception when E : Connection_Error => Log ("Error Connection_Path on ID " & Image (ID)); Log (From_UTF_8 (Ada.Exceptions.Exception_Information (E))); return ""; end Connection_Path; ------------------------------- -- Connection_Client_Address -- ------------------------------- function Connection_Client_Address (ID : Gnoga.Types.Connection_ID) return String is Socket : constant Socket_Type := Connection_Manager.Connection_Socket (ID); Client_Address : constant GNAT.Sockets.Sock_Addr_Type := Get_Client_Address (Socket.all); begin return From_UTF_8 (GNAT.Sockets.Image (Client_Address)); exception when E : Connection_Error => Log ("Error Connection_Client_Address on ID " & Image (ID)); Log (From_UTF_8 (Ada.Exceptions.Exception_Information (E))); return ""; end Connection_Client_Address; ------------------------ -- Active_Connections -- ------------------------ function Active_Connections return Natural is begin return Natural (Connection_Manager.Active_Connections); end Active_Connections; ----------------------------- -- On_Post_Request_Handler -- ----------------------------- procedure On_Post_Request_Handler (Event : Post_Request_Event) is begin On_Post_Request_Event := Event; end On_Post_Request_Handler; --------------------- -- On_Post_Handler -- --------------------- procedure On_Post_Handler (Event : in Post_Event) is begin On_Post_Event := Event; end On_Post_Handler; -------------------------- -- On_Post_File_Handler -- -------------------------- procedure On_Post_File_Handler (Event : in Post_File_Event) is begin On_Post_File_Event := Event; end On_Post_File_Handler; -------------------- -- Form_Parameter -- -------------------- function Form_Parameter (ID : Gnoga.Types.Connection_ID; Name : String) return String is begin return Execute_Script (ID, "params['" & Name & "'];"); end Form_Parameter; ----------- -- Valid -- ----------- function Valid (ID : Gnoga.Types.Connection_ID) return Boolean is begin if ID = Gnoga.Types.No_Connection then return False; else return Connection_Manager.Valid (ID); end if; end Valid; ----------- -- Close -- ----------- procedure Close (ID : Gnoga.Types.Connection_ID) is begin if Valid (ID) then declare Socket : constant Socket_Type := Connection_Manager.Connection_Socket (ID); begin if Socket.Content.Connection_Type = Long_Polling then Socket.Content.Finalized := True; else Execute_Script (ID, "ws.close()"); end if; exception when E : others => Log ("Error Close on ID " & Image (ID)); Log (From_UTF_8 (Ada.Exceptions.Exception_Information (E))); end; end if; end Close; ------------------- -- HTML_On_Close -- ------------------- procedure HTML_On_Close (ID : in Gnoga.Types.Connection_ID; HTML : in String) is begin Execute_Script (ID => ID, Script => "gnoga['html_on_close']='" & Escape_Quotes (HTML) & "';"); end HTML_On_Close; --------------------- -- ID_Machine_Type -- --------------------- protected type ID_Machine_Type is procedure Next_ID (ID : out Gnoga.Types.Unique_ID); private Current_ID : Gnoga.Types.Unique_ID := 0; end ID_Machine_Type; protected body ID_Machine_Type is procedure Next_ID (ID : out Gnoga.Types.Unique_ID) is begin Current_ID := Current_ID + 1; ID := Current_ID; end Next_ID; end ID_Machine_Type; ID_Machine : ID_Machine_Type; ------------------- -- New_Unique_ID -- ------------------- procedure New_Unique_ID (New_ID : out Gnoga.Types.Unique_ID) is begin ID_Machine.Next_ID (New_ID); end New_Unique_ID; ------------- -- New_GID -- ------------- function New_GID return String is New_ID : Gnoga.Types.Unique_ID; begin New_Unique_ID (New_ID); return "g" & Image (New_ID); end New_GID; -------------------------- -- Add_To_Message_Queue -- -------------------------- procedure Add_To_Message_Queue (Object : in out Gnoga.Gui.Base.Base_Type'Class) is begin Object_Manager.Insert (Object.Unique_ID, Object'Unchecked_Access); end Add_To_Message_Queue; ------------------------------- -- Delete_From_Message_Queue -- ------------------------------- procedure Delete_From_Message_Queue (Object : in out Gnoga.Gui.Base.Base_Type'Class) is begin Object_Manager.Delete (Object.Unique_ID); end Delete_From_Message_Queue; ---------- -- Stop -- ---------- procedure Stop is ID : Gnoga.Types.Connection_ID; procedure Free is new Ada.Unchecked_Deallocation (Watchdog_Type, Watchdog_Access); procedure Free is new Ada.Unchecked_Deallocation (Gnoga_HTTP_Server_Type, Gnoga_HTTP_Server_Access); begin if not Exit_Application_Requested and Watchdog /= null and Gnoga_HTTP_Server /= null then Exit_Application_Requested := True; Watchdog.Stop; Free (Watchdog); Connection_Manager.First (ID); while ID /= 0 loop begin Close (ID); Connection_Manager.Next (ID); exception when others => Connection_Manager.First (ID); end; end loop; Connection_Manager.Delete_All_Connections; Gnoga_HTTP_Server.Stop; Free (Gnoga_HTTP_Server); end if; end Stop; ----------- -- Write -- ----------- procedure Write (Stream : access Ada.Streams.Root_Stream_Type'Class; Item : in Gnoga_HTTP_Content) is begin null; end Write; --------- -- Get -- --------- overriding function Get (Source : access Gnoga_HTTP_Content) return Standard.String is begin if Source.Buffer.Length = 0 then if Source.Connection_Type = HTTP then return ""; elsif Source.Finalized then declare ID : constant Gnoga.Types.Connection_ID := Connection_Manager.Find_Connection_ID (Source.Socket); begin Gnoga.Log ("Shutting down long polling connection ID " & Image (ID)); return ""; end; else raise Content_Not_Ready; end if; else declare Chunk_Size : constant := Max_HTTP_Output_Chunk - 80; S : String; begin Source.Buffer.Get_And_Clear (S); if Length (S) > Chunk_Size then Source.Buffer.Preface (Slice (Source => S, Low => 1 + Chunk_Size, High => Length (S))); return Standard.String (To_UTF_8 (Slice (Source => S, Low => 1, High => Chunk_Size))); else return Standard.String (To_UTF_8 (S)); end if; end; end if; end Get; -------------- -- Finalize -- -------------- overriding procedure Finalize (Client : in out Gnoga_HTTP_Client) is ID : constant Gnoga.Types.Connection_ID := Connection_Manager.Find_Connection_ID (Client'Unchecked_Access); begin if Ada.Streams.Stream_IO.Is_Open (Client.Content.FS) then Ada.Streams.Stream_IO.Close (Client.Content.FS); end if; if ID /= Gnoga.Types.No_Connection then Gnoga.Log ("Deleting connection during finalize ID " & Image (ID)); Connection_Manager.Delete_Connection (ID); end if; HTTP_Client (Client).Finalize; exception when E : others => Log ("Error Finalize Gnoga_HTTP_Client ID " & Image (ID)); Log (From_UTF_8 (Ada.Exceptions.Exception_Information (E))); end Finalize; begin Gnoga.Server.Connection.Common.Gnoga_Client_Factory := Global_Gnoga_Client_Factory'Access; end Gnoga.Server.Connection;