-----------------------------------------------------------------------
--  awa-users-model -- User management module
--  Copyright (C) 2009, 2010, 2011, 2012, 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with AWA.Modules.Beans;
with AWA.Modules.Get;

with AWA.Applications;
with AWA.Users.Beans;

with Util.Log.Loggers;
package body AWA.Users.Modules is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Users.Module");

   package Register is new AWA.Modules.Beans (Module => User_Module,
                                              Module_Access => User_Module_Access);

   --  ------------------------------
   --  Initialize the user module.
   --  ------------------------------
   overriding
   procedure Initialize (Plugin : in out User_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config) is
   begin
      Log.Info ("Initializing the users module");

      --  Setup the resource bundles.
      App.Register ("userMsg", "users");

      --  Register the OpenID servlets.
      App.Add_Servlet (Name   => "openid-auth",
                       Server => Plugin.Auth'Unchecked_Access);
      App.Add_Servlet (Name   => "openid-verify",
                       Server => Plugin.Verify_Auth'Unchecked_Access);

      --  Setup the verify access key filter.
      App.Add_Filter ("verify-access-key", Plugin.Key_Filter'Unchecked_Access);
      App.Add_Filter ("auth-filter", Plugin.Auth_Filter'Unchecked_Access);

      Plugin.Key_Filter.Initialize (App.all);

      Register.Register (Plugin  => Plugin,
                         Name    => "AWA.Users.Beans.Authenticate_Bean",
                         Handler => AWA.Users.Beans.Create_Authenticate_Bean'Access);

      Register.Register (Plugin  => Plugin,
                         Name    => "AWA.Users.Beans.Current_User_Bean",
                         Handler => AWA.Users.Beans.Create_Current_User_Bean'Access);

      AWA.Modules.Module (Plugin).Initialize (App, Props);

      --  Create the user manager when everything is initialized.
      Plugin.Manager := Plugin.Create_User_Manager;
   end Initialize;

   --  ------------------------------
   --  Get the user manager.
   --  ------------------------------
   function Get_User_Manager (Plugin : in User_Module) return Services.User_Service_Access is
   begin
      return Plugin.Manager;
   end Get_User_Manager;

   --  ------------------------------
   --  Create a user manager.  This operation can be overriden to provide another
   --  user service implementation.
   --  ------------------------------
   function Create_User_Manager (Plugin : in User_Module) return Services.User_Service_Access is
      Result : constant Services.User_Service_Access := new Services.User_Service;
   begin
      Result.Initialize (Plugin);
      return Result;
   end Create_User_Manager;

   --  ------------------------------
   --  Get the user module instance associated with the current application.
   --  ------------------------------
   function Get_User_Module return User_Module_Access is
      function Get is new AWA.Modules.Get (User_Module, User_Module_Access, NAME);
   begin
      return Get;
   end Get_User_Module;

   --  ------------------------------
   --  Get the user manager instance associated with the current application.
   --  ------------------------------
   function Get_User_Manager return Services.User_Service_Access is
      Module : constant User_Module_Access := Get_User_Module;
   begin
      if Module = null then
         Log.Error ("There is no active User_Module");
         return null;
      else
         return Module.Get_User_Manager;
      end if;
   end Get_User_Manager;

end AWA.Users.Modules;

-----------------------------------------------------------------------
--  awa-users-model -- User management module
--  Copyright (C) 2009, 2010, 2011, 2012, 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with AWA.Modules.Beans;
with AWA.Modules.Get;

with AWA.Applications;
with AWA.Users.Beans;

with Util.Log.Loggers;
package body AWA.Users.Modules is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Users.Module");

   package Register is new AWA.Modules.Beans (Module => User_Module,
                                              Module_Access => User_Module_Access);

   --  ------------------------------
   --  Initialize the user module.
   --  ------------------------------
   overriding
   procedure Initialize (Plugin : in out User_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config) is
   begin
      Log.Info ("Initializing the users module");

      --  Setup the resource bundles.
      App.Register ("userMsg", "users");

      --  Register the OpenID servlets.
      App.Add_Servlet (Name   => "openid-auth",
                       Server => Plugin.Auth'Unchecked_Access);
      App.Add_Servlet (Name   => "openid-verify",
                       Server => Plugin.Verify_Auth'Unchecked_Access);

      --  Setup the verify access key filter.
      App.Add_Filter ("verify-access-key", Plugin.Key_Filter'Unchecked_Access);
      App.Add_Filter ("auth-filter", Plugin.Auth_Filter'Unchecked_Access);

      Register.Register (Plugin  => Plugin,
                         Name    => "AWA.Users.Beans.Authenticate_Bean",
                         Handler => AWA.Users.Beans.Create_Authenticate_Bean'Access);

      Register.Register (Plugin  => Plugin,
                         Name    => "AWA.Users.Beans.Current_User_Bean",
                         Handler => AWA.Users.Beans.Create_Current_User_Bean'Access);

      AWA.Modules.Module (Plugin).Initialize (App, Props);

      --  Create the user manager when everything is initialized.
      Plugin.Manager := Plugin.Create_User_Manager;
   end Initialize;

   --  ------------------------------
   --  Get the user manager.
   --  ------------------------------
   function Get_User_Manager (Plugin : in User_Module) return Services.User_Service_Access is
   begin
      return Plugin.Manager;
   end Get_User_Manager;

   --  ------------------------------
   --  Create a user manager.  This operation can be overriden to provide another
   --  user service implementation.
   --  ------------------------------
   function Create_User_Manager (Plugin : in User_Module) return Services.User_Service_Access is
      Result : constant Services.User_Service_Access := new Services.User_Service;
   begin
      Result.Initialize (Plugin);
      return Result;
   end Create_User_Manager;

   --  ------------------------------
   --  Get the user module instance associated with the current application.
   --  ------------------------------
   function Get_User_Module return User_Module_Access is
      function Get is new AWA.Modules.Get (User_Module, User_Module_Access, NAME);
   begin
      return Get;
   end Get_User_Module;

   --  ------------------------------
   --  Get the user manager instance associated with the current application.
   --  ------------------------------
   function Get_User_Manager return Services.User_Service_Access is
      Module : constant User_Module_Access := Get_User_Module;
   begin
      if Module = null then
         Log.Error ("There is no active User_Module");
         return null;
      else
         return Module.Get_User_Manager;
      end if;
   end Get_User_Manager;

end AWA.Users.Modules;

Remove the Key_Filter initialization because this is now correctly done by ASF


-----------------------------------------------------------------------
--  asf.responses.web -- ASF Responses with AWS server
--  Copyright (C) 2009, 2010, 2011 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with AWS.Headers;
with AWS.Messages;
with AWS.Response.Set;
with AWS.Containers.Tables;
package body ASF.Responses.Web is

   procedure Initialize (Resp : in out Response) is
   begin
      Resp.Content.Initialize (Size   => 256 * 1024,
                               Output => Resp'Unchecked_Access,
                               Input  => null);
      Resp.Stream := Resp.Content'Unchecked_Access;
   end Initialize;

   --  ------------------------------
   --  Write the buffer array to the output stream.
   --  ------------------------------
   procedure Write (Stream : in out Response;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
   begin
      AWS.Response.Set.Append_Body (D    => Stream.Data,
                                    Item => Buffer);
   end Write;

   --  ------------------------------
   --  Flush the buffer (if any) to the sink.
   --  ------------------------------
   procedure Flush (Stream : in out Response) is
   begin
      null;
   end Flush;

   function To_Status_Code (Status : in Natural) return AWS.Messages.Status_Code;

   function To_Status_Code (Status : in Natural) return AWS.Messages.Status_Code is
      use AWS.Messages;
   begin
      case Status is
         when 100 =>
            return S100;
         when 101 =>
            return S101;
         when 200 =>
            return S200;
         when 201 =>
            return S201;
         when 202 =>
            return S202;
         when 301 =>
            return S301;
         when 302 =>
            return S302;
         when 400 =>
            return S400;
         when 401 =>
            return S401;
         when 402 =>
            return S402;
         when 403 =>
            return S403;
         when 404 =>
            return S404;
         when others =>
            return S500;
      end case;
   end To_Status_Code;

   --  ------------------------------
   --  Iterate over the response headers and executes the <b>Process</b> procedure.
   --  ------------------------------
   procedure Iterate_Headers (Resp    : in Response;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String)) is
      Headers : constant AWS.Headers.List := AWS.Response.Header (Resp.Data);
   begin
      AWS.Containers.Tables.Iterate_Names (AWS.Containers.Tables.Table_Type (Headers),
                                           ";", Process);
   end Iterate_Headers;

   --  ------------------------------
   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   --  ------------------------------
   function Contains_Header (Resp : in Response;
                             Name : in String) return Boolean is
   begin
      raise Program_Error with "Contains_Header is not implemented";
      return False;
   end Contains_Header;

   --  ------------------------------
   --  Sets a response header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   --  ------------------------------
   procedure Set_Header (Resp  : in out Response;
                         Name  : in String;
                         Value : in String) is
   begin
      if AWS.Response.Header (Resp.Data, Name)'Length = 0 then
         AWS.Response.Set.Add_Header (D     => Resp.Data,
                                      Name  => Name,
                                      Value => Value);
      end if;
   end Set_Header;

   --  ------------------------------
   --  Adds a response header with the given name and value.
   --  This method allows response headers to have multiple values.
   --  ------------------------------
   procedure Add_Header (Resp  : in out Response;
                         Name  : in String;
                         Value : in String) is
   begin
      AWS.Response.Set.Add_Header (D     => Resp.Data,
                                   Name  => Name,
                                   Value => Value);
   end Add_Header;

   --  ------------------------------
   --  Sends a temporary redirect response to the client using the specified redirect
   --  location URL. This method can accept relative URLs; the servlet container must
   --  convert the relative URL to an absolute URL before sending the response to the
   --  client. If the location is relative without a leading '/' the container
   --  interprets it as relative to the current request URI. If the location is relative
   --  with a leading '/' the container interprets it as relative to the servlet
   --  container root.
   --
   --  If the response has already been committed, this method throws an
   --  IllegalStateException. After using this method, the response should be
   --  considered to be committed and should not be written to.
   --  ------------------------------
   procedure Send_Redirect (Resp     : in out Response;
                            Location : in String) is
   begin
      Response'Class (Resp).Set_Status (SC_FOUND);
      Response'Class (Resp).Set_Header (Name  => "Location",
                                        Value => Location);
      Resp.Redirect := True;
   end Send_Redirect;

   --  ------------------------------
   --  Prepare the response data by collecting the status, content type and message body.
   --  ------------------------------
   procedure Build (Resp : in out Response) is
   begin
      if not Resp.Redirect then
         AWS.Response.Set.Content_Type (D     => Resp.Data,
                                        Value => Resp.Get_Content_Type);
         Resp.Content.Flush;
      else
         AWS.Response.Set.Mode (D     => Resp.Data,
                                Value => AWS.Response.Header);
      end if;
      AWS.Response.Set.Status_Code (D     => Resp.Data,
                                    Value => To_Status_Code (Resp.Get_Status));
   end Build;

   --  ------------------------------
   --  Get the response data
   --  ------------------------------
   function Get_Data (Resp : in Response) return AWS.Response.Data is
   begin
      return Resp.Data;
   end Get_Data;

end ASF.Responses.Web;

-----------------------------------------------------------------------
--  asf.responses.web -- ASF Responses with AWS server
--  Copyright (C) 2009, 2010, 2011 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with AWS.Headers;
with AWS.Messages;
with AWS.Response.Set;
with AWS.Containers.Tables;
package body ASF.Responses.Web is

   procedure Initialize (Resp : in out Response) is
   begin
      Resp.Content.Initialize (Size   => 256 * 1024,
                               Output => Resp'Unchecked_Access,
                               Input  => null);
      Resp.Stream := Resp.Content'Unchecked_Access;
   end Initialize;

   --  ------------------------------
   --  Write the buffer array to the output stream.
   --  ------------------------------
   procedure Write (Stream : in out Response;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
   begin
      AWS.Response.Set.Append_Body (D    => Stream.Data,
                                    Item => Buffer);
   end Write;

   --  ------------------------------
   --  Flush the buffer (if any) to the sink.
   --  ------------------------------
   procedure Flush (Stream : in out Response) is
   begin
      null;
   end Flush;

   function To_Status_Code (Status : in Natural) return AWS.Messages.Status_Code;

   function To_Status_Code (Status : in Natural) return AWS.Messages.Status_Code is
      use AWS.Messages;
   begin
      case Status is
         when 100 =>
            return S100;
         when 101 =>
            return S101;
         when 200 =>
            return S200;
         when 201 =>
            return S201;
         when 202 =>
            return S202;
         when 301 =>
            return S301;
         when 302 =>
            return S302;
         when 400 =>
            return S400;
         when 401 =>
            return S401;
         when 402 =>
            return S402;
         when 403 =>
            return S403;
         when 404 =>
            return S404;
         when others =>
            return S500;
      end case;
   end To_Status_Code;

   --  ------------------------------
   --  Iterate over the response headers and executes the <b>Process</b> procedure.
   --  ------------------------------
   procedure Iterate_Headers (Resp    : in Response;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String)) is
      Headers : constant AWS.Headers.List := AWS.Response.Header (Resp.Data);
   begin
      AWS.Containers.Tables.Iterate_Names (AWS.Containers.Tables.Table_Type (Headers),
                                           ";", Process);
   end Iterate_Headers;

   --  ------------------------------
   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   --  ------------------------------
   function Contains_Header (Resp : in Response;
                             Name : in String) return Boolean is
   begin
      raise Program_Error with "Contains_Header is not implemented";
      return False;
   end Contains_Header;

   --  ------------------------------
   --  Sets a response header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   --  ------------------------------
   procedure Set_Header (Resp  : in out Response;
                         Name  : in String;
                         Value : in String) is
   begin
      if AWS.Response.Header (Resp.Data, Name)'Length = 0 then
         AWS.Response.Set.Add_Header (D     => Resp.Data,
                                      Name  => Name,
                                      Value => Value);
      end if;
   end Set_Header;

   --  ------------------------------
   --  Adds a response header with the given name and value.
   --  This method allows response headers to have multiple values.
   --  ------------------------------
   procedure Add_Header (Resp  : in out Response;
                         Name  : in String;
                         Value : in String) is
   begin
      AWS.Response.Set.Add_Header (D     => Resp.Data,
                                   Name  => Name,
                                   Value => Value);
   end Add_Header;

   --  ------------------------------
   --  Sends a temporary redirect response to the client using the specified redirect
   --  location URL. This method can accept relative URLs; the servlet container must
   --  convert the relative URL to an absolute URL before sending the response to the
   --  client. If the location is relative without a leading '/' the container
   --  interprets it as relative to the current request URI. If the location is relative
   --  with a leading '/' the container interprets it as relative to the servlet
   --  container root.
   --
   --  If the response has already been committed, this method throws an
   --  IllegalStateException. After using this method, the response should be
   --  considered to be committed and should not be written to.
   --  ------------------------------
   procedure Send_Redirect (Resp     : in out Response;
                            Location : in String) is
   begin
      Response'Class (Resp).Set_Status (SC_FOUND);
      Response'Class (Resp).Set_Header (Name  => "Location",
                                        Value => Location);
      Resp.Redirect := True;
   end Send_Redirect;

   --  ------------------------------
   --  Prepare the response data by collecting the status, content type and message body.
   --  ------------------------------
   procedure Build (Resp : in out Response) is
   begin
      if not Resp.Redirect then
         AWS.Response.Set.Content_Type (D     => Resp.Data,
                                        Value => Resp.Get_Content_Type);
         Resp.Content.Flush;
         if AWS.Response.Is_Empty (Resp.Data) then
            AWS.Response.Set.Message_Body (Resp.Data, "");
         end if;
      else
         AWS.Response.Set.Mode (D     => Resp.Data,
                                Value => AWS.Response.Header);
      end if;
      AWS.Response.Set.Status_Code (D     => Resp.Data,
                                    Value => To_Status_Code (Resp.Get_Status));
   end Build;

   --  ------------------------------
   --  Get the response data
   --  ------------------------------
   function Get_Data (Resp : in Response) return AWS.Response.Data is
   begin
      return Resp.Data;
   end Get_Data;

end ASF.Responses.Web;

Fix AWS support - if the response is empty and this is not a redirect, return an empty body.


-----------------------------------------------------------------------
--  awa-events -- AWA Events
--  Copyright (C) 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Strings;
with Util.Events;
with Util.Beans.Objects;
with Util.Beans.Basic;

with ASF.Applications;

--  == Introduction ==
--  The AWA.Events package defines an event framework for modules to post events
--  and have Ada bean methods be invoked when these events are dispatched.  Subscription to
--  events is done through configuration files.  This allows to configure the modules and
--  integrate them together easily at configuration time.
--
--  1/ Modules define the events that they can generate by instantiating the Definition
--     package. This is a static definition of the event.  Each event is given a unique name.
--
--    package Event_New_User is new AWA.Events.Definition ("new-user");
--
--  2/ The module can post an event to inform other modules or the system that a particular
--     action occurred.  The module creates the event instance of type Module_Event and
--     populates that event with useful properties for event receivers.
--
--      Event : AWA.Events.Module_Event;
--
--      Event.Set_Event_Kind (Event_New_User.Kind);
--      Event.Set_Parameter ("email", "harry.potter@hogwarts.org");
--
--  3/ The module will post the event by using the Send_Event operation.
--
--    Manager.Send_Event (Event);
--
--  4/ Modules or applications interested by a particular event will configure the event manager
--     to dispatch the event to an Ada bean event action.  The Ada bean is an object that must
--     implement a procedure that matches the prototype:
--
--        type Action_Bean is new Util.Beans.Basic.Readonly_Bean ...;
--        procedure Action (Bean : in out Action_Bean; Event : in AWA.Events.Module_Event'Class);
--
--     The Ada bean method and object are registered as other Ada beans.
--
--  5/ The configuration file indicates how to bind the Ada bean action and the event together.
--     The action is specified using an EL Method Expression (See Ada EL or JSR 245).
--
--       <on-event name="new_user">
--           <action>#{ada_bean.action}</action>
--       </on-event>
--
package AWA.Events is

   type Queue_Index is new Natural;
   type Event_Index is new Natural;

   --  ------------------------------
   --  Event kind definition
   --  ------------------------------
   --  This package must be instantiated for each event that a module can post.
   generic
      Name : String;
   package Definition is
      function Kind return Event_Index;
      pragma Inline_Always (Kind);
   end Definition;

   --  Exception raised if an event name is not found.
   Not_Found : exception;

   --  Identifies an invalid event.
   Invalid_Event : constant Event_Index := 0;

   --  Find the event runtime index given the event name.
   --  Raises Not_Found exception if the event name is not recognized.
   function Find_Event_Index (Name : in String) return Event_Index;

   --  ------------------------------
   --  Module event
   --  ------------------------------
   type Module_Event is new Util.Events.Event and Util.Beans.Basic.Readonly_Bean with private;
   type Module_Event_Access is access all Module_Event'Class;

   --  Set the event type which identifies the event.
   procedure Set_Event_Kind (Event : in out Module_Event;
                             Kind  : in Event_Index);

   --  Get the event type which identifies the event.
   function Get_Event_Kind (Event : in Module_Event) return Event_Index;

   --  Set a parameter on the message.
   procedure Set_Parameter (Event  : in out Module_Event;
                            Name   : in String;
                            Value  : in String);

   --  Get the parameter with the given name.
   function Get_Parameter (Event : in Module_Event;
                           Name  : in String) return String;

   --  Get the value that corresponds to the parameter with the given name.
   overriding
   function Get_Value (Event : in Module_Event;
                       Name  : in String) return Util.Beans.Objects.Object;

private

   type Module_Event is new Util.Events.Event and Util.Beans.Basic.Readonly_Bean with record
      Kind  : Event_Index := Invalid_Event;
      Props : ASF.Applications.Config;
   end record;

   --  The index of the last event definition.
   Last_Event : Event_Index := 0;

   --  Get the event type name.
   function Get_Event_Type_Name (Index : in Event_Index) return Util.Strings.Name_Access;

   --  Make and return a copy of the event.
   function Copy (Event : in Module_Event) return Module_Event_Access;

end AWA.Events;

-----------------------------------------------------------------------
--  awa-events -- AWA Events
--  Copyright (C) 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Strings;
with Util.Events;
with Util.Beans.Objects;
with Util.Beans.Basic;

with ASF.Applications;

--  == Introduction ==
--  The AWA.Events package defines an event framework for modules to post events
--  and have Ada bean methods be invoked when these events are dispatched.  Subscription to
--  events is done through configuration files.  This allows to configure the modules and
--  integrate them together easily at configuration time.
--
--  1/ Modules define the events that they can generate by instantiating the Definition
--     package. This is a static definition of the event.  Each event is given a unique name.
--
--    package Event_New_User is new AWA.Events.Definition ("new-user");
--
--  2/ The module can post an event to inform other modules or the system that a particular
--     action occurred.  The module creates the event instance of type Module_Event and
--     populates that event with useful properties for event receivers.
--
--      Event : AWA.Events.Module_Event;
--
--      Event.Set_Event_Kind (Event_New_User.Kind);
--      Event.Set_Parameter ("email", "harry.potter@hogwarts.org");
--
--  3/ The module will post the event by using the Send_Event operation.
--
--    Manager.Send_Event (Event);
--
--  4/ Modules or applications interested by a particular event will configure the event manager
--     to dispatch the event to an Ada bean event action.  The Ada bean is an object that must
--     implement a procedure that matches the prototype:
--
--        type Action_Bean is new Util.Beans.Basic.Readonly_Bean ...;
--        procedure Action (Bean : in out Action_Bean; Event : in AWA.Events.Module_Event'Class);
--
--     The Ada bean method and object are registered as other Ada beans.
--
--  5/ The configuration file indicates how to bind the Ada bean action and the event together.
--     The action is specified using an EL Method Expression (See Ada EL or JSR 245).
--
--       <on-event name="new_user">
--           <action>#{ada_bean.action}</action>
--       </on-event>
--
--  == Data Model ==
--  @include Queues.hbm.xml
--
package AWA.Events is

   type Queue_Index is new Natural;
   type Event_Index is new Natural;

   --  ------------------------------
   --  Event kind definition
   --  ------------------------------
   --  This package must be instantiated for each event that a module can post.
   generic
      Name : String;
   package Definition is
      function Kind return Event_Index;
      pragma Inline_Always (Kind);
   end Definition;

   --  Exception raised if an event name is not found.
   Not_Found : exception;

   --  Identifies an invalid event.
   Invalid_Event : constant Event_Index := 0;

   --  Find the event runtime index given the event name.
   --  Raises Not_Found exception if the event name is not recognized.
   function Find_Event_Index (Name : in String) return Event_Index;

   --  ------------------------------
   --  Module event
   --  ------------------------------
   type Module_Event is new Util.Events.Event and Util.Beans.Basic.Readonly_Bean with private;
   type Module_Event_Access is access all Module_Event'Class;

   --  Set the event type which identifies the event.
   procedure Set_Event_Kind (Event : in out Module_Event;
                             Kind  : in Event_Index);

   --  Get the event type which identifies the event.
   function Get_Event_Kind (Event : in Module_Event) return Event_Index;

   --  Set a parameter on the message.
   procedure Set_Parameter (Event  : in out Module_Event;
                            Name   : in String;
                            Value  : in String);

   --  Get the parameter with the given name.
   function Get_Parameter (Event : in Module_Event;
                           Name  : in String) return String;

   --  Get the value that corresponds to the parameter with the given name.
   overriding
   function Get_Value (Event : in Module_Event;
                       Name  : in String) return Util.Beans.Objects.Object;

private

   type Module_Event is new Util.Events.Event and Util.Beans.Basic.Readonly_Bean with record
      Kind  : Event_Index := Invalid_Event;
      Props : ASF.Applications.Config;
   end record;

   --  The index of the last event definition.
   Last_Event : Event_Index := 0;

   --  Get the event type name.
   function Get_Event_Type_Name (Index : in Event_Index) return Util.Strings.Name_Access;

   --  Make and return a copy of the event.
   function Copy (Event : in Module_Event) return Module_Event_Access;

end AWA.Events;

Add the event data model

Add the event data model


-----------------------------------------------------------------------
--  json -- JSON Reader
--  Copyright (C) 2010, 2011 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Ada.Text_IO;
with Ada.Command_Line;
with Util.Serialize.IO.JSON;
with Ada.Containers;
with Mapping;
with Util.Streams.Texts;
with Util.Streams.Buffered;
procedure Json is

   use Util.Streams.Buffered;
   use Ada.Strings.Unbounded;
   use type Mapping.Person_Access;
   use type Ada.Containers.Count_Type;

   Reader : Util.Serialize.IO.JSON.Parser;

   Count  : constant Natural := Ada.Command_Line.Argument_Count;

   procedure Print (P : in Mapping.Person_Vector.Cursor);
   procedure Print (P : in Mapping.Person);

   procedure Print (P : in Mapping.Person) is
   begin
      Ada.Text_IO.Put_Line ("first_name : " & To_String (P.First_Name));
      Ada.Text_IO.Put_Line ("last_name  : " & To_String (P.Last_Name));
      Ada.Text_IO.Put_Line ("Age        : " & Natural'Image (P.Age));
      Ada.Text_IO.Put_Line ("Street     : " & To_String (P.Addr.Street));
      Ada.Text_IO.Put_Line ("City       : " & To_String (P.Addr.City));
      Ada.Text_IO.Put_Line ("Zip        : " & Natural'Image (P.Addr.Zip));
      Ada.Text_IO.Put_Line ("Country    : " & To_String (P.Addr.Country));
      Ada.Text_IO.Put_Line ("Info       : " & To_String (P.Addr.Info.Name)
                            & "=" & To_String (P.Addr.Info.Value));
   end Print;

   procedure Print (P : in Mapping.Person_Vector.Cursor) is
   begin
      Print (Mapping.Person_Vector.Element (P));
   end Print;

begin
   if Count = 0 then
      Ada.Text_IO.Put_Line ("Usage: json file...");
      return;
   end if;

   Reader.Add_Mapping ("list", Mapping.Get_Person_Vector_Mapper.all'Access);
   Reader.Add_Mapping ("person", Mapping.Get_Person_Mapper.all'Access);
   for I in 1 .. Count loop
      declare
         S    : constant String := Ada.Command_Line.Argument (I);

         List : aliased Mapping.Person_Vector.Vector;
         P    : aliased Mapping.Person;
      begin
         Mapping.Person_Vector_Mapper.Set_Context (Reader, List'Unchecked_Access);
         Mapping.Person_Mapper.Set_Context (Reader, P'Unchecked_Access);
         Reader.Parse (S);

         --  The list now contains our elements.
         List.Iterate (Process => Print'Access);
         if List.Length = 0 then
            Print (P);
         end if;

         declare
            Output : Util.Serialize.IO.JSON.Output_Stream;
         begin
            Output.Initialize (Size => 10000);
            Mapping.Get_Person_Mapper.Write (Output, P);
            Ada.Text_IO.Put_Line ("Person: "
                                  & Util.Streams.Texts.To_String (Buffered_Stream (Output)));
         end;

         declare
            Output : Util.Serialize.IO.JSON.Output_Stream;
         begin
            Output.Initialize (Size => 10000);
            Output.Write ("{""list"":");
            Mapping.Get_Person_Vector_Mapper.Write (Output, List);
            Output.Write ("}");

            Ada.Text_IO.Put_Line ("IO:");
            Ada.Text_IO.Put_Line (Util.Streams.Texts.To_String (Buffered_Stream (Output)));
         end;
      end;
   end loop;
end Json;

-----------------------------------------------------------------------
--  json -- JSON Reader
--  Copyright (C) 2010, 2011 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Ada.Text_IO;
with Ada.Command_Line;
with Util.Serialize.IO.JSON;
with Ada.Containers;
with Mapping;
with Util.Streams.Texts;
with Util.Streams.Buffered;
procedure Json is

   use Util.Streams.Buffered;
   use Ada.Strings.Unbounded;
   use type Mapping.Person_Access;
   use type Ada.Containers.Count_Type;

   Reader : Util.Serialize.IO.JSON.Parser;

   Count  : constant Natural := Ada.Command_Line.Argument_Count;

   procedure Print (P : in Mapping.Person_Vector.Cursor);
   procedure Print (P : in Mapping.Person);

   procedure Print (P : in Mapping.Person) is
   begin
      Ada.Text_IO.Put_Line ("Name       : " & To_String (P.Name));
      Ada.Text_IO.Put_Line ("first_name : " & To_String (P.First_Name));
      Ada.Text_IO.Put_Line ("last_name  : " & To_String (P.Last_Name));
      Ada.Text_IO.Put_Line ("Age        : " & Natural'Image (P.Age));
      Ada.Text_IO.Put_Line ("Street     : " & To_String (P.Addr.Street));
      Ada.Text_IO.Put_Line ("City       : " & To_String (P.Addr.City));
      Ada.Text_IO.Put_Line ("Zip        : " & Natural'Image (P.Addr.Zip));
      Ada.Text_IO.Put_Line ("Country    : " & To_String (P.Addr.Country));
      Ada.Text_IO.Put_Line ("Info       : " & To_String (P.Addr.Info.Name)
                            & "=" & To_String (P.Addr.Info.Value));
   end Print;

   procedure Print (P : in Mapping.Person_Vector.Cursor) is
   begin
      Print (Mapping.Person_Vector.Element (P));
   end Print;

begin
   if Count = 0 then
      Ada.Text_IO.Put_Line ("Usage: json file...");
      return;
   end if;

   Reader.Add_Mapping ("/list", Mapping.Get_Person_Vector_Mapper.all'Access);
   Reader.Add_Mapping ("/person", Mapping.Get_Person_Mapper.all'Access);
   for I in 1 .. Count loop
      declare
         S    : constant String := Ada.Command_Line.Argument (I);

         List : aliased Mapping.Person_Vector.Vector;
         P    : aliased Mapping.Person;
      begin
         Mapping.Person_Vector_Mapper.Set_Context (Reader, List'Unchecked_Access);
         Mapping.Person_Mapper.Set_Context (Reader, P'Unchecked_Access);
         Reader.Parse (S);

         --  The list now contains our elements.
         List.Iterate (Process => Print'Access);
         if List.Length = 0 then
            Print (P);
         end if;

         declare
            Output : Util.Serialize.IO.JSON.Output_Stream;
         begin
            Output.Initialize (Size => 10000);
            Mapping.Get_Person_Mapper.Write (Output, P);
            Ada.Text_IO.Put_Line ("Person: "
                                  & Util.Streams.Texts.To_String (Buffered_Stream (Output)));
         end;

         declare
            Output : Util.Serialize.IO.JSON.Output_Stream;
         begin
            Output.Initialize (Size => 10000);
            Output.Write ("{""list"":");
            Mapping.Get_Person_Vector_Mapper.Write (Output, List);
            Output.Write ("}");

            Ada.Text_IO.Put_Line ("IO:");
            Ada.Text_IO.Put_Line (Util.Streams.Texts.To_String (Buffered_Stream (Output)));
         end;
      end;
   end loop;
end Json;

Update the json example

Update the json example


-----------------------------------------------------------------------
--  AWA tests - AWA Tests Framework
--  Copyright (C) 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Task_Termination;
with Ada.Task_Identification;
with Ada.Exceptions;
with Ada.Unchecked_Deallocation;

with ASF.Server.Tests;
with ASF.Server.Web;
with ASF.Converters.Dates;

with ASF.Tests;

with AWA.Users.Modules;
with AWA.Mail.Modules;
with AWA.Blogs.Modules;
with AWA.Workspaces.Modules;
with AWA.Storages.Modules;

--  with AWA.Applications;
with AWA.Applications.Factory;
with AWA.Services.Filters;
with AWA.Services.Contexts;
package body AWA.Tests is

   protected Shutdown is
      procedure Termination (Cause : in Ada.Task_Termination.Cause_Of_Termination;
                             Id    : in Ada.Task_Identification.Task_Id;
                             Ex    : in Ada.Exceptions.Exception_Occurrence);
   end Shutdown;

   Application_Created : Boolean := False;
   Application    : AWA.Applications.Application_Access := null;

   Factory        : AWA.Applications.Factory.Application_Factory;

   Service_Filter : aliased AWA.Services.Filters.Service_Filter;

   Users          : aliased AWA.Users.Modules.User_Module;

   Workspaces     : aliased AWA.Workspaces.Modules.Workspace_Module;

   Mail           : aliased AWA.Mail.Modules.Mail_Module;

   Blogs          : aliased AWA.Blogs.Modules.Blog_Module;

   Storages       : aliased AWA.Storages.Modules.Storage_Module;

   Date_Converter : aliased ASF.Converters.Dates.Date_Converter;

   protected body Shutdown is
      procedure Termination (Cause : in Ada.Task_Termination.Cause_Of_Termination;
                             Id    : in Ada.Task_Identification.Task_Id;
                             Ex    : in Ada.Exceptions.Exception_Occurrence) is
         pragma Unreferenced (Cause, Id, Ex);

         procedure Free is
            new Ada.Unchecked_Deallocation (Object => AWA.Applications.Application'Class,
                                            Name   => AWA.Applications.Application_Access);
      begin
         Free (Application);
      end Termination;
   end Shutdown;

   --  ------------------------------
   --  Setup the service context before executing the test.
   --  ------------------------------
   overriding
   procedure Set_Up (T : in out Test) is
      pragma Unreferenced (T);
   begin
      ASF.Server.Tests.Set_Context (Application.all'Access);
   end Set_Up;

   procedure Initialize (Props : in Util.Properties.Manager) is
   begin
      Initialize (null, Props, True);
   end Initialize;

   --  ------------------------------
   --  Called when the testsuite execution has finished.
   --  ------------------------------
   procedure Finish (Status : in Util.XUnit.Status) is
      pragma Unreferenced (Status);

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => AWA.Applications.Application'Class,
                                        Name   => AWA.Applications.Application_Access);

   begin
      if Application_Created then
         Free (Application);
      end if;
   end Finish;

   --  ------------------------------
   --  Initialize the AWA test framework mockup.
   --  ------------------------------
   procedure Initialize (App         : in AWA.Applications.Application_Access;
                         Props       : in Util.Properties.Manager;
                         Add_Modules : in Boolean) is
      use AWA.Applications;
   begin
      --  Create the application unless it is specified as argument.
      --  Install a shutdown hook to delete the application when the primary task exits.
      --  This allows to stop the event threads if any.
      if App = null then
         Application_Created := True;
         Application := new AWA.Applications.Application;
         Ada.Task_Termination.Set_Specific_Handler (Ada.Task_Identification.Current_Task,
                                                    Shutdown.Termination'Access);
      else
         Application := App;
      end if;

      ASF.Tests.Initialize (Props, Application.all'Access, Factory);
      Application.Add_Filter ("service", Service_Filter'Access);
      Application.Add_Filter_Mapping (Name => "service", Pattern => "*.html");

      if Add_Modules then
         declare
            Ctx    : AWA.Services.Contexts.Service_Context;
            Users : constant AWA.Users.Modules.User_Module_Access := AWA.Tests.Users'Access;
         begin
            Ctx.Set_Context (Application, null);
            Register (App    => Application.all'Access,
                      Name   => AWA.Users.Modules.NAME,
                      URI    => "user",
                      Module => Users.all'Access);

            Register (App    => Application.all'Access,
                      Name   => "mail",
                      URI    => "mail",
                      Module => Mail'Access);

            Register (App    => Application.all'Access,
                      Name   => "workspaces",
                      URI    => "workspaces",
                      Module => Workspaces'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Storages.Modules.NAME,
                      URI    => "storages",
                      Module => Storages'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Blogs.Modules.NAME,
                      URI    => "blogs",
                      Module => Blogs'Access);

            if Props.Exists ("test.server") then
               declare
                  WS : ASF.Server.Web.AWS_Container;
               begin
                  Application.Add_Converter (Name      => "dateConverter",
                                             Converter => Date_Converter'Access);

                  WS.Register_Application ("/asfunit", Application.all'Access);

                  WS.Start;
                  delay 6000.0;
               end;
            end if;
            ASF.Server.Tests.Set_Context (Application.all'Access);
         end;
      end if;
   end Initialize;

   --  ------------------------------
   --  Get the test application.
   --  ------------------------------
   function Get_Application return AWA.Applications.Application_Access is
   begin
      return Application;
   end Get_Application;

   --  ------------------------------
   --  Set the application context to simulate a web request context.
   --  ------------------------------
   procedure Set_Application_Context is
   begin
      ASF.Server.Tests.Set_Context (Application.all'Access);
   end Set_Application_Context;

end AWA.Tests;

-----------------------------------------------------------------------
--  AWA tests - AWA Tests Framework
--  Copyright (C) 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Task_Termination;
with Ada.Task_Identification;
with Ada.Exceptions;
with Ada.Unchecked_Deallocation;

with ASF.Server.Tests;
with ASF.Server.Web;
with ASF.Converters.Dates;

with ASF.Tests;

with AWA.Converters.Dates;
with AWA.Users.Modules;
with AWA.Mail.Modules;
with AWA.Blogs.Modules;
with AWA.Workspaces.Modules;
with AWA.Storages.Modules;

--  with AWA.Applications;
with AWA.Applications.Factory;
with AWA.Services.Filters;
with AWA.Services.Contexts;
package body AWA.Tests is

   protected Shutdown is
      procedure Termination (Cause : in Ada.Task_Termination.Cause_Of_Termination;
                             Id    : in Ada.Task_Identification.Task_Id;
                             Ex    : in Ada.Exceptions.Exception_Occurrence);
   end Shutdown;

   Application_Created : Boolean := False;
   Application    : AWA.Applications.Application_Access := null;

   Factory        : AWA.Applications.Factory.Application_Factory;

   Service_Filter : aliased AWA.Services.Filters.Service_Filter;

   Users          : aliased AWA.Users.Modules.User_Module;

   Workspaces     : aliased AWA.Workspaces.Modules.Workspace_Module;

   Mail           : aliased AWA.Mail.Modules.Mail_Module;

   Blogs          : aliased AWA.Blogs.Modules.Blog_Module;

   Storages       : aliased AWA.Storages.Modules.Storage_Module;

   Date_Converter : aliased ASF.Converters.Dates.Date_Converter;

   Rel_Date_Converter : aliased AWA.Converters.Dates.Relative_Date_Converter;

   protected body Shutdown is
      procedure Termination (Cause : in Ada.Task_Termination.Cause_Of_Termination;
                             Id    : in Ada.Task_Identification.Task_Id;
                             Ex    : in Ada.Exceptions.Exception_Occurrence) is
         pragma Unreferenced (Cause, Id, Ex);

         procedure Free is
            new Ada.Unchecked_Deallocation (Object => AWA.Applications.Application'Class,
                                            Name   => AWA.Applications.Application_Access);
      begin
         Free (Application);
      end Termination;
   end Shutdown;

   --  ------------------------------
   --  Setup the service context before executing the test.
   --  ------------------------------
   overriding
   procedure Set_Up (T : in out Test) is
      pragma Unreferenced (T);
   begin
      ASF.Server.Tests.Set_Context (Application.all'Access);
   end Set_Up;

   procedure Initialize (Props : in Util.Properties.Manager) is
   begin
      Initialize (null, Props, True);
   end Initialize;

   --  ------------------------------
   --  Called when the testsuite execution has finished.
   --  ------------------------------
   procedure Finish (Status : in Util.XUnit.Status) is
      pragma Unreferenced (Status);

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => AWA.Applications.Application'Class,
                                        Name   => AWA.Applications.Application_Access);

   begin
      if Application_Created then
         Free (Application);
      end if;
   end Finish;

   --  ------------------------------
   --  Initialize the AWA test framework mockup.
   --  ------------------------------
   procedure Initialize (App         : in AWA.Applications.Application_Access;
                         Props       : in Util.Properties.Manager;
                         Add_Modules : in Boolean) is
      use AWA.Applications;
   begin
      --  Create the application unless it is specified as argument.
      --  Install a shutdown hook to delete the application when the primary task exits.
      --  This allows to stop the event threads if any.
      if App = null then
         Application_Created := True;
         Application := new AWA.Applications.Application;
         Ada.Task_Termination.Set_Specific_Handler (Ada.Task_Identification.Current_Task,
                                                    Shutdown.Termination'Access);
      else
         Application := App;
      end if;

      ASF.Tests.Initialize (Props, Application.all'Access, Factory);
      Application.Add_Filter ("service", Service_Filter'Access);
      Application.Add_Filter_Mapping (Name => "service", Pattern => "*.html");

      if Add_Modules then
         declare
            Ctx    : AWA.Services.Contexts.Service_Context;
            Users : constant AWA.Users.Modules.User_Module_Access := AWA.Tests.Users'Access;
         begin
            Ctx.Set_Context (Application, null);
            Register (App    => Application.all'Access,
                      Name   => AWA.Users.Modules.NAME,
                      URI    => "user",
                      Module => Users.all'Access);

            Register (App    => Application.all'Access,
                      Name   => "mail",
                      URI    => "mail",
                      Module => Mail'Access);

            Register (App    => Application.all'Access,
                      Name   => "workspaces",
                      URI    => "workspaces",
                      Module => Workspaces'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Storages.Modules.NAME,
                      URI    => "storages",
                      Module => Storages'Access);

            Register (App    => Application.all'Access,
                      Name   => AWA.Blogs.Modules.NAME,
                      URI    => "blogs",
                      Module => Blogs'Access);

            if Props.Exists ("test.server") then
               declare
                  WS : ASF.Server.Web.AWS_Container;
               begin
                  Application.Add_Converter (Name      => "dateConverter",
                                             Converter => Date_Converter'Access);
                  Application.Add_Converter (Name      => "smartDateConverter",
                                             Converter => Rel_Date_Converter'Access);

                  WS.Register_Application ("/asfunit", Application.all'Access);

                  WS.Start;
                  delay 6000.0;
               end;
            end if;
            ASF.Server.Tests.Set_Context (Application.all'Access);
         end;
      end if;
   end Initialize;

   --  ------------------------------
   --  Get the test application.
   --  ------------------------------
   function Get_Application return AWA.Applications.Application_Access is
   begin
      return Application;
   end Get_Application;

   --  ------------------------------
   --  Set the application context to simulate a web request context.
   --  ------------------------------
   procedure Set_Application_Context is
   begin
      ASF.Server.Tests.Set_Context (Application.all'Access);
   end Set_Application_Context;

end AWA.Tests;

Add a relative date converter

Add a relative date converter


-----------------------------------------------------------------------
--  wiki-filters -- Wiki filters
--  Copyright (C) 2015, 2016 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

package body Wiki.Filters is

   --  ------------------------------
   --  Add a simple node such as N_LINE_BREAK, N_HORIZONTAL_RULE or N_PARAGRAPH to the document.
   --  ------------------------------
   procedure Add_Node (Filter    : in out Filter_Type;
                       Document  : in out Wiki.Nodes.Document;
                       Kind      : in Wiki.Nodes.Simple_Node_Kind) is
   begin
      if Filter.Next /= null then
         Filter.Add_Node (Document, Kind);
      else
         Wiki.Nodes.Append (Document, Kind);
      end if;
   end Add_Node;

   --  ------------------------------
   --  Add a text content with the given format to the document.
   --  ------------------------------
   procedure Add_Text (Filter    : in out Filter_Type;
                       Document  : in out Wiki.Nodes.Document;
                       Text      : in Wiki.Strings.WString;
                       Format    : in Wiki.Nodes.Format_Map) is
   begin
      if Filter.Next /= null then
         Filter.Add_Text (Document, Text, Format);
      else
         Wiki.Nodes.Append (Document, Text, Format);
      end if;
   end Add_Text;

   --  ------------------------------
   --  Add a section header with the given level in the document.
   --  ------------------------------
   procedure Add_Header (Filter    : in out Filter_Type;
                         Document  : in out Wiki.Nodes.Document;
                         Header    : in Wiki.Strings.WString;
                         Level     : in Natural) is
   begin
      if Filter.Next /= null then
         Filter.Add_Header (Document, Header, Level);
      else
         Wiki.Nodes.Append (Document, Header, Level);
      end if;
   end Add_Header;

   --  ------------------------------
   --  Add a blockquote (<blockquote>).  The level indicates the blockquote nested level.
   --  The blockquote must be closed at the next header.
   --  ------------------------------
   overriding
   procedure Add_Blockquote (Document : in out Filter_Type;
                             Level    : in Natural) is
   begin
      Document.Document.Add_Blockquote (Level);
   end Add_Blockquote;

   --  ------------------------------
   --  Add a list item (<li>).  Close the previous paragraph and list item if any.
   --  The list item will be closed at the next list item, next paragraph or next header.
   --  ------------------------------
   overriding
   procedure Add_List_Item (Document : in out Filter_Type;
                            Level    : in Positive;
                            Ordered  : in Boolean) is
   begin
      Document.Document.Add_List_Item (Level, Ordered);
   end Add_List_Item;

   --  ------------------------------
   --  Add a link.
   --  ------------------------------
   overriding
   procedure Add_Link (Document : in out Filter_Type;
                       Name     : in Unbounded_Wide_Wide_String;
                       Link     : in Unbounded_Wide_Wide_String;
                       Language : in Unbounded_Wide_Wide_String;
                       Title    : in Unbounded_Wide_Wide_String) is
   begin
      Document.Document.Add_Link (Name, Link, Language, Title);
   end Add_Link;

   --  ------------------------------
   --  Add an image.
   --  ------------------------------
   overriding
   procedure Add_Image (Document    : in out Filter_Type;
                        Link        : in Unbounded_Wide_Wide_String;
                        Alt         : in Unbounded_Wide_Wide_String;
                        Position    : in Unbounded_Wide_Wide_String;
                        Description : in Unbounded_Wide_Wide_String) is
   begin
      Document.Document.Add_Image (Link, Alt, Position, Description);
   end Add_Image;

   --  ------------------------------
   --  Add a quote.
   --  ------------------------------
   overriding
   procedure Add_Quote (Document : in out Filter_Type;
                        Quote    : in Unbounded_Wide_Wide_String;
                        Link     : in Unbounded_Wide_Wide_String;
                        Language : in Unbounded_Wide_Wide_String) is
   begin
      Document.Document.Add_Quote (Quote, Link, Language);
   end Add_Quote;

   --  ------------------------------
   --  Add a text block with the given format.
   --  ------------------------------
   overriding
   procedure Add_Text (Document : in out Filter_Type;
                       Text     : in Unbounded_Wide_Wide_String;
                       Format   : in Wiki.Documents.Format_Map) is
   begin
      Document.Document.Add_Text (Text, Format);
   end Add_Text;

   --  ------------------------------
   --  Add a text block that is pre-formatted.
   --  ------------------------------
   overriding
   procedure Add_Preformatted (Document : in out Filter_Type;
                               Text     : in Unbounded_Wide_Wide_String;
                               Format   : in Unbounded_Wide_Wide_String) is
   begin
      Document.Document.Add_Preformatted (Text, Format);
   end Add_Preformatted;

   overriding
   procedure Start_Element (Document   : in out Filter_Type;
                            Name       : in Unbounded_Wide_Wide_String;
                            Attributes : in Wiki.Attributes.Attribute_List_Type) is
   begin
      Document.Document.Start_Element (Name, Attributes);
   end Start_Element;

   overriding
   procedure End_Element (Document : in out Filter_Type;
                          Name     : in Unbounded_Wide_Wide_String) is
   begin
      Document.Document.End_Element (Name);
   end End_Element;

   --  ------------------------------
   --  Finish the document after complete wiki text has been parsed.
   --  ------------------------------
   overriding
   procedure Finish (Document : in out Filter_Type) is
   begin
      Document.Document.Finish;
   end Finish;

end Wiki.Filters;

-----------------------------------------------------------------------
--  wiki-filters -- Wiki filters
--  Copyright (C) 2015, 2016 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

package body Wiki.Filters is

   --  ------------------------------
   --  Add a simple node such as N_LINE_BREAK, N_HORIZONTAL_RULE or N_PARAGRAPH to the document.
   --  ------------------------------
   procedure Add_Node (Filter    : in out Filter_Type;
                       Document  : in out Wiki.Nodes.Document;
                       Kind      : in Wiki.Nodes.Simple_Node_Kind) is
   begin
      if Filter.Next /= null then
         Filter.Add_Node (Document, Kind);
      else
         Wiki.Nodes.Append (Document, Kind);
      end if;
   end Add_Node;

   --  ------------------------------
   --  Add a text content with the given format to the document.
   --  ------------------------------
   procedure Add_Text (Filter    : in out Filter_Type;
                       Document  : in out Wiki.Nodes.Document;
                       Text      : in Wiki.Strings.WString;
                       Format    : in Wiki.Nodes.Format_Map) is
   begin
      if Filter.Next /= null then
         Filter.Add_Text (Document, Text, Format);
      else
         Wiki.Nodes.Append (Document, Text, Format);
      end if;
   end Add_Text;

   --  ------------------------------
   --  Add a section header with the given level in the document.
   --  ------------------------------
   procedure Add_Header (Filter    : in out Filter_Type;
                         Document  : in out Wiki.Nodes.Document;
                         Header    : in Wiki.Strings.WString;
                         Level     : in Natural) is
   begin
      if Filter.Next /= null then
         Filter.Add_Header (Document, Header, Level);
      else
         Wiki.Nodes.Append (Document, Header, Level);
      end if;
   end Add_Header;

   --  ------------------------------
   --  Push a HTML node with the given tag to the document.
   --  ------------------------------
   procedure Push_Node (Filter     : in out Filter_Type;
                        Document   : in out Wiki.Nodes.Document;
                        Tag        : in Wiki.Nodes.Html_Tag_Type;
                        Attributes : in out Wiki.Attributes.Attribute_List_Type) is
   begin
      if Filter.Next /= null then
         Filter.Push_Node (Document, Tag, Attributes);
      else
         Wiki.Nodes.Append (Document, Tag, Attributes);
      end if;
   end Push_Node;

   --  ------------------------------
   --  Pop a HTML node with the given tag.
   --  ------------------------------
   procedure Pop_Node (Filter   : in out Filter_Type;
                       Document : in out Wiki.Nodes.Document;
                       Tag     : in Wiki.Nodes.Html_Tag_Type) is
   begin
      if Filter.Next /= null then
         Filter.Pop_Node (Document, Tag);
      else
         Wiki.Nodes.Append (Document, Tag);
      end if;
   end Pop_Node;

   --  ------------------------------
   --  Add a blockquote (<blockquote>).  The level indicates the blockquote nested level.
   --  The blockquote must be closed at the next header.
   --  ------------------------------
   overriding
   procedure Add_Blockquote (Document : in out Filter_Type;
                             Level    : in Natural) is
   begin
      Document.Document.Add_Blockquote (Level);
   end Add_Blockquote;

   --  ------------------------------
   --  Add a list item (<li>).  Close the previous paragraph and list item if any.
   --  The list item will be closed at the next list item, next paragraph or next header.
   --  ------------------------------
   overriding
   procedure Add_List_Item (Document : in out Filter_Type;
                            Level    : in Positive;
                            Ordered  : in Boolean) is
   begin
      Document.Document.Add_List_Item (Level, Ordered);
   end Add_List_Item;

   --  ------------------------------
   --  Add a link.
   --  ------------------------------
   overriding
   procedure Add_Link (Document : in out Filter_Type;
                       Name     : in Unbounded_Wide_Wide_String;
                       Link     : in Unbounded_Wide_Wide_String;
                       Language : in Unbounded_Wide_Wide_String;
                       Title    : in Unbounded_Wide_Wide_String) is
   begin
      Document.Document.Add_Link (Name, Link, Language, Title);
   end Add_Link;

   --  ------------------------------
   --  Add an image.
   --  ------------------------------
   overriding
   procedure Add_Image (Document    : in out Filter_Type;
                        Link        : in Unbounded_Wide_Wide_String;
                        Alt         : in Unbounded_Wide_Wide_String;
                        Position    : in Unbounded_Wide_Wide_String;
                        Description : in Unbounded_Wide_Wide_String) is
   begin
      Document.Document.Add_Image (Link, Alt, Position, Description);
   end Add_Image;

   --  ------------------------------
   --  Add a quote.
   --  ------------------------------
   overriding
   procedure Add_Quote (Document : in out Filter_Type;
                        Quote    : in Unbounded_Wide_Wide_String;
                        Link     : in Unbounded_Wide_Wide_String;
                        Language : in Unbounded_Wide_Wide_String) is
   begin
      Document.Document.Add_Quote (Quote, Link, Language);
   end Add_Quote;

   --  ------------------------------
   --  Add a text block that is pre-formatted.
   --  ------------------------------
   overriding
   procedure Add_Preformatted (Document : in out Filter_Type;
                               Text     : in Unbounded_Wide_Wide_String;
                               Format   : in Unbounded_Wide_Wide_String) is
   begin
      Document.Document.Add_Preformatted (Text, Format);
   end Add_Preformatted;

   --  ------------------------------
   --  Finish the document after complete wiki text has been parsed.
   --  ------------------------------
   overriding
   procedure Finish (Document : in out Filter_Type) is
   begin
      Document.Document.Finish;
   end Finish;

end Wiki.Filters;

Implement the Push_Node and Pop_Node operations


-----------------------------------------------------------------------
--  awa-jobs -- AWA Jobs
--  Copyright (C) 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Serialize.Tools;
with Util.Log.Loggers;

with Ada.Tags;
with Ada.Calendar;
with Ada.Unchecked_Deallocation;

with ADO.Sessions.Entities;

with AWA.Users.Models;
with AWA.Events.Models;
with AWA.Services.Contexts;
with AWA.Jobs.Modules;
with AWA.Applications;
with AWA.Events.Services;
with AWA.Modules;
package body AWA.Jobs.Services is

   package ASC renames AWA.Services.Contexts;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Jobs.Services");

   --  ------------------------------
   --  Set the job parameter identified by the Name to the value given in Value.
   --  ------------------------------
   procedure Set_Parameter (Job   : in out Abstract_Job_Type;
                            Name  : in String;
                            Value : in String) is
   begin
      Job.Set_Parameter (Name, Util.Beans.Objects.To_Object (Value));
   end Set_Parameter;

   --  ------------------------------
   --  Set the job parameter identified by the Name to the value given in Value.
   --  ------------------------------
   procedure Set_Parameter (Job   : in out Abstract_Job_Type;
                            Name  : in String;
                            Value : in Integer) is
   begin
      Job.Set_Parameter (Name, Util.Beans.Objects.To_Object (Value));
   end Set_Parameter;

   --  ------------------------------
   --  Set the job parameter identified by the Name to the value given in Value.
   --  The value object can hold any kind of basic value type (integer, enum, date, strings).
   --  If the value represents a bean, the <tt>Invalid_Value</tt> exception is raised.
   --  ------------------------------
   procedure Set_Parameter (Job   : in out Abstract_Job_Type;
                            Name  : in String;
                            Value : in Util.Beans.Objects.Object) is
   begin
      Job.Props.Include (Name, Value);
      Job.Props_Modified := True;
   end Set_Parameter;

   --  ------------------------------
   --  Get the job parameter identified by the Name and convert the value into a string.
   --  ------------------------------
   function Get_Parameter (Job  : in Abstract_Job_Type;
                           Name : in String) return String is
      Value : constant Util.Beans.Objects.Object := Job.Get_Parameter (Name);
   begin
      return Util.Beans.Objects.To_String (Value);
   end Get_Parameter;

   --  ------------------------------
   --  Get the job parameter identified by the Name and convert the value as an integer.
   --  If the parameter is not defined, return the default value passed in Default.
   --  ------------------------------
   function Get_Parameter (Job     : in Abstract_Job_Type;
                           Name    : in String;
                           Default : in Integer) return Integer is
      Pos : constant Util.Beans.Objects.Maps.Cursor := Job.Props.Find (Name);
   begin
      if Util.Beans.Objects.Maps.Has_Element (Pos) then
         declare
            Value : constant Util.Beans.Objects.Object := Util.Beans.Objects.Maps.Element (Pos);
         begin
            if Util.Beans.Objects.Is_Null (Value) then
               return Default;
            else
               return Util.Beans.Objects.To_Integer (Value);
            end if;
         end;
      else
         return Default;
      end if;
   end Get_Parameter;

   --  ------------------------------
   --  Get the job parameter identified by the Name and return it as a typed object.
   --  ------------------------------
   function Get_Parameter (Job  : in Abstract_Job_Type;
                           Name : in String) return Util.Beans.Objects.Object is
   begin
      return Job.Props.Element (Name);
   end Get_Parameter;

   --  ------------------------------
   --  Get the job status.
   --  ------------------------------
   function Get_Status (Job : in Abstract_Job_Type) return AWA.Jobs.Models.Job_Status_Type is
   begin
      return Job.Job.Get_Status;
   end Get_Status;

   --  ------------------------------
   --  Set the job status.
   --  When the job is terminated, it is closed and the job parameters or results cannot be
   --  changed.
   --  ------------------------------
   procedure Set_Status (Job    : in out Abstract_Job_Type;
                         Status : in AWA.Jobs.Models.Job_Status_Type) is
   begin
      case Job.Job.Get_Status is
         when AWA.Jobs.Models.CANCELED | Models.FAILED | Models.TERMINATED =>
            raise Closed_Error;

         when Models.SCHEDULED | Models.RUNNING =>
            Job.Job.Set_Status (Status);

      end case;
   end Set_Status;

   --  ------------------------------
   --  Save the job information in the database.  Use the database session defined by DB
   --  to save the job.
   --  ------------------------------
   procedure Save (Job : in out Abstract_Job_Type;
                   DB  : in out ADO.Sessions.Master_Session'Class) is
   begin
      if Job.Results_Modified then
         Job.Job.Set_Results (Util.Serialize.Tools.To_JSON (Job.Results));
         Job.Results_Modified := False;
      end if;
      Job.Job.Save (DB);
   end Save;

   --  Schedule the job.
   procedure Schedule (Job        : in out Abstract_Job_Type;
                       Definition : in Job_Factory'Class) is

      procedure Set_Event (Manager : in out AWA.Events.Services.Event_Manager);

      Ctx : constant ASC.Service_Context_Access := ASC.Current;
      DB   : ADO.Sessions.Master_Session := ASC.Get_Master_Session (Ctx);
      Msg  : AWA.Events.Models.Message_Ref;
      User : constant AWA.Users.Models.User_Ref := Ctx.Get_User;
      Sess : constant AWA.Users.Models.Session_Ref := Ctx.Get_User_Session;
      App  : constant AWA.Applications.Application_Access := Ctx.Get_Application;

      procedure Set_Event (Manager : in out AWA.Events.Services.Event_Manager) is
      begin
         Manager.Set_Message_Type (Msg, Job_Create_Event.Kind);
         Manager.Set_Event_Queue (Msg, "job-queue");
      end Set_Event;

   begin
      if Job.Job.Is_Inserted then
         Log.Error ("Job is already scheduled");
         raise Schedule_Error with "The job is already scheduled.";
      end if;
      AWA.Jobs.Modules.Create_Event (Msg);
      Job.Job.Set_Create_Date (Msg.Get_Create_Date);

      DB.Begin_Transaction;
      Job.Job.Set_Name (Definition.Get_Name);
      Job.Job.Set_User (User);
      Job.Job.Set_Session (Sess);
      Job.Save (DB);

      --  Create the event
      Msg.Set_Parameters (Util.Serialize.Tools.To_JSON (Job.Props));
      App.Do_Event_Manager (Process => Set_Event'Access);
      Msg.Set_User (User);
      Msg.Set_Session (Sess);
      Msg.Set_Entity_Id (Job.Job.Get_Id);
      Msg.Set_Entity_Type (ADO.Sessions.Entities.Find_Entity_Type (Session => DB,
                                                                   Object  => Job.Job.Get_Key));
      Msg.Save (DB);

      Job.Job.Set_Event (Msg);
      Job.Job.Save (DB);
      DB.Commit;
   end Schedule;

   --  ------------------------------
   --  Execute the job and save the job information in the database.
   --  ------------------------------
   procedure Execute (Job : in out Abstract_Job_Type'Class;
                      DB  : in out ADO.Sessions.Master_Session'Class) is
      use type AWA.Jobs.Models.Job_Status_Type;
   begin
      --  Execute the job with an exception guard.
      begin
         Job.Execute;

      exception
         when E : others =>
            Log.Error ("Exception when executing job {0}", Job.Job.Get_Name);
            Log.Error ("Exception: {0}", E, True);
            Job.Job.Set_Status (Models.FAILED);
      end;

      --  If the job did not set a completion status, mark it as terminated.
      if Job.Job.Get_Status = Models.SCHEDULED or Job.Job.Get_Status = Models.RUNNING then
         Job.Job.Set_Status (Models.TERMINATED);
      end if;

      --  And save the job.
      DB.Begin_Transaction;
      Job.Job.Set_Finish_Date (ADO.Nullable_Time '(Is_Null => True, Value => Ada.Calendar.Clock));
      Job.Save (DB);
      DB.Commit;
   end Execute;

   --  ------------------------------
   --  Execute the job associated with the given event.
   --  ------------------------------
   procedure Execute (Event : in AWA.Events.Module_Event'Class) is
      use AWA.Jobs.Modules;
      use type AWA.Modules.Module_Access;

      procedure Free is
         new Ada.Unchecked_Deallocation (Object => Abstract_Job_Type'Class,
                                         Name   => Abstract_Job_Access);

      Ctx    : constant ASC.Service_Context_Access := ASC.Current;
      App    : constant AWA.Applications.Application_Access := Ctx.Get_Application;
      Module : constant AWA.Modules.Module_Access := App.Find_Module (AWA.Jobs.Modules.NAME);
      DB     : ADO.Sessions.Master_Session := ASC.Get_Master_Session (Ctx);
      Job    : AWA.Jobs.Models.Job_Ref;
   begin
      if Module = null then
         Log.Warn ("There is no Job module to execute a job");
         raise Execute_Error;
      end if;
      if not (Module.all in AWA.Jobs.Modules.Job_Module'Class) then
         Log.Warn ("The 'job' module is not a valid module for job execution");
         raise Execute_Error;
      end if;

      DB.Begin_Transaction;
      Job.Load (Session => DB,
                Id      => Event.Get_Entity_Identifier);
      Job.Set_Start_Date (ADO.Nullable_Time '(Is_Null => False, Value => Ada.Calendar.Clock));
      Job.Set_Status (AWA.Jobs.Models.RUNNING);
      Job.Save (Session => DB);
      DB.Commit;

      declare
         Name : constant String := Job.Get_Name;
      begin
         Log.Info ("Restoring job '{0}'", Name);
         declare
            Plugin  : constant Job_Module_Access := Job_Module'Class (Module.all)'Access;
            Factory : constant Job_Factory_Access := Plugin.Find_Factory (Name);
            Work    : AWA.Jobs.Services.Abstract_Job_Access := null;
         begin
            if Factory /= null then
               Work := Factory.Create;
               Work.Job := Job;
               Work.Execute (DB);
               Free (Work);
            else
               Log.Error ("There is no factory to execute job '{0}'", Name);
               Job.Set_Status (AWA.Jobs.Models.FAILED);
               DB.Begin_Transaction;
               Job.Save (Session => DB);
               DB.Commit;
            end if;
         end;
      end;
   end Execute;

   function Get_Name (Factory : in Job_Factory'Class) return String is
   begin
      return Ada.Tags.Expanded_Name (Factory'Tag);
   end Get_Name;

   procedure Set_Work (Job  : in out Job_Type;
                       Work : in Work_Factory'Class) is
   begin
      Job.Work := Work.Work;
      Job.Job.Set_Name (Work.Get_Name);
   end Set_Work;

   procedure Execute (Job : in out Job_Type) is
   begin
      Job.Work (Job);
   end Execute;

   overriding
   function Create (Factory : in Work_Factory) return Abstract_Job_Access is
   begin
      return new Job_Type '(Ada.Finalization.Limited_Controlled with
                              Work => Factory.Work,
                              others => <>);
   end Create;

   --  ------------------------------
   --  Job Declaration
   --  ------------------------------
   --  The <tt>Definition</tt> package must be instantiated with a given job type to
   --  register the new job definition.
   package body Definition is

      function Create (Factory : in Job_Type_Factory) return Abstract_Job_Access is
         pragma Unreferenced (Factory);
      begin
         return new T;
      end Create;

   end Definition;

end AWA.Jobs.Services;

-----------------------------------------------------------------------
--  awa-jobs -- AWA Jobs
--  Copyright (C) 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Serialize.Tools;
with Util.Log.Loggers;

with Ada.Tags;
with Ada.Calendar;
with Ada.Unchecked_Deallocation;

with ADO.Sessions.Entities;

with AWA.Users.Models;
with AWA.Events.Models;
with AWA.Services.Contexts;
with AWA.Jobs.Modules;
with AWA.Applications;
with AWA.Events.Services;
with AWA.Modules;
package body AWA.Jobs.Services is

   package ASC renames AWA.Services.Contexts;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Jobs.Services");

   --  ------------------------------
   --  Set the job parameter identified by the Name to the value given in Value.
   --  ------------------------------
   procedure Set_Parameter (Job   : in out Abstract_Job_Type;
                            Name  : in String;
                            Value : in String) is
   begin
      Job.Set_Parameter (Name, Util.Beans.Objects.To_Object (Value));
   end Set_Parameter;

   --  ------------------------------
   --  Set the job parameter identified by the Name to the value given in Value.
   --  ------------------------------
   procedure Set_Parameter (Job   : in out Abstract_Job_Type;
                            Name  : in String;
                            Value : in Integer) is
   begin
      Job.Set_Parameter (Name, Util.Beans.Objects.To_Object (Value));
   end Set_Parameter;

   --  ------------------------------
   --  Set the job parameter identified by the Name to the value given in Value.
   --  The value object can hold any kind of basic value type (integer, enum, date, strings).
   --  If the value represents a bean, the <tt>Invalid_Value</tt> exception is raised.
   --  ------------------------------
   procedure Set_Parameter (Job   : in out Abstract_Job_Type;
                            Name  : in String;
                            Value : in Util.Beans.Objects.Object) is
   begin
      Job.Props.Include (Name, Value);
      Job.Props_Modified := True;
   end Set_Parameter;

   --  ------------------------------
   --  Get the job parameter identified by the Name and convert the value into a string.
   --  ------------------------------
   function Get_Parameter (Job  : in Abstract_Job_Type;
                           Name : in String) return String is
      Value : constant Util.Beans.Objects.Object := Job.Get_Parameter (Name);
   begin
      return Util.Beans.Objects.To_String (Value);
   end Get_Parameter;

   --  ------------------------------
   --  Get the job parameter identified by the Name and convert the value as an integer.
   --  If the parameter is not defined, return the default value passed in Default.
   --  ------------------------------
   function Get_Parameter (Job     : in Abstract_Job_Type;
                           Name    : in String;
                           Default : in Integer) return Integer is
      Pos : constant Util.Beans.Objects.Maps.Cursor := Job.Props.Find (Name);
   begin
      if Util.Beans.Objects.Maps.Has_Element (Pos) then
         declare
            Value : constant Util.Beans.Objects.Object := Util.Beans.Objects.Maps.Element (Pos);
         begin
            if Util.Beans.Objects.Is_Null (Value) then
               return Default;
            else
               return Util.Beans.Objects.To_Integer (Value);
            end if;
         end;
      else
         return Default;
      end if;
   end Get_Parameter;

   --  ------------------------------
   --  Get the job parameter identified by the Name and return it as a typed object.
   --  ------------------------------
   function Get_Parameter (Job  : in Abstract_Job_Type;
                           Name : in String) return Util.Beans.Objects.Object is
   begin
      return Job.Props.Element (Name);
   end Get_Parameter;

   --  ------------------------------
   --  Get the job status.
   --  ------------------------------
   function Get_Status (Job : in Abstract_Job_Type) return AWA.Jobs.Models.Job_Status_Type is
   begin
      return Job.Job.Get_Status;
   end Get_Status;

   --  ------------------------------
   --  Set the job status.
   --  When the job is terminated, it is closed and the job parameters or results cannot be
   --  changed.
   --  ------------------------------
   procedure Set_Status (Job    : in out Abstract_Job_Type;
                         Status : in AWA.Jobs.Models.Job_Status_Type) is
   begin
      case Job.Job.Get_Status is
         when AWA.Jobs.Models.CANCELED | Models.FAILED | Models.TERMINATED =>
            raise Closed_Error;

         when Models.SCHEDULED | Models.RUNNING =>
            Job.Job.Set_Status (Status);

      end case;
   end Set_Status;

   --  ------------------------------
   --  Save the job information in the database.  Use the database session defined by DB
   --  to save the job.
   --  ------------------------------
   procedure Save (Job : in out Abstract_Job_Type;
                   DB  : in out ADO.Sessions.Master_Session'Class) is
   begin
      if Job.Results_Modified then
         Job.Job.Set_Results (Util.Serialize.Tools.To_JSON (Job.Results));
         Job.Results_Modified := False;
      end if;
      Job.Job.Save (DB);
   end Save;

   --  Schedule the job.
   procedure Schedule (Job        : in out Abstract_Job_Type;
                       Definition : in Job_Factory'Class) is

      procedure Set_Event (Manager : in out AWA.Events.Services.Event_Manager);

      Ctx : constant ASC.Service_Context_Access := ASC.Current;
      DB   : ADO.Sessions.Master_Session := ASC.Get_Master_Session (Ctx);
      Msg  : AWA.Events.Models.Message_Ref;
      User : constant AWA.Users.Models.User_Ref := Ctx.Get_User;
      Sess : constant AWA.Users.Models.Session_Ref := Ctx.Get_User_Session;
      App  : constant AWA.Applications.Application_Access := Ctx.Get_Application;

      procedure Set_Event (Manager : in out AWA.Events.Services.Event_Manager) is
      begin
         Manager.Set_Message_Type (Msg, Job_Create_Event.Kind);
         Manager.Set_Event_Queue (Msg, "job-queue");
      end Set_Event;

   begin
      if Job.Job.Is_Inserted then
         Log.Error ("Job is already scheduled");
         raise Schedule_Error with "The job is already scheduled.";
      end if;
      AWA.Jobs.Modules.Create_Event (Msg);
      Job.Job.Set_Create_Date (Msg.Get_Create_Date);

      DB.Begin_Transaction;
      Job.Job.Set_Name (Definition.Get_Name);
      Job.Job.Set_User (User);
      Job.Job.Set_Session (Sess);
      Job.Save (DB);

      --  Create the event
      Msg.Set_Parameters (Util.Serialize.Tools.To_JSON (Job.Props));
      App.Do_Event_Manager (Process => Set_Event'Access);
      Msg.Set_User (User);
      Msg.Set_Session (Sess);
      Msg.Set_Entity_Id (Job.Job.Get_Id);
      Msg.Set_Entity_Type (ADO.Sessions.Entities.Find_Entity_Type (Session => DB,
                                                                   Object  => Job.Job.Get_Key));
      Msg.Save (DB);

      Job.Job.Set_Event (Msg);
      Job.Job.Save (DB);
      DB.Commit;
   end Schedule;

   --  ------------------------------
   --  Execute the job and save the job information in the database.
   --  ------------------------------
   procedure Execute (Job : in out Abstract_Job_Type'Class;
                      DB  : in out ADO.Sessions.Master_Session'Class) is
      use type AWA.Jobs.Models.Job_Status_Type;
   begin
      --  Execute the job with an exception guard.
      begin
         Job.Execute;

      exception
         when E : others =>
            Log.Error ("Exception when executing job {0}", Job.Job.Get_Name);
            Log.Error ("Exception:", E, True);
            Job.Job.Set_Status (Models.FAILED);
      end;

      --  If the job did not set a completion status, mark it as terminated.
      if Job.Job.Get_Status = Models.SCHEDULED or Job.Job.Get_Status = Models.RUNNING then
         Job.Job.Set_Status (Models.TERMINATED);
      end if;

      --  And save the job.
      DB.Begin_Transaction;
      Job.Job.Set_Finish_Date (ADO.Nullable_Time '(Is_Null => False,
                                                   Value   => Ada.Calendar.Clock));
      Job.Save (DB);
      DB.Commit;
   end Execute;

   --  ------------------------------
   --  Execute the job associated with the given event.
   --  ------------------------------
   procedure Execute (Event : in AWA.Events.Module_Event'Class) is
      use AWA.Jobs.Modules;
      use type AWA.Modules.Module_Access;

      procedure Free is
         new Ada.Unchecked_Deallocation (Object => Abstract_Job_Type'Class,
                                         Name   => Abstract_Job_Access);

      Ctx    : constant ASC.Service_Context_Access := ASC.Current;
      App    : constant AWA.Applications.Application_Access := Ctx.Get_Application;
      Module : constant AWA.Modules.Module_Access := App.Find_Module (AWA.Jobs.Modules.NAME);
      DB     : ADO.Sessions.Master_Session := ASC.Get_Master_Session (Ctx);
      Job    : AWA.Jobs.Models.Job_Ref;
   begin
      if Module = null then
         Log.Warn ("There is no Job module to execute a job");
         raise Execute_Error;
      end if;
      if not (Module.all in AWA.Jobs.Modules.Job_Module'Class) then
         Log.Warn ("The 'job' module is not a valid module for job execution");
         raise Execute_Error;
      end if;

      DB.Begin_Transaction;
      Job.Load (Session => DB,
                Id      => Event.Get_Entity_Identifier);
      Job.Set_Start_Date (ADO.Nullable_Time '(Is_Null => False, Value => Ada.Calendar.Clock));
      Job.Set_Status (AWA.Jobs.Models.RUNNING);
      Job.Save (Session => DB);
      DB.Commit;

      declare
         Name : constant String := Job.Get_Name;
      begin
         Log.Info ("Restoring job '{0}'", Name);
         declare
            Plugin  : constant Job_Module_Access := Job_Module'Class (Module.all)'Access;
            Factory : constant Job_Factory_Access := Plugin.Find_Factory (Name);
            Work    : AWA.Jobs.Services.Abstract_Job_Access := null;
         begin
            if Factory /= null then
               Work := Factory.Create;
               Work.Job := Job;
               Work.Execute (DB);
               Free (Work);
            else
               Log.Error ("There is no factory to execute job '{0}'", Name);
               Job.Set_Status (AWA.Jobs.Models.FAILED);
               Job.Set_Finish_Date (ADO.Nullable_Time '(Is_Null => False,
                                                        Value   => Ada.Calendar.Clock));
               DB.Begin_Transaction;
               Job.Save (Session => DB);
               DB.Commit;
            end if;
         end;
      end;
   end Execute;

   function Get_Name (Factory : in Job_Factory'Class) return String is
   begin
      return Ada.Tags.Expanded_Name (Factory'Tag);
   end Get_Name;

   procedure Set_Work (Job  : in out Job_Type;
                       Work : in Work_Factory'Class) is
   begin
      Job.Work := Work.Work;
      Job.Job.Set_Name (Work.Get_Name);
   end Set_Work;

   procedure Execute (Job : in out Job_Type) is
   begin
      Job.Work (Job);
   end Execute;

   overriding
   function Create (Factory : in Work_Factory) return Abstract_Job_Access is
   begin
      return new Job_Type '(Ada.Finalization.Limited_Controlled with
                              Work => Factory.Work,
                              others => <>);
   end Create;

   --  ------------------------------
   --  Job Declaration
   --  ------------------------------
   --  The <tt>Definition</tt> package must be instantiated with a given job type to
   --  register the new job definition.
   package body Definition is

      function Create (Factory : in Job_Type_Factory) return Abstract_Job_Access is
         pragma Unreferenced (Factory);
      begin
         return new T;
      end Create;

   end Definition;

end AWA.Jobs.Services;

Fix setting the finish date after job execution