-----------------------------------------------------------------------
--  mat-targets-gtkmat - Gtk target management
--  Copyright (C) 2014 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 Glib.Error;
with Gtk.Main;

with MAT.Callbacks;
package body MAT.Targets.Gtkmat is

   --  ------------------------------
   --  Initialize the target instance.
   --  ------------------------------
   overriding
   procedure Initialize (Target : in out Target_Type) is
   begin
      Target.Options.Graphical := True;
   end Initialize;

   --  ------------------------------
   --  Initialize the widgets and create the Gtk gui.
   --  ------------------------------
   procedure Initialize_Widget (Target : in out Target_Type;
                                Widget : out Gtk.Widget.Gtk_Widget) is
      Error   : aliased Glib.Error.GError;
      Result  : Glib.Guint;
   begin
      if Target.Options.Graphical then
         Gtk.Main.Init;
         Gtkada.Builder.Gtk_New (Target.Builder);
         Result := Target.Builder.Add_From_File ("mat.glade", Error'Access);
         MAT.Callbacks.Initialize (Target.Builder);
         Target.Builder.Do_Connect;
         Widget := Gtk.Widget.Gtk_Widget (Target.Builder.Get_Object ("main"));
         Widget.Show_All;
         Target.Gui_Task.Start (Widget);
      else
         Widget := null;
      end if;
   end Initialize_Widget;

   task body Gtk_Loop is
      Main : Gtk.Widget.Gtk_Widget;
   begin
      select
         accept Start (Widget : in Gtk.Widget.Gtk_Widget) do
            Main := Widget;
         end Start;
         Gtk.Main.Main;
      or
         terminate;
      end select;
   end Gtk_Loop;

   --  ------------------------------
   --  Create a process instance to hold and keep track of memory and other information about
   --  the given process ID.
   --  ------------------------------
   overriding
   procedure Create_Process (Target  : in out Target_Type;
                             Pid     : in MAT.Types.Target_Process_Ref;
                             Path    : in Ada.Strings.Unbounded.Unbounded_String;
                             Process : out Target_Process_Type_Access) is
   begin
      MAT.Targets.Target_Type (Target).Create_Process (Pid, Path, Process);
   end Create_Process;

end MAT.Targets.Gtkmat;

-----------------------------------------------------------------------
--  mat-targets-gtkmat - Gtk target management
--  Copyright (C) 2014 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 Glib.Error;
with Gtk.Main;

with MAT.Callbacks;
package body MAT.Targets.Gtkmat is

   --  ------------------------------
   --  Initialize the target instance.
   --  ------------------------------
   overriding
   procedure Initialize (Target : in out Target_Type) is
   begin
      Target.Options.Interactive := False;
      Target.Options.Graphical   := True;
   end Initialize;

   --  ------------------------------
   --  Initialize the widgets and create the Gtk gui.
   --  ------------------------------
   procedure Initialize_Widget (Target : in out Target_Type;
                                Widget : out Gtk.Widget.Gtk_Widget) is
      Error   : aliased Glib.Error.GError;
      Result  : Glib.Guint;
   begin
      if Target.Options.Graphical then
         Gtk.Main.Init;
         Gtkada.Builder.Gtk_New (Target.Builder);
         Result := Target.Builder.Add_From_File ("mat.glade", Error'Access);
         MAT.Callbacks.Initialize (Target.Builder);
         Target.Builder.Do_Connect;
         Widget := Gtk.Widget.Gtk_Widget (Target.Builder.Get_Object ("main"));
      else
         Widget := null;
      end if;
   end Initialize_Widget;

   --  ------------------------------
   --  Enter in the interactive loop reading the commands from the standard input
   --  and executing the commands.
   --  ------------------------------
   overriding
   procedure Interactive (Target : in out Target_Type) is
      Main : Gtk.Widget.Gtk_Widget;
   begin
      if Target.Options.Graphical then
         Main := Gtk.Widget.Gtk_Widget (Target.Builder.Get_Object ("main"));
         Main.Show_All;
      end if;
      if Target.Options.Interactive and Target.Options.Graphical then
         Target.Gui_Task.Start (Target'Unchecked_Access);
      end if;
      if Target.Options.Graphical then
         Gtk.Main.Main;
      else
         MAT.Targets.Target_Type (Target).Interactive;
      end if;
   end Interactive;

   task body Gtk_Loop is
      Main : Target_Type_Access;
   begin
      select
         accept Start (Target : in Target_Type_Access) do
            Main := Target;
         end Start;
         MAT.Targets.Target_Type (Main.all).Interactive;
      or
         terminate;
      end select;
   end Gtk_Loop;

   --  ------------------------------
   --  Create a process instance to hold and keep track of memory and other information about
   --  the given process ID.
   --  ------------------------------
   overriding
   procedure Create_Process (Target  : in out Target_Type;
                             Pid     : in MAT.Types.Target_Process_Ref;
                             Path    : in Ada.Strings.Unbounded.Unbounded_String;
                             Process : out Target_Process_Type_Access) is
   begin
      MAT.Targets.Target_Type (Target).Create_Process (Pid, Path, Process);
   end Create_Process;

end MAT.Targets.Gtkmat;

Change to keep the Gtk thread on the main thread and have a specific task for the interactive mode when both interactive and graphical modes are enabled


-----------------------------------------------------------------------
--  Marshaller -- Marshalling of data in communication buffer
--  Copyright (C) 2014 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 System;
with Ada.Strings.Unbounded;
with MAT.Types;
with MAT.Events;
package MAT.Readers.Marshaller is

   Buffer_Underflow_Error : exception;

   Buffer_Overflow_Error : exception;

   function Get_Raw_Uint32 (Buf : System.Address) return MAT.Types.Uint32;

   --  Get an 8-bit value from the buffer.
   function Get_Uint8 (Buffer : in Buffer_Ptr) return MAT.Types.Uint8;

   --  Get a 16-bit value either from big-endian or little endian.
   function Get_Uint16 (Buffer : in Buffer_Ptr) return MAT.Types.Uint16;

   --  Get a 32-bit value either from big-endian or little endian.
   function Get_Uint32 (Buffer : in Buffer_Ptr) return MAT.Types.Uint32;

   function Get_Uint64 (Buffer : in Buffer_Ptr) return MAT.Types.Uint64;

   --  Extract a string from the buffer.  The string starts with a byte that
   --  indicates the string length.
   function Get_String (Buffer : in Buffer_Ptr) return String;

   --  Extract a string from the buffer.  The string starts with a byte that
   --  indicates the string length.
   function Get_String (Msg : in Buffer_Ptr) return Ada.Strings.Unbounded.Unbounded_String;

   --  procedure Put_Uint8 (Buffer : in Buffer_Ptr; Data : in Uint8);

   --  procedure Put_Uint16 (Buffer : in Buffer_Ptr; Data : in Uint16);

   --  procedure Put_Uint32 (Buffer : in Buffer_Ptr; Data : in Uint32);
   generic
      type Target_Type is mod <>;
   function Get_Target_Value (Msg  : in Buffer_Ptr;
                              Kind : in MAT.Events.Attribute_Type) return Target_Type;
--
--     function Get_Target_Size is new Get_Target_Value (MAT.Types.Target_Size);
--
--     function Get_Target_Addr is new Get_Target_Value (MAT.Types.Target_Addr);
--
--     function Get_Target_Tick is new Get_Target_Value (MAT.Types.Target_Tick_Ref);
--
--     function Get_Target_Thread is new Get_Target_Value (MAT.Types.Target_Thread_Ref);

   function Get_Target_Size (Msg  : in Buffer_Ptr;
                             Kind : in MAT.Events.Attribute_Type) return MAT.Types.Target_Size;

   function Get_Target_Addr (Msg  : in Buffer_Ptr;
                             Kind : in MAT.Events.Attribute_Type) return MAT.Types.Target_Addr;

   function Get_Target_Uint32 (Msg  : in Buffer_Ptr;
                               Kind : in MAT.Events.Attribute_Type) return MAT.Types.Uint32;

   --  Skip the given number of bytes from the message.
   procedure Skip (Buffer : in Buffer_Ptr;
                   Size   : in Natural);

end MAT.Readers.Marshaller;

-----------------------------------------------------------------------
--  Marshaller -- Marshalling of data in communication buffer
--  Copyright (C) 2014 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 System;
with Ada.Strings.Unbounded;
with MAT.Types;
with MAT.Events;
package MAT.Readers.Marshaller is

   Buffer_Underflow_Error : exception;

   Buffer_Overflow_Error : exception;

   function Get_Raw_Uint32 (Buf : System.Address) return MAT.Types.Uint32;

   --  Get an 8-bit value from the buffer.
   function Get_Uint8 (Buffer : in Buffer_Ptr) return MAT.Types.Uint8;

   --  Get a 16-bit value either from big-endian or little endian.
   function Get_Uint16 (Buffer : in Buffer_Ptr) return MAT.Types.Uint16;

   --  Get a 32-bit value either from big-endian or little endian.
   function Get_Uint32 (Buffer : in Buffer_Ptr) return MAT.Types.Uint32;

   --  Get a 64-bit value either from big-endian or little endian.
   function Get_Uint64 (Buffer : in Buffer_Ptr) return MAT.Types.Uint64;

   --  Extract a string from the buffer.  The string starts with a byte that
   --  indicates the string length.
   function Get_String (Buffer : in Buffer_Ptr) return String;

   --  Extract a string from the buffer.  The string starts with a byte that
   --  indicates the string length.
   function Get_String (Msg : in Buffer_Ptr) return Ada.Strings.Unbounded.Unbounded_String;

   --  procedure Put_Uint8 (Buffer : in Buffer_Ptr; Data : in Uint8);

   --  procedure Put_Uint16 (Buffer : in Buffer_Ptr; Data : in Uint16);

   --  procedure Put_Uint32 (Buffer : in Buffer_Ptr; Data : in Uint32);
   generic
      type Target_Type is mod <>;
   function Get_Target_Value (Msg  : in Buffer_Ptr;
                              Kind : in MAT.Events.Attribute_Type) return Target_Type;
--
--     function Get_Target_Size is new Get_Target_Value (MAT.Types.Target_Size);
--
--     function Get_Target_Addr is new Get_Target_Value (MAT.Types.Target_Addr);
--
--     function Get_Target_Tick is new Get_Target_Value (MAT.Types.Target_Tick_Ref);
--
--     function Get_Target_Thread is new Get_Target_Value (MAT.Types.Target_Thread_Ref);

   function Get_Target_Size (Msg  : in Buffer_Ptr;
                             Kind : in MAT.Events.Attribute_Type) return MAT.Types.Target_Size;

   function Get_Target_Addr (Msg  : in Buffer_Ptr;
                             Kind : in MAT.Events.Attribute_Type) return MAT.Types.Target_Addr;

   function Get_Target_Uint32 (Msg  : in Buffer_Ptr;
                               Kind : in MAT.Events.Attribute_Type) return MAT.Types.Uint32;

   --  Skip the given number of bytes from the message.
   procedure Skip (Buffer : in Buffer_Ptr;
                   Size   : in Natural);

end MAT.Readers.Marshaller;

Document Get_Uint64

Document Get_Uint64


-----------------------------------------------------------------------
--  security-openid-servlets - Servlets for OpenID 2.0 Authentication
--  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 ASF.Sessions;

with Util.Beans.Objects;
with Util.Beans.Objects.Records;
with Util.Log.Loggers;
package body Security.Openid.Servlets is

   use Util.Log;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Security.Openid.Servlets");

   --  Make a package to store the Association in the session.
   package Association_Bean is new Util.Beans.Objects.Records (Security.Openid.Association);

   subtype Association_Access is Association_Bean.Element_Type_Access;

   --  ------------------------------
   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   --  ------------------------------
   procedure Initialize (Server  : in out Openid_Servlet;
                         Context : in ASF.Servlets.Servlet_Registry'Class) is
   begin
      null;
   end Initialize;

   --  Property name that specifies the OpenID callback URL.
   OPENID_VERIFY_URL      : constant String := "openid.callback_url";

   --  Property name that specifies the realm.
   OPENID_REALM           : constant String := "openid.realm";

   --  Name of the session attribute which holds information about the active authentication.
   OPENID_ASSOC_ATTRIBUTE : constant String := "openid-assoc";

   procedure Initialize (Server  : in Openid_Servlet;
                         Manager : in out Security.Openid.Manager) is
      Ctx          : constant ASF.Servlets.Servlet_Registry_Access := Server.Get_Servlet_Context;
      Callback_URI : constant String := Ctx.Get_Init_Parameter (OPENID_VERIFY_URL);
      Realm        : constant String := Ctx.Get_Init_Parameter (OPENID_REALM);
   begin
      Manager.Initialize (Return_To => Callback_URI,
                          Name      => Realm);
   end Initialize;

   function Get_Provider_URL (Server   : in Request_Auth_Servlet;
                              Request  : in ASF.Requests.Request'Class) return String is
      Ctx  : constant ASF.Servlets.Servlet_Registry_Access := Server.Get_Servlet_Context;
      URI  : constant String := Request.Get_Path_Info;
   begin
      if URI'Length = 0 then
         return "";
      end if;
      Log.Info ("OpenID authentication with {0}", URI);
      return Ctx.Get_Init_Parameter ("openid.provider." & URI (URI'First + 1 .. URI'Last));
   end Get_Provider_URL;

   --  ------------------------------
   --  Proceed to the OpenID authentication with an OpenID provider.
   --  Find the OpenID provider URL and starts the discovery, association phases
   --  during which a private key is obtained from the OpenID provider.
   --  After OpenID discovery and association, the user will be redirected to
   --  the OpenID provider.
   --  ------------------------------
   procedure Do_Get (Server   : in Request_Auth_Servlet;
                     Request  : in out ASF.Requests.Request'Class;
                     Response : in out ASF.Responses.Response'Class) is

      Provider : constant String := Server.Get_Provider_URL (Request);
   begin
      Log.Info ("Request OpenId authentication to {0}", Provider);

      if Provider'Length = 0 then
         Response.Set_Status (ASF.Responses.SC_NOT_FOUND);
         return;
      end if;

      declare
         Mgr   : Security.Openid.Manager;
         OP    : Security.Openid.End_Point;
         Bean  : constant Util.Beans.Objects.Object := Association_Bean.Create;
         Assoc : constant Association_Access := Association_Bean.To_Element_Access (Bean);
      begin
         Server.Initialize (Mgr);

         --  Yadis discovery (get the XRDS file).
         Mgr.Discover (Provider, OP);

         --  Associate to the OpenID provider and get an end-point with a key.
         Mgr.Associate (OP, Assoc.all);

         --  Save the association in the HTTP session and
         --  redirect the user to the OpenID provider.
         declare
            Auth_URL : constant String := Mgr.Get_Authentication_URL (OP, Assoc.all);
            Session  : ASF.Sessions.Session := Request.Get_Session (Create => True);
         begin
            Log.Info ("Redirect to auth URL: {0}", Auth_URL);

            Response.Send_Redirect (Location => Auth_URL);
            Session.Set_Attribute (Name  => OPENID_ASSOC_ATTRIBUTE,
                                   Value => Bean);
         end;
      end;
   end Do_Get;

   --  ------------------------------
   --  Verify the authentication result that was returned by the OpenID provider.
   --  If the authentication succeeded and the signature was correct, sets a
   --  user principals on the session.
   --  ------------------------------
   procedure Do_Get (Server   : in Verify_Auth_Servlet;
                     Request  : in out ASF.Requests.Request'Class;
                     Response : in out ASF.Responses.Response'Class) is

      Session : ASF.Sessions.Session := Request.Get_Session (Create => False);
      Bean    : constant Util.Beans.Objects.Object := Session.Get_Attribute (OPENID_ASSOC_ATTRIBUTE);
      Mgr     : Security.Openid.Manager;
      Assoc   : Association_Access;
      Auth    : Security.Openid.Authentication;
      Ctx     : constant ASF.Servlets.Servlet_Registry_Access := Server.Get_Servlet_Context;
   begin
      Log.Info ("Verify openid authentication");

      --  Cleanup the session and drop the association end point.
      Session.Remove_Attribute (OPENID_ASSOC_ATTRIBUTE);
      if Util.Beans.Objects.Is_Null (Bean) then
         Log.Warn ("Verify openid request without active session");
         Response.Set_Status (ASF.Responses.SC_FORBIDDEN);
         return;
      end if;

      Assoc := Association_Bean.To_Element_Access (Bean);
      Server.Initialize (Mgr);

      --  Verify that what we receive through the callback matches the association key.
      Mgr.Verify (Assoc.all, Request, Auth);
      if Get_Status (Auth) /= AUTHENTICATED then
         Log.Info ("Authentication has failed");
         Response.Set_Status (ASF.Responses.SC_FORBIDDEN);
         return;
      end if;

      Log.Info ("Authentication succeeded for {0}", Get_Email (Auth));

      --  Get a user principal and set it on the session.
      declare
         User : ASF.Principals.Principal_Access;
         URL  : constant String := Ctx.Get_Init_Parameter ("openid.success_url");
      begin
         Verify_Auth_Servlet'Class (Server).Create_Principal (Auth, User);
         Session.Set_Principal (User);

         Log.Info ("Redirect user to success URL: {0}", URL);
         Response.Send_Redirect (Location => URL);
      end;
   end Do_Get;

   --  ------------------------------
   --  Create a principal object that correspond to the authenticated user identified
   --  by the <b>Auth</b> information.  The principal will be attached to the session
   --  and will be destroyed when the session is closed.
   --  ------------------------------
   procedure Create_Principal (Server : in Verify_Auth_Servlet;
                               Auth   : in Authentication;
                               Result : out ASF.Principals.Principal_Access) is
      pragma Unreferenced (Server);

      P : constant Principal_Access := new Principal;
   begin
      P.Auth := Auth;
      Result := P.all'Access;
   end Create_Principal;

end Security.Openid.Servlets;

-----------------------------------------------------------------------
--  security-openid-servlets - Servlets for OpenID 2.0 Authentication
--  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 ASF.Sessions;

with Util.Beans.Objects;
with Util.Beans.Objects.Records;
with Util.Log.Loggers;
package body Security.Openid.Servlets is

   use Util.Log;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Security.Openid.Servlets");

   --  Make a package to store the Association in the session.
   package Association_Bean is new Util.Beans.Objects.Records (Security.Openid.Association);

   subtype Association_Access is Association_Bean.Element_Type_Access;

   --  ------------------------------
   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   --  ------------------------------
   procedure Initialize (Server  : in out Openid_Servlet;
                         Context : in ASF.Servlets.Servlet_Registry'Class) is
   begin
      null;
   end Initialize;

   --  Property name that specifies the OpenID callback URL.
   OPENID_VERIFY_URL      : constant String := "openid.callback_url";

   --  Property name that specifies the realm.
   OPENID_REALM           : constant String := "openid.realm";

   --  Name of the session attribute which holds information about the active authentication.
   OPENID_ASSOC_ATTRIBUTE : constant String := "openid-assoc";

   procedure Initialize (Server  : in Openid_Servlet;
                         Manager : in out Security.Openid.Manager) is
      Ctx          : constant ASF.Servlets.Servlet_Registry_Access := Server.Get_Servlet_Context;
      Callback_URI : constant String := Ctx.Get_Init_Parameter (OPENID_VERIFY_URL);
      Realm        : constant String := Ctx.Get_Init_Parameter (OPENID_REALM);
   begin
      Manager.Initialize (Return_To => Callback_URI,
                          Name      => Realm);
   end Initialize;

   function Get_Provider_URL (Server   : in Request_Auth_Servlet;
                              Request  : in ASF.Requests.Request'Class) return String is
      Ctx  : constant ASF.Servlets.Servlet_Registry_Access := Server.Get_Servlet_Context;
      URI  : constant String := Request.Get_Path_Info;
   begin
      if URI'Length = 0 then
         return "";
      end if;
      Log.Info ("OpenID authentication with {0}", URI);
      return Ctx.Get_Init_Parameter ("openid.provider." & URI (URI'First + 1 .. URI'Last));
   end Get_Provider_URL;

   --  ------------------------------
   --  Proceed to the OpenID authentication with an OpenID provider.
   --  Find the OpenID provider URL and starts the discovery, association phases
   --  during which a private key is obtained from the OpenID provider.
   --  After OpenID discovery and association, the user will be redirected to
   --  the OpenID provider.
   --  ------------------------------
   procedure Do_Get (Server   : in Request_Auth_Servlet;
                     Request  : in out ASF.Requests.Request'Class;
                     Response : in out ASF.Responses.Response'Class) is

      Provider : constant String := Server.Get_Provider_URL (Request);
   begin
      Log.Info ("Request OpenId authentication to {0}", Provider);

      if Provider'Length = 0 then
         Response.Set_Status (ASF.Responses.SC_NOT_FOUND);
         return;
      end if;

      declare
         Mgr   : Security.Openid.Manager;
         OP    : Security.Openid.End_Point;
         Bean  : constant Util.Beans.Objects.Object := Association_Bean.Create;
         Assoc : constant Association_Access := Association_Bean.To_Element_Access (Bean);
      begin
         Server.Initialize (Mgr);

         --  Yadis discovery (get the XRDS file).
         Mgr.Discover (Provider, OP);

         --  Associate to the OpenID provider and get an end-point with a key.
         Mgr.Associate (OP, Assoc.all);

         --  Save the association in the HTTP session and
         --  redirect the user to the OpenID provider.
         declare
            Auth_URL : constant String := Mgr.Get_Authentication_URL (OP, Assoc.all);
            Session  : ASF.Sessions.Session := Request.Get_Session (Create => True);
         begin
            Log.Info ("Redirect to auth URL: {0}", Auth_URL);

            Response.Send_Redirect (Location => Auth_URL);
            Session.Set_Attribute (Name  => OPENID_ASSOC_ATTRIBUTE,
                                   Value => Bean);
         end;
      end;
   end Do_Get;

   --  ------------------------------
   --  Verify the authentication result that was returned by the OpenID provider.
   --  If the authentication succeeded and the signature was correct, sets a
   --  user principals on the session.
   --  ------------------------------
   procedure Do_Get (Server   : in Verify_Auth_Servlet;
                     Request  : in out ASF.Requests.Request'Class;
                     Response : in out ASF.Responses.Response'Class) is

      Session : ASF.Sessions.Session := Request.Get_Session (Create => False);
      Bean    : Util.Beans.Objects.Object;
      Mgr     : Security.Openid.Manager;
      Assoc   : Association_Access;
      Auth    : Security.Openid.Authentication;
      Ctx     : constant ASF.Servlets.Servlet_Registry_Access := Server.Get_Servlet_Context;
   begin
      Log.Info ("Verify openid authentication");

      if not Session.Is_Valid then
         Log.Warn ("Session has expired during OpenID authentication process");
         Response.Set_Status (ASF.Responses.SC_FORBIDDEN);
         return;
      end if;

      Bean := Session.Get_Attribute (OPENID_ASSOC_ATTRIBUTE);

      --  Cleanup the session and drop the association end point.
      Session.Remove_Attribute (OPENID_ASSOC_ATTRIBUTE);
      if Util.Beans.Objects.Is_Null (Bean) then
         Log.Warn ("Verify openid request without active session");
         Response.Set_Status (ASF.Responses.SC_FORBIDDEN);
         return;
      end if;

      Assoc := Association_Bean.To_Element_Access (Bean);
      Server.Initialize (Mgr);

      --  Verify that what we receive through the callback matches the association key.
      Mgr.Verify (Assoc.all, Request, Auth);
      if Get_Status (Auth) /= AUTHENTICATED then
         Log.Info ("Authentication has failed");
         Response.Set_Status (ASF.Responses.SC_FORBIDDEN);
         return;
      end if;

      Log.Info ("Authentication succeeded for {0}", Get_Email (Auth));

      --  Get a user principal and set it on the session.
      declare
         User : ASF.Principals.Principal_Access;
         URL  : constant String := Ctx.Get_Init_Parameter ("openid.success_url");
      begin
         Verify_Auth_Servlet'Class (Server).Create_Principal (Auth, User);
         Session.Set_Principal (User);

         Log.Info ("Redirect user to success URL: {0}", URL);
         Response.Send_Redirect (Location => URL);
      end;
   end Do_Get;

   --  ------------------------------
   --  Create a principal object that correspond to the authenticated user identified
   --  by the <b>Auth</b> information.  The principal will be attached to the session
   --  and will be destroyed when the session is closed.
   --  ------------------------------
   procedure Create_Principal (Server : in Verify_Auth_Servlet;
                               Auth   : in Authentication;
                               Result : out ASF.Principals.Principal_Access) is
      pragma Unreferenced (Server);

      P : constant Principal_Access := new Principal;
   begin
      P.Auth := Auth;
      Result := P.all'Access;
   end Create_Principal;

end Security.Openid.Servlets;

Verify that the session is valid before getting the association attribute


-----------------------------------------------------------------------
--  util-strings -- Various String Utility
--  Copyright (C) 2001, 2002, 2003, 2009, 2010, 2011, 2012, 2017 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.Fixed;
with Ada.Strings.Hash;
with Ada.Unchecked_Deallocation;
package body Util.Strings is

   --  ------------------------------
   --  Compute the hash value of the string.
   --  ------------------------------
   function Hash (Key : Name_Access) return Ada.Containers.Hash_Type is
   begin
      return Ada.Strings.Hash (Key.all);
   end Hash;

   --  ------------------------------
   --  Returns true if left and right strings are equivalent.
   --  ------------------------------
   function Equivalent_Keys (Left, Right : Name_Access) return Boolean is
   begin
      if Left = null or Right = null then
         return False;
      end if;
      return Left.all = Right.all;
   end Equivalent_Keys;

   --  ------------------------------
   --  Returns Integer'Image (Value) with the possible space stripped.
   --  ------------------------------
   function Image (Value : in Integer) return String is
      S : constant String := Integer'Image (Value);
   begin
      if S (S'First) = ' ' then
         return S (S'First + 1 .. S'Last);
      else
         return S;
      end if;
   end Image;

   --  ------------------------------
   --  Returns Integer'Image (Value) with the possible space stripped.
   --  ------------------------------
   function Image (Value : in Long_Long_Integer) return String is
      S : constant String := Long_Long_Integer'Image (Value);
   begin
      if S (S'First) = ' ' then
         return S (S'First + 1 .. S'Last);
      else
         return S;
      end if;
   end Image;

   use Util.Concurrent.Counters;

   --  ------------------------------
   --  Create a string reference from a string.
   --  ------------------------------
   function To_String_Ref (S : in String) return String_Ref is
      Str : constant String_Record_Access
        := new String_Record '(Len => S'Length, Str => S, Counter => ONE);
   begin
      return String_Ref '(Ada.Finalization.Controlled with
                          Str => Str);
   end To_String_Ref;

   --  ------------------------------
   --  Create a string reference from an unbounded string.
   --  ------------------------------
   function To_String_Ref (S : in Ada.Strings.Unbounded.Unbounded_String) return String_Ref is
      use Ada.Strings.Unbounded;

      Len : constant Natural := Length (S);
      Str : constant String_Record_Access
        := new String_Record '(Len => Len, Str => To_String (S), Counter => ONE);
   begin
      return String_Ref '(Ada.Finalization.Controlled with
                          Str => Str);
   end To_String_Ref;

   --  ------------------------------
   --  Get the string
   --  ------------------------------
   function To_String (S : in String_Ref) return String is
   begin
      if S.Str = null then
         return "";
      else
         return S.Str.Str;
      end if;
   end To_String;

   --  ------------------------------
   --  Get the string as an unbounded string
   --  ------------------------------
   function To_Unbounded_String (S : in String_Ref)
                                 return Ada.Strings.Unbounded.Unbounded_String is
   begin
      if S.Str = null then
         return Ada.Strings.Unbounded.Null_Unbounded_String;
      else
         return Ada.Strings.Unbounded.To_Unbounded_String (S.Str.Str);
      end if;
   end To_Unbounded_String;

   --  ------------------------------
   --  Compute the hash value of the string reference.
   --  ------------------------------
   function Hash (Key : String_Ref) return Ada.Containers.Hash_Type is
   begin
      if Key.Str = null then
         return 0;
      else
         return Ada.Strings.Hash (Key.Str.Str);
      end if;
   end Hash;

   --  ------------------------------
   --  Returns true if left and right string references are equivalent.
   --  ------------------------------
   function Equivalent_Keys (Left, Right : String_Ref) return Boolean is
   begin
      if Left.Str = Right.Str then
         return True;
      elsif Left.Str = null or Right.Str = null then
         return False;
      else
         return Left.Str.Str = Right.Str.Str;
      end if;
   end Equivalent_Keys;

   function "=" (Left  : in String_Ref;
                 Right : in String) return Boolean is
   begin
      if Left.Str = null then
         return False;
      else
         return Left.Str.Str = Right;
      end if;
   end "=";

   function "=" (Left  : in String_Ref;
                 Right : in Ada.Strings.Unbounded.Unbounded_String) return Boolean is
      use Ada.Strings.Unbounded;
   begin
      if Left.Str = null then
         return Right = Null_Unbounded_String;
      else
         return Right = Left.Str.Str;
      end if;
   end "=";

   --  ------------------------------
   --  Returns the string length.
   --  ------------------------------
   function Length (S : in String_Ref) return Natural is
   begin
      if S.Str = null then
         return 0;
      else
         return S.Str.Len;
      end if;
   end Length;

   --  ------------------------------
   --  Increment the reference counter.
   --  ------------------------------
   overriding
   procedure Adjust (Object : in out String_Ref) is
   begin
      if Object.Str /= null then
         Util.Concurrent.Counters.Increment (Object.Str.Counter);
      end if;
   end Adjust;

   --  ------------------------------
   --  Decrement the reference counter and free the allocated string.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out String_Ref) is

      procedure Free is
        new Ada.Unchecked_Deallocation (String_Record, String_Record_Access);

      Is_Zero : Boolean;
   begin
      if Object.Str /= null then
         Util.Concurrent.Counters.Decrement (Object.Str.Counter, Is_Zero);
         if Is_Zero then
            Free (Object.Str);
         else
            Object.Str := null;
         end if;
      end if;
   end Finalize;

   --  ------------------------------
   --  Search for the first occurrence of the character in the string
   --  after the from index.  This implementation is 3-times faster than
   --  the Ada.Strings.Fixed version.
   --  Returns the index of the first occurrence or 0.
   --  ------------------------------
   function Index (Source : in String;
                   Char   : in Character;
                   From   : in Natural := 0) return Natural is
      Pos : Natural := From;
   begin
      if Pos < Source'First then
         Pos := Source'First;
      end if;
      for I in Pos .. Source'Last loop
         if Source (I) = Char then
            return I;
         end if;
      end loop;
      return 0;
   end Index;

   --  ------------------------------
   --  Search for the first occurrence of the pattern in the string.
   --  ------------------------------
   function Index (Source  : in String;
                   Pattern : in String;
                   From    : in Positive;
                   Going   : in Ada.Strings.Direction := Ada.Strings.Forward) return Natural is
   begin
      return Ada.Strings.Fixed.Index (Source, Pattern, From, Going);
   end Index;

   --  ------------------------------
   --  Returns True if the source string starts with the given prefix.
   --  ------------------------------
   function Starts_With (Source  : in String;
                         Prefix  : in String) return Boolean is
   begin
      return Source'Length >= Prefix'Length
        and then Source (Source'First .. Source'First + Prefix'Length - 1) = Prefix;
   end Starts_With;

   --  ------------------------------
   --  Returns True if the source string ends with the given suffix.
   --  ------------------------------
   function Ends_With (Source  : in String;
                       Suffix  : in String) return Boolean is
   begin
      return Source'Length >= Suffix'Length
        and then Source (Source'Last - Suffix'Length + 1 .. Source'Last) = Suffix;
   end Ends_With;

   --  ------------------------------
   --  Returns True if the source contains the pattern.
   --  ------------------------------
   function Contains (Source  : in String;
                      Pattern : in String) return Boolean is
   begin
      return Ada.Strings.Fixed.Index (Source, Pattern) /= 0;
   end Contains;

   --  ------------------------------
   --  Search for the first occurrence of the character in the string
   --  before the from index and going backward.
   --  This implementation is 3-times faster than the Ada.Strings.Fixed version.
   --  Returns the index of the first occurrence or 0.
   --  ------------------------------
   function Rindex (Source : in String;
                    Ch     : in Character;
                    From   : in Natural := 0) return Natural is
      Pos : Natural := From;
   begin
      if Pos < Source'First then
         Pos := Source'Last;
      end if;
      for I in reverse Source'First .. Pos loop
         if Source (I) = Ch then
            return I;
         end if;
      end loop;
      return 0;
   end Rindex;

end Util.Strings;

-----------------------------------------------------------------------
--  util-strings -- Various String Utility
--  Copyright (C) 2001, 2002, 2003, 2009, 2010, 2011, 2012, 2017, 2022 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.Fixed;
with Ada.Strings.Hash;
with Ada.Unchecked_Deallocation;
package body Util.Strings is

   --  ------------------------------
   --  Compute the hash value of the string.
   --  ------------------------------
   function Hash (Key : Name_Access) return Ada.Containers.Hash_Type is
   begin
      return Ada.Strings.Hash (Key.all);
   end Hash;

   --  ------------------------------
   --  Returns true if left and right strings are equivalent.
   --  ------------------------------
   function Equivalent_Keys (Left, Right : Name_Access) return Boolean is
   begin
      if Left = null or Right = null then
         return False;
      end if;
      return Left.all = Right.all;
   end Equivalent_Keys;

   --  ------------------------------
   --  Returns Integer'Image (Value) with the possible space stripped.
   --  ------------------------------
   function Image (Value : in Integer) return String is
      S : constant String := Integer'Image (Value);
   begin
      if S (S'First) = ' ' then
         return S (S'First + 1 .. S'Last);
      else
         return S;
      end if;
   end Image;

   --  ------------------------------
   --  Returns Integer'Image (Value) with the possible space stripped.
   --  ------------------------------
   function Image (Value : in Long_Long_Integer) return String is
      S : constant String := Long_Long_Integer'Image (Value);
   begin
      if S (S'First) = ' ' then
         return S (S'First + 1 .. S'Last);
      else
         return S;
      end if;
   end Image;

   use Util.Concurrent.Counters;

   --  ------------------------------
   --  Create a string reference from a string.
   --  ------------------------------
   function To_String_Ref (S : in String) return String_Ref is
      Str : constant String_Record_Access
        := new String_Record '(Len => S'Length, Str => S, Counter => ONE);
   begin
      return String_Ref '(Ada.Finalization.Controlled with
                          Str => Str);
   end To_String_Ref;

   --  ------------------------------
   --  Create a string reference from an unbounded string.
   --  ------------------------------
   function To_String_Ref (S : in Ada.Strings.Unbounded.Unbounded_String) return String_Ref is
      use Ada.Strings.Unbounded;

      Len : constant Natural := Length (S);
      Str : constant String_Record_Access
        := new String_Record '(Len => Len, Str => To_String (S), Counter => ONE);
   begin
      return String_Ref '(Ada.Finalization.Controlled with
                          Str => Str);
   end To_String_Ref;

   --  ------------------------------
   --  Get the string
   --  ------------------------------
   function To_String (S : in String_Ref) return String is
   begin
      if S.Str = null then
         return "";
      else
         return S.Str.Str;
      end if;
   end To_String;

   --  ------------------------------
   --  Get the string as an unbounded string
   --  ------------------------------
   function To_Unbounded_String (S : in String_Ref)
                                 return Ada.Strings.Unbounded.Unbounded_String is
   begin
      if S.Str = null then
         return Ada.Strings.Unbounded.Null_Unbounded_String;
      else
         return Ada.Strings.Unbounded.To_Unbounded_String (S.Str.Str);
      end if;
   end To_Unbounded_String;

   --  ------------------------------
   --  Compute the hash value of the string reference.
   --  ------------------------------
   function Hash (Key : String_Ref) return Ada.Containers.Hash_Type is
   begin
      if Key.Str = null then
         return 0;
      else
         return Ada.Strings.Hash (Key.Str.Str);
      end if;
   end Hash;

   --  ------------------------------
   --  Returns true if left and right string references are equivalent.
   --  ------------------------------
   function Equivalent_Keys (Left, Right : String_Ref) return Boolean is
   begin
      if Left.Str = Right.Str then
         return True;
      elsif Left.Str = null or Right.Str = null then
         return False;
      else
         return Left.Str.Str = Right.Str.Str;
      end if;
   end Equivalent_Keys;

   function "=" (Left  : in String_Ref;
                 Right : in String) return Boolean is
   begin
      if Left.Str = null then
         return False;
      else
         return Left.Str.Str = Right;
      end if;
   end "=";

   function "=" (Left  : in String_Ref;
                 Right : in Ada.Strings.Unbounded.Unbounded_String) return Boolean is
      use Ada.Strings.Unbounded;
   begin
      if Left.Str = null then
         return Right = Null_Unbounded_String;
      else
         return Right = Left.Str.Str;
      end if;
   end "=";

   --  ------------------------------
   --  Returns the string length.
   --  ------------------------------
   function Length (S : in String_Ref) return Natural is
   begin
      if S.Str = null then
         return 0;
      else
         return S.Str.Len;
      end if;
   end Length;

   --  ------------------------------
   --  Increment the reference counter.
   --  ------------------------------
   overriding
   procedure Adjust (Object : in out String_Ref) is
   begin
      if Object.Str /= null then
         Util.Concurrent.Counters.Increment (Object.Str.Counter);
      end if;
   end Adjust;

   --  ------------------------------
   --  Decrement the reference counter and free the allocated string.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out String_Ref) is

      procedure Free is
        new Ada.Unchecked_Deallocation (String_Record, String_Record_Access);

      Is_Zero : Boolean;
   begin
      if Object.Str /= null then
         Util.Concurrent.Counters.Decrement (Object.Str.Counter, Is_Zero);
         if Is_Zero then
            Free (Object.Str);
         else
            Object.Str := null;
         end if;
      end if;
   end Finalize;

   --  ------------------------------
   --  Search for the first occurrence of the character in the string
   --  after the from index.  This implementation is 3-times faster than
   --  the Ada.Strings.Fixed version.
   --  Returns the index of the first occurrence or 0.
   --  ------------------------------
   function Index (Source : in String;
                   Char   : in Character;
                   From   : in Natural := 0) return Natural is
      Pos : Natural := From;
   begin
      if Pos < Source'First then
         Pos := Source'First;
      end if;
      for I in Pos .. Source'Last loop
         if Source (I) = Char then
            return I;
         end if;
      end loop;
      return 0;
   end Index;

   --  ------------------------------
   --  Search for the first occurrence of the pattern in the string.
   --  ------------------------------
   function Index (Source  : in String;
                   Pattern : in String;
                   From    : in Positive;
                   Going   : in Ada.Strings.Direction := Ada.Strings.Forward) return Natural is
   begin
      return Ada.Strings.Fixed.Index (Source, Pattern, From, Going);
   end Index;

   --  ------------------------------
   --  Returns True if the source string starts with the given prefix.
   --  ------------------------------
   function Starts_With (Source  : in String;
                         Prefix  : in String) return Boolean is
   begin
      return Source'Length >= Prefix'Length
        and then Source (Source'First .. Source'First + Prefix'Length - 1) = Prefix;
   end Starts_With;

   --  ------------------------------
   --  Returns True if the source string ends with the given suffix.
   --  ------------------------------
   function Ends_With (Source  : in String;
                       Suffix  : in String) return Boolean is
   begin
      return Source'Length >= Suffix'Length
        and then Source (Source'Last - Suffix'Length + 1 .. Source'Last) = Suffix;
   end Ends_With;

   --  ------------------------------
   --  Returns True if the source contains the pattern.
   --  ------------------------------
   function Contains (Source  : in String;
                      Pattern : in String) return Boolean is
   begin
      return Ada.Strings.Fixed.Index (Source, Pattern) /= 0;
   end Contains;

   --  ------------------------------
   --  Search for the first occurrence of the character in the string
   --  before the from index and going backward.
   --  This implementation is 3-times faster than the Ada.Strings.Fixed version.
   --  Returns the index of the first occurrence or 0.
   --  ------------------------------
   function Rindex (Source : in String;
                    Ch     : in Character;
                    From   : in Natural := 0) return Natural is
      Pos : Natural := From;
   begin
      if Pos < Source'First then
         Pos := Source'Last;
      end if;
      for I in reverse Source'First .. Pos loop
         if Source (I) = Ch then
            return I;
         end if;
      end loop;
      return 0;
   end Rindex;

   --  ------------------------------
   --  Simple string replacement within the source of the specified content
   --  by another string.  By default, replace only the first sequence.
   --  ------------------------------
   function Replace (Source  : in String;
                     Content : in String;
                     By      : in String;
                     First   : in Boolean := True) return String is
      use Ada.Strings.Unbounded;

      Result : Unbounded_String;
      Pos    : Natural := Source'First;
   begin
      while Pos <= Source'Last loop
         if Source'Last - Pos >= Content'Length and
         then Source (Pos .. Pos + Content'Length - 1) = Content
         then
            Append (Result, By);
            Pos := Pos + Content'Length;
            if First and Pos <= Source'Last then
               Append (Result, Source (Pos .. Source'Last));
               Pos := Source'Last + 1;
            end if;
         else
            Append (Result, Source (Pos));
            Pos := Pos + 1;
         end if;
      end loop;
      return To_String (Result);
   end Replace;

end Util.Strings;

Implement the Replace function

Implement the Replace function


-----------------------------------------------------------------------
--  util-nullables -- Basic types that can hold a null value
--  Copyright (C) 2017 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.Calendar;
with Ada.Strings.Unbounded;

--  === Nullable types ===
--  Sometimes it is necessary to represent a simple data type with an optional boolean information
--  that indicates whether the value is valid or just null.  The concept of nullable type is often
--  used in databases but also in JSON data representation.  The <tt>Util.Nullables</tt> package
--  provides several standard type to express the null capability of a value.
--
--  By default a nullable instance is created with the null flag set.
package Util.Nullables is

   use type Ada.Strings.Unbounded.Unbounded_String;
   use type Ada.Calendar.Time;

   --  ------------------------------
   --  A boolean which can be null.
   --  ------------------------------
   type Nullable_Boolean is record
      Value   : Boolean := False;
      Is_Null : Boolean := True;
   end record;

   --  Return True if the two nullable times are identical (both null or both same value).
   function "=" (Left, Right : in Nullable_Boolean) return Boolean is
      (Left.Is_Null = Right.Is_Null and (Left.Is_Null or else Left.Value = Right.Value));

   --  ------------------------------
   --  An integer which can be null.
   --  ------------------------------
   type Nullable_Integer is record
      Value   : Integer := 0;
      Is_Null : Boolean := True;
   end record;

   --  Return True if the two nullable times are identical (both null or both same value).
   function "=" (Left, Right : in Nullable_Integer) return Boolean is
      (Left.Is_Null = Right.Is_Null and (Left.Is_Null or else Left.Value = Right.Value));

   --  ------------------------------
   --  A long which can be null.
   --  ------------------------------
   type Nullable_Long is record
      Value   : Long_Long_Integer := 0;
      Is_Null : Boolean := True;
   end record;

   --  Return True if the two nullable times are identical (both null or both same value).
   function "=" (Left, Right : in Nullable_Long) return Boolean is
      (Left.Is_Null = Right.Is_Null and (Left.Is_Null or else Left.Value = Right.Value));

   --  ------------------------------
   --  A string which can be null.
   --  ------------------------------
   type Nullable_String is record
      Value   : Ada.Strings.Unbounded.Unbounded_String;
      Is_Null : Boolean := True;
   end record;

   --  Return True if the two nullable times are identical (both null or both same value).
   function "=" (Left, Right : in Nullable_String) return Boolean is
      (Left.Is_Null = Right.Is_Null and (Left.Is_Null or else Left.Value = Right.Value));

   --  ------------------------------
   --  A date which can be null.
   --  ------------------------------
   type Nullable_Time is record
      Value   : Ada.Calendar.Time;
      Is_Null : Boolean := True;
   end record;

   --  Return True if the two nullable times are identical (both null or both same time).
   function "=" (Left, Right : in Nullable_Time) return Boolean is
      (Left.Is_Null = Right.Is_Null and (Left.Is_Null or else Left.Value = Right.Value));

end Util.Nullables;

-----------------------------------------------------------------------
--  util-nullables -- Basic types that can hold a null value
--  Copyright (C) 2017 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.Calendar;
with Ada.Strings.Unbounded;

--  === Nullable types ===
--  Sometimes it is necessary to represent a simple data type with an optional boolean information
--  that indicates whether the value is valid or just null.  The concept of nullable type is often
--  used in databases but also in JSON data representation.  The <tt>Util.Nullables</tt> package
--  provides several standard type to express the null capability of a value.
--
--  By default a nullable instance is created with the null flag set.
package Util.Nullables is

   use type Ada.Strings.Unbounded.Unbounded_String;
   use type Ada.Calendar.Time;

   DEFAULT_TIME : constant Ada.Calendar.Time;

   --  ------------------------------
   --  A boolean which can be null.
   --  ------------------------------
   type Nullable_Boolean is record
      Value   : Boolean := False;
      Is_Null : Boolean := True;
   end record;

   Null_Boolean : constant Nullable_Boolean;

   --  Return True if the two nullable times are identical (both null or both same value).
   function "=" (Left, Right : in Nullable_Boolean) return Boolean is
      (Left.Is_Null = Right.Is_Null and (Left.Is_Null or else Left.Value = Right.Value));

   --  ------------------------------
   --  An integer which can be null.
   --  ------------------------------
   type Nullable_Integer is record
      Value   : Integer := 0;
      Is_Null : Boolean := True;
   end record;

   Null_Integer : constant Nullable_Integer;

   --  Return True if the two nullable times are identical (both null or both same value).
   function "=" (Left, Right : in Nullable_Integer) return Boolean is
      (Left.Is_Null = Right.Is_Null and (Left.Is_Null or else Left.Value = Right.Value));

   --  ------------------------------
   --  A long which can be null.
   --  ------------------------------
   type Nullable_Long is record
      Value   : Long_Long_Integer := 0;
      Is_Null : Boolean := True;
   end record;

   Null_Long : constant Nullable_Long;

   --  Return True if the two nullable times are identical (both null or both same value).
   function "=" (Left, Right : in Nullable_Long) return Boolean is
      (Left.Is_Null = Right.Is_Null and (Left.Is_Null or else Left.Value = Right.Value));

   --  ------------------------------
   --  A string which can be null.
   --  ------------------------------
   type Nullable_String is record
      Value   : Ada.Strings.Unbounded.Unbounded_String;
      Is_Null : Boolean := True;
   end record;

   Null_String : constant Nullable_String;

   --  Return True if the two nullable times are identical (both null or both same value).
   function "=" (Left, Right : in Nullable_String) return Boolean is
      (Left.Is_Null = Right.Is_Null and (Left.Is_Null or else Left.Value = Right.Value));

   --  ------------------------------
   --  A date which can be null.
   --  ------------------------------
   type Nullable_Time is record
      Value   : Ada.Calendar.Time := DEFAULT_TIME;
      Is_Null : Boolean := True;
   end record;

   Null_Time : constant Nullable_Time;

   --  Return True if the two nullable times are identical (both null or both same time).
   function "=" (Left, Right : in Nullable_Time) return Boolean is
      (Left.Is_Null = Right.Is_Null and (Left.Is_Null or else Left.Value = Right.Value));

private

   DEFAULT_TIME : constant Ada.Calendar.Time := Ada.Calendar.Time_Of (Year    => 1901,
                                                                      Month   => 1,
                                                                      Day     => 2,
                                                                      Seconds => 0.0);
   Null_Boolean : constant Nullable_Boolean
     := Nullable_Boolean '(Is_Null => True,
                           Value   => False);

   Null_Integer : constant Nullable_Integer
     := Nullable_Integer '(Is_Null => True,
                           Value   => 0);

   Null_Long : constant Nullable_Long
     := Nullable_Long '(Is_Null => True,
                        Value   => 0);

   Null_String : constant Nullable_String
     := Nullable_String '(Is_Null => True,
                          Value   => Ada.Strings.Unbounded.Null_Unbounded_String);

   Null_Time : constant Nullable_Time
     := Nullable_Time '(Is_Null => True,
                        Value   => DEFAULT_TIME);

end Util.Nullables;

Declare DEFAULT_TIME, Null_Integer, Null_Boolean, Null_String, Null_Time constants


-----------------------------------------------------------------------
--  awa-blogs-tests -- Unit tests for blogs module
--  Copyright (C) 2017 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.Tests;
with Ada.Strings.Unbounded;

package AWA.Blogs.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new Util.Tests.Test with record
      Blog_Ident : Ada.Strings.Unbounded.Unbounded_String;
      Post_Ident : Ada.Strings.Unbounded.Unbounded_String;
      Post_Uri   : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   --  Get some access on the blog as anonymous users.
   procedure Verify_Anonymous (T    : in out Test;
                               Post : in String);

   --  Test access to the blog as anonymous user.
   procedure Test_Anonymous_Access (T : in out Test);

   --  Test creation of blog by simulating web requests.
   procedure Test_Create_Blog (T : in out Test);

   --  Test updating a post by simulating web requests.
   procedure Test_Update_Post (T : in out Test);

end AWA.Blogs.Tests;

-----------------------------------------------------------------------
--  awa-blogs-tests -- Unit tests for blogs module
--  Copyright (C) 2017 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.Tests;
with Ada.Strings.Unbounded;

package AWA.Blogs.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new Util.Tests.Test with record
      Blog_Ident : Ada.Strings.Unbounded.Unbounded_String;
      Post_Ident : Ada.Strings.Unbounded.Unbounded_String;
      Post_Uri   : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   --  Get some access on the blog as anonymous users.
   procedure Verify_Anonymous (T    : in out Test;
                               Post : in String);

   --  Test access to the blog as anonymous user.
   procedure Test_Anonymous_Access (T : in out Test);

   --  Test creation of blog by simulating web requests.
   procedure Test_Create_Blog (T : in out Test);

   --  Test updating a post by simulating web requests.
   procedure Test_Update_Post (T : in out Test);

   --  Test listing the blog posts.
   procedure Test_Admin_List_Posts (T : in out Test);

end AWA.Blogs.Tests;

Declare the Test_Admin_List_Posts procedure for another unit test


-----------------------------------------------------------------------
--  awa-blogs-tests -- Unit tests for blogs module
--  Copyright (C) 2017 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.Tests;
with Ada.Strings.Unbounded;

package AWA.Blogs.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new Util.Tests.Test with record
      Blog_Ident : Ada.Strings.Unbounded.Unbounded_String;
      Post_Ident : Ada.Strings.Unbounded.Unbounded_String;
      Post_Uri   : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   --  Get some access on the blog as anonymous users.
   procedure Verify_Anonymous (T    : in out Test;
                               Post : in String);

   --  Test access to the blog as anonymous user.
   procedure Test_Anonymous_Access (T : in out Test);

   --  Test creation of blog by simulating web requests.
   procedure Test_Create_Blog (T : in out Test);

   --  Test updating a post by simulating web requests.
   procedure Test_Update_Post (T : in out Test);

   --  Test listing the blog posts.
   procedure Test_Admin_List_Posts (T : in out Test);

end AWA.Blogs.Tests;

-----------------------------------------------------------------------
--  awa-blogs-tests -- Unit tests for blogs module
--  Copyright (C) 2017 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.Tests;
with Ada.Strings.Unbounded;

package AWA.Blogs.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new Util.Tests.Test with record
      Blog_Ident : Ada.Strings.Unbounded.Unbounded_String;
      Post_Ident : Ada.Strings.Unbounded.Unbounded_String;
      Post_Uri   : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   --  Get some access on the blog as anonymous users.
   procedure Verify_Anonymous (T    : in out Test;
                               Post : in String);

   --  Test access to the blog as anonymous user.
   procedure Test_Anonymous_Access (T : in out Test);

   --  Test creation of blog by simulating web requests.
   procedure Test_Create_Blog (T : in out Test);

   --  Test updating a post by simulating web requests.
   procedure Test_Update_Post (T : in out Test);

   --  Test listing the blog posts.
   procedure Test_Admin_List_Posts (T : in out Test);

   --  Test listing the blog comments.
   procedure Test_Admin_List_Comments (T : in out Test);

end AWA.Blogs.Tests;

Declare the Test_Admin_List_Comments procedure to test the list of comments


-----------------------------------------------------------------------
--  mat-events-targets - Events received and collected from a target
--  Copyright (C) 2014, 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 Ada.Containers.Ordered_Maps;
with Ada.Containers.Vectors;

with Util.Concurrent.Counters;

with MAT.Frames;
package MAT.Events.Targets is

   Not_Found : exception;

   type Event_Type is mod 16;
   type Probe_Index_Type is mod 16;

   type Event_Id_Type is new Natural;

   type Probe_Event_Type is record
      Id       : Event_Id_Type;
      Event    : MAT.Types.Uint16;
      Index    : Probe_Index_Type;
      Time     : MAT.Types.Target_Tick_Ref;
      Thread   : MAT.Types.Target_Thread_Ref;
      Frame    : MAT.Frames.Frame_Type;
      Addr     : MAT.Types.Target_Addr;
      Size     : MAT.Types.Target_Size;
      Old_Addr : MAT.Types.Target_Addr;
   end record;

   subtype Target_Event is Probe_Event_Type;

   package Target_Event_Vectors is
     new Ada.Containers.Vectors (Positive, Target_Event);

   subtype Target_Event_Vector is Target_Event_Vectors.Vector;
   subtype Target_Event_Cursor is Target_Event_Vectors.Cursor;

   type Target_Events is tagged limited private;
   type Target_Events_Access is access all Target_Events'Class;

   --  Add the event in the list of events and increment the event counter.
   procedure Insert (Target : in out Target_Events;
                     Event  : in Probe_Event_Type);

   procedure Get_Events (Target : in out Target_Events;
                         Start  : in MAT.Types.Target_Time;
                         Finish : in MAT.Types.Target_Time;
                         Into   : in out Target_Event_Vector);

   --  Get the start and finish time for the events that have been received.
   procedure Get_Time_Range (Target : in out Target_Events;
                             Start  : out MAT.Types.Target_Time;
                             Finish : out MAT.Types.Target_Time);

   --  Get the probe event with the given allocated unique id.
   function Get_Event (Target : in Target_Events;
                       Id     : in Event_Id_Type) return Probe_Event_Type;

   --  Get the first and last event that have been received.
   procedure Get_Limits (Target : in out Target_Events;
                         First  : out Probe_Event_Type;
                         Last   : out Probe_Event_Type);

   --  Get the current event counter.
   function Get_Event_Counter (Target : in Target_Events) return Integer;

   --  Iterate over the events starting from the <tt>Start</tt> event and until the
   --  <tt>Finish</tt> event is found (inclusive).  Execute the <tt>Process</tt> procedure
   --  with each event instance.
   procedure Iterate (Target  : in out Target_Events;
                      Start   : in Event_Id_Type;
                      Finish  : in Event_Id_Type;
                      Process : access procedure (Event : in Probe_Event_Type));

private

   EVENT_BLOCK_SIZE : constant Event_Id_Type := 1024;

   type Probe_Event_Array is array (1 .. EVENT_BLOCK_SIZE) of Probe_Event_Type;

   type Event_Block is record
      Start  : MAT.Types.Target_Time;
      Finish : MAT.Types.Target_Time;
      Count  : Event_Id_Type := 0;
      Events : Probe_Event_Array;
   end record;
   type Event_Block_Access is access all Event_Block;

   use type MAT.Types.Target_Time;
   package Event_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Time,
                                      Element_Type => Event_Block_Access);

   subtype Event_Map is Event_Maps.Map;
   subtype Event_Cursor is Event_Maps.Cursor;

   package Event_Id_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => Event_Id_Type,
                                      Element_Type => Event_Block_Access);

   subtype Event_Id_Map is Event_Id_Maps.Map;
   subtype Event_Id_Cursor is Event_Id_Maps.Cursor;

   protected type Event_Collector is

      --  Add the event in the list of events.
      procedure Insert (Event  : in Probe_Event_Type);

      procedure Get_Events (Start  : in MAT.Types.Target_Time;
                            Finish : in MAT.Types.Target_Time;
                            Into   : in out Target_Event_Vector);

      --  Get the first and last event that have been received.
      procedure Get_Limits (First : out Probe_Event_Type;
                            Last  : out Probe_Event_Type);

      --  Get the start and finish time for the events that have been received.
      procedure Get_Time_Range (Start  : out MAT.Types.Target_Time;
                                Finish : out MAT.Types.Target_Time);

      --  Get the probe event with the given allocated unique id.
      function Get_Event (Id : in Event_Id_Type) return Probe_Event_Type;

      --  Iterate over the events starting from the <tt>Start</tt> event and until the
      --  <tt>Finish</tt> event is found (inclusive).  Execute the <tt>Process</tt> procedure
      --  with each event instance.
      procedure Iterate (Start   : in Event_Id_Type;
                         Finish  : in Event_Id_Type;
                         Process : access procedure (Event : in Probe_Event_Type));

   private
      Current       : Event_Block_Access := null;
      Events        : Event_Map;
      Ids           : Event_Id_Map;
      Last_Id       : Event_Id_Type := 0;
   end Event_Collector;

   type Target_Events is tagged limited record
      Events      : Event_Collector;
      Event_Count : Util.Concurrent.Counters.Counter;
   end record;

end MAT.Events.Targets;

-----------------------------------------------------------------------
--  mat-events-targets - Events received and collected from a target
--  Copyright (C) 2014, 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 Ada.Containers.Ordered_Maps;
with Ada.Containers.Vectors;

with Util.Concurrent.Counters;

with MAT.Frames;
package MAT.Events.Targets is

   Not_Found : exception;

   type Event_Type is mod 16;
   type Probe_Index_Type is (MSG_BEGIN,
                             MSG_END,
                             MSG_LIBRARY,
                             MSG_MALLOC,
                             MSG_FREE,
                             MSG_REALLOC
                             );

   type Event_Id_Type is new Natural;

   type Probe_Event_Type is record
      Id       : Event_Id_Type;
      Event    : MAT.Types.Uint16;
      Index    : Probe_Index_Type;
      Time     : MAT.Types.Target_Tick_Ref;
      Thread   : MAT.Types.Target_Thread_Ref;
      Frame    : MAT.Frames.Frame_Type;
      Addr     : MAT.Types.Target_Addr;
      Size     : MAT.Types.Target_Size;
      Old_Addr : MAT.Types.Target_Addr;
   end record;

   subtype Target_Event is Probe_Event_Type;

   package Target_Event_Vectors is
     new Ada.Containers.Vectors (Positive, Target_Event);

   subtype Target_Event_Vector is Target_Event_Vectors.Vector;
   subtype Target_Event_Cursor is Target_Event_Vectors.Cursor;

   type Target_Events is tagged limited private;
   type Target_Events_Access is access all Target_Events'Class;

   --  Add the event in the list of events and increment the event counter.
   procedure Insert (Target : in out Target_Events;
                     Event  : in Probe_Event_Type);

   procedure Get_Events (Target : in out Target_Events;
                         Start  : in MAT.Types.Target_Time;
                         Finish : in MAT.Types.Target_Time;
                         Into   : in out Target_Event_Vector);

   --  Get the start and finish time for the events that have been received.
   procedure Get_Time_Range (Target : in out Target_Events;
                             Start  : out MAT.Types.Target_Time;
                             Finish : out MAT.Types.Target_Time);

   --  Get the probe event with the given allocated unique id.
   function Get_Event (Target : in Target_Events;
                       Id     : in Event_Id_Type) return Probe_Event_Type;

   --  Get the first and last event that have been received.
   procedure Get_Limits (Target : in out Target_Events;
                         First  : out Probe_Event_Type;
                         Last   : out Probe_Event_Type);

   --  Get the current event counter.
   function Get_Event_Counter (Target : in Target_Events) return Integer;

   --  Iterate over the events starting from the <tt>Start</tt> event and until the
   --  <tt>Finish</tt> event is found (inclusive).  Execute the <tt>Process</tt> procedure
   --  with each event instance.
   procedure Iterate (Target  : in out Target_Events;
                      Start   : in Event_Id_Type;
                      Finish  : in Event_Id_Type;
                      Process : access procedure (Event : in Probe_Event_Type));

private

   EVENT_BLOCK_SIZE : constant Event_Id_Type := 1024;

   type Probe_Event_Array is array (1 .. EVENT_BLOCK_SIZE) of Probe_Event_Type;

   type Event_Block is record
      Start  : MAT.Types.Target_Time;
      Finish : MAT.Types.Target_Time;
      Count  : Event_Id_Type := 0;
      Events : Probe_Event_Array;
   end record;
   type Event_Block_Access is access all Event_Block;

   use type MAT.Types.Target_Time;
   package Event_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Time,
                                      Element_Type => Event_Block_Access);

   subtype Event_Map is Event_Maps.Map;
   subtype Event_Cursor is Event_Maps.Cursor;

   package Event_Id_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => Event_Id_Type,
                                      Element_Type => Event_Block_Access);

   subtype Event_Id_Map is Event_Id_Maps.Map;
   subtype Event_Id_Cursor is Event_Id_Maps.Cursor;

   protected type Event_Collector is

      --  Add the event in the list of events.
      procedure Insert (Event  : in Probe_Event_Type);

      procedure Get_Events (Start  : in MAT.Types.Target_Time;
                            Finish : in MAT.Types.Target_Time;
                            Into   : in out Target_Event_Vector);

      --  Get the first and last event that have been received.
      procedure Get_Limits (First : out Probe_Event_Type;
                            Last  : out Probe_Event_Type);

      --  Get the start and finish time for the events that have been received.
      procedure Get_Time_Range (Start  : out MAT.Types.Target_Time;
                                Finish : out MAT.Types.Target_Time);

      --  Get the probe event with the given allocated unique id.
      function Get_Event (Id : in Event_Id_Type) return Probe_Event_Type;

      --  Iterate over the events starting from the <tt>Start</tt> event and until the
      --  <tt>Finish</tt> event is found (inclusive).  Execute the <tt>Process</tt> procedure
      --  with each event instance.
      procedure Iterate (Start   : in Event_Id_Type;
                         Finish  : in Event_Id_Type;
                         Process : access procedure (Event : in Probe_Event_Type));

   private
      Current       : Event_Block_Access := null;
      Events        : Event_Map;
      Ids           : Event_Id_Map;
      Last_Id       : Event_Id_Type := 0;
   end Event_Collector;

   type Target_Events is tagged limited record
      Events      : Event_Collector;
      Event_Count : Util.Concurrent.Counters.Counter;
   end record;

end MAT.Events.Targets;

Change the Probe_Index_Type to an enum with the declaration of all supported message types


-----------------------------------------------------------------------
--  awa-modules-lifecycles -- Lifecycle listeners
--  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.
-----------------------------------------------------------------------
package body AWA.Modules.Lifecycles is

   --  ------------------------------
   --  Inform the the lifecycle listeners registered in `List` that the item passed in `Item`
   --  has been created (calls `On_Create`).
   --  ------------------------------
   procedure Notify_Create (Service : in AWA.Modules.Module_Manager'Class;
                            Item    : in Element_Type) is
   begin
      LF.Notify_Create (Service.Module.Listeners, Item);
   end Notify_Create;

   --  ------------------------------
   --  Inform the the lifecycle listeners registered in `List` that the item passed in `Item`
   --  has been updated (calls `On_Update`).
   --  ------------------------------
   procedure Notify_Update (Service : in AWA.Modules.Module_Manager'Class;
                            Item    : in Element_Type) is
   begin
      LF.Notify_Update (Service.Module.Listeners, Item);
   end Notify_Update;

   --  ------------------------------
   --  Inform the the lifecycle listeners registered in `List` that the item passed in `Item`
   --  has been deleted (calls `On_Delete`).
   --  ------------------------------
   procedure Notify_Delete (Service : in AWA.Modules.Module_Manager'Class;
                            Item    : in Element_Type) is
   begin
      LF.Notify_Delete (Service.Module.Listeners, Item);
   end Notify_Delete;

end AWA.Modules.Lifecycles;

-----------------------------------------------------------------------
--  awa-modules-lifecycles -- Lifecycle listeners
--  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.
-----------------------------------------------------------------------
package body AWA.Modules.Lifecycles is

   --  ------------------------------
   --  Inform the the life cycle listeners registered in `List` that the item passed in `Item`
   --  has been created (calls `On_Create`).
   --  ------------------------------
   procedure Notify_Create (Service : in AWA.Modules.Module_Manager'Class;
                            Item    : in Element_Type) is
   begin
      LF.Notify_Create (Service.Module.Listeners, Item);
   end Notify_Create;

   --  ------------------------------
   --  Inform the the life cycle listeners registered in `List` that the item passed in `Item`
   --  has been created (calls `On_Create`).
   --  ------------------------------
   procedure Notify_Create (Service : in AWA.Modules.Module'Class;
                            Item    : in Element_Type) is
   begin
      LF.Notify_Create (Service.Listeners, Item);
   end Notify_Create;

   --  ------------------------------
   --  Inform the the life cycle listeners registered in `List` that the item passed in `Item`
   --  has been updated (calls `On_Update`).
   --  ------------------------------
   procedure Notify_Update (Service : in AWA.Modules.Module_Manager'Class;
                            Item    : in Element_Type) is
   begin
      LF.Notify_Update (Service.Module.Listeners, Item);
   end Notify_Update;

   --  ------------------------------
   --  Inform the the life cycle listeners registered in `List` that the item passed in `Item`
   --  has been updated (calls `On_Update`).
   --  ------------------------------
   procedure Notify_Update (Service : in AWA.Modules.Module'Class;
                            Item    : in Element_Type) is
   begin
      LF.Notify_Update (Service.Listeners, Item);
   end Notify_Update;

   --  ------------------------------
   --  Inform the the life cycle listeners registered in `List` that the item passed in `Item`
   --  has been deleted (calls `On_Delete`).
   --  ------------------------------
   procedure Notify_Delete (Service : in AWA.Modules.Module_Manager'Class;
                            Item    : in Element_Type) is
   begin
      LF.Notify_Delete (Service.Module.Listeners, Item);
   end Notify_Delete;

   --  ------------------------------
   --  Inform the the life cycle listeners registered in `List` that the item passed in `Item`
   --  has been deleted (calls `On_Delete`).
   --  ------------------------------
   procedure Notify_Delete (Service : in AWA.Modules.Module'Class;
                            Item    : in Element_Type) is
   begin
      LF.Notify_Delete (Service.Listeners, Item);
   end Notify_Delete;

end AWA.Modules.Lifecycles;

Implement the Notify_Create, Notify_Update and Notify_Delete with the Module'Class instance


-----------------------------------------------------------------------
--  html.lists -- List of items
--  Copyright (C) 2009, 2010 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.Log.Loggers;
with Util.Beans.Basic;
with ASF.Components.Base;
package body ASF.Components.Html.Lists is

   use Util.Log;
   use type EL.Objects.Data_Type;

   Log : constant Loggers.Logger := Loggers.Create ("ASF.Components.Html.Lists");

   --  ------------------------------
   --  Get the value to write on the output.
   --  ------------------------------
   function Get_Value (UI : in UIList) return EL.Objects.Object is
   begin
      return UI.Get_Attribute (UI.Get_Context.all, "value");
   end Get_Value;

   --  ------------------------------
   --  Set the value to write on the output.
   --  ------------------------------
   procedure Set_Value (UI    : in out UIList;
                        Value : in EL.Objects.Object) is
   begin
      null;
   end Set_Value;

   --  ------------------------------
   --  Get the variable name
   --  ------------------------------
   function Get_Var (UI : in UIList) return String is
      Var : constant EL.Objects.Object := UI.Get_Attribute (UI.Get_Context.all, "var");
   begin
      return EL.Objects.To_String (Var);
   end Get_Var;

   procedure Encode_Children (UI      : in UIList;
                              Context : in out Faces_Context'Class) is
   begin
      if not UI.Is_Rendered (Context) then
         return;
      end if;

      declare
         Value : EL.Objects.Object := Get_Value (UI);
         Kind  : constant EL.Objects.Data_Type := EL.Objects.Get_Type (Value);
         Name  : constant String := UI.Get_Var;
         Bean  : access Util.Beans.Basic.Readonly_Bean'Class;
         Is_Reverse : constant Boolean := UI.Get_Attribute ("reverse", Context, False);
         List  : Util.Beans.Basic.List_Bean_Access;
         Count : Natural;
      begin
         --  Check that we have a List_Bean but do not complain if we have a null value.
         if Kind /= EL.Objects.TYPE_BEAN then
            if Kind /= EL.Objects.TYPE_NULL then
               Log.Error ("Invalid list bean (found a {0})", EL.Objects.Get_Type_Name (Value));
            end if;
            return;
         end if;

         Bean := EL.Objects.To_Bean (Value);
         if Bean = null or else not (Bean.all in Util.Beans.Basic.List_Bean'Class) then
            Log.Error ("Invalid list bean: it does not implement 'List_Bean' interface");
            return;
         end if;

         List := Util.Beans.Basic.List_Bean'Class (Bean.all)'Unchecked_Access;
         Count := List.Get_Count;
         if Is_Reverse then
            for I in reverse 1 .. Count loop
               List.Set_Row_Index (I);
               Value := List.Get_Row;

               Context.Set_Attribute (Name, Value);
               Log.Debug ("Set variable {0}", Name);
               Base.UIComponent (UI).Encode_Children (Context);
            end loop;
         else
            for I in 1 .. Count loop
               List.Set_Row_Index (I);
               Value := List.Get_Row;

               Context.Set_Attribute (Name, Value);
               Log.Debug ("Set variable {0}", Name);
               Base.UIComponent (UI).Encode_Children (Context);
            end loop;
         end if;
      end;
   end Encode_Children;

end ASF.Components.Html.Lists;

-----------------------------------------------------------------------
--  html.lists -- List of items
--  Copyright (C) 2009, 2010, 2013 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.Log.Loggers;
with Util.Beans.Basic;
with ASF.Components.Base;
package body ASF.Components.Html.Lists is

   use Util.Log;
   use type EL.Objects.Data_Type;

   Log : constant Loggers.Logger := Loggers.Create ("ASF.Components.Html.Lists");

   --  ------------------------------
   --  Get the value to write on the output.
   --  ------------------------------
   function Get_Value (UI : in UIList) return EL.Objects.Object is
   begin
      return UI.Get_Attribute (UI.Get_Context.all, "value");
   end Get_Value;

   --  ------------------------------
   --  Set the value to write on the output.
   --  ------------------------------
   procedure Set_Value (UI    : in out UIList;
                        Value : in EL.Objects.Object) is
   begin
      null;
   end Set_Value;

   --  ------------------------------
   --  Get the variable name
   --  ------------------------------
   function Get_Var (UI : in UIList) return String is
      Var : constant EL.Objects.Object := UI.Get_Attribute (UI.Get_Context.all, "var");
   begin
      return EL.Objects.To_String (Var);
   end Get_Var;

   procedure Encode_Children (UI      : in UIList;
                              Context : in out Faces_Context'Class) is
   begin
      if not UI.Is_Rendered (Context) then
         return;
      end if;

      declare
         Value : EL.Objects.Object := Get_Value (UI);
         Kind  : constant EL.Objects.Data_Type := EL.Objects.Get_Type (Value);
         Name  : constant String := UI.Get_Var;
         Bean  : access Util.Beans.Basic.Readonly_Bean'Class;
         Is_Reverse : constant Boolean := UI.Get_Attribute ("reverse", Context, False);
         List  : Util.Beans.Basic.List_Bean_Access;
         Count : Natural;
      begin
         --  Check that we have a List_Bean but do not complain if we have a null value.
         if Kind /= EL.Objects.TYPE_BEAN then
            if Kind /= EL.Objects.TYPE_NULL then
               ASF.Components.Base.Log_Error (UI, "Invalid list bean (found a {0})",
                                              EL.Objects.Get_Type_Name (Value));
            end if;
            return;
         end if;

         Bean := EL.Objects.To_Bean (Value);
         if Bean = null or else not (Bean.all in Util.Beans.Basic.List_Bean'Class) then
            ASF.Components.Base.Log_Error (UI, "Invalid list bean: "
                                           & "it does not implement 'List_Bean' interface");
            return;
         end if;

         List := Util.Beans.Basic.List_Bean'Class (Bean.all)'Unchecked_Access;
         Count := List.Get_Count;
         if Is_Reverse then
            for I in reverse 1 .. Count loop
               List.Set_Row_Index (I);
               Value := List.Get_Row;

               Context.Set_Attribute (Name, Value);
               Log.Debug ("Set variable {0}", Name);
               Base.UIComponent (UI).Encode_Children (Context);
            end loop;
         else
            for I in 1 .. Count loop
               List.Set_Row_Index (I);
               Value := List.Get_Row;

               Context.Set_Attribute (Name, Value);
               Log.Debug ("Set variable {0}", Name);
               Base.UIComponent (UI).Encode_Children (Context);
            end loop;
         end if;
      end;
   end Encode_Children;

end ASF.Components.Html.Lists;

Use the Log_Error procedure to report the error message and associate the error with the view file and line number