-----------------------------------------------------------------------
--  asf-servlets-faces-mappers -- Read faces specific configuration files
--  Copyright (C) 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.Unchecked_Deallocation;
with ASF.Routes.Servlets.Faces;
package body ASF.Servlets.Faces.Mappers is

   use type ASF.Routes.Route_Type_Access;

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => ASF.Routes.Servlets.Faces.Faces_Route_Type'Class,
                                     Name   => ASF.Routes.Servlets.Faces.Faces_Route_Type_Access);

   function Find_Servlet (Container : in Servlet_Registry_Access;
                          View      : in String)
                          return ASF.Servlets.Servlet_Access is
      Disp  : constant Request_Dispatcher := Container.Get_Request_Dispatcher (View);
      Route : constant ASF.Routes.Route_Type_Access := Disp.Context.Get_Route;
   begin
      if Route = null then
         raise Util.Serialize.Mappers.Field_Error with "No servlet mapped to view " & View;
      end if;
      if not (Route.all in ASF.Routes.Servlets.Servlet_Route_Type'Class) then
         raise Util.Serialize.Mappers.Field_Error with "View " & View & " not mapped to a servlet";
      end if;
      return ASF.Routes.Servlets.Servlet_Route_Type'Class (Route.all).Servlet;
   end Find_Servlet;

   --  ------------------------------
   --  Save in the servlet config object the value associated with the given field.
   --  When the URL_MAPPING, URL_PATTERN, VIEW_ID field
   --  is reached, insert the new configuration rule in the servlet registry.
   --  ------------------------------
   procedure Set_Member (N     : in out Servlet_Config;
                         Field : in Servlet_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use Util.Beans.Objects;

      Route : ASF.Routes.Servlets.Faces.Faces_Route_Type_Access;
   begin
      case Field is
         when URL_PATTERN =>
            N.URL_Pattern := Value;

         when VIEW_ID =>
            N.View_Id := Value;

         when URL_MAPPING =>
            declare
               View    : constant String := To_String (N.View_Id);
               Servlet : constant ASF.Servlets.Servlet_Access := Find_Servlet (N.Handler, View);
            begin
               Route := new ASF.Routes.Servlets.Faces.Faces_Route_Type;
               Route.View    := To_Unbounded_String (View);
               Route.Servlet := Servlet;
               N.Handler.Add_Route (Pattern   => To_String (N.URL_Pattern),
                                    To        => Route.all'Access,
                                    ELContext => N.Context.all);
            exception
               when others =>
                  Free (Route);
                  raise;
            end;
      end case;
   end Set_Member;

   SMapper : aliased Servlet_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the servlet and mapping rules <b>url-mapping</b>.
   --  ------------------------------
   package body Reader_Config is
   begin
      Reader.Add_Mapping ("faces-config", SMapper'Access);
      Reader.Add_Mapping ("module", SMapper'Access);
      Reader.Add_Mapping ("web-app", SMapper'Access);
      Config.Handler := Handler;
      Config.Context := Context;
      Servlet_Mapper.Set_Context (Reader, Config'Unchecked_Access);
   end Reader_Config;

begin
   SMapper.Add_Mapping ("url-mapping", URL_MAPPING);
   SMapper.Add_Mapping ("url-mapping/pattern", URL_PATTERN);
   SMapper.Add_Mapping ("url-mapping/view-id", VIEW_ID);
end ASF.Servlets.Faces.Mappers;

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

   use type ASF.Routes.Route_Type_Access;

   function Find_Servlet (Container : in Servlet_Registry_Access;
                          View      : in String)
                          return ASF.Servlets.Servlet_Access;

   function Find_Servlet (Container : in Servlet_Registry_Access;
                          View      : in String)
                          return ASF.Servlets.Servlet_Access is
      Disp  : constant Request_Dispatcher := Container.Get_Request_Dispatcher (View);
      Route : constant ASF.Routes.Route_Type_Access := Disp.Context.Get_Route;
   begin
      if Route = null then
         raise Util.Serialize.Mappers.Field_Error with "No servlet mapped to view " & View;
      end if;
      if not (Route.all in ASF.Routes.Servlets.Servlet_Route_Type'Class) then
         raise Util.Serialize.Mappers.Field_Error with "View " & View & " not mapped to a servlet";
      end if;
      return ASF.Routes.Servlets.Servlet_Route_Type'Class (Route.all).Servlet;
   end Find_Servlet;

   --  ------------------------------
   --  Save in the servlet config object the value associated with the given field.
   --  When the URL_MAPPING, URL_PATTERN, VIEW_ID field
   --  is reached, insert the new configuration rule in the servlet registry.
   --  ------------------------------
   procedure Set_Member (N     : in out Servlet_Config;
                         Field : in Servlet_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use Util.Beans.Objects;
   begin
      case Field is
         when URL_PATTERN =>
            N.URL_Pattern := Value;

         when VIEW_ID =>
            N.View_Id := Value;

         when URL_MAPPING =>
            declare
               procedure Insert (Route : in out ASF.Routes.Route_Type_Ref);

               View    : constant String := To_String (N.View_Id);
               Servlet : constant ASF.Servlets.Servlet_Access := Find_Servlet (N.Handler, View);

               procedure Insert (Route : in out ASF.Routes.Route_Type_Ref) is
                  To : ASF.Routes.Servlets.Faces.Faces_Route_Type_Access;
               begin
                  if Route.Is_Null then
                     To := new ASF.Routes.Servlets.Faces.Faces_Route_Type;
                     To.View    := To_Unbounded_String (View);
                     To.Servlet := Servlet;
                     Route := ASF.Routes.Route_Type_Refs.Create (To.all'Access);
                  end if;
               end Insert;

            begin
               N.Handler.Add_Route (Pattern   => To_String (N.URL_Pattern),
                                    ELContext => N.Context.all,
                                    Process   => Insert'Access);
            end;
      end case;
   end Set_Member;

   SMapper : aliased Servlet_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the servlet and mapping rules <b>url-mapping</b>.
   --  ------------------------------
   package body Reader_Config is
   begin
      Reader.Add_Mapping ("faces-config", SMapper'Access);
      Reader.Add_Mapping ("module", SMapper'Access);
      Reader.Add_Mapping ("web-app", SMapper'Access);
      Config.Handler := Handler;
      Config.Context := Context;
      Servlet_Mapper.Set_Context (Reader, Config'Unchecked_Access);
   end Reader_Config;

begin
   SMapper.Add_Mapping ("url-mapping", URL_MAPPING);
   SMapper.Add_Mapping ("url-mapping/pattern", URL_PATTERN);
   SMapper.Add_Mapping ("url-mapping/view-id", VIEW_ID);
end ASF.Servlets.Faces.Mappers;

Update the route creation to use a Insert procedure for updating the route


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

with ASF.Requests;
with ASF.Responses;
with ASF.Server;
with Ada.IO_Exceptions;

with Util.Files;
with Util.Properties;

with EL.Contexts.Default;

with AWA.Modules.Reader;
with AWA.Applications;
package body AWA.Modules is

   --  ------------------------------
   --  Get the module configuration property identified by the name.
   --  If the configuration property does not exist, returns the default value.
   --  ------------------------------
   function Get_Config (Plugin  : Module_Manager;
                        Name    : String;
                        Default : String := "") return String is
   begin
      return Plugin.Module.all.Get_Config (Name, Default);
   end Get_Config;

   --  ------------------------------
   --  Get the module configuration property identified by the <tt>Config</tt> parameter.
   --  If the property does not exist, the default configuration value is returned.
   --  ------------------------------
   function Get_Config (Plugin : in Module_Manager;
                        Config : in ASF.Applications.Config_Param) return String is
   begin
      return Plugin.Module.all.Get_Config (Config);
   end Get_Config;

   --  ------------------------------
   --  Get the module name
   --  ------------------------------
   function Get_Name (Plugin : in Module) return String is
   begin
      return To_String (Plugin.Name);
   end Get_Name;

   --  ------------------------------
   --  Get the base URI for this module
   --  ------------------------------
   function Get_URI (Plugin : in Module) return String is
   begin
      return To_String (Plugin.URI);
   end Get_URI;

   --  ------------------------------
   --  Get the application in which this module is registered.
   --  ------------------------------
   function Get_Application (Plugin : in Module) return Application_Access is
   begin
      return Plugin.App;
   end Get_Application;

   --  ------------------------------
   --  Get the module configuration property identified by the name.
   --  If the configuration property does not exist, returns the default value.
   --  ------------------------------
   function Get_Config (Plugin  : Module;
                        Name    : String;
                        Default : String := "") return String is
   begin
      return Plugin.Config.Get (Name, Default);
   end Get_Config;

   --  ------------------------------
   --  Get the module configuration property identified by the name.
   --  If the configuration property does not exist, returns the default value.
   --  ------------------------------
   function Get_Config (Plugin  : in Module;
                        Name    : in String;
                        Default : in Integer := -1) return Integer is
      Value : constant String := Plugin.Config.Get (Name, Integer'Image (Default));
   begin
      return Integer'Value (Value);

   exception
      when Constraint_Error =>
         return Default;
   end Get_Config;

   --  ------------------------------
   --  Get the module configuration property identified by the <tt>Config</tt> parameter.
   --  If the property does not exist, the default configuration value is returned.
   --  ------------------------------
   function Get_Config (Plugin : in Module;
                        Config : in ASF.Applications.Config_Param) return String is
   begin
      return Plugin.Config.Get (Config);
   end Get_Config;

   --  ------------------------------
   --  Get the module configuration property identified by the <tt>Config</tt> parameter.
   --  If the property does not exist, the default configuration value is returned.
   --  ------------------------------
   function Get_Config (Plugin  : in Module;
                        Name    : in String;
                        Default : in String := "")
                        return EL.Expressions.Expression is

      type Event_ELResolver is new EL.Contexts.Default.Default_ELResolver with null record;

      overriding
      function Get_Value (Resolver : Event_ELResolver;
                          Context  : EL.Contexts.ELContext'Class;
                          Base     : access Util.Beans.Basic.Readonly_Bean'Class;
                          Name     : Unbounded_String) return Util.Beans.Objects.Object;

      --  ------------------------------
      --  Get the value associated with a base object and a given property.
      --  ------------------------------
      overriding
      function Get_Value (Resolver : Event_ELResolver;
                          Context  : EL.Contexts.ELContext'Class;
                          Base     : access Util.Beans.Basic.Readonly_Bean'Class;
                          Name     : Unbounded_String) return Util.Beans.Objects.Object is
      begin
         if Base /= null then
            return EL.Contexts.Default.Default_ELResolver (Resolver).Get_Value (Context, Base,
                                                                                Name);
         else
            return Util.Beans.Objects.To_Object (Plugin.Get_Config (To_String (Name), ""));
         end if;
      end Get_Value;

      Resolver : aliased Event_ELResolver;
      Context  : EL.Contexts.Default.Default_Context;
      Value    : constant String := Plugin.Get_Config (Name, Default);
   begin
      Context.Set_Resolver (Resolver'Unchecked_Access);
      return EL.Expressions.Reduce_Expression (EL.Expressions.Create_Expression (Value, Context),
                                               Context);

   exception
      when E : others =>
         Log.Error ("Invalid parameter ", E, True);
         return EL.Expressions.Create_Expression ("", Context);

   end Get_Config;

   --  ------------------------------
   --  Send the event to the module
   --  ------------------------------
   procedure Send_Event (Plugin  : in Module;
                         Content : in AWA.Events.Module_Event'Class) is
   begin
      Plugin.App.Send_Event (Content);
   end Send_Event;

   --  ------------------------------
   --  Find the module with the given name
   --  ------------------------------
   function Find_Module (Plugin : Module;
                         Name   : String) return Module_Access is
   begin
      if Plugin.Registry = null then
         return null;
      end if;
      return Find_By_Name (Plugin.Registry.all, Name);
   end Find_Module;

   --  ------------------------------
   --  Register under the given name a function to create the bean instance when
   --  it is accessed for a first time.  The scope defines the scope of the bean.
   --  bean
   --  ------------------------------
   procedure Register (Plugin : in out Module;
                       Name    : in String;
                       Bind    : in ASF.Beans.Class_Binding_Access) is
   begin
      Plugin.App.Register_Class (Name, Bind);
   end Register;

   --  ------------------------------
   --  Finalize the module.
   --  ------------------------------
   overriding
   procedure Finalize (Plugin : in out Module) is
   begin
      null;
   end Finalize;

   procedure Initialize (Manager : in out Module_Manager;
                         Module  : in AWA.Modules.Module'Class) is
   begin
      Manager.Module := Module.Self;
   end Initialize;

   function Get_Value (Manager : in Module_Manager;
                       Name    : in String) return Util.Beans.Objects.Object is
      pragma Unreferenced (Manager, Name);
   begin
      return Util.Beans.Objects.Null_Object;
   end Get_Value;

   --  Module manager
   --
   --  ------------------------------
   --  Get the database connection for reading
   --  ------------------------------
   function Get_Session (Manager : Module_Manager)
                            return ADO.Sessions.Session is
   begin
      return Manager.Module.Get_Session;
   end Get_Session;

   --  ------------------------------
   --  Get the database connection for writing
   --  ------------------------------
   function Get_Master_Session (Manager : Module_Manager)
                                   return ADO.Sessions.Master_Session is
   begin
      return Manager.Module.Get_Master_Session;
   end Get_Master_Session;

   --  ------------------------------
   --  Send the event to the module.  The module identified by To is
   --  found and the event is posted on its event channel.
   --  ------------------------------
   procedure Send_Event (Manager : in Module_Manager;
                         Content : in AWA.Events.Module_Event'Class) is
   begin
      Manager.Module.Send_Event (Content);
   end Send_Event;

   procedure Initialize (Plugin : in out Module;
                         App    : in Application_Access;
                         Props  : in ASF.Applications.Config) is
      pragma Unreferenced (Props);
   begin
      Plugin.Self := Plugin'Unchecked_Access;
      Plugin.App := App;
   end Initialize;

   --  ------------------------------
   --  Initialize the registry
   --  ------------------------------
   procedure Initialize (Registry : in out Module_Registry;
                         Config   : in ASF.Applications.Config) is
   begin
      Registry.Config := Config;
   end Initialize;

   --  ------------------------------
   --  Register the module in the registry.
   --  ------------------------------
   procedure Register (Registry : in Module_Registry_Access;
                       App      : in Application_Access;
                       Plugin   : in Module_Access;
                       Name     : in String;
                       URI      : in String) is
      procedure Copy (Params : in Util.Properties.Manager'Class);

      procedure Copy (Params : in Util.Properties.Manager'Class) is
      begin
         Plugin.Config.Copy (From => Params, Prefix => Name & ".", Strip => True);
      end Copy;

      Paths : constant String := Registry.Config.Get (Applications.P_Module_Dir.P);
   begin
      Log.Info ("Register module '{0}' under URI '{1}'", Name, URI);

      if Plugin.Registry /= null then
         Log.Error ("Module '{0}' is already attached to a registry", Name);

         raise Program_Error with "Module '" & Name & "' already registered";
      end if;
      Plugin.App      := App;
      Plugin.Registry := Registry;
      Plugin.Name     := To_Unbounded_String (Name);
      Plugin.URI      := To_Unbounded_String (URI);
      Plugin.Registry.Name_Map.Insert (Name, Plugin);
      if URI /= "" then
         Plugin.Registry.URI_Map.Insert (URI, Plugin);
      end if;

      --  Load the module configuration file
      Log.Debug ("Module search path: {0}", Paths);
      declare
         Base  : constant String := Name & ".properties";
         Path  : constant String := Util.Files.Find_File_Path (Base, Paths);
      begin
         Plugin.Config.Load_Properties (Path => Path, Prefix => Name & ".", Strip => True);

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Log.Info ("Module configuration file '{0}' does not exist", Path);
      end;

      Plugin.Initialize (App, Plugin.Config);

      --  Read the module XML configuration file if there is one.
      declare
         Base : constant String := Plugin.Config.Get ("config", Name & ".xml");
         Path : constant String := Util.Files.Find_File_Path (Base, Paths);
         Ctx  : aliased EL.Contexts.Default.Default_Context;
      begin
         AWA.Modules.Reader.Read_Configuration (Plugin.all, Path, Ctx'Unchecked_Access);

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Log.Warn ("Module configuration file '{0}' does not exist", Path);
      end;

      --  Override the module configuration with the application configuration
      App.Get_Init_Parameters (Copy'Access);

      Plugin.Configure (Plugin.Config);

   exception
      when Constraint_Error =>
         Log.Error ("Another module is already registered "
                    & "under name '{0}' or URI '{1}'", Name, URI);
         raise;
   end Register;

   --  ------------------------------
   --  Find the module with the given name
   --  ------------------------------
   function Find_By_Name (Registry : Module_Registry;
                          Name     : String) return Module_Access is
      Pos : constant Module_Maps.Cursor := Module_Maps.Find (Registry.Name_Map, Name);
   begin
      if Module_Maps.Has_Element (Pos) then
         return Module_Maps.Element (Pos);
      end if;
      return null;
   end Find_By_Name;

   --  ------------------------------
   --  Find the module mapped to a given URI
   --  ------------------------------
   function Find_By_URI (Registry : Module_Registry;
                         URI      : String) return Module_Access is
      Pos : constant Module_Maps.Cursor := Module_Maps.Find (Registry.URI_Map, URI);
   begin
      if Module_Maps.Has_Element (Pos) then
         return Module_Maps.Element (Pos);
      end if;
      return null;
   end Find_By_URI;

   --  ------------------------------
   --  Iterate over the modules that have been registered and execute the Process
   --  procedure on each of the module instance.
   --  ------------------------------
   procedure Iterate (Registry : in Module_Registry;
                      Process  : access procedure (Plugin : in out Module'Class)) is
      Iter : Module_Maps.Cursor := Registry.Name_Map.First;
   begin
      while Module_Maps.Has_Element (Iter) loop
         Process (Module_Maps.Element (Iter).all);
         Module_Maps.Next (Iter);
      end loop;
   end Iterate;

   --  ------------------------------
   --  Get the database connection for reading
   --  ------------------------------
   function Get_Session (Manager : Module)
                            return ADO.Sessions.Session is
   begin
      return Manager.App.Get_Session;
   end Get_Session;

   --  ------------------------------
   --  Get the database connection for writing
   --  ------------------------------
   function Get_Master_Session (Manager : Module)
                                return ADO.Sessions.Master_Session is
   begin
      return Manager.App.Get_Master_Session;
   end Get_Master_Session;

   --  ------------------------------
   --  Add a listener to the module listner list.  The module will invoke the listner
   --  depending on events or actions that occur in the module.
   --  ------------------------------
   procedure Add_Listener (Into : in out Module;
                           Item : in Util.Listeners.Listener_Access) is
   begin
      Util.Listeners.Add_Listener (Into.Listeners, Item);
   end Add_Listener;

   --  ------------------------------
   --  Find the module with the given name in the application and add the listener to the
   --  module listener list.
   --  ------------------------------
   procedure Add_Listener (Plugin : in Module;
                           Name   : in String;
                           Item   : in Util.Listeners.Listener_Access) is
      M : constant Module_Access := Plugin.App.Find_Module (Name);
   begin
      if M = null then
         Log.Error ("Cannot find module {0} to add a lifecycle listener", Name);
      else
         M.Add_Listener (Item);
      end if;
   end Add_Listener;

   --  ------------------------------
   --  Remove a listener from the module listener list.
   --  ------------------------------
   procedure Remove_Listener (Into : in out Module;
                              Item : in Util.Listeners.Listener_Access) is
   begin
      Util.Listeners.Remove_Listener (Into.Listeners, Item);
   end Remove_Listener;

   --  Get per request manager => look in Request
   --  Get per session manager => look in Request.Get_Session
   --  Get per application manager => look in Application
   --  Get per pool manager => look in pool attached to Application
   function Get_Manager return Manager_Type_Access is

      procedure Process (Request  : in out ASF.Requests.Request'Class;
                         Response : in out ASF.Responses.Response'Class);

      Value : Util.Beans.Objects.Object;

      procedure Process (Request  : in out ASF.Requests.Request'Class;
                         Response : in out ASF.Responses.Response'Class) is
         pragma Unreferenced (Response);
      begin
         Value := Request.Get_Attribute (Name);
         if Util.Beans.Objects.Is_Null (Value) then
            declare
               M : constant Manager_Type_Access := new Manager_Type;
            begin
               Value := Util.Beans.Objects.To_Object (M.all'Unchecked_Access);
               Request.Set_Attribute (Name, Value);
            end;
         end if;
      end Process;

   begin
      ASF.Server.Update_Context (Process'Access);
      if Util.Beans.Objects.Is_Null (Value) then
         return null;
      end if;
      declare
         B : constant access Util.Beans.Basic.Readonly_Bean'Class
           := Util.Beans.Objects.To_Bean (Value);
      begin
         if not (B.all in Manager_Type'Class) then
            return null;
         end if;
         return Manager_Type'Class (B.all)'Unchecked_Access;
      end;
   end Get_Manager;

end AWA.Modules;

-----------------------------------------------------------------------
--  awa -- Ada Web Application
--  Copyright (C) 2009, 2010, 2011, 2012, 2015, 2016, 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 ASF.Requests;
with ASF.Responses;
with ASF.Server;
with Ada.IO_Exceptions;

with Util.Files;
with Util.Properties;

with EL.Contexts.Default;

with AWA.Modules.Reader;
with AWA.Applications;
package body AWA.Modules is

   --  ------------------------------
   --  Get the module configuration property identified by the name.
   --  If the configuration property does not exist, returns the default value.
   --  ------------------------------
   function Get_Config (Plugin  : Module_Manager;
                        Name    : String;
                        Default : String := "") return String is
   begin
      return Plugin.Module.all.Get_Config (Name, Default);
   end Get_Config;

   --  ------------------------------
   --  Get the module configuration property identified by the <tt>Config</tt> parameter.
   --  If the property does not exist, the default configuration value is returned.
   --  ------------------------------
   function Get_Config (Plugin : in Module_Manager;
                        Config : in ASF.Applications.Config_Param) return String is
   begin
      return Plugin.Module.all.Get_Config (Config);
   end Get_Config;

   --  ------------------------------
   --  Get the module name
   --  ------------------------------
   function Get_Name (Plugin : in Module) return String is
   begin
      return To_String (Plugin.Name);
   end Get_Name;

   --  ------------------------------
   --  Get the base URI for this module
   --  ------------------------------
   function Get_URI (Plugin : in Module) return String is
   begin
      return To_String (Plugin.URI);
   end Get_URI;

   --  ------------------------------
   --  Get the application in which this module is registered.
   --  ------------------------------
   function Get_Application (Plugin : in Module) return Application_Access is
   begin
      return Plugin.App;
   end Get_Application;

   --  ------------------------------
   --  Get the module configuration property identified by the name.
   --  If the configuration property does not exist, returns the default value.
   --  ------------------------------
   function Get_Config (Plugin  : Module;
                        Name    : String;
                        Default : String := "") return String is
   begin
      return Plugin.Config.Get (Name, Default);
   end Get_Config;

   --  ------------------------------
   --  Get the module configuration property identified by the name.
   --  If the configuration property does not exist, returns the default value.
   --  ------------------------------
   function Get_Config (Plugin  : in Module;
                        Name    : in String;
                        Default : in Integer := -1) return Integer is
      Value : constant String := Plugin.Config.Get (Name, Integer'Image (Default));
   begin
      return Integer'Value (Value);

   exception
      when Constraint_Error =>
         return Default;
   end Get_Config;

   --  ------------------------------
   --  Get the module configuration property identified by the name.
   --  If the configuration property does not exist, returns the default value.
   --  ------------------------------
   function Get_Config (Plugin  : in Module;
                        Name    : in String;
                        Default : in Boolean := False) return Boolean is
      Value : constant String := Plugin.Config.Get (Name, Boolean'Image (Default));
   begin
      if Value in "yes" | "true" | "1" then
         return True;
      else
         return False;
      end if;

   exception
      when Constraint_Error =>
         return Default;
   end Get_Config;

   --  ------------------------------
   --  Get the module configuration property identified by the <tt>Config</tt> parameter.
   --  If the property does not exist, the default configuration value is returned.
   --  ------------------------------
   function Get_Config (Plugin : in Module;
                        Config : in ASF.Applications.Config_Param) return String is
   begin
      return Plugin.Config.Get (Config);
   end Get_Config;

   --  ------------------------------
   --  Get the module configuration property identified by the <tt>Config</tt> parameter.
   --  If the property does not exist, the default configuration value is returned.
   --  ------------------------------
   function Get_Config (Plugin  : in Module;
                        Name    : in String;
                        Default : in String := "")
                        return EL.Expressions.Expression is

      type Event_ELResolver is new EL.Contexts.Default.Default_ELResolver with null record;

      overriding
      function Get_Value (Resolver : Event_ELResolver;
                          Context  : EL.Contexts.ELContext'Class;
                          Base     : access Util.Beans.Basic.Readonly_Bean'Class;
                          Name     : Unbounded_String) return Util.Beans.Objects.Object;

      --  ------------------------------
      --  Get the value associated with a base object and a given property.
      --  ------------------------------
      overriding
      function Get_Value (Resolver : Event_ELResolver;
                          Context  : EL.Contexts.ELContext'Class;
                          Base     : access Util.Beans.Basic.Readonly_Bean'Class;
                          Name     : Unbounded_String) return Util.Beans.Objects.Object is
      begin
         if Base /= null then
            return EL.Contexts.Default.Default_ELResolver (Resolver).Get_Value (Context, Base,
                                                                                Name);
         else
            return Util.Beans.Objects.To_Object (Plugin.Get_Config (To_String (Name), ""));
         end if;
      end Get_Value;

      Resolver : aliased Event_ELResolver;
      Context  : EL.Contexts.Default.Default_Context;
      Value    : constant String := Plugin.Get_Config (Name, Default);
   begin
      Context.Set_Resolver (Resolver'Unchecked_Access);
      return EL.Expressions.Reduce_Expression (EL.Expressions.Create_Expression (Value, Context),
                                               Context);

   exception
      when E : others =>
         Log.Error ("Invalid parameter ", E, True);
         return EL.Expressions.Create_Expression ("", Context);

   end Get_Config;

   --  ------------------------------
   --  Send the event to the module
   --  ------------------------------
   procedure Send_Event (Plugin  : in Module;
                         Content : in AWA.Events.Module_Event'Class) is
   begin
      Plugin.App.Send_Event (Content);
   end Send_Event;

   --  ------------------------------
   --  Find the module with the given name
   --  ------------------------------
   function Find_Module (Plugin : Module;
                         Name   : String) return Module_Access is
   begin
      if Plugin.Registry = null then
         return null;
      end if;
      return Find_By_Name (Plugin.Registry.all, Name);
   end Find_Module;

   --  ------------------------------
   --  Register under the given name a function to create the bean instance when
   --  it is accessed for a first time.  The scope defines the scope of the bean.
   --  bean
   --  ------------------------------
   procedure Register (Plugin : in out Module;
                       Name    : in String;
                       Bind    : in ASF.Beans.Class_Binding_Access) is
   begin
      Plugin.App.Register_Class (Name, Bind);
   end Register;

   --  ------------------------------
   --  Finalize the module.
   --  ------------------------------
   overriding
   procedure Finalize (Plugin : in out Module) is
   begin
      null;
   end Finalize;

   procedure Initialize (Manager : in out Module_Manager;
                         Module  : in AWA.Modules.Module'Class) is
   begin
      Manager.Module := Module.Self;
   end Initialize;

   function Get_Value (Manager : in Module_Manager;
                       Name    : in String) return Util.Beans.Objects.Object is
      pragma Unreferenced (Manager, Name);
   begin
      return Util.Beans.Objects.Null_Object;
   end Get_Value;

   --  Module manager
   --
   --  ------------------------------
   --  Get the database connection for reading
   --  ------------------------------
   function Get_Session (Manager : Module_Manager)
                            return ADO.Sessions.Session is
   begin
      return Manager.Module.Get_Session;
   end Get_Session;

   --  ------------------------------
   --  Get the database connection for writing
   --  ------------------------------
   function Get_Master_Session (Manager : Module_Manager)
                                   return ADO.Sessions.Master_Session is
   begin
      return Manager.Module.Get_Master_Session;
   end Get_Master_Session;

   --  ------------------------------
   --  Send the event to the module.  The module identified by To is
   --  found and the event is posted on its event channel.
   --  ------------------------------
   procedure Send_Event (Manager : in Module_Manager;
                         Content : in AWA.Events.Module_Event'Class) is
   begin
      Manager.Module.Send_Event (Content);
   end Send_Event;

   procedure Initialize (Plugin : in out Module;
                         App    : in Application_Access;
                         Props  : in ASF.Applications.Config) is
      pragma Unreferenced (Props);
   begin
      Plugin.Self := Plugin'Unchecked_Access;
      Plugin.App := App;
   end Initialize;

   --  ------------------------------
   --  Initialize the registry
   --  ------------------------------
   procedure Initialize (Registry : in out Module_Registry;
                         Config   : in ASF.Applications.Config) is
   begin
      Registry.Config := Config;
   end Initialize;

   --  ------------------------------
   --  Register the module in the registry.
   --  ------------------------------
   procedure Register (Registry : in Module_Registry_Access;
                       App      : in Application_Access;
                       Plugin   : in Module_Access;
                       Name     : in String;
                       URI      : in String) is
      procedure Copy (Params : in Util.Properties.Manager'Class);

      procedure Copy (Params : in Util.Properties.Manager'Class) is
      begin
         Plugin.Config.Copy (From => Params, Prefix => Name & ".", Strip => True);
      end Copy;

      Paths : constant String := Registry.Config.Get (Applications.P_Module_Dir.P);
   begin
      Log.Info ("Register module '{0}' under URI '{1}'", Name, URI);

      if Plugin.Registry /= null then
         Log.Error ("Module '{0}' is already attached to a registry", Name);

         raise Program_Error with "Module '" & Name & "' already registered";
      end if;
      Plugin.App      := App;
      Plugin.Registry := Registry;
      Plugin.Name     := To_Unbounded_String (Name);
      Plugin.URI      := To_Unbounded_String (URI);
      Plugin.Registry.Name_Map.Insert (Name, Plugin);
      if URI /= "" then
         Plugin.Registry.URI_Map.Insert (URI, Plugin);
      end if;

      --  Load the module configuration file
      Log.Debug ("Module search path: {0}", Paths);
      declare
         Base  : constant String := Name & ".properties";
         Path  : constant String := Util.Files.Find_File_Path (Base, Paths);
      begin
         Plugin.Config.Load_Properties (Path => Path, Prefix => Name & ".", Strip => True);

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Log.Info ("Module configuration file '{0}' does not exist", Path);
      end;

      Plugin.Initialize (App, Plugin.Config);

      --  Read the module XML configuration file if there is one.
      declare
         Base : constant String := Plugin.Config.Get ("config", Name & ".xml");
         Path : constant String := Util.Files.Find_File_Path (Base, Paths);
         Ctx  : aliased EL.Contexts.Default.Default_Context;
      begin
         AWA.Modules.Reader.Read_Configuration (Plugin.all, Path, Ctx'Unchecked_Access);

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Log.Warn ("Module configuration file '{0}' does not exist", Path);
      end;

      --  Override the module configuration with the application configuration
      App.Get_Init_Parameters (Copy'Access);

      Plugin.Configure (Plugin.Config);

   exception
      when Constraint_Error =>
         Log.Error ("Another module is already registered "
                    & "under name '{0}' or URI '{1}'", Name, URI);
         raise;
   end Register;

   --  ------------------------------
   --  Find the module with the given name
   --  ------------------------------
   function Find_By_Name (Registry : Module_Registry;
                          Name     : String) return Module_Access is
      Pos : constant Module_Maps.Cursor := Module_Maps.Find (Registry.Name_Map, Name);
   begin
      if Module_Maps.Has_Element (Pos) then
         return Module_Maps.Element (Pos);
      end if;
      return null;
   end Find_By_Name;

   --  ------------------------------
   --  Find the module mapped to a given URI
   --  ------------------------------
   function Find_By_URI (Registry : Module_Registry;
                         URI      : String) return Module_Access is
      Pos : constant Module_Maps.Cursor := Module_Maps.Find (Registry.URI_Map, URI);
   begin
      if Module_Maps.Has_Element (Pos) then
         return Module_Maps.Element (Pos);
      end if;
      return null;
   end Find_By_URI;

   --  ------------------------------
   --  Iterate over the modules that have been registered and execute the Process
   --  procedure on each of the module instance.
   --  ------------------------------
   procedure Iterate (Registry : in Module_Registry;
                      Process  : access procedure (Plugin : in out Module'Class)) is
      Iter : Module_Maps.Cursor := Registry.Name_Map.First;
   begin
      while Module_Maps.Has_Element (Iter) loop
         Process (Module_Maps.Element (Iter).all);
         Module_Maps.Next (Iter);
      end loop;
   end Iterate;

   --  ------------------------------
   --  Get the database connection for reading
   --  ------------------------------
   function Get_Session (Manager : Module)
                            return ADO.Sessions.Session is
   begin
      return Manager.App.Get_Session;
   end Get_Session;

   --  ------------------------------
   --  Get the database connection for writing
   --  ------------------------------
   function Get_Master_Session (Manager : Module)
                                return ADO.Sessions.Master_Session is
   begin
      return Manager.App.Get_Master_Session;
   end Get_Master_Session;

   --  ------------------------------
   --  Add a listener to the module listner list.  The module will invoke the listner
   --  depending on events or actions that occur in the module.
   --  ------------------------------
   procedure Add_Listener (Into : in out Module;
                           Item : in Util.Listeners.Listener_Access) is
   begin
      Util.Listeners.Add_Listener (Into.Listeners, Item);
   end Add_Listener;

   --  ------------------------------
   --  Find the module with the given name in the application and add the listener to the
   --  module listener list.
   --  ------------------------------
   procedure Add_Listener (Plugin : in Module;
                           Name   : in String;
                           Item   : in Util.Listeners.Listener_Access) is
      M : constant Module_Access := Plugin.App.Find_Module (Name);
   begin
      if M = null then
         Log.Error ("Cannot find module {0} to add a lifecycle listener", Name);
      else
         M.Add_Listener (Item);
      end if;
   end Add_Listener;

   --  ------------------------------
   --  Remove a listener from the module listener list.
   --  ------------------------------
   procedure Remove_Listener (Into : in out Module;
                              Item : in Util.Listeners.Listener_Access) is
   begin
      Util.Listeners.Remove_Listener (Into.Listeners, Item);
   end Remove_Listener;

   --  Get per request manager => look in Request
   --  Get per session manager => look in Request.Get_Session
   --  Get per application manager => look in Application
   --  Get per pool manager => look in pool attached to Application
   function Get_Manager return Manager_Type_Access is

      procedure Process (Request  : in out ASF.Requests.Request'Class;
                         Response : in out ASF.Responses.Response'Class);

      Value : Util.Beans.Objects.Object;

      procedure Process (Request  : in out ASF.Requests.Request'Class;
                         Response : in out ASF.Responses.Response'Class) is
         pragma Unreferenced (Response);
      begin
         Value := Request.Get_Attribute (Name);
         if Util.Beans.Objects.Is_Null (Value) then
            declare
               M : constant Manager_Type_Access := new Manager_Type;
            begin
               Value := Util.Beans.Objects.To_Object (M.all'Unchecked_Access);
               Request.Set_Attribute (Name, Value);
            end;
         end if;
      end Process;

   begin
      ASF.Server.Update_Context (Process'Access);
      if Util.Beans.Objects.Is_Null (Value) then
         return null;
      end if;
      declare
         B : constant access Util.Beans.Basic.Readonly_Bean'Class
           := Util.Beans.Objects.To_Bean (Value);
      begin
         if not (B.all in Manager_Type'Class) then
            return null;
         end if;
         return Manager_Type'Class (B.all)'Unchecked_Access;
      end;
   end Get_Manager;

end AWA.Modules;

Implement the Get_Config function to retrieve a boolean configuration parameter


-----------------------------------------------------------------------
--  util-commands -- Support to make command line tools
--  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.Command_Line;
with Ada.Characters.Handling;
package body Util.Commands is

   --  ------------------------------
   --  Get the number of arguments available.
   --  ------------------------------
   overriding
   function Get_Count (List : in Default_Argument_List) return Natural is
      Count : constant Natural := Ada.Command_Line.Argument_Count;
   begin
      if Count > List.Offset then
         return Count - List.Offset;
      else
         return 0;
      end if;
   end Get_Count;

   --  ------------------------------
   --  Get the argument at the given position.
   --  ------------------------------
   overriding
   function Get_Argument (List : in Default_Argument_List;
                          Pos  : in Positive) return String is
   begin
      return Ada.Command_Line.Argument (Pos + List.Offset);
   end Get_Argument;

   --  ------------------------------
   --  Get the command name.
   --  ------------------------------
   function Get_Command_Name (List : in Default_Argument_List) return String is
      pragma Unreferenced (List);
   begin
      return Ada.Command_Line.Command_Name;
   end Get_Command_Name;

   --  ------------------------------
   --  Set the argument list to the given string and split the arguments.
   --  ------------------------------
   procedure Initialize (List : in out String_Argument_List;
                         Line : in String) is
      First : Natural := Line'First;
   begin
      List.Length := Line'Length;
      List.Line (1 .. Line'Length) := Line;
      List.Count := 0;
      loop
         while First <= Line'Length
           and then Ada.Characters.Handling.Is_Space (List.Line (First)) loop
            First := First + 1;
         end loop;
         exit when First > Line'Length;
         List.Start_Pos (List.Count) := First;
         while First <= Line'Length
           and then not Ada.Characters.Handling.Is_Space (List.Line (First)) loop
            First := First + 1;
         end loop;
         List.End_Pos (List.Count) := First - 1;
         List.Count := List.Count + 1;
      end loop;
      if List.Count > 0 then
         List.Count := List.Count - 1;
      end if;
   end Initialize;

   --  ------------------------------
   --  Get the number of arguments available.
   --  ------------------------------
   overriding
   function Get_Count (List : in String_Argument_List) return Natural is
   begin
      return List.Count;
   end Get_Count;

   --  ------------------------------
   --  Get the argument at the given position.
   --  ------------------------------
   overriding
   function Get_Argument (List : in String_Argument_List;
                          Pos  : in Positive) return String is
   begin
      return List.Line (List.Start_Pos (Pos) .. List.End_Pos (Pos));
   end Get_Argument;

   --  ------------------------------
   --  Get the command name.
   --  ------------------------------
   overriding
   function Get_Command_Name (List : in String_Argument_List) return String is
   begin
      return List.Line (List.Start_Pos (0) .. List.End_Pos (0));
   end Get_Command_Name;

end Util.Commands;

-----------------------------------------------------------------------
--  util-commands -- Support to make command line tools
--  Copyright (C) 2017, 2018 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.Command_Line;
with Ada.Characters.Handling;
package body Util.Commands is

   --  ------------------------------
   --  Get the number of arguments available.
   --  ------------------------------
   overriding
   function Get_Count (List : in Default_Argument_List) return Natural is
      Count : constant Natural := Ada.Command_Line.Argument_Count;
   begin
      if Count > List.Offset then
         return Count - List.Offset;
      else
         return 0;
      end if;
   end Get_Count;

   --  ------------------------------
   --  Get the argument at the given position.
   --  ------------------------------
   overriding
   function Get_Argument (List : in Default_Argument_List;
                          Pos  : in Positive) return String is
   begin
      return Ada.Command_Line.Argument (Pos + List.Offset);
   end Get_Argument;

   --  ------------------------------
   --  Get the command name.
   --  ------------------------------
   function Get_Command_Name (List : in Default_Argument_List) return String is
      pragma Unreferenced (List);
   begin
      return Ada.Command_Line.Command_Name;
   end Get_Command_Name;

   --  ------------------------------
   --  Set the argument list to the given string and split the arguments.
   --  ------------------------------
   procedure Initialize (List : in out String_Argument_List;
                         Line : in String) is
      First : Natural := Line'First;
   begin
      List.Length := Line'Length;
      List.Line (1 .. Line'Length) := Line;
      List.Count := 0;
      loop
         while First <= Line'Length
           and then Ada.Characters.Handling.Is_Space (List.Line (First)) loop
            First := First + 1;
         end loop;
         exit when First > Line'Length;
         List.Start_Pos (List.Count) := First;
         while First <= Line'Length
           and then not Ada.Characters.Handling.Is_Space (List.Line (First)) loop
            First := First + 1;
         end loop;
         List.End_Pos (List.Count) := First - 1;
         List.Count := List.Count + 1;
      end loop;
      if List.Count > 0 then
         List.Count := List.Count - 1;
      end if;
   end Initialize;

   --  ------------------------------
   --  Get the number of arguments available.
   --  ------------------------------
   overriding
   function Get_Count (List : in String_Argument_List) return Natural is
   begin
      return List.Count;
   end Get_Count;

   --  ------------------------------
   --  Get the argument at the given position.
   --  ------------------------------
   overriding
   function Get_Argument (List : in String_Argument_List;
                          Pos  : in Positive) return String is
   begin
      return List.Line (List.Start_Pos (Pos) .. List.End_Pos (Pos));
   end Get_Argument;

   --  ------------------------------
   --  Get the command name.
   --  ------------------------------
   overriding
   function Get_Command_Name (List : in String_Argument_List) return String is
   begin
      return List.Line (List.Start_Pos (0) .. List.End_Pos (0));
   end Get_Command_Name;

   --  ------------------------------
   --  Get the number of arguments available.
   --  ------------------------------
   function Get_Count (List : in Dynamic_Argument_List) return Natural is
   begin
      return Natural (List.List.Length);
   end Get_Count;

   --  ------------------------------
   --  Get the argument at the given position.
   --  ------------------------------
   function Get_Argument (List : in Dynamic_Argument_List;
                          Pos  : in Positive) return String is
   begin
      return List.List.Element (Pos);
   end Get_Argument;

   --  ------------------------------
   --  Get the command name.
   --  ------------------------------
   function Get_Command_Name (List : in Dynamic_Argument_List) return String is
   begin
      return List.List.Element (1);
   end Get_Command_Name;

end Util.Commands;

Implement Get_Count, Get_Argument, Get_Command_Name for the Dynamic_Argument_List type


-----------------------------------------------------------------------
--  mat-memory-tests -- Unit tests for MAT memory
--  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 Util.Test_Caller;

with MAT.Memory.Targets;
package body MAT.Memory.Tests is

   use Util.Tests;

   package Caller is new Util.Test_Caller (Test, "Memory");

   --  Builtin and well known definition of test frames.
   Frame_1_0 : constant MAT.Frames.Frame_Table (1 .. 10) :=
     (1_0, 1_2, 1_3, 1_4, 1_5, 1_6, 1_7, 1_8, 1_9, 1_10);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test MAT.Memory.Probe_Malloc",
                       Test_Probe_Malloc'Access);
      Caller.Add_Test (Suite, "Test MAT.Memory.Probe_Free",
                       Test_Probe_Free'Access);
   end Add_Tests;

   --  ------------------------------
   --  Basic consistency checks when creating the test tree
   --  ------------------------------
   procedure Test_Probe_Malloc (T : in out Test) is
      M    : MAT.Memory.Targets.Target_Memory;
      S    : Allocation;
      R    : Allocation_Map;
   begin
      S.Size :=  4;
      M.Create_Frame (Frame_1_0, S.Frame);

      --  Create memory slots:
      --   [10 .. 14] [20 .. 24] [30 ..34] .. [100 .. 104]
      for I in 1 .. 10 loop
         M.Probe_Malloc (MAT.Types.Target_Addr (10 * I), S);
      end loop;

      --  Search for a memory region that does not overlap a memory slot.
      M.Find (15, 19, R);
      Util.Tests.Assert_Equals (T, 0, Integer (R.Length),
                                "Find must return 0 slots in range [15 .. 19]");
      M.Find (1, 9, R);
      Util.Tests.Assert_Equals (T, 0, Integer (R.Length),
                                "Find must return 0 slots in range [1 .. 9]");
      M.Find (105, 1000, R);
      Util.Tests.Assert_Equals (T, 0, Integer (R.Length),
                                "Find must return 0 slots in range [105 .. 1000]");

      --  Search with an overlap.
      M.Find (1, 1000, R);
      Util.Tests.Assert_Equals (T, 10, Integer (R.Length),
                                "Find must return 10 slots in range [1 .. 1000]");

      R.Clear;
      M.Find (1, 19, R);
      Util.Tests.Assert_Equals (T, 1, Integer (R.Length),
                                "Find must return 1 slot in range [1 .. 19]");

      R.Clear;
      M.Find (13, 19, R);
      Util.Tests.Assert_Equals (T, 1, Integer (R.Length),
                                "Find must return 1 slot in range [13 .. 19]");

      R.Clear;
      M.Find (100, 1000, R);
      Util.Tests.Assert_Equals (T, 1, Integer (R.Length),
                                "Find must return 1 slot in range [100 .. 1000]");

      R.Clear;
      M.Find (101, 1000, R);
      Util.Tests.Assert_Equals (T, 1, Integer (R.Length),
                                "Find must return 1 slot in range [101 .. 1000]");

   end Test_Probe_Malloc;

   --  ------------------------------
   --  Test Probe_Free with update of memory slots.
   --  ------------------------------
   procedure Test_Probe_Free (T : in out Test) is
      M    : MAT.Memory.Targets.Target_Memory;
      S    : Allocation;
      R    : Allocation_Map;
   begin
      S.Size :=  4;
      M.Create_Frame (Frame_1_0, S.Frame);

      --  Malloc followed by a free.
      M.Probe_Malloc (10, S);
      M.Probe_Free (10, S);

      M.Find (1, 1000, R);
      Util.Tests.Assert_Equals (T, 0, Integer (R.Length),
                                "Find must return 0 slot after a free");

      --  Free the same slot a second time (free error).
      M.Probe_Free (10, S);

      --  Malloc followed by a free.
      M.Probe_Malloc (10, S);
      M.Probe_Malloc (20, S);
      M.Probe_Malloc (30, S);
      M.Probe_Free (20, S);

      M.Find (1, 1000, R);
      Util.Tests.Assert_Equals (T, 2, Integer (R.Length),
                                "Find must return 2 slots after a malloc/free sequence");
   end Test_Probe_Free;

end MAT.Memory.Tests;

-----------------------------------------------------------------------
--  mat-memory-tests -- Unit tests for MAT memory
--  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 Util.Test_Caller;

with MAT.Expressions;
with MAT.Memory.Targets;
package body MAT.Memory.Tests is

   use Util.Tests;

   package Caller is new Util.Test_Caller (Test, "Memory");

   --  Builtin and well known definition of test frames.
   Frame_1_0 : constant MAT.Frames.Frame_Table (1 .. 10) :=
     (1_0, 1_2, 1_3, 1_4, 1_5, 1_6, 1_7, 1_8, 1_9, 1_10);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test MAT.Memory.Probe_Malloc",
                       Test_Probe_Malloc'Access);
      Caller.Add_Test (Suite, "Test MAT.Memory.Probe_Free",
                       Test_Probe_Free'Access);
   end Add_Tests;

   --  ------------------------------
   --  Basic consistency checks when creating the test tree
   --  ------------------------------
   procedure Test_Probe_Malloc (T : in out Test) is
      M    : MAT.Memory.Targets.Target_Memory;
      S    : Allocation;
      R    : Allocation_Map;
   begin
      S.Size :=  4;
      M.Create_Frame (Frame_1_0, S.Frame);

      --  Create memory slots:
      --   [10 .. 14] [20 .. 24] [30 ..34] .. [100 .. 104]
      for I in 1 .. 10 loop
         M.Probe_Malloc (MAT.Types.Target_Addr (10 * I), S);
      end loop;

      --  Search for a memory region that does not overlap a memory slot.
      M.Find (15, 19, MAT.Expressions.EMPTY, R);
      Util.Tests.Assert_Equals (T, 0, Integer (R.Length),
                                "Find must return 0 slots in range [15 .. 19]");
      M.Find (1, 9, MAT.Expressions.EMPTY, R);
      Util.Tests.Assert_Equals (T, 0, Integer (R.Length),
                                "Find must return 0 slots in range [1 .. 9]");
      M.Find (105, 1000, MAT.Expressions.EMPTY, R);
      Util.Tests.Assert_Equals (T, 0, Integer (R.Length),
                                "Find must return 0 slots in range [105 .. 1000]");

      --  Search with an overlap.
      M.Find (1, 1000, MAT.Expressions.EMPTY, R);
      Util.Tests.Assert_Equals (T, 10, Integer (R.Length),
                                "Find must return 10 slots in range [1 .. 1000]");

      R.Clear;
      M.Find (1, 19, MAT.Expressions.EMPTY, R);
      Util.Tests.Assert_Equals (T, 1, Integer (R.Length),
                                "Find must return 1 slot in range [1 .. 19]");

      R.Clear;
      M.Find (13, 19, MAT.Expressions.EMPTY, R);
      Util.Tests.Assert_Equals (T, 1, Integer (R.Length),
                                "Find must return 1 slot in range [13 .. 19]");

      R.Clear;
      M.Find (100, 1000, MAT.Expressions.EMPTY, R);
      Util.Tests.Assert_Equals (T, 1, Integer (R.Length),
                                "Find must return 1 slot in range [100 .. 1000]");

      R.Clear;
      M.Find (101, 1000, MAT.Expressions.EMPTY, R);
      Util.Tests.Assert_Equals (T, 1, Integer (R.Length),
                                "Find must return 1 slot in range [101 .. 1000]");

   end Test_Probe_Malloc;

   --  ------------------------------
   --  Test Probe_Free with update of memory slots.
   --  ------------------------------
   procedure Test_Probe_Free (T : in out Test) is
      M    : MAT.Memory.Targets.Target_Memory;
      S    : Allocation;
      R    : Allocation_Map;
   begin
      S.Size :=  4;
      M.Create_Frame (Frame_1_0, S.Frame);

      --  Malloc followed by a free.
      M.Probe_Malloc (10, S);
      M.Probe_Free (10, S);

      M.Find (1, 1000, MAT.Expressions.EMPTY, R);
      Util.Tests.Assert_Equals (T, 0, Integer (R.Length),
                                "Find must return 0 slot after a free");

      --  Free the same slot a second time (free error).
      M.Probe_Free (10, S);

      --  Malloc followed by a free.
      M.Probe_Malloc (10, S);
      M.Probe_Malloc (20, S);
      M.Probe_Malloc (30, S);
      M.Probe_Free (20, S);

      M.Find (1, 1000, MAT.Expressions.EMPTY, R);
      Util.Tests.Assert_Equals (T, 2, Integer (R.Length),
                                "Find must return 2 slots after a malloc/free sequence");
   end Test_Probe_Free;

end MAT.Memory.Tests;

Add the EMPTY expression tree to the Find operation


-- Simple Lumen demo/test program, using earliest incomplete library.

with Ada.Command_Line;
with System.Address_To_Access_Conversions;

with Lumen.Events.Animate;
with Lumen.Image;
with Lumen.Window;

with GL;
with GLU;

procedure Texture is

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

   -- Rotation wraps around at this point, in degrees
   Max_Rotation : constant := 359;

   -- Traditional cinema framrate, in frames per second
   Framerate    : constant := 24;

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

   Win      : Lumen.Window.Handle;
   Event    : Lumen.Events.Event_Data;
   Wide     : Natural;  -- no longer have default values since they're now set by the image size
   High     : Natural;
   Rotation : Natural := 0;
   Image    : Lumen.Image.Descriptor;
   Img_Wide : GL.glFloat;
   Img_High : GL.glFloat;
   Tx_Name  : aliased GL.GLuint;

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

   Program_Exit : exception;

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

   -- Create a texture and bind a 2D image to it
   procedure Create_Texture is

      use GL;
      use GLU;

      package GLB is new System.Address_To_Access_Conversions (GLubyte);

      IP : GLpointer;

   begin  -- Create_Texture

      -- Allocate a texture name
      glGenTextures (1, Tx_Name'Unchecked_Access);

      -- Bind texture operations to the newly-created texture name
      glBindTexture (GL_TEXTURE_2D, Tx_Name);

      -- Select modulate to mix texture with color for shading
      glTexEnvi (GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE);

      -- Wrap textures at both edges
      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT);
      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_REPEAT);

      -- How the texture behaves when minified and magnified
      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST);
      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST);

      -- Create a pointer to the image.  This sort of horror show is going to
      -- be disappearing once Lumen includes its own OpenGL bindings.
      IP := GLB.To_Pointer (Image.Values (0, 0)'Address).all'Unchecked_Access;

      -- Build our texture from the image we loaded earlier
      glTexImage2D (GL_TEXTURE_2D, 0, GL_RGBA, GLsizei (Image.Width), GLsizei (Image.Height), 0,
                    GL_RGBA, GL_UNSIGNED_BYTE, IP);

   end Create_Texture;

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

   -- Set or reset the window view parameters
   procedure Set_View (W, H : in Natural) is

      use GL;
      use GLU;

      Aspect : GLdouble;

   begin  -- Set_View

      -- Viewport dimensions
      glViewport (0, 0, GLsizei (W), GLsizei (H));

      -- Size of rectangle upon which image is mapped
      if Wide > High then
         Img_Wide := glFloat (1.5);
         Img_High := glFloat (1.5) * glFloat (Float (High) / Float (Wide));
      else
         Img_Wide := glFloat (1.5) * glFloat (Float (Wide) / Float (High));
         Img_High := glFloat (1.5);
      end if;

      -- Set up the projection matrix based on the window's shape--wider than
      -- high, or higher than wide
      glMatrixMode (GL_PROJECTION);
      glLoadIdentity;

      -- Set up a 3D viewing frustum, which is basically a truncated pyramid
      -- in which the scene takes place.  Roughly, the narrow end is your
      -- screen, and the wide end is 10 units away from the camera.
      if W <= H then
         Aspect := GLdouble (H) / GLdouble (W);
         glFrustum (-1.0, 1.0, -Aspect, Aspect, 2.0, 10.0);
      else
         Aspect := GLdouble (W) / GLdouble (H);
         glFrustum (-Aspect, Aspect, -1.0, 1.0, 2.0, 10.0);
      end if;

   end Set_View;

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

   -- Draw our scene
   procedure Draw is

      use GL;

   begin  -- Draw

      -- Set a black background
      glClearColor (0.8, 0.8, 0.8, 1.0);
      glClear (GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);

      -- Draw a texture-mapped rectangle with the same aspect ratio as the
      -- original image
      glBegin (GL_POLYGON);
      begin
         glTexCoord3f (0.0, 1.0, 0.0);
         glVertex3f (-Img_Wide, -Img_High, 0.0);

         glTexCoord3f (0.0, 0.0, 0.0);
         glVertex3f (-Img_Wide,  Img_High, 0.0);

         glTexCoord3f (1.0, 0.0, 0.0);
         glVertex3f ( Img_Wide,  Img_High, 0.0);

         glTexCoord3f (1.0, 1.0, 0.0);
         glVertex3f ( Img_Wide, -Img_High, 0.0);
      end;
      glEnd;

      -- Rotate the object around the Y and Z axes by the current amount, to
      -- give a "tumbling" effect.
      glMatrixMode (GL_MODELVIEW);
      glLoadIdentity;
      glTranslated (0.0, 0.0, -4.0);
      glRotated (GLdouble (Rotation), 0.0, 1.0, 0.0);
      glRotated (GLdouble (Rotation), 0.0, 0.0, 1.0);

      glFlush;

      -- Now show it
      Lumen.Window.Swap (Win);

   end Draw;

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

   -- Simple event handler routine for keypresses and close-window events
   procedure Quit_Handler (Event : in Lumen.Events.Event_Data) is
   begin  -- Quit_Handler
      raise Program_Exit;
   end Quit_Handler;

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

   -- Simple event handler routine for Exposed events
   procedure Expose_Handler (Event : in Lumen.Events.Event_Data) is
   begin  -- Expose_Handler
      Draw;
   end Expose_Handler;

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

   -- Simple event handler routine for Resized events
   procedure Resize_Handler (Event : in Lumen.Events.Event_Data) is
   begin  -- Resize_Handler
      Wide := Event.Resize_Data.Width;
      High := Event.Resize_Data.Height;
      Set_View (Wide, High);
      Draw;
   end Resize_Handler;

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

   -- Our draw-a-frame routine, should get called FPS times a second
   procedure New_Frame (Frame_Delta : in Duration) is
   begin  -- New_Frame
      if Rotation >= Max_Rotation then
         Rotation := 0;
      else
         Rotation := Rotation + 1;
      end if;

      Draw;
   end New_Frame;

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

begin  -- Texture

   -- If we haven't been given an image to work with, just do nothing
   if Ada.Command_Line.Argument_Count < 1 then
      raise Program_Exit;
   end if;

   -- Read image and use it to size the window.  This will suck if your image
   -- is very large.
   Image := Lumen.Image.From_File (Ada.Command_Line.Argument (1));
   Wide := Image.Width;
   High := Image.Height;

   -- Create Lumen window, accepting most defaults; turn double buffering off
   -- for simplicity
   Lumen.Window.Create (Win, Name   => "Spinning Picture Demo",
                        Width  => Wide,
                        Height => High,
                        Events => (Lumen.Window.Want_Key_Press => True,
                                   Lumen.Window.Want_Exposure  => True,
                                   others => False));

   -- Set up the viewport and scene parameters
   Set_View (Wide, High);

   -- Now create the texture and set up to use it
   Create_Texture;
   GL.glEnable (GL.GL_TEXTURE_2D);
   GL.glBindTexture (GL.GL_TEXTURE_2D, Tx_Name);

   -- Enter the event loop
   declare
      use Lumen.Events;
   begin
      Animate.Select_Events (Win   => Win,
                             Calls => (Key_Press    => Quit_Handler'Unrestricted_Access,
                                       Exposed      => Expose_Handler'Unrestricted_Access,
                                       Resized      => Resize_Handler'Unrestricted_Access,
                                       Close_Window => Quit_Handler'Unrestricted_Access,
                                       others       => No_Callback),
                             FPS   => Framerate,
                             Frame => New_Frame'Unrestricted_Access);
   end;

exception
   when Program_Exit =>
      null;  -- just exit this block, which terminates the app

end Texture;

-- Simple Lumen demo/test program, using earliest incomplete library.

with Ada.Command_Line;
with System.Address_To_Access_Conversions;

with Lumen.Events.Animate;
with Lumen.Image;
with Lumen.Window;

with GL;
with GLU;

procedure Texture is

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

   -- Rotation wraps around at this point, in degrees
   Max_Rotation : constant := 359;

   -- Traditional cinema framrate, in frames per second
   Framerate    : constant := 24;

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

   Win      : Lumen.Window.Handle;
   Direct   : Boolean := True;
   Event    : Lumen.Events.Event_Data;
   Wide     : Natural;  -- no longer have default values since they're now set by the image size
   High     : Natural;
   Rotation : Natural := 0;
   Image    : Lumen.Image.Descriptor;
   Img_Wide : GL.glFloat;
   Img_High : GL.glFloat;
   Tx_Name  : aliased GL.GLuint;

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

   Program_Exit : exception;

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

   -- Create a texture and bind a 2D image to it
   procedure Create_Texture is

      use GL;
      use GLU;

      package GLB is new System.Address_To_Access_Conversions (GLubyte);

      IP : GLpointer;

   begin  -- Create_Texture

      -- Allocate a texture name
      glGenTextures (1, Tx_Name'Unchecked_Access);

      -- Bind texture operations to the newly-created texture name
      glBindTexture (GL_TEXTURE_2D, Tx_Name);

      -- Select modulate to mix texture with color for shading
      glTexEnvi (GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE);

      -- Wrap textures at both edges
      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT);
      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_REPEAT);

      -- How the texture behaves when minified and magnified
      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST);
      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST);

      -- Create a pointer to the image.  This sort of horror show is going to
      -- be disappearing once Lumen includes its own OpenGL bindings.
      IP := GLB.To_Pointer (Image.Values (0, 0)'Address).all'Unchecked_Access;

      -- Build our texture from the image we loaded earlier
      glTexImage2D (GL_TEXTURE_2D, 0, GL_RGBA, GLsizei (Image.Width), GLsizei (Image.Height), 0,
                    GL_RGBA, GL_UNSIGNED_BYTE, IP);

   end Create_Texture;

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

   -- Set or reset the window view parameters
   procedure Set_View (W, H : in Natural) is

      use GL;
      use GLU;

      Aspect : GLdouble;

   begin  -- Set_View

      -- Viewport dimensions
      glViewport (0, 0, GLsizei (W), GLsizei (H));

      -- Size of rectangle upon which image is mapped
      if Wide > High then
         Img_Wide := glFloat (1.5);
         Img_High := glFloat (1.5) * glFloat (Float (High) / Float (Wide));
      else
         Img_Wide := glFloat (1.5) * glFloat (Float (Wide) / Float (High));
         Img_High := glFloat (1.5);
      end if;

      -- Set up the projection matrix based on the window's shape--wider than
      -- high, or higher than wide
      glMatrixMode (GL_PROJECTION);
      glLoadIdentity;

      -- Set up a 3D viewing frustum, which is basically a truncated pyramid
      -- in which the scene takes place.  Roughly, the narrow end is your
      -- screen, and the wide end is 10 units away from the camera.
      if W <= H then
         Aspect := GLdouble (H) / GLdouble (W);
         glFrustum (-1.0, 1.0, -Aspect, Aspect, 2.0, 10.0);
      else
         Aspect := GLdouble (W) / GLdouble (H);
         glFrustum (-Aspect, Aspect, -1.0, 1.0, 2.0, 10.0);
      end if;

   end Set_View;

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

   -- Draw our scene
   procedure Draw is

      use GL;

   begin  -- Draw

      -- Set a black background
      glClearColor (0.8, 0.8, 0.8, 1.0);
      glClear (GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);

      -- Draw a texture-mapped rectangle with the same aspect ratio as the
      -- original image
      glBegin (GL_POLYGON);
      begin
         glTexCoord3f (0.0, 1.0, 0.0);
         glVertex3f (-Img_Wide, -Img_High, 0.0);

         glTexCoord3f (0.0, 0.0, 0.0);
         glVertex3f (-Img_Wide,  Img_High, 0.0);

         glTexCoord3f (1.0, 0.0, 0.0);
         glVertex3f ( Img_Wide,  Img_High, 0.0);

         glTexCoord3f (1.0, 1.0, 0.0);
         glVertex3f ( Img_Wide, -Img_High, 0.0);
      end;
      glEnd;

      -- Rotate the object around the Y and Z axes by the current amount, to
      -- give a "tumbling" effect.
      glMatrixMode (GL_MODELVIEW);
      glLoadIdentity;
      glTranslated (0.0, 0.0, -4.0);
      glRotated (GLdouble (Rotation), 0.0, 1.0, 0.0);
      glRotated (GLdouble (Rotation), 0.0, 0.0, 1.0);

      glFlush;

      -- Now show it
      Lumen.Window.Swap (Win);

   end Draw;

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

   -- Simple event handler routine for keypresses and close-window events
   procedure Quit_Handler (Event : in Lumen.Events.Event_Data) is
   begin  -- Quit_Handler
      raise Program_Exit;
   end Quit_Handler;

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

   -- Simple event handler routine for Exposed events
   procedure Expose_Handler (Event : in Lumen.Events.Event_Data) is
   begin  -- Expose_Handler
      Draw;
   end Expose_Handler;

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

   -- Simple event handler routine for Resized events
   procedure Resize_Handler (Event : in Lumen.Events.Event_Data) is
   begin  -- Resize_Handler
      Wide := Event.Resize_Data.Width;
      High := Event.Resize_Data.Height;
      Set_View (Wide, High);
      Draw;
   end Resize_Handler;

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

   -- Our draw-a-frame routine, should get called FPS times a second
   procedure New_Frame (Frame_Delta : in Duration) is
   begin  -- New_Frame
      if Rotation >= Max_Rotation then
         Rotation := 0;
      else
         Rotation := Rotation + 1;
      end if;

      Draw;
   end New_Frame;

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

begin  -- Texture

   -- If we haven't been given an image to work with, just do nothing
   if Ada.Command_Line.Argument_Count < 1 then
      raise Program_Exit;
   end if;

   -- Read image and use it to size the window.  This will suck if your image
   -- is very large.
   Image := Lumen.Image.From_File (Ada.Command_Line.Argument (1));
   Wide := Image.Width;
   High := Image.Height;

   -- If the user provides a second argument, it means "no direct rendering"
   -- for the OpenGL context
   if Ada.Command_Line.Argument_Count > 1 then
      Direct := False;
   end if;

   -- Create Lumen window, accepting most defaults; turn double buffering off
   -- for simplicity
   Lumen.Window.Create (Win, Name   => "Spinning Picture Demo",
                        Width  => Wide,
                        Height => High,
                        Direct => Direct,
                        Events => (Lumen.Window.Want_Key_Press => True,
                                   Lumen.Window.Want_Exposure  => True,
                                   others => False));

   -- Set up the viewport and scene parameters
   Set_View (Wide, High);

   -- Now create the texture and set up to use it
   Create_Texture;
   GL.glEnable (GL.GL_TEXTURE_2D);
   GL.glBindTexture (GL.GL_TEXTURE_2D, Tx_Name);

   -- Enter the event loop
   declare
      use Lumen.Events;
   begin
      Animate.Select_Events (Win   => Win,
                             Calls => (Key_Press    => Quit_Handler'Unrestricted_Access,
                                       Exposed      => Expose_Handler'Unrestricted_Access,
                                       Resized      => Resize_Handler'Unrestricted_Access,
                                       Close_Window => Quit_Handler'Unrestricted_Access,
                                       others       => No_Callback),
                             FPS   => Framerate,
                             Frame => New_Frame'Unrestricted_Access);
   end;

exception
   when Program_Exit =>
      null;  -- just exit this block, which terminates the app

end Texture;

Allow a second command-line param, meaning "direct rendering off"


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

--  The Security.OAuth.Clients package implements the client OAuth 2.0 authorization.
--
--  Note: OAuth 1.0 could be implemented but since it's being deprecated it's not worth doing it.
package Security.OAuth.Clients is

   --  ------------------------------
   --  Access Token
   --  ------------------------------
   --  Access tokens are credentials used to access protected resources.
   --  The access token is represented as a Principal.  This is an opaque
   --  value for an application.
   type Access_Token (Len : Natural) is new Security.Principal with private;
   type Access_Token_Access is access all Access_Token'Class;

   --  Get the principal name.  This is the OAuth access token.
   function Get_Name (From : in Access_Token) return String;

   type OpenID_Token (Len, Id_Len, Refresh_Len : Natural) is new Access_Token with private;
   type OpenID_Token_Access is access all OpenID_Token'Class;

   --  Get the id_token that was returned by the authentication process.
   function Get_Id_Token (From : in OpenID_Token) return String;

   --  Generate a random nonce with at last the number of random bits.
   --  The number of bits is rounded up to a multiple of 32.
   --  The random bits are then converted to base64url in the returned string.
   function Create_Nonce (Bits : in Positive := 256) return String;

   type Grant_Type is new Security.Principal with private;

   --  Get the principal name.  This is the OAuth access token.
   function Get_Name (From : in Grant_Type) return String;

   --  ------------------------------
   --  Application
   --  ------------------------------
   --  The Application holds the necessary information to let a user
   --  grant access to its protected resources on the resource server.  It contains
   --  information that allows the OAuth authorization server to identify the
   --  application (client id and secret key).
   type Application is new Security.OAuth.Application with private;

   --  Set the OAuth authorization server URI that the application must use
   --  to exchange the OAuth code into an access token.
   procedure Set_Provider_URI (App : in out Application;
                               URI : in String);

   --  OAuth 2.0 Section 4.1.1  Authorization Request

   --  Build a unique opaque value used to prevent cross-site request forgery.
   --  The Nonce parameters is an optional but recommended unique value
   --  used only once.  The state value will be returned back by the OAuth provider.
   --  This protects the <tt>client_id</tt> and <tt>redirect_uri</tt> parameters.
   function Get_State (App   : in Application;
                       Nonce : in String) return String;

   --  Get the authenticate parameters to build the URI to redirect the user to
   --  the OAuth authorization form.
   function Get_Auth_Params (App : in Application;
                             State : in String;
                             Scope : in String := "") return String;

   --  OAuth 2.0 Section 4.1.2  Authorization Response

   --  Verify that the State opaque value was created by the Get_State
   --  operation with the given client and redirect URL.
   function Is_Valid_State (App   : in Application;
                            Nonce : in String;
                            State : in String) return Boolean;

   --  OAuth 2.0 Section 4.1.3.  Access Token Request
   --            Section 4.1.4.  Access Token Response

   --  Exchange the OAuth code into an access token.
   function Request_Access_Token (App  : in Application;
                                  Code : in String) return Access_Token_Access;

   --  Create the access token
   function Create_Access_Token (App      : in Application;
                                 Token    : in String;
                                 Refresh  : in String;
                                 Id_Token : in String;
                                 Expires  : in Natural) return Access_Token_Access;

private

   type Access_Token (Len : Natural) is new Security.Principal with record
      Access_Id : String (1 .. Len);
   end record;

   type OpenID_Token (Len, Id_Len, Refresh_Len : Natural) is new Access_Token (Len) with record
      Id_Token      : String (1 .. Id_Len);
      Refresh_Token : String (1 .. Refresh_Len);
   end record;

   type Application is new Security.OAuth.Application with record
      Request_URI : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   type Grant_Type is new Security.Principal with record
      Access_Token  : Ada.Strings.Unbounded.Unbounded_String;
      Refresh_Token : Ada.Strings.Unbounded.Unbounded_String;
      Id_Token      : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end Security.OAuth.Clients;

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

--  The Security.OAuth.Clients package implements the client OAuth 2.0 authorization.
--
--  Note: OAuth 1.0 could be implemented but since it's being deprecated it's not worth doing it.
package Security.OAuth.Clients is

   --  ------------------------------
   --  Access Token
   --  ------------------------------
   --  Access tokens are credentials used to access protected resources.
   --  The access token is represented as a Principal.  This is an opaque
   --  value for an application.
   type Access_Token (Len : Natural) is new Security.Principal with private;
   type Access_Token_Access is access all Access_Token'Class;

   --  Get the principal name.  This is the OAuth access token.
   function Get_Name (From : in Access_Token) return String;

   type OpenID_Token (Len, Id_Len, Refresh_Len : Natural) is new Access_Token with private;
   type OpenID_Token_Access is access all OpenID_Token'Class;

   --  Get the id_token that was returned by the authentication process.
   function Get_Id_Token (From : in OpenID_Token) return String;

   --  Generate a random nonce with at last the number of random bits.
   --  The number of bits is rounded up to a multiple of 32.
   --  The random bits are then converted to base64url in the returned string.
   function Create_Nonce (Bits : in Positive := 256) return String;

   type Grant_Type is new Security.Principal with private;

   --  Get the principal name.  This is the OAuth access token.
   function Get_Name (From : in Grant_Type) return String;

   --  ------------------------------
   --  Application
   --  ------------------------------
   --  The Application holds the necessary information to let a user
   --  grant access to its protected resources on the resource server.  It contains
   --  information that allows the OAuth authorization server to identify the
   --  application (client id and secret key).
   type Application is new Security.OAuth.Application with private;

   --  Set the OAuth authorization server URI that the application must use
   --  to exchange the OAuth code into an access token.
   procedure Set_Provider_URI (App : in out Application;
                               URI : in String);

   --  OAuth 2.0 Section 4.1.1  Authorization Request

   --  Build a unique opaque value used to prevent cross-site request forgery.
   --  The Nonce parameters is an optional but recommended unique value
   --  used only once.  The state value will be returned back by the OAuth provider.
   --  This protects the <tt>client_id</tt> and <tt>redirect_uri</tt> parameters.
   function Get_State (App   : in Application;
                       Nonce : in String) return String;

   --  Get the authenticate parameters to build the URI to redirect the user to
   --  the OAuth authorization form.
   function Get_Auth_Params (App : in Application;
                             State : in String;
                             Scope : in String := "") return String;

   --  OAuth 2.0 Section 4.1.2  Authorization Response

   --  Verify that the State opaque value was created by the Get_State
   --  operation with the given client and redirect URL.
   function Is_Valid_State (App   : in Application;
                            Nonce : in String;
                            State : in String) return Boolean;

   --  OAuth 2.0 Section 4.1.3.  Access Token Request
   --            Section 4.1.4.  Access Token Response

   --  Exchange the OAuth code into an access token.
   function Request_Access_Token (App  : in Application;
                                  Code : in String) return Access_Token_Access;

   --  Get a request token with username and password.
   --  RFC 6749: 4.3.  Resource Owner Password Credentials Grant
   procedure Request_Token (App      : in Application;
                            Username : in String;
                            Password : in String;
                            Scope    : in String;
                            Token    : in out Grant_Type'Class);

   --  Create the access token
   function Create_Access_Token (App      : in Application;
                                 Token    : in String;
                                 Refresh  : in String;
                                 Id_Token : in String;
                                 Expires  : in Natural) return Access_Token_Access;

private

   type Access_Token (Len : Natural) is new Security.Principal with record
      Access_Id : String (1 .. Len);
   end record;

   type OpenID_Token (Len, Id_Len, Refresh_Len : Natural) is new Access_Token (Len) with record
      Id_Token      : String (1 .. Id_Len);
      Refresh_Token : String (1 .. Refresh_Len);
   end record;

   type Application is new Security.OAuth.Application with record
      Request_URI : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   type Grant_Type is new Security.Principal with record
      Access_Token  : Ada.Strings.Unbounded.Unbounded_String;
      Refresh_Token : Ada.Strings.Unbounded.Unbounded_String;
      Id_Token      : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end Security.OAuth.Clients;

Declare the Request_Token procedure to get a grant using RFC 6749: 4.3. Resource Owner Password Credentials Grant