-----------------------------------------------------------------------
--  wiki-writers-builders -- Wiki writer to a string builder
--  Copyright (C) 2011, 2012, 2013, 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.Characters.Conversions;
package body Wiki.Writers.Builders is

   --  ------------------------------
   --  Write the content to the string builder.
   --  ------------------------------
   overriding
   procedure Write (Writer  : in out Writer_Builder_Type;
                    Content : in Wide_Wide_String) is
   begin
      Wide_Wide_Builders.Append (Writer.Content, Content);
   end Write;

   --  ------------------------------
   --  Write the content to the string builder.
   --  ------------------------------
   overriding
   procedure Write (Writer  : in out Writer_Builder_Type;
                    Content : in Unbounded_Wide_Wide_String) is
   begin
      Wide_Wide_Builders.Append (Writer.Content, To_Wide_Wide_String (Content));
   end Write;

   --  ------------------------------
   --  Iterate over the buffer content calling the <tt>Process</tt> procedure with each
   --  chunk.
   --  ------------------------------
   procedure Iterate (Source  : in Writer_Builder_Type;
                      Process : not null access procedure (Chunk : in Wide_Wide_String)) is
   begin
      Wide_Wide_Builders.Iterate (Source.Content, Process);
   end Iterate;

   --  ------------------------------
   --  Convert what was collected in the writer builder to a string and return it.
   --  ------------------------------
   function To_String (Source : in Writer_Builder_Type) return String is
      Pos    : Natural := 0;
      Result : String (1 .. Wide_Wide_Builders.Length (Source.Content));

      procedure Convert (Chunk : in Wide_Wide_String) is
      begin
         for I in Chunk'Range loop
            Pos := Pos + 1;
            Result (Pos) := Ada.Characters.Conversions.To_Character (Chunk (I));
         end loop;
      end Convert;

   begin
      Wide_Wide_Builders.Iterate (Source.Content, Convert'Access);
      return Result;
   end To_String;

   --  ------------------------------
   --  Write a single character to the string builder.
   --  ------------------------------
   procedure Write (Writer : in out Writer_Builder_Type;
                    Char   : in Wide_Wide_Character) is
   begin
      Wide_Wide_Builders.Append (Writer.Content, Char);
   end Write;

   --  ------------------------------
   --  Write a single character to the string builder.
   --  ------------------------------
   procedure Write_Char (Writer : in out Writer_Builder_Type;
                         Char   : in Character) is
   begin
      Wide_Wide_Builders.Append (Writer.Content,
                                 Ada.Characters.Conversions.To_Wide_Wide_Character (Char));
   end Write_Char;

   --  ------------------------------
   --  Write the string to the string builder.
   --  ------------------------------
   procedure Write_String (Writer : in out Writer_Builder_Type;
                           Content : in String) is
   begin
      for I in Content'Range loop
         Writer.Write_Char (Content (I));
      end loop;
   end Write_String;

   type Unicode_Char is mod 2**31;

   --  ------------------------------
   --  Internal method to write a character on the response stream
   --  and escape that character as necessary.  Unlike 'Write_Char',
   --  this operation does not closes the current XML entity.
   --  ------------------------------
   procedure Write_Escape (Stream : in out Html_Writer_Type'Class;
                           Char   : in Wide_Wide_Character) is
      Code : constant Unicode_Char := Wide_Wide_Character'Pos (Char);
   begin
      --  If "?" or over, no escaping is needed (this covers
      --  most of the Latin alphabet)
      if Code > 16#3F# or Code <= 16#20# then
         Stream.Write (Char);
      elsif Char = '<' then
         Stream.Write ("<");
      elsif Char = '>' then
         Stream.Write (">");
      elsif Char = '&' then
         Stream.Write ("&");
      else
         Stream.Write (Char);
      end if;
   end Write_Escape;

   --  ------------------------------
   --  Close the current XML entity if an entity was started
   --  ------------------------------
   procedure Close_Current (Stream : in out Html_writer_Type'Class) is
   begin
      if Stream.Close_Start then
         Stream.Write_Char ('>');
         Stream.Close_Start := False;
      end if;
   end Close_Current;

   procedure Write_Wide_Element (Writer  : in out Html_writer_Type;
                                 Name    : in String;
                                 Content : in Unbounded_Wide_Wide_String) is

   begin
      Writer.Start_Element (Name);
      Writer.Write_Wide_Text (Content);
      Writer.End_Element (Name);
   end Write_Wide_Element;

   procedure Write_Wide_Attribute (Writer  : in out Html_writer_Type;
                                   Name    : in String;
                                   Content : in Unbounded_Wide_Wide_String) is
      Count : constant Natural := Length (Content);
   begin
      if Writer.Close_Start then
         Writer.Write_Char (' ');
         Writer.Write_String (Name);
         Writer.Write_Char ('=');
         Writer.Write_Char ('"');
         for I in 1 .. Count loop
            declare
               C : constant Wide_Wide_Character := Element (Content, I);
            begin
               if C = '"' then
                  Writer.Write_String (""");
               else
                  Writer.Write_Escape (C);
               end if;
            end;
         end loop;
         Writer.Write_Char ('"');
      end if;
   end Write_Wide_Attribute;

   procedure Start_Element (Writer : in out Html_Writer_Type;
                            Name   : in String) is
   begin
      Close_Current (Writer);
      Writer.Write_Char ('<');
      Writer.Write_String (Name);
      Writer.Close_Start := True;
   end Start_Element;

   procedure End_Element (Writer : in out Html_Writer_Type;
                          Name   : in String) is
   begin
      Close_Current (Writer);
      Writer.Write_String ("</");
      Writer.Write_String (Name);
      Writer.Write_Char ('>');
   end End_Element;

   procedure Write_Wide_Text (Writer  : in out Html_Writer_Type;
                              Content : in Unbounded_Wide_Wide_String) is
      Count : constant Natural := Length (Content);
   begin
      Close_Current (Writer);
      if Count > 0 then
         for I in 1 .. Count loop
            Html_Writer_Type'Class (Writer).Write_Escape (Element (Content, I));
         end loop;
      end if;
   end Write_Wide_Text;

end Wiki.Writers.Builders;

-----------------------------------------------------------------------
--  wiki-writers-builders -- Wiki writer to a string builder
--  Copyright (C) 2011, 2012, 2013, 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.Characters.Conversions;
package body Wiki.Writers.Builders is

   --  ------------------------------
   --  Write the content to the string builder.
   --  ------------------------------
   overriding
   procedure Write (Writer  : in out Writer_Builder_Type;
                    Content : in Wide_Wide_String) is
   begin
      Wide_Wide_Builders.Append (Writer.Content, Content);
   end Write;

   --  ------------------------------
   --  Write the content to the string builder.
   --  ------------------------------
   overriding
   procedure Write (Writer  : in out Writer_Builder_Type;
                    Content : in Unbounded_Wide_Wide_String) is
   begin
      Wide_Wide_Builders.Append (Writer.Content, To_Wide_Wide_String (Content));
   end Write;

   --  ------------------------------
   --  Iterate over the buffer content calling the <tt>Process</tt> procedure with each
   --  chunk.
   --  ------------------------------
   procedure Iterate (Source  : in Writer_Builder_Type;
                      Process : not null access procedure (Chunk : in Wide_Wide_String)) is
   begin
      Wide_Wide_Builders.Iterate (Source.Content, Process);
   end Iterate;

   --  ------------------------------
   --  Convert what was collected in the writer builder to a string and return it.
   --  ------------------------------
   function To_String (Source : in Writer_Builder_Type) return String is
      Pos    : Natural := 0;
      Result : String (1 .. Wide_Wide_Builders.Length (Source.Content));

      procedure Convert (Chunk : in Wide_Wide_String) is
      begin
         for I in Chunk'Range loop
            Pos := Pos + 1;
            Result (Pos) := Ada.Characters.Conversions.To_Character (Chunk (I));
         end loop;
      end Convert;

   begin
      Wide_Wide_Builders.Iterate (Source.Content, Convert'Access);
      return Result;
   end To_String;

   --  ------------------------------
   --  Write a single character to the string builder.
   --  ------------------------------
   procedure Write (Writer : in out Writer_Builder_Type;
                    Char   : in Wide_Wide_Character) is
   begin
      Wide_Wide_Builders.Append (Writer.Content, Char);
   end Write;

   --  ------------------------------
   --  Write a single character to the string builder.
   --  ------------------------------
   procedure Write_Char (Writer : in out Writer_Builder_Type;
                         Char   : in Character) is
   begin
      Wide_Wide_Builders.Append (Writer.Content,
                                 Ada.Characters.Conversions.To_Wide_Wide_Character (Char));
   end Write_Char;

   --  ------------------------------
   --  Write the string to the string builder.
   --  ------------------------------
   procedure Write_String (Writer : in out Writer_Builder_Type;
                           Content : in String) is
   begin
      for I in Content'Range loop
         Writer.Write_Char (Content (I));
      end loop;
   end Write_String;

   type Unicode_Char is mod 2**31;

   --  ------------------------------
   --  Internal method to write a character on the response stream
   --  and escape that character as necessary.  Unlike 'Write_Char',
   --  this operation does not closes the current XML entity.
   --  ------------------------------
   procedure Write_Escape (Stream : in out Html_Writer_Type'Class;
                           Char   : in Wide_Wide_Character) is
      Code : constant Unicode_Char := Wide_Wide_Character'Pos (Char);
   begin
      --  If "?" or over, no escaping is needed (this covers
      --  most of the Latin alphabet)
      if Code > 16#3F# or Code <= 16#20# then
         Stream.Write (Char);
      elsif Char = '<' then
         Stream.Write ("<");
      elsif Char = '>' then
         Stream.Write (">");
      elsif Char = '&' then
         Stream.Write ("&");
      else
         Stream.Write (Char);
      end if;
   end Write_Escape;

   --  ------------------------------
   --  Close the current XML entity if an entity was started
   --  ------------------------------
   procedure Close_Current (Stream : in out Html_writer_Type'Class) is
   begin
      if Stream.Close_Start then
         Stream.Write_Char ('>');
         Stream.Close_Start := False;
      end if;
   end Close_Current;

   procedure Write_Wide_Element (Writer  : in out Html_writer_Type;
                                 Name    : in String;
                                 Content : in Unbounded_Wide_Wide_String) is

   begin
      Writer.Start_Element (Name);
      Writer.Write_Wide_Text (Content);
      Writer.End_Element (Name);
   end Write_Wide_Element;

   --  Write an XML attribute within an XML element.
   --  The attribute value is escaped according to the XML escape rules.
   procedure Write_Wide_Attribute (Writer  : in out Html_Writer_Type;
                                   Name    : in String;
                                   Content : in Wide_Wide_String) is
   begin
      if Writer.Close_Start then
         Writer.Write_Char (' ');
         Writer.Write_String (Name);
         Writer.Write_Char ('=');
         Writer.Write_Char ('"');
         for I in Content'Range loop
            declare
               C : constant Wide_Wide_Character := Content (I);
            begin
               if C = '"' then
                  Writer.Write_String (""");
               else
                  Writer.Write_Escape (C);
               end if;
            end;
         end loop;
         Writer.Write_Char ('"');
      end if;
   end Write_Wide_Attribute;

   procedure Write_Wide_Attribute (Writer  : in out Html_Writer_Type;
                                   Name    : in String;
                                   Content : in Unbounded_Wide_Wide_String) is
      Count : constant Natural := Length (Content);
   begin
      if Writer.Close_Start then
         Writer.Write_Char (' ');
         Writer.Write_String (Name);
         Writer.Write_Char ('=');
         Writer.Write_Char ('"');
         for I in 1 .. Count loop
            declare
               C : constant Wide_Wide_Character := Element (Content, I);
            begin
               if C = '"' then
                  Writer.Write_String (""");
               else
                  Writer.Write_Escape (C);
               end if;
            end;
         end loop;
         Writer.Write_Char ('"');
      end if;
   end Write_Wide_Attribute;

   procedure Start_Element (Writer : in out Html_Writer_Type;
                            Name   : in String) is
   begin
      Close_Current (Writer);
      Writer.Write_Char ('<');
      Writer.Write_String (Name);
      Writer.Close_Start := True;
   end Start_Element;

   procedure End_Element (Writer : in out Html_Writer_Type;
                          Name   : in String) is
   begin
      Close_Current (Writer);
      Writer.Write_String ("</");
      Writer.Write_String (Name);
      Writer.Write_Char ('>');
   end End_Element;

   procedure Write_Wide_Text (Writer  : in out Html_Writer_Type;
                              Content : in Unbounded_Wide_Wide_String) is
      Count : constant Natural := Length (Content);
   begin
      Close_Current (Writer);
      if Count > 0 then
         for I in 1 .. Count loop
            Html_Writer_Type'Class (Writer).Write_Escape (Element (Content, I));
         end loop;
      end if;
   end Write_Wide_Text;

end Wiki.Writers.Builders;

Implement the Write_Wide_Attribute procedure


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

with Ada.IO_Exceptions;

with ADO.Drivers;

with EL.Contexts.Default;
with Util.Files;
with Util.Log.Loggers;

with ASF.Server;
with ASF.Servlets;

with AWA.Services.Contexts;
with AWA.Components.Factory;
with AWA.Applications.Factory;
with AWA.Applications.Configs;
with AWA.Helpers.Selectors;
with AWA.Permissions.Services;
with AWA.Permissions.Beans;
package body AWA.Applications is

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

   --  ------------------------------
   --  Initialize the application
   --  ------------------------------
   overriding
   procedure Initialize (App     : in out Application;
                         Conf    : in ASF.Applications.Config;
                         Factory : in out ASF.Applications.Main.Application_Factory'Class) is
      Ctx    : AWA.Services.Contexts.Service_Context;
   begin
      Log.Info ("Initializing application");

      Ctx.Set_Context (App'Unchecked_Access, null);
      AWA.Applications.Factory.Set_Application (Factory, App'Unchecked_Access);
      ASF.Applications.Main.Application (App).Initialize (Conf, Factory);

      --  Load the application configuration before any module.
      Application'Class (App).Load_Configuration (App.Get_Config (P_Config_File.P));

      --  Register the application modules and load their configuration.
      Application'Class (App).Initialize_Modules;

      --  Load the plugin application configuration after the module are configured.
      Application'Class (App).Load_Configuration (App.Get_Config (P_Plugin_Config_File.P));
   end Initialize;

   --  ------------------------------
   --  Initialize the application configuration properties.  Properties defined in Conf
   --  are expanded by using the EL expression resolver.
   --  ------------------------------
   overriding
   procedure Initialize_Config (App  : in out Application;
                                Conf : in out ASF.Applications.Config) is
   begin
      Log.Info ("Initializing configuration");

      if Conf.Get ("app.modules.dir", "") = "" then
         Conf.Set ("app.modules.dir", "#{fn:composePath(app_search_dirs,'config')}");
      end if;
      if Conf.Get ("bundle.dir", "") = "" then
         Conf.Set ("bundle.dir", "#{fn:composePath(app_search_dirs,'bundles')}");
      end if;
      if Conf.Get ("ado.queries.paths", "") = "" then
         Conf.Set ("ado.queries.paths", "#{fn:composePath(app_search_dirs,'db')}");
      end if;
      ASF.Applications.Main.Application (App).Initialize_Config (Conf);
      ADO.Drivers.Initialize (Conf);
      App.DB_Factory.Create (Conf.Get ("database"));
      App.Events.Initialize (App'Unchecked_Access);
      AWA.Modules.Initialize (App.Modules, Conf);

      App.Register_Class ("AWA.Helpers.Selectors.Select_List_Bean",
                          AWA.Helpers.Selectors.Create_Select_List_Bean'Access);

      App.Register_Class ("AWA.Permissions.Beans.Permission_Bean",
                          AWA.Permissions.Beans.Create_Permission_Bean'Access);
   end Initialize_Config;

   --  ------------------------------
   --  Initialize the servlets provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application servlets.
   --  ------------------------------
   overriding
   procedure Initialize_Servlets (App : in out Application) is
   begin
      Log.Info ("Initializing application servlets");

      ASF.Applications.Main.Application (App).Initialize_Servlets;
   end Initialize_Servlets;

   --  ------------------------------
   --  Initialize the filters provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application filters.
   --  ------------------------------
   overriding
   procedure Initialize_Filters (App : in out Application) is
   begin
      Log.Info ("Initializing application filters");

      ASF.Applications.Main.Application (App).Initialize_Filters;
   end Initialize_Filters;

   --  ------------------------------
   --  Initialize the ASF components provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the component factories used by the application.
   --  ------------------------------
   overriding
   procedure Initialize_Components (App : in out Application) is
      procedure Register_Functions is
         new ASF.Applications.Main.Register_Functions (AWA.Permissions.Services.Set_Functions);
   begin
      Log.Info ("Initializing application components");

      ASF.Applications.Main.Application (App).Initialize_Components;
      App.Add_Components (AWA.Components.Factory.Definition);
      Register_Functions (App);
   end Initialize_Components;

   --  ------------------------------
   --  Read the application configuration file awa.xml.  This is called after the servlets
   --  and filters have been registered in the application but before the module registration.
   --  ------------------------------
   procedure Load_Configuration (App   : in out Application;
                                 Files : in String) is
      procedure Load_Config (File : in String;
                             Done : out Boolean);

      Paths     : constant String := App.Get_Config (P_Module_Dir.P);
      Ctx       : aliased EL.Contexts.Default.Default_Context;

      procedure Load_Config (File : in String;
                             Done : out Boolean) is
         Path  : constant String := Util.Files.Find_File_Path (File, Paths);
      begin
         Done := False;
         AWA.Applications.Configs.Read_Configuration (App, Path, Ctx'Unchecked_Access);

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

      end Load_Config;

   begin
      Util.Files.Iterate_Path (Files, Load_Config'Access);
   end Load_Configuration;

   --  ------------------------------
   --  Initialize the AWA modules provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the modules used by the application.
   --  ------------------------------
   procedure Initialize_Modules (App : in out Application) is
   begin
      null;
   end Initialize_Modules;

   --  ------------------------------
   --  Start the application.  This is called by the server container when the server is started.
   --  ------------------------------
   overriding
   procedure Start (App : in out Application) is
   begin
      --  Start the event service.
      App.Events.Start;

      --  Start the application.
      ASF.Applications.Main.Application (App).Start;

      --  Dump the route and filters to help in configuration issues.
      App.Dump_Routes (Util.Log.INFO_LEVEL);
   end Start;

   --  ------------------------------
   --  Register the module in the application
   --  ------------------------------
   procedure Register (App     : in Application_Access;
                       Module  : access AWA.Modules.Module'Class;
                       Name    : in String;
                       URI     : in String := "") is
   begin
      App.Register (Module.all'Unchecked_Access, Name, URI);
   end Register;

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

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

   --  ------------------------------
   --  Find the module with the given name
   --  ------------------------------
   function Find_Module (App : in Application;
                         Name : in String) return AWA.Modules.Module_Access is
   begin
      return AWA.Modules.Find_By_Name (App.Modules, Name);
   end Find_Module;

   --  ------------------------------
   --  Register the module in the application
   --  ------------------------------
   procedure Register (App     : in out Application;
                       Module  : in AWA.Modules.Module_Access;
                       Name    : in String;
                       URI     : in String := "") is
   begin
      AWA.Modules.Register (App.Modules'Unchecked_Access, App'Unchecked_Access, Module, Name, URI);
   end Register;

   --  ------------------------------
   --  Send the event in the application event queues.
   --  ------------------------------
   procedure Send_Event (App   : in Application;
                         Event : in AWA.Events.Module_Event'Class) is
   begin
      App.Events.Send (Event);
   end Send_Event;

   --  ------------------------------
   --  Execute the <tt>Process</tt> procedure with the event manager used by the application.
   --  ------------------------------
   procedure Do_Event_Manager (App : in out Application;
                               Process : access procedure
                                 (Events : in out AWA.Events.Services.Event_Manager)) is
   begin
      Process (App.Events);
   end Do_Event_Manager;

   --  ------------------------------
   --  Initialize the parser represented by Parser to recognize the configuration
   --  that are specific to the plugins that have been registered so far.
   --  ------------------------------
   procedure Initialize_Parser (App : in out Application'Class;
                                Parser : in out Util.Serialize.IO.Parser'Class) is
      procedure Process (Module : in out AWA.Modules.Module'Class);

      procedure Process (Module : in out AWA.Modules.Module'Class) is
      begin
         Module.Initialize_Parser (Parser);
      end Process;
   begin
      AWA.Modules.Iterate (App.Modules, Process'Access);
   end Initialize_Parser;

   --  ------------------------------
   --  Get the current application from the servlet context or service context.
   --  ------------------------------
   function Current return Application_Access is
      use type AWA.Services.Contexts.Service_Context_Access;

      Ctx : constant AWA.Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
   begin
      if Ctx /= null then
         return Ctx.Get_Application;
      end if;

      --  If there is no service context, look in the servlet current context.
      declare
         use type ASF.Servlets.Servlet_Registry_Access;

         Ctx : constant ASF.Servlets.Servlet_Registry_Access := ASF.Server.Current;
      begin
         if Ctx = null then
            Log.Warn ("There is no service context");
            return null;
         end if;
         if not (Ctx.all in AWA.Applications.Application'Class) then
            Log.Warn ("The servlet context is not an application");
            return null;
         end if;
         return AWA.Applications.Application'Class (Ctx.all)'Access;
      end;
   end Current;

end AWA.Applications;

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

with Ada.IO_Exceptions;

with ADO.Drivers;

with EL.Contexts.Default;
with Util.Files;
with Util.Log.Loggers;

with ASF.Server;
with ASF.Servlets;

with AWA.Services.Contexts;
with AWA.Components.Factory;
with AWA.Applications.Factory;
with AWA.Applications.Configs;
with AWA.Helpers.Selectors;
with AWA.Permissions.Services;
with AWA.Permissions.Beans;
package body AWA.Applications is

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

   --  ------------------------------
   --  Initialize the application
   --  ------------------------------
   overriding
   procedure Initialize (App     : in out Application;
                         Conf    : in ASF.Applications.Config;
                         Factory : in out ASF.Applications.Main.Application_Factory'Class) is
      Ctx    : AWA.Services.Contexts.Service_Context;
   begin
      Log.Info ("Initializing application");

      Ctx.Set_Context (App'Unchecked_Access, null);
      AWA.Applications.Factory.Set_Application (Factory, App'Unchecked_Access);
      ASF.Applications.Main.Application (App).Initialize (Conf, Factory);

      --  Load the application configuration before any module.
      Application'Class (App).Load_Configuration (App.Get_Config (P_Config_File.P));

      --  Register the application modules and load their configuration.
      Application'Class (App).Initialize_Modules;

      --  Load the plugin application configuration after the module are configured.
      Application'Class (App).Load_Configuration (App.Get_Config (P_Plugin_Config_File.P));
   end Initialize;

   --  ------------------------------
   --  Initialize the application configuration properties.  Properties defined in Conf
   --  are expanded by using the EL expression resolver.
   --  ------------------------------
   overriding
   procedure Initialize_Config (App  : in out Application;
                                Conf : in out ASF.Applications.Config) is
   begin
      Log.Info ("Initializing configuration");

      if Conf.Get ("app.modules.dir", "") = "" then
         Conf.Set ("app.modules.dir", "#{fn:composePath(app_search_dirs,'config')}");
      end if;
      if Conf.Get ("bundle.dir", "") = "" then
         Conf.Set ("bundle.dir", "#{fn:composePath(app_search_dirs,'bundles')}");
      end if;
      if Conf.Get ("ado.queries.paths", "") = "" then
         Conf.Set ("ado.queries.paths", "#{fn:composePath(app_search_dirs,'db')}");
      end if;
      ASF.Applications.Main.Application (App).Initialize_Config (Conf);
      ADO.Drivers.Initialize (Conf);
      App.DB_Factory.Create (Conf.Get ("database"));
      App.Events.Initialize (App'Unchecked_Access);
      AWA.Modules.Initialize (App.Modules, Conf);

      App.Register_Class ("AWA.Helpers.Selectors.Select_List_Bean",
                          AWA.Helpers.Selectors.Create_Select_List_Bean'Access);

      App.Register_Class ("AWA.Permissions.Beans.Permission_Bean",
                          AWA.Permissions.Beans.Create_Permission_Bean'Access);
   end Initialize_Config;

   --  ------------------------------
   --  Initialize the servlets provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application servlets.
   --  ------------------------------
   overriding
   procedure Initialize_Servlets (App : in out Application) is
   begin
      Log.Info ("Initializing application servlets");

      ASF.Applications.Main.Application (App).Initialize_Servlets;
   end Initialize_Servlets;

   --  ------------------------------
   --  Initialize the filters provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application filters.
   --  ------------------------------
   overriding
   procedure Initialize_Filters (App : in out Application) is
   begin
      Log.Info ("Initializing application filters");

      ASF.Applications.Main.Application (App).Initialize_Filters;
   end Initialize_Filters;

   --  ------------------------------
   --  Initialize the ASF components provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the component factories used by the application.
   --  ------------------------------
   overriding
   procedure Initialize_Components (App : in out Application) is
      procedure Register_Functions is
         new ASF.Applications.Main.Register_Functions (AWA.Permissions.Services.Set_Functions);
   begin
      Log.Info ("Initializing application components");

      ASF.Applications.Main.Application (App).Initialize_Components;
      App.Add_Components (AWA.Components.Factory.Definition);
      Register_Functions (App);
   end Initialize_Components;

   --  ------------------------------
   --  Read the application configuration file awa.xml.  This is called after the servlets
   --  and filters have been registered in the application but before the module registration.
   --  ------------------------------
   procedure Load_Configuration (App   : in out Application;
                                 Files : in String) is
      procedure Load_Config (File : in String;
                             Done : out Boolean);

      Paths     : constant String := App.Get_Config (P_Module_Dir.P);
      Ctx       : aliased EL.Contexts.Default.Default_Context;

      procedure Load_Config (File : in String;
                             Done : out Boolean) is
         Path  : constant String := Util.Files.Find_File_Path (File, Paths);
      begin
         Done := False;
         AWA.Applications.Configs.Read_Configuration (App, Path, Ctx'Unchecked_Access, True);

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

      end Load_Config;

   begin
      Util.Files.Iterate_Path (Files, Load_Config'Access);
   end Load_Configuration;

   --  ------------------------------
   --  Initialize the AWA modules provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the modules used by the application.
   --  ------------------------------
   procedure Initialize_Modules (App : in out Application) is
   begin
      null;
   end Initialize_Modules;

   --  ------------------------------
   --  Start the application.  This is called by the server container when the server is started.
   --  ------------------------------
   overriding
   procedure Start (App : in out Application) is
   begin
      --  Start the event service.
      App.Events.Start;

      --  Start the application.
      ASF.Applications.Main.Application (App).Start;

      --  Dump the route and filters to help in configuration issues.
      App.Dump_Routes (Util.Log.INFO_LEVEL);
   end Start;

   --  ------------------------------
   --  Register the module in the application
   --  ------------------------------
   procedure Register (App     : in Application_Access;
                       Module  : access AWA.Modules.Module'Class;
                       Name    : in String;
                       URI     : in String := "") is
   begin
      App.Register (Module.all'Unchecked_Access, Name, URI);
   end Register;

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

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

   --  ------------------------------
   --  Find the module with the given name
   --  ------------------------------
   function Find_Module (App : in Application;
                         Name : in String) return AWA.Modules.Module_Access is
   begin
      return AWA.Modules.Find_By_Name (App.Modules, Name);
   end Find_Module;

   --  ------------------------------
   --  Register the module in the application
   --  ------------------------------
   procedure Register (App     : in out Application;
                       Module  : in AWA.Modules.Module_Access;
                       Name    : in String;
                       URI     : in String := "") is
   begin
      AWA.Modules.Register (App.Modules'Unchecked_Access, App'Unchecked_Access, Module, Name, URI);
   end Register;

   --  ------------------------------
   --  Send the event in the application event queues.
   --  ------------------------------
   procedure Send_Event (App   : in Application;
                         Event : in AWA.Events.Module_Event'Class) is
   begin
      App.Events.Send (Event);
   end Send_Event;

   --  ------------------------------
   --  Execute the <tt>Process</tt> procedure with the event manager used by the application.
   --  ------------------------------
   procedure Do_Event_Manager (App : in out Application;
                               Process : access procedure
                                 (Events : in out AWA.Events.Services.Event_Manager)) is
   begin
      Process (App.Events);
   end Do_Event_Manager;

   --  ------------------------------
   --  Initialize the parser represented by Parser to recognize the configuration
   --  that are specific to the plugins that have been registered so far.
   --  ------------------------------
   procedure Initialize_Parser (App : in out Application'Class;
                                Parser : in out Util.Serialize.IO.Parser'Class) is
      procedure Process (Module : in out AWA.Modules.Module'Class);

      procedure Process (Module : in out AWA.Modules.Module'Class) is
      begin
         Module.Initialize_Parser (Parser);
      end Process;
   begin
      AWA.Modules.Iterate (App.Modules, Process'Access);
   end Initialize_Parser;

   --  ------------------------------
   --  Get the current application from the servlet context or service context.
   --  ------------------------------
   function Current return Application_Access is
      use type AWA.Services.Contexts.Service_Context_Access;

      Ctx : constant AWA.Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
   begin
      if Ctx /= null then
         return Ctx.Get_Application;
      end if;

      --  If there is no service context, look in the servlet current context.
      declare
         use type ASF.Servlets.Servlet_Registry_Access;

         Ctx : constant ASF.Servlets.Servlet_Registry_Access := ASF.Server.Current;
      begin
         if Ctx = null then
            Log.Warn ("There is no service context");
            return null;
         end if;
         if not (Ctx.all in AWA.Applications.Application'Class) then
            Log.Warn ("The servlet context is not an application");
            return null;
         end if;
         return AWA.Applications.Application'Class (Ctx.all)'Access;
      end;
   end Current;

end AWA.Applications;

Load the configuration files and allow to override the <context-param>


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

with Util.Log.Loggers;
with Util.Serialize.Mappers.Record_Mapper;
with Util.Strings.Tokenizers;

with Security.Controllers;
with Security.Controllers.Roles;

package body Security.Policies.Roles is

   use Util.Log;

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

   --  ------------------------------
   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   --  ------------------------------
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in Role_Map) is
      Policy : constant Security.Policies.Policy_Access := Context.Get_Policy (NAME);
      Data   : Role_Policy_Context_Access;
   begin
      if Policy = null then
         Log.Error ("There is no security policy: " & NAME);
      end if;
      Data := new Role_Policy_Context;
      Data.Roles := Roles;

      Context.Set_Policy_Context (Policy, Data.all'Access);
   end Set_Role_Context;

   --  ------------------------------
   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   --  ------------------------------
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in String) is
      Policy : constant Security.Policies.Policy_Access := Context.Get_Policy (NAME);
      Data   : Role_Policy_Context_Access;
      Map    : Role_Map;
   begin
      if Policy = null then
         Log.Error ("There is no security policy: " & NAME);
      end if;
      Role_Policy'Class (Policy.all).Set_Roles (Roles, Map);
      Data := new Role_Policy_Context;
      Data.Roles := Map;

      Context.Set_Policy_Context (Policy, Data.all'Access);
   end Set_Role_Context;

   --  ------------------------------
   --  Get the policy name.
   --  ------------------------------
   overriding
   function Get_Name (From : in Role_Policy) return String is
      pragma Unreferenced (From);
   begin
      return NAME;
   end Get_Name;

   --  ------------------------------
   --  Get the role name.
   --  ------------------------------
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      if Manager.Names (Role) = null then
         return "";
      else
         return Manager.Names (Role).all;
      end if;
   end Get_Role_Name;

   --  ------------------------------
   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   --  ------------------------------
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      Log.Debug ("Searching role {0}", Name);

      for I in Role_Type'First .. Manager.Next_Role loop
         exit when Manager.Names (I) = null;
         if Name = Manager.Names (I).all then
            return I;
         end if;
      end loop;

      Log.Debug ("Role {0} not found", Name);
      raise Invalid_Name;
   end Find_Role;

   --  ------------------------------
   --  Create a role
   --  ------------------------------
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type) is
   begin
      Role := Manager.Next_Role;
      Log.Info ("Role {0} is {1}", Name, Role_Type'Image (Role));

      if Manager.Next_Role = Role_Type'Last then
         Log.Error ("Too many roles allocated.  Number of roles is {0}",
                    Role_Type'Image (Role_Type'Last));
      else
         Manager.Next_Role := Manager.Next_Role + 1;
      end if;
      Manager.Names (Role) := new String '(Name);
   end Create_Role;

   --  ------------------------------
   --  Get or build a permission type for the given name.
   --  ------------------------------
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type) is
   begin
      Result := Manager.Find_Role (Name);

   exception
      when Invalid_Name =>
         Manager.Create_Role (Name, Result);
   end Add_Role_Type;

   --  ------------------------------
   --  Set the roles specified in the <tt>Roles</tt> parameter.  Each role is represented by
   --  its name and multiple roles are separated by ','.
   --  Raises Invalid_Name if a role was not found.
   --  ------------------------------
   procedure Set_Roles (Manager : in Role_Policy;
                        Roles   : in String;
                        Into    : out Role_Map) is
      procedure Process (Role : in String;
                         Done : out Boolean);

      procedure Process (Role : in String;
                         Done : out Boolean) is
      begin
         Into (Manager.Find_Role (Role)) := True;
         Done := False;
      end Process;

   begin
      Into := (others => False);
      Util.Strings.Tokenizers.Iterate_Tokens (Content => Roles,
                                              Pattern => ",",
                                              Process => Process'Access,
                                              Going   => Ada.Strings.Forward);
   end Set_Roles;

   type Config_Fields is (FIELD_NAME, FIELD_ROLE, FIELD_ROLE_PERMISSION, FIELD_ROLE_NAME);

   type Controller_Config_Access is access all Controller_Config;

   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Called while parsing the XML policy file when the <name>, <role> and <role-permission>
   --  XML entities are found.  Create the new permission when the complete permission definition
   --  has been parsed and save the permission in the security manager.
   --  ------------------------------
   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use Security.Controllers.Roles;
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_ROLE =>
            declare
               Role : constant String := Util.Beans.Objects.To_String (Value);
            begin
               Into.Roles (Into.Count + 1) := Into.Manager.Find_Role (Role);
               Into.Count := Into.Count + 1;

            exception
               when Permissions.Invalid_Name =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid role: " & Role;
            end;

         when FIELD_ROLE_PERMISSION =>
            if Into.Count = 0 then
               raise Util.Serialize.Mappers.Field_Error with "Missing at least one role";
            end if;
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Name);
               Perm : constant Role_Controller_Access
                 := new Role_Controller '(Count => Into.Count,
                                          Roles => Into.Roles (1 .. Into.Count));
            begin
               Into.Manager.Add_Permission (Name, Perm.all'Access);
               Into.Count := 0;
            end;

         when FIELD_ROLE_NAME =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
               Role : Role_Type;
            begin
               Into.Manager.Add_Role_Type (Name, Role);
            end;
      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Controller_Config,
                                               Element_Type_Access => Controller_Config_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Mapper : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the role-permission description.
   --  ------------------------------
   procedure Prepare_Config (Policy : in out Role_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser) is
      Config : Controller_Config_Access := new Controller_Config;
   begin
      Reader.Add_Mapping ("policy-rules", Mapper'Access);
      Reader.Add_Mapping ("module", Mapper'Access);
      Config.Manager := Policy'Unchecked_Access;
      Config_Mapper.Set_Context (Reader, Config);
   end Prepare_Config;

   --  ------------------------------
   --  Finalize the policy manager.
   --  ------------------------------
   overriding
   procedure Finalize (Policy : in out Role_Policy) is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      for I in Policy.Names'Range loop
         exit when Policy.Names (I) = null;
         Ada.Strings.Unbounded.Free (Policy.Names (I));
      end loop;
   end Finalize;

begin
   Mapper.Add_Mapping ("role-permission", FIELD_ROLE_PERMISSION);
   Mapper.Add_Mapping ("role-permission/name", FIELD_NAME);
   Mapper.Add_Mapping ("role-permission/role", FIELD_ROLE);
   Mapper.Add_Mapping ("security-role/role-name", FIELD_ROLE_NAME);
end Security.Policies.Roles;

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

with Util.Log.Loggers;
with Util.Serialize.Mappers.Record_Mapper;
with Util.Strings.Tokenizers;

with Security.Controllers;
with Security.Controllers.Roles;

package body Security.Policies.Roles is

   use Util.Log;

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

   --  ------------------------------
   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   --  ------------------------------
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in Role_Map) is
      Policy : constant Security.Policies.Policy_Access := Context.Get_Policy (NAME);
      Data   : Role_Policy_Context_Access;
   begin
      if Policy = null then
         Log.Error ("There is no security policy: " & NAME);
      end if;
      Data := new Role_Policy_Context;
      Data.Roles := Roles;

      Context.Set_Policy_Context (Policy, Data.all'Access);
   end Set_Role_Context;

   --  ------------------------------
   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   --  ------------------------------
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in String) is
      Policy : constant Security.Policies.Policy_Access := Context.Get_Policy (NAME);
      Data   : Role_Policy_Context_Access;
      Map    : Role_Map;
   begin
      if Policy = null then
         Log.Error ("There is no security policy: " & NAME);
      end if;
      Role_Policy'Class (Policy.all).Set_Roles (Roles, Map);
      Data := new Role_Policy_Context;
      Data.Roles := Map;

      Context.Set_Policy_Context (Policy, Data.all'Access);
   end Set_Role_Context;

   --  ------------------------------
   --  Get the policy name.
   --  ------------------------------
   overriding
   function Get_Name (From : in Role_Policy) return String is
      pragma Unreferenced (From);
   begin
      return NAME;
   end Get_Name;

   --  ------------------------------
   --  Get the role name.
   --  ------------------------------
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      if Manager.Names (Role) = null then
         return "";
      else
         return Manager.Names (Role).all;
      end if;
   end Get_Role_Name;

   --  ------------------------------
   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   --  ------------------------------
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      Log.Debug ("Searching role {0}", Name);

      for I in Role_Type'First .. Manager.Next_Role loop
         exit when Manager.Names (I) = null;
         if Name = Manager.Names (I).all then
            return I;
         end if;
      end loop;

      Log.Debug ("Role {0} not found", Name);
      raise Invalid_Name;
   end Find_Role;

   --  ------------------------------
   --  Create a role
   --  ------------------------------
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type) is
   begin
      Role := Manager.Next_Role;
      Log.Info ("Role {0} is {1}", Name, Role_Type'Image (Role));

      if Manager.Next_Role = Role_Type'Last then
         Log.Error ("Too many roles allocated.  Number of roles is {0}",
                    Role_Type'Image (Role_Type'Last));
      else
         Manager.Next_Role := Manager.Next_Role + 1;
      end if;
      Manager.Names (Role) := new String '(Name);
   end Create_Role;

   --  ------------------------------
   --  Get or build a permission type for the given name.
   --  ------------------------------
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type) is
   begin
      Result := Manager.Find_Role (Name);

   exception
      when Invalid_Name =>
         Manager.Create_Role (Name, Result);
   end Add_Role_Type;

   --  ------------------------------
   --  Set the roles specified in the <tt>Roles</tt> parameter.  Each role is represented by
   --  its name and multiple roles are separated by ','.
   --  Raises Invalid_Name if a role was not found.
   --  ------------------------------
   procedure Set_Roles (Manager : in Role_Policy;
                        Roles   : in String;
                        Into    : out Role_Map) is
      procedure Process (Role : in String;
                         Done : out Boolean);

      procedure Process (Role : in String;
                         Done : out Boolean) is
      begin
         Into (Manager.Find_Role (Role)) := True;
         Done := False;
      end Process;

   begin
      Into := (others => False);
      Util.Strings.Tokenizers.Iterate_Tokens (Content => Roles,
                                              Pattern => ",",
                                              Process => Process'Access,
                                              Going   => Ada.Strings.Forward);
   end Set_Roles;

   type Config_Fields is (FIELD_NAME, FIELD_ROLE, FIELD_ROLE_PERMISSION, FIELD_ROLE_NAME);

   type Controller_Config_Access is access all Controller_Config;

   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Called while parsing the XML policy file when the <name>, <role> and <role-permission>
   --  XML entities are found.  Create the new permission when the complete permission definition
   --  has been parsed and save the permission in the security manager.
   --  ------------------------------
   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use Security.Controllers.Roles;
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_ROLE =>
            declare
               Role : constant String := Util.Beans.Objects.To_String (Value);
            begin
               Into.Roles (Into.Count + 1) := Into.Manager.Find_Role (Role);
               Into.Count := Into.Count + 1;

            exception
               when Permissions.Invalid_Name =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid role: " & Role;
            end;

         when FIELD_ROLE_PERMISSION =>
            if Into.Count = 0 then
               raise Util.Serialize.Mappers.Field_Error with "Missing at least one role";
            end if;
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Name);
               Perm : constant Role_Controller_Access
                 := new Role_Controller '(Count => Into.Count,
                                          Roles => Into.Roles (1 .. Into.Count));
            begin
               Into.Manager.Add_Permission (Name, Perm.all'Access);
               Into.Count := 0;
            end;

         when FIELD_ROLE_NAME =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
               Role : Role_Type;
            begin
               Into.Manager.Add_Role_Type (Name, Role);
            end;
      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Controller_Config,
                                               Element_Type_Access => Controller_Config_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Mapper : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the role-permission description.
   --  ------------------------------
   procedure Prepare_Config (Policy : in out Role_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser) is
      Config : Controller_Config_Access := new Controller_Config;
   begin
      Reader.Add_Mapping ("policy-rules", Mapper'Access);
      Reader.Add_Mapping ("module", Mapper'Access);
      Config.Manager := Policy'Unchecked_Access;
      Config_Mapper.Set_Context (Reader, Config);
   end Prepare_Config;

   --  ------------------------------
   --  Finalize the policy manager.
   --  ------------------------------
   overriding
   procedure Finalize (Policy : in out Role_Policy) is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      for I in Policy.Names'Range loop
         exit when Policy.Names (I) = null;
         Ada.Strings.Unbounded.Free (Policy.Names (I));
      end loop;
   end Finalize;

   --  ------------------------------
   --  Get the role policy associated with the given policy manager.
   --  Returns the role policy instance or null if it was not registered in the policy manager.
   --  ------------------------------
   function Get_Role_Policy (Manager : in Security.Policies.Policy_Manager'Class)
                             return Role_Policy_Access is
      Policy : constant Security.Policies.Policy_Access := Manager.Get_Policy (NAME);
   begin
      if Policy = null or else not (Policy.all in Role_Policy'Class) then
         return null;
      else
         return Role_Policy'Class (Policy.all)'Access;
      end if;
   end Get_Role_Policy;

begin
   Mapper.Add_Mapping ("role-permission", FIELD_ROLE_PERMISSION);
   Mapper.Add_Mapping ("role-permission/name", FIELD_NAME);
   Mapper.Add_Mapping ("role-permission/role", FIELD_ROLE);
   Mapper.Add_Mapping ("security-role/role-name", FIELD_ROLE_NAME);
end Security.Policies.Roles;

Implement the new function Get_Role_Policy


------------------------------------------------------------------------------
--                                                                          --
--                    Copyright (C) 2016, AdaCore                           --
--                                                                          --
--  Redistribution and use in source and binary forms, with or without      --
--  modification, are permitted provided that the following conditions are  --
--  met:                                                                    --
--     1. Redistributions of source code must retain the above copyright    --
--        notice, this list of conditions and the following disclaimer.     --
--     2. Redistributions in binary form must reproduce the above copyright --
--        notice, this list of conditions and the following disclaimer in   --
--        the documentation and/or other materials provided with the        --
--        distribution.                                                     --
--     3. Neither the name of the copyright holder nor the names of its     --
--        contributors may be used to endorse or promote products derived   --
--        from this software without specific prior written permission.     --
--                                                                          --
--   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    --
--   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      --
--   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR  --
--   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT   --
--   HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --
--   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT       --
--   LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,  --
--   DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY  --
--   THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT    --
--   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE  --
--   OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.   --
--                                                                          --
------------------------------------------------------------------------------

with Cortex_M.Debug;
with System.Machine_Code; use System.Machine_Code;
with HAL; use HAL;
with Ada.Unchecked_Conversion;
with Interfaces.C; use Interfaces.C;

package body Semihosting is

   type SH_u32_Array is array (Integer range <>) of SH_Word
     with Pack, Convention => C, Volatile_Components;

   function To_SH_u32 is new Ada.Unchecked_Conversion
     (Source => System.Address, Target => SH_Word);
   function To_SH_u32 is new Ada.Unchecked_Conversion
     (Source => Integer, Target => SH_Word);

   subtype Syscall is SH_Word;

   SYS_OPEN     : constant Syscall := 16#01#;
   SYS_CLOSE    : constant Syscall := 16#02#;
   SYS_WRITEC   : constant Syscall := 16#03#;
   SYS_WRITE0   : constant Syscall := 16#04#;
   SYS_WRITE    : constant Syscall := 16#05#;
   SYS_READ     : constant Syscall := 16#06#;
   --  SYS_READC    : constant Syscall := 16#07#;
   --  SYS_ISERROR  : constant Syscall := 16#08#;
   --  SYS_ISTTY    : constant Syscall := 16#09#;
   SYS_SEEK     : constant Syscall := 16#0A#;
   --  SYS_FLEN     : constant Syscall := 16#0C#;
   --  SYS_TMPNAM   : constant Syscall := 16#0D#;
   SYS_REMOVE   : constant Syscall := 16#0E#;
   --  SYS_RENAME   : constant Syscall := 16#0E#;
   --  SYS_CLOCK    : constant Syscall := 16#10#;
   --  SYS_TIME     : constant Syscall := 16#11#;
   SYS_ERRNO    : constant Syscall := 16#13#;
   --  SYS_GET_CMD  : constant Syscall := 16#15#;
   --  SYS_HEAPINFO : constant Syscall := 16#16#;
   --  SYS_ELAPSED  : constant Syscall := 16#30#;
   --  SYS_TICKFREQ : constant Syscall := 16#31#;

   function Semihosting_Enabled return Boolean is
     (Cortex_M.Debug.Halting_Debug_Enabled);
   function Generic_SH_Call (R0, R1 : SH_Word) return SH_Word;
   function Generic_SH_Call (R0 : SH_Word; R1 : System.Address) return SH_Word;

   ---------------------
   -- Generic_SH_Call --
   ---------------------

   function Generic_SH_Call (R0, R1 : SH_Word) return SH_Word is
      Ret : SH_Word;
   begin
      Asm ("mov r0, %1" & ASCII.LF & ASCII.HT &
           "mov r1, %2" & ASCII.LF & ASCII.HT &
           "bkpt #0xAB" & ASCII.LF & ASCII.HT &
           "mov %0, r0",
           Outputs  => (SH_Word'Asm_Output ("=r", Ret)),
           Inputs   => (SH_Word'Asm_Input ("r", R0),
                        SH_Word'Asm_Input ("r", R1)),
           Volatile => True,
           Clobber => ("r1, r0"));
      return Ret;
   end Generic_SH_Call;

   ---------------------
   -- Generic_SH_Call --
   ---------------------

   function Generic_SH_Call (R0 : SH_Word; R1 : System.Address) return SH_Word is
   begin
      return Generic_SH_Call (R0, To_SH_u32 (R1));
   end Generic_SH_Call;

   -----------
   -- Close --
   -----------

   function Close (File_Handle : SH_Word) return SH_Word is
      Block : SH_u32_Array (0 .. 0);
   begin
      if not Semihosting_Enabled then
         --  No debugger attached
         return SH_Word'Last;
      end if;

      Block (0) := File_Handle;
      return Generic_SH_Call (SYS_CLOSE, Block'Address);
   end Close;

   ----------
   -- Open --
   ----------

   function Open (Filename : String; Mode : Flag) return SH_Word is
      Block  : SH_u32_Array (0 .. 2);
      C_Name : char_array (0 .. Filename'Length) with Volatile;
   begin
      if not Semihosting_Enabled then
         --  No debugger attached
         return SH_Word'Last;
      end if;

      for J in Filename'Range loop
         C_Name (size_t (J - Filename'First)) :=
           char'Val (Character'Pos (Filename (J)));
      end loop;
      C_Name (C_Name'Last) := nul;

      Block (0) := To_SH_u32 (C_Name'Address);
      Block (1) := Mode;
      Block (2) := Filename'Length;

      return Generic_SH_Call (SYS_OPEN, Block'Address);
   end Open;

   ----------
   -- Read --
   ----------

   function Read (File_Handle     : SH_Word;
                  Buffer_Address  : System.Address;
                  Buffer_Size     : SH_Word) return SH_Word
   is
      Block  : SH_u32_Array (0 .. 2);
   begin
      if not Semihosting_Enabled then
         --  No debugger attached
         return Buffer_Size;
      end if;

      Block (0) := File_Handle;
      Block (1) := To_SH_u32 (Buffer_Address);
      Block (2) := Buffer_Size;

      return Generic_SH_Call (SYS_READ, Block'Address);
   end Read;

   -----------
   -- Write --
   -----------

   function Write (File_Handle     : SH_Word;
                   Buffer_Address  : System.Address;
                   Buffer_Size     : SH_Word) return SH_Word
   is
      Block  : SH_u32_Array (0 .. 3);
   begin
      if not Semihosting_Enabled then
         --  No debugger attached
         return Buffer_Size;
      end if;

      Block (0) := File_Handle;
      Block (1) := To_SH_u32 (Buffer_Address);
      Block (2) := Buffer_Size;

      return Generic_SH_Call (SYS_WRITE, Block'Address);
   end Write;

   ------------
   -- Remove --
   ------------

   function Remove (Filename : String) return SH_Word is
      Block  : SH_u32_Array (0 .. 1);
      C_Name : char_array (0 .. Filename'Length) with Volatile;
   begin
      if not Semihosting_Enabled then
         --  No debugger attached
         return SH_Word'Last;
      end if;

      for J in Filename'Range loop
         C_Name (size_t (J - Filename'First)) :=
           char'Val (Character'Pos (Filename (J)));
      end loop;
      C_Name (C_Name'Last) := nul;

      Block (0) := To_SH_u32 (C_Name'Address);
      Block (1) := To_SH_u32 (Filename'Length);

      return Generic_SH_Call (SYS_REMOVE, Block'Address);
   end Remove;

   ----------
   -- Seek --
   ----------

   function Seek (File_Handle       : SH_Word;
                  Absolute_Position : SH_Word) return SH_Word
   is
      Block  : SH_u32_Array (0 .. 1);
   begin
      if not Semihosting_Enabled then
         --  No debugger attached
         return SH_Word'Last;
      end if;

      Block (0) := File_Handle;
      Block (1) := Absolute_Position;

      return Generic_SH_Call (SYS_SEEK, Block'Address);
   end Seek;

   -----------
   -- Errno --
   -----------

   function Errno return SH_Word is
   begin
      return Generic_SH_Call (SYS_ERRNO, 0);
   end Errno;

   -------------
   -- Write_C --
   -------------

   procedure Write_C (C : Character) is
      Ret : SH_Word with Unreferenced;
   begin
      if not Semihosting_Enabled then
         --  No debugger attached
         return;
      end if;

      Ret := Generic_SH_Call (SYS_WRITEC, C'Address);
   end Write_C;

   -------------
   -- Write_0 --
   -------------

   procedure Write_0 (Str : String) is
      Data : UInt8_Array (Str'First .. Str'Last + 1);
      Ret  : SH_Word with Unreferenced;
   begin
      if not Semihosting_Enabled then
         --  No debugger attached
         return;
      end if;

      for Index in Str'Range loop
         Data (Index) := Character'Pos (Str (Index));
      end loop;

      --  Add trailing zero
      Data (Str'Last + 1) := 0;

      Ret := Generic_SH_Call (SYS_WRITE0, Data'Address);
   end Write_0;

   --------------
   -- Log_Line --
   --------------

   procedure Log_Line (Str : String) is
   begin
      Log (Str);
      Log_New_Line;
   end Log_Line;

   ------------------
   -- Log_New_Line --
   ------------------

   procedure Log_New_Line is
   begin
      Write_C (ASCII.LF);
   end Log_New_Line;

end Semihosting;

------------------------------------------------------------------------------
--                                                                          --
--                  Copyright (C) 2016-2020, AdaCore                        --
--                                                                          --
--  Redistribution and use in source and binary forms, with or without      --
--  modification, are permitted provided that the following conditions are  --
--  met:                                                                    --
--     1. Redistributions of source code must retain the above copyright    --
--        notice, this list of conditions and the following disclaimer.     --
--     2. Redistributions in binary form must reproduce the above copyright --
--        notice, this list of conditions and the following disclaimer in   --
--        the documentation and/or other materials provided with the        --
--        distribution.                                                     --
--     3. Neither the name of the copyright holder nor the names of its     --
--        contributors may be used to endorse or promote products derived   --
--        from this software without specific prior written permission.     --
--                                                                          --
--   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    --
--   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      --
--   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR  --
--   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT   --
--   HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --
--   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT       --
--   LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,  --
--   DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY  --
--   THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT    --
--   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE  --
--   OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.   --
--                                                                          --
------------------------------------------------------------------------------

with Cortex_M.Debug;
with System.Machine_Code; use System.Machine_Code;
with HAL; use HAL;
with Ada.Unchecked_Conversion;
with Interfaces.C; use Interfaces.C;

package body Semihosting is

   type SH_u32_Array is array (Integer range <>) of SH_Word
     with Pack, Convention => C, Volatile_Components;

   function To_SH_u32 is new Ada.Unchecked_Conversion
     (Source => System.Address, Target => SH_Word);
   function To_SH_u32 is new Ada.Unchecked_Conversion
     (Source => Integer, Target => SH_Word);

   subtype Syscall is SH_Word;

   SYS_OPEN     : constant Syscall := 16#01#;
   SYS_CLOSE    : constant Syscall := 16#02#;
   SYS_WRITEC   : constant Syscall := 16#03#;
   SYS_WRITE0   : constant Syscall := 16#04#;
   SYS_WRITE    : constant Syscall := 16#05#;
   SYS_READ     : constant Syscall := 16#06#;
   --  SYS_READC    : constant Syscall := 16#07#;
   --  SYS_ISERROR  : constant Syscall := 16#08#;
   --  SYS_ISTTY    : constant Syscall := 16#09#;
   SYS_SEEK     : constant Syscall := 16#0A#;
   --  SYS_FLEN     : constant Syscall := 16#0C#;
   --  SYS_TMPNAM   : constant Syscall := 16#0D#;
   SYS_REMOVE   : constant Syscall := 16#0E#;
   --  SYS_RENAME   : constant Syscall := 16#0E#;
   --  SYS_CLOCK    : constant Syscall := 16#10#;
   --  SYS_TIME     : constant Syscall := 16#11#;
   SYS_ERRNO    : constant Syscall := 16#13#;
   --  SYS_GET_CMD  : constant Syscall := 16#15#;
   --  SYS_HEAPINFO : constant Syscall := 16#16#;
   --  SYS_ELAPSED  : constant Syscall := 16#30#;
   --  SYS_TICKFREQ : constant Syscall := 16#31#;

   function Semihosting_Enabled return Boolean is
     (Cortex_M.Debug.Halting_Debug_Enabled);
   function Generic_SH_Call (R0, R1 : SH_Word) return SH_Word;
   function Generic_SH_Call (R0 : SH_Word; R1 : System.Address) return SH_Word;

   ---------------------
   -- Generic_SH_Call --
   ---------------------

   function Generic_SH_Call (R0, R1 : SH_Word) return SH_Word is
      Ret : SH_Word;
   begin
      Asm ("mov r0, %1" & ASCII.LF & ASCII.HT &
           "mov r1, %2" & ASCII.LF & ASCII.HT &
           "bkpt #0xAB" & ASCII.LF & ASCII.HT &
           "mov %0, r0",
           Outputs  => (SH_Word'Asm_Output ("=r", Ret)),
           Inputs   => (SH_Word'Asm_Input ("r", R0),
                        SH_Word'Asm_Input ("r", R1)),
           Volatile => True,
           Clobber => ("r1, r0"));
      return Ret;
   end Generic_SH_Call;

   ---------------------
   -- Generic_SH_Call --
   ---------------------

   function Generic_SH_Call (R0 : SH_Word; R1 : System.Address) return SH_Word is
   begin
      return Generic_SH_Call (R0, To_SH_u32 (R1));
   end Generic_SH_Call;

   -----------
   -- Close --
   -----------

   function Close (File_Handle : SH_Word) return SH_Word is
      Block : SH_u32_Array (0 .. 0);
   begin
      if not Semihosting_Enabled then
         --  No debugger attached
         return SH_Word'Last;
      end if;

      Block (0) := File_Handle;
      return Generic_SH_Call (SYS_CLOSE, Block'Address);
   end Close;

   ----------
   -- Open --
   ----------

   function Open (Filename : String; Mode : Flag) return SH_Word is
      Block  : SH_u32_Array (0 .. 2);
      C_Name : char_array (0 .. Filename'Length) with Volatile;
   begin
      if not Semihosting_Enabled then
         --  No debugger attached
         return SH_Word'Last;
      end if;

      for J in Filename'Range loop
         C_Name (size_t (J - Filename'First)) :=
           char'Val (Character'Pos (Filename (J)));
      end loop;
      C_Name (C_Name'Last) := nul;

      Block (0) := To_SH_u32 (C_Name'Address);
      Block (1) := Mode;
      Block (2) := Filename'Length;

      return Generic_SH_Call (SYS_OPEN, Block'Address);
   end Open;

   ----------
   -- Read --
   ----------

   function Read (File_Handle     : SH_Word;
                  Buffer_Address  : System.Address;
                  Buffer_Size     : SH_Word) return SH_Word
   is
      Block  : SH_u32_Array (0 .. 2);
   begin
      if not Semihosting_Enabled then
         --  No debugger attached
         return Buffer_Size;
      end if;

      Block (0) := File_Handle;
      Block (1) := To_SH_u32 (Buffer_Address);
      Block (2) := Buffer_Size;

      return Generic_SH_Call (SYS_READ, Block'Address);
   end Read;

   -----------
   -- Write --
   -----------

   function Write (File_Handle     : SH_Word;
                   Buffer_Address  : System.Address;
                   Buffer_Size     : SH_Word) return SH_Word
   is
      Block  : SH_u32_Array (0 .. 3);
   begin
      if not Semihosting_Enabled then
         --  No debugger attached
         return Buffer_Size;
      end if;

      Block (0) := File_Handle;
      Block (1) := To_SH_u32 (Buffer_Address);
      Block (2) := Buffer_Size;

      return Generic_SH_Call (SYS_WRITE, Block'Address);
   end Write;

   ------------
   -- Remove --
   ------------

   function Remove (Filename : String) return SH_Word is
      Block  : SH_u32_Array (0 .. 1);
      C_Name : char_array (0 .. Filename'Length) with Volatile;
   begin
      if not Semihosting_Enabled then
         --  No debugger attached
         return SH_Word'Last;
      end if;

      for J in Filename'Range loop
         C_Name (size_t (J - Filename'First)) :=
           char'Val (Character'Pos (Filename (J)));
      end loop;
      C_Name (C_Name'Last) := nul;

      Block (0) := To_SH_u32 (C_Name'Address);
      Block (1) := To_SH_u32 (Filename'Length);

      return Generic_SH_Call (SYS_REMOVE, Block'Address);
   end Remove;

   ----------
   -- Seek --
   ----------

   function Seek (File_Handle       : SH_Word;
                  Absolute_Position : SH_Word) return SH_Word
   is
      Block  : SH_u32_Array (0 .. 1);
   begin
      if not Semihosting_Enabled then
         --  No debugger attached
         return SH_Word'Last;
      end if;

      Block (0) := File_Handle;
      Block (1) := Absolute_Position;

      return Generic_SH_Call (SYS_SEEK, Block'Address);
   end Seek;

   -----------
   -- Errno --
   -----------

   function Errno return SH_Word is
   begin
      return Generic_SH_Call (SYS_ERRNO, 0);
   end Errno;

   -------------
   -- Write_C --
   -------------

   procedure Write_C (C : Character) is
      Ret : SH_Word with Unreferenced;
   begin
      if not Semihosting_Enabled then
         --  No debugger attached
         return;
      end if;

      Ret := Generic_SH_Call (SYS_WRITEC, C'Address);
   end Write_C;

   -------------
   -- Write_0 --
   -------------

   procedure Write_0 (Str : String) is
      type Byte_Array is new UInt8_Array with Volatile_Components;
      Data : Byte_Array (Str'First .. Str'Last + 1);
      Ret  : SH_Word with Unreferenced;
   begin
      if not Semihosting_Enabled then
         --  No debugger attached
         return;
      end if;

      for Index in Str'Range loop
         Data (Index) := Character'Pos (Str (Index));
      end loop;

      --  Add trailing zero
      Data (Str'Last + 1) := 0;

      Ret := Generic_SH_Call (SYS_WRITE0, Data'Address);
   end Write_0;

   --------------
   -- Log_Line --
   --------------

   procedure Log_Line (Str : String) is
   begin
      Log (Str);
      Log_New_Line;
   end Log_Line;

   ------------------
   -- Log_New_Line --
   ------------------

   procedure Log_New_Line is
   begin
      Write_C (ASCII.LF);
   end Log_New_Line;

end Semihosting;

Reduce optimization opportunities in Semihosting.

  * arch/ARM/cortex_m/src/semihosting.adb (Write_0): Data is of new
      type Byte_Array, which is a new UInt8_Array with volatile
      components (FSF GCC was miscompiling at -O3).