-----------------------------------------------------------------------
--  Render Tests - Unit tests for ASF.Applications.Views
--  Copyright (C) 2009, 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 Ada.Text_IO;
with ASF.Applications.Main;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Requests.Tools;
with ASF.Servlets.Faces;
with Ada.Directories;

with Util.Test_Caller;
with Util.Files;
with Util.Measures;
package body ASF.Applications.Views.Tests is

   use Ada.Strings.Unbounded;

   overriding
   procedure Set_Up (T : in out Test) is
   begin
      null;
   end Set_Up;
   --  Set up performed before each test case

   --  Test loading of facelet file
   procedure Test_Load_Facelet (T : in out Test) is

      use ASF;
      use ASF.Contexts.Faces;

      App      : Applications.Main.Application;
--        H        : Applications.Views.View_Handler;

      View_Name   : constant String := To_String (T.File);
      Result_File : constant String := To_String (T.Result);
      Conf        : Applications.Config;
      App_Factory : Applications.Main.Application_Factory;
      Dir         : constant String := "regtests/files";
      Path        : constant String := Util.Tests.Get_Path (Dir);
      Faces       : aliased ASF.Servlets.Faces.Faces_Servlet;
   begin
      Conf.Load_Properties ("regtests/view.properties");
      Conf.Set ("view.dir", Path);
      App.Initialize (Conf, App_Factory);
      App.Register_Application ("/");
      App.Add_Servlet ("faces", Faces'Unchecked_Access);

      App.Set_Global ("function", "Test_Load_Facelet");
      for I in 1 .. 2 loop
         declare
            S : Util.Measures.Stamp;
            Req       : ASF.Requests.Mockup.Request;
            Rep       : aliased ASF.Responses.Mockup.Response;
            Content   : Unbounded_String;
         begin
            ASF.Requests.Tools.Set_Context (Req      => Req,
                                            Servlet  => Faces'Unchecked_Access,
                                            Response => Rep'Unchecked_Access);
            Req.Set_Method ("GET");
            Req.Set_Path_Info (View_Name);
            Req.Set_Parameter ("file-name", To_String (T.Name));
            Req.Set_Header ("file", To_String (T.Name));
            App.Dispatch (Page     => View_Name,
                          Request  => Req,
                          Response => Rep);
            Util.Measures.Report (S, "Pass" & Integer'Image (I) & ": Render view "
                                  & View_Name);

            Rep.Read_Content (Content);
            Util.Files.Write_File (Result_File, Content);
            Util.Tests.Assert_Equal_Files (T       => T,
                                           Expect  => To_String (T.Expect),
                                           Test    => Result_File,
                                           Message => "Restore and render view");
         end;
      end loop;
   end Test_Load_Facelet;

   --  Test case name
   overriding
   function Name (T : Test) return Util.Tests.Message_String is
   begin
      return Util.Tests.Format ("Test " & To_String (T.Name));
   end Name;

   --  Perform the test.
   overriding
   procedure Run_Test (T : in out Test) is
   begin
      T.Test_Load_Facelet;
   end Run_Test;

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
      use Ada.Directories;

      Result_Dir  : constant String := "regtests/result/views";
      Dir         : constant String := "regtests/files/views";
      Expect_Dir  : constant String := "regtests/expect/views";
      Path        : constant String := Util.Tests.Get_Path (Dir);
      Expect_Path : constant String := Util.Tests.Get_Path (Expect_Dir);
      Result_Path : constant String := Util.Tests.Get_Test_Path (Result_Dir);
      Search      : Search_Type;
      Filter      : constant Filter_Type := (others => True);
      Ent         : Directory_Entry_Type;
   begin
      if Kind (Path) = Directory then
         Ada.Text_IO.Put_Line ("Cannot read test directory: " & Path);
      end if;

      Start_Search (Search, Directory => Path, Pattern => "*.xhtml", Filter => Filter);
      while More_Entries (Search) loop
         Get_Next_Entry (Search, Ent);
         declare
            Simple    : constant String := Simple_Name (Ent);
            Tst      : Test_Case_Access;
         begin
            if Simple /= "." and then Simple /= ".."
              and then Simple /= ".svn" then
               Tst := new Test;
               Tst.Name := To_Unbounded_String (Dir & "/" & Simple);
               Tst.File := To_Unbounded_String ("views/" & Simple);
               Tst.Expect := To_Unbounded_String (Expect_Path & "/" & Simple);
               Tst.Result := To_Unbounded_String (Result_Path & "/" & Simple);
               Suite.Add_Test (Tst.all'Access);
            end if;
         end;
      end loop;
   end Add_Tests;

end ASF.Applications.Views.Tests;

-----------------------------------------------------------------------
--  Render Tests - Unit tests for ASF.Applications.Views
--  Copyright (C) 2009, 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 Ada.Text_IO;
with ASF.Applications.Main;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Requests.Tools;
with ASF.Servlets.Faces;
with Ada.Directories;

with Util.Test_Caller;
with Util.Files;
with Util.Measures;
package body ASF.Applications.Views.Tests is

   use Ada.Strings.Unbounded;

   overriding
   procedure Set_Up (T : in out Test) is
   begin
      null;
   end Set_Up;
   --  Set up performed before each test case

   --  Test loading of facelet file
   procedure Test_Load_Facelet (T : in out Test) is

      use ASF;
      use ASF.Contexts.Faces;

      App      : Applications.Main.Application;
--        H        : Applications.Views.View_Handler;

      View_Name   : constant String := To_String (T.File);
      Result_File : constant String := To_String (T.Result);
      Conf        : Applications.Config;
      App_Factory : Applications.Main.Application_Factory;
      Dir         : constant String := "regtests/files";
      Path        : constant String := Util.Tests.Get_Path (Dir);
      Faces       : aliased ASF.Servlets.Faces.Faces_Servlet;
   begin
      Conf.Load_Properties ("regtests/view.properties");
      Conf.Set ("view.dir", Path);
      App.Initialize (Conf, App_Factory);
      App.Register_Application ("/");
      App.Add_Servlet ("faces", Faces'Unchecked_Access);

      App.Set_Global ("function", "Test_Load_Facelet");
      for I in 1 .. 2 loop
         declare
            S : Util.Measures.Stamp;
            Req       : ASF.Requests.Mockup.Request;
            Rep       : aliased ASF.Responses.Mockup.Response;
            Content   : Unbounded_String;
         begin
            ASF.Requests.Tools.Set_Context (Req      => Req,
                                            Servlet  => Faces'Unchecked_Access,
                                            Response => Rep'Unchecked_Access);
            Req.Set_Method ("GET");
            Req.Set_Path_Info (View_Name);
            Req.Set_Parameter ("file-name", To_String (T.Name));
            Req.Set_Header ("file", To_String (T.Name));
            App.Dispatch (Page     => View_Name,
                          Request  => Req,
                          Response => Rep);
            Util.Measures.Report (S, "Pass" & Integer'Image (I) & ": Render view "
                                  & View_Name);

            Rep.Read_Content (Content);
            Util.Files.Write_File (Result_File, Content);
            Util.Tests.Assert_Equal_Files (T       => T,
                                           Expect  => To_String (T.Expect),
                                           Test    => Result_File,
                                           Message => "Restore and render view");
         end;
      end loop;
   end Test_Load_Facelet;

   --  Test case name
   overriding
   function Name (T : Test) return Util.Tests.Message_String is
   begin
      return Util.Tests.Format ("Test " & To_String (T.Name));
   end Name;

   --  Perform the test.
   overriding
   procedure Run_Test (T : in out Test) is
   begin
      T.Test_Load_Facelet;
   end Run_Test;

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
      use Ada.Directories;

      Result_Dir  : constant String := "regtests/result/views";
      Dir         : constant String := "regtests/files/views";
      Expect_Dir  : constant String := "regtests/expect/views";
      Path        : constant String := Util.Tests.Get_Path (Dir);
      Expect_Path : constant String := Util.Tests.Get_Path (Expect_Dir);
      Result_Path : constant String := Util.Tests.Get_Test_Path (Result_Dir);
      Search      : Search_Type;
      Filter      : constant Filter_Type := (others => True);
      Ent         : Directory_Entry_Type;
   begin
      if Kind (Path) /= Directory then
         Ada.Text_IO.Put_Line ("Cannot read test directory: " & Path);
      end if;

      Start_Search (Search, Directory => Path, Pattern => "*.xhtml", Filter => Filter);
      while More_Entries (Search) loop
         Get_Next_Entry (Search, Ent);
         declare
            Simple    : constant String := Simple_Name (Ent);
            Tst      : Test_Case_Access;
         begin
            if Simple /= "." and then Simple /= ".."
              and then Simple /= ".svn" then
               Tst := new Test;
               Tst.Name := To_Unbounded_String (Dir & "/" & Simple);
               Tst.File := To_Unbounded_String ("views/" & Simple);
               Tst.Expect := To_Unbounded_String (Expect_Path & "/" & Simple);
               Tst.Result := To_Unbounded_String (Result_Path & "/" & Simple);
               Suite.Add_Test (Tst.all'Access);
            end if;
         end;
      end loop;
   end Add_Tests;

end ASF.Applications.Views.Tests;

Fix an invalid warning reported during execution of unit tests


-----------------------------------------------------------------------
--  atlas-reviews-beans -- Beans for module reviews
--  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.
-----------------------------------------------------------------------

package body Atlas.Reviews.Beans is

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Review_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return Atlas.Reviews.Models.Review_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Review_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "title" then
         From.Set_Title (Util.Beans.Objects.To_String (Value));
      elsif Name = "site" then
         From.Set_Site (Util.Beans.Objects.To_String (Value));
      elsif Name = "text" then
         From.Set_Text (Util.Beans.Objects.To_String (Value));
      end if;
   end Set_Value;

   overriding
   procedure Save (Bean : in out Review_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Module.Save (Bean);
   end Save;

   overriding
   procedure Delete (Bean : in out Review_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Module.Delete (Bean);
   end Delete;

   --  ------------------------------
   --  Create the Review_Bean bean instance.
   --  ------------------------------
   function Create_Review_Bean (Module : in Atlas.Reviews.Modules.Review_Module_Access)
      return Util.Beans.Basic.Readonly_Bean_Access is
      Object : constant Review_Bean_Access := new Review_Bean;
   begin
      Object.Module := Module;
      return Object.all'Access;
   end Create_Review_Bean;

end Atlas.Reviews.Beans;

-----------------------------------------------------------------------
--  atlas-reviews-beans -- Beans for module reviews
--  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 ADO.Sessions;
with ADO.Queries;
with ADO.Utils;
with ADO.Datasets;
with AWA.Services.Contexts;
package body Atlas.Reviews.Beans is

   package ASC renames AWA.Services.Contexts;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Review_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return Atlas.Reviews.Models.Review_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Review_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "title" then
         From.Set_Title (Util.Beans.Objects.To_String (Value));
      elsif Name = "site" then
         From.Set_Site (Util.Beans.Objects.To_String (Value));
      elsif Name = "text" then
         From.Set_Text (Util.Beans.Objects.To_String (Value));
      elsif Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         declare
            Ctx : constant ASC.Service_Context_Access := AWA.Services.Contexts.Current;
            DB  : ADO.Sessions.Session := AWA.Services.Contexts.Get_Session (Ctx);
            Id  : constant ADO.Identifier := ADO.Utils.To_Identifier (Value);
            Found : Boolean;
         begin
            From.Load (DB, Id, Found);
         end;
      end if;
   end Set_Value;

   overriding
   procedure Save (Bean : in out Review_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Module.Save (Bean);
   end Save;

   overriding
   procedure Delete (Bean : in out Review_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Module.Delete (Bean);
   end Delete;

   overriding
   procedure Load (Bean : in out Review_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      Session     : ADO.Sessions.Session := Bean.Module.Get_Session;
   begin
      null;
   end Load;

   --  ------------------------------
   --  Create the Review_Bean bean instance.
   --  ------------------------------
   function Create_Review_Bean (Module : in Atlas.Reviews.Modules.Review_Module_Access)
      return Util.Beans.Basic.Readonly_Bean_Access is
      Object : constant Review_Bean_Access := new Review_Bean;
   begin
      Object.Module := Module;
      return Object.all'Access;
   end Create_Review_Bean;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Review_List_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "page" then
         return Util.Beans.Objects.To_Object (From.Page);
      elsif Name = "page_size" then
         return Util.Beans.Objects.To_Object (From.Page_Size);
      elsif Name = "count" then
         return Util.Beans.Objects.To_Object (From.Count);
      elsif Name = "reviews" then
         return Util.Beans.Objects.To_Object (Value   => From.Reviews_Bean,
                                              Storage => Util.Beans.Objects.STATIC);
      else
         return From.Reviews.Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Review_List_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "page" then
         From.Page := Util.Beans.Objects.To_Integer (Value);
      elsif Name = "page_size" then
         From.Page_Size := Util.Beans.Objects.To_Integer (Value);
      end if;
   end Set_Value;

   overriding
   procedure Load (Into    : in out Review_List_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      Session     : ADO.Sessions.Session := Into.Module.Get_Session;
      Query       : ADO.Queries.Context;
      Count_Query : ADO.Queries.Context;
      First       : constant Natural  := (Into.Page - 1) * Into.Page_Size;
      Last        : constant Positive := First + Into.Page_Size;
   begin
      Query.Set_Query (Atlas.Reviews.Models.Query_List);
      Count_Query.Set_Count_Query (Atlas.Reviews.Models.Query_List);
      Query.Bind_Param (Name => "first", Value => First);
      Query.Bind_Param (Name => "last", Value => Last);
      Atlas.Reviews.Models.List (Into.Reviews, Session, Query);
      Into.Count := ADO.Datasets.Get_Count (Session, Count_Query);
   end Load;

   --  ------------------------------
   --  Create the Review_List_Bean bean instance.
   --  ------------------------------
   function Create_Review_List_Bean (Module : in Atlas.Reviews.Modules.Review_Module_Access)
                                     return Util.Beans.Basic.Readonly_Bean_Access is
      Object  : constant Review_List_Bean_Access := new Review_List_Bean;
   begin
      Object.Module       := Module;
      Object.Reviews_Bean := Object.Reviews'Access;
      Object.Page_Size    := 20;
      Object.Page         := 1;
      Object.Count        := 0;
      return Object.all'Access;
   end Create_Review_List_Bean;

end Atlas.Reviews.Beans;

Implement the Review_List_Bean

Implement the Review_List_Bean


-----------------------------------------------------------------------
--  awa-counters-modules -- Module counters
--  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 ADO.Queries;
with ADO.Statements;
with ADO.Sessions;
with ADO.Sessions.Entities;
with ADO.SQL;

with Util.Dates;
with Util.Log.Loggers;

with AWA.Services.Contexts;
with AWA.Counters.Models;
with AWA.Modules.Get;
package body AWA.Counters.Modules is

   use type ADO.Schemas.Class_Mapping_Access;

   package ASC renames AWA.Services.Contexts;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Awa.Counters.Module");

   procedure Load_Definition (DB     : in out ADO.Sessions.Master_Session;
                              Def    : in Counter_Def;
                              Result : out Natural);

   procedure Flush (DB       : in out ADO.Sessions.Master_Session;
                    Counter  : in Counter_Def;
                    Def_Id   : in Natural;
                    Counters : in Counter_Maps.Map;
                    Date     : in Ada.Calendar.Time);

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

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

      --  Add here the creation of manager instances.
   end Initialize;

   --  ------------------------------
   --  Configures the module after its initialization and after having read its XML configuration.
   --  ------------------------------
   overriding
   procedure Configure (Plugin : in out Counter_Module;
                        Props  : in ASF.Applications.Config) is
      pragma Unreferenced (Props);
   begin
      Plugin.Counter_Limit := Plugin.Get_Config (PARAM_COUNTER_LIMIT, DEFAULT_COUNTER_LIMIT);
      Plugin.Age_Limit := Duration (Plugin.Get_Config (PARAM_AGE_LIMIT, 300));
   end Configure;

   --  ------------------------------
   --  Get the counters module.
   --  ------------------------------
   function Get_Counter_Module return Counter_Module_Access is
      function Get is new AWA.Modules.Get (Counter_Module, Counter_Module_Access, NAME);
   begin
      return Get;
   end Get_Counter_Module;

   --  ------------------------------
   --  Increment the counter identified by <tt>Counter</tt> and associated with the
   --  database object <tt>Object</tt>.
   --  ------------------------------
   procedure Increment (Plugin  : in out Counter_Module;
                        Counter : in Counter_Index_Type;
                        Object  : in ADO.Objects.Object_Ref'Class) is
   begin
      if Plugin.Counters.Need_Flush (Plugin.Counter_Limit, Plugin.Age_Limit) then
         Plugin.Flush;
      end if;
      Plugin.Counters.Increment (Counter, Object);
   end Increment;

   protected body Counter_Table is

      --  ------------------------------
      --  Increment the counter identified by <tt>Counter</tt> and associated with the
      --  database object <tt>Object</tt>.
      --  ------------------------------
      procedure Increment (Counter : in Counter_Index_Type;
                           Object  : in ADO.Objects.Object_Ref'Class) is

         procedure Increment (Key     : in ADO.Objects.Object_Key;
                              Element : in out Positive);

         procedure Increment (Key     : in ADO.Objects.Object_Key;
                              Element : in out Positive) is
            pragma Unreferenced (Key);
         begin
            Element := Element + 1;
         end Increment;

         Key : constant ADO.Objects.Object_Key := Object.Get_Key;
         Pos : Counter_Maps.Cursor;
      begin
         if Counters = null then
            Counters := new Counter_Map_Array (1 .. Counter_Arrays.Get_Last);
            Day := Ada.Calendar.Clock;
            Day_End := Util.Dates.Get_Day_End (Day);
         end if;
         Pos := Counters (Counter).Find (Key);
         if Counter_Maps.Has_Element (Pos) then
            Counters (Counter).Update_Element (Pos, Increment'Access);
         else
            Counters (Counter).Insert (Key, 1);
            Nb_Counters := Nb_Counters + 1;
         end if;
      end Increment;

      --  ------------------------------
      --  Get the counters that have been collected with the date and prepare to collect
      --  new counters.
      --  ------------------------------
      procedure Steal_Counters (Result : out Counter_Map_Array_Access;
                                Date   : out Ada.Calendar.Time) is
      begin
         Result      := Counters;
         Date        := Day;
         Counters    := null;
         Nb_Counters := 0;
      end Steal_Counters;

      --  ------------------------------
      --  Check if we must flush the counters.
      --  ------------------------------
      function Need_Flush (Limit   : in Natural;
                           Seconds : in Duration) return Boolean is
         use type Ada.Calendar.Time;
      begin
         if Counters = null then
            return False;
         elsif Nb_Counters > Limit then
            return True;
         else
            declare
               Now : constant Ada.Calendar.Time := Ada.Calendar.Clock;
            begin
               return Now > Day_End or Now - Day >= Seconds;
            end;
         end if;
      end Need_Flush;

      --  ------------------------------
      --  Get the definition ID associated with the counter.
      --  ------------------------------
      procedure Get_Definition (Counter : in Counter_Index_Type;
                                Result  : out Natural) is
      begin
         if Definitions = null then
            Definitions := new Definition_Array_Type (1 .. Counter_Arrays.Get_Last);
            Definitions.all := (others => 0);
         end if;
         if Definitions (Counter) = 0 then
            declare
               Ctx     : constant ASC.Service_Context_Access := ASC.Current;
               Session : ADO.Sessions.Master_Session := ASC.Get_Master_Session (Ctx);
            begin
               Load_Definition (Session, Counter_Arrays.Get_Element (Counter).all,
                                Definitions (Counter));
            end;
         end if;
         Result := Definitions (Counter);
      end Get_Definition;

   end Counter_Table;

   procedure Load_Definition (DB     : in out ADO.Sessions.Master_Session;
                              Def    : in Counter_Def;
                              Result : out Natural) is

      Def_Db : AWA.Counters.Models.Counter_Definition_Ref;
      Query  : ADO.SQL.Query;
      Found  : Boolean;
   begin
      if Def.Table = null then
         Query.Set_Filter ("name = :name AND entity_type IS NULL");
      else
         Query.Set_Filter ("name = :name AND entity_type = :entity_type");
         ADO.Sessions.Entities.Bind_Param (Params  => Query,
                                           Name    => "entity_type",
                                           Table   => Def.Table,
                                           Session => DB);
      end if;
      Query.Bind_Param ("name", Def.Field.all);
      Def_Db.Find (DB, Query, Found);
      if not Found then
         if Def.Table /= null then
            Def_Db.Set_Entity_Type (ADO.Sessions.Entities.Find_Entity_Type (DB, Def.Table));
         end if;
         Def_Db.Set_Name (Def.Field.all);
         Def_Db.Save (DB);
      end if;
      Result := Natural (Def_Db.Get_Id);
   end Load_Definition;

   procedure Flush (DB       : in out ADO.Sessions.Master_Session;
                    Counter  : in Counter_Def;
                    Def_Id   : in Natural;
                    Counters : in Counter_Maps.Map;
                    Date     : in Ada.Calendar.Time) is
      Query  : ADO.Queries.Context;
      Stmt   : ADO.Statements.Query_Statement;
      Update : ADO.Statements.Query_Statement;
      Iter   : Counter_Maps.Cursor := Counters.First;
      Id     : ADO.Identifier;
   begin
      Query.Set_Query (AWA.Counters.Models.Query_Counter_Update);
      Stmt := DB.Create_Statement (Query);
      if Counter.Table /= null then
         Query.Set_Query (AWA.Counters.Models.Query_Counter_Update_Field);
         Update := DB.Create_Statement (Counter.Table);
         Update.Bind_Param ("table", Counter.Table.Table.all);
         Update.Bind_Param ("field", Counter.Field.all);
      end if;
      while Counter_Maps.Has_Element (Iter) loop
         Id := ADO.Objects.Get_Value (Counter_Maps.Key (Iter));
         Stmt.Bind_Param ("date", Date);
         Stmt.Bind_Param ("id", Id);
         Stmt.Bind_Param ("counter", Counter_Maps.Element (Iter));
         Stmt.Bind_Param ("definition", Integer (Def_Id));
         Stmt.Execute;
         if Counter.Table /= null then
            Update.Bind_Param ("counter", Counter_Maps.Element (Iter));
            Update.Bind_Param ("id", Id);
            Update.Execute;
         end if;
         Counter_Maps.Next (Iter);
      end loop;
   end Flush;

   --  ------------------------------
   --  Flush the existing counters and update all the database records refered to them.
   --  ------------------------------
   procedure Flush (Plugin : in out Counter_Module) is
      procedure Free is new
        Ada.Unchecked_Deallocation (Object => Counter_Map_Array,
                                    Name   => Counter_Map_Array_Access);

      Day      : Ada.Calendar.Time;
      Counters : Counter_Map_Array_Access;
   begin
      Plugin.Counters.Steal_Counters (Counters, Day);
      if Counters = null then
         return;
      end if;
      declare
         DB     : ADO.Sessions.Master_Session := Plugin.Get_Master_Session;
         Date   : constant Ada.Calendar.Time := Util.Dates.Get_Day_Start (Day);
         Def_Id : Natural;
      begin
         DB.Begin_Transaction;
         for I in Counters'Range loop
            if not Counters (I).Is_Empty then
               declare
                  Counter : constant Counter_Def := Counter_Arrays.Get_Element (I).all;
               begin
                  Plugin.Counters.Get_Definition (I, Def_Id);
                  Flush (DB, Counter, Def_Id, Counters (I), Date);
               end;
            end if;
         end loop;
         DB.Commit;
      end;
      Free (Counters);
   end Flush;

end AWA.Counters.Modules;

-----------------------------------------------------------------------
--  awa-counters-modules -- Module counters
--  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 ADO.Queries;
with ADO.Statements;
with ADO.Sessions;
with ADO.Sessions.Entities;
with ADO.SQL;

with Util.Dates;
with Util.Log.Loggers;

with AWA.Services.Contexts;
with AWA.Counters.Models;
with AWA.Modules.Get;
package body AWA.Counters.Modules is

   use type ADO.Schemas.Class_Mapping_Access;

   package ASC renames AWA.Services.Contexts;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Awa.Counters.Module");

   procedure Load_Definition (DB     : in out ADO.Sessions.Master_Session;
                              Def    : in Counter_Def;
                              Result : out Natural);

   procedure Flush (DB       : in out ADO.Sessions.Master_Session;
                    Counter  : in Counter_Def;
                    Def_Id   : in Natural;
                    Counters : in Counter_Maps.Map;
                    Date     : in Ada.Calendar.Time);

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

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

      --  Add here the creation of manager instances.
   end Initialize;

   --  ------------------------------
   --  Configures the module after its initialization and after having read its XML configuration.
   --  ------------------------------
   overriding
   procedure Configure (Plugin : in out Counter_Module;
                        Props  : in ASF.Applications.Config) is
      pragma Unreferenced (Props);
   begin
      Plugin.Counter_Limit := Plugin.Get_Config (PARAM_COUNTER_LIMIT, DEFAULT_COUNTER_LIMIT);
      Plugin.Age_Limit := Duration (Plugin.Get_Config (PARAM_AGE_LIMIT, 300));
   end Configure;

   --  ------------------------------
   --  Get the counters module.
   --  ------------------------------
   function Get_Counter_Module return Counter_Module_Access is
      function Get is new AWA.Modules.Get (Counter_Module, Counter_Module_Access, NAME);
   begin
      return Get;
   end Get_Counter_Module;

   --  ------------------------------
   --  Increment the counter identified by <tt>Counter</tt> and associated with the
   --  database object <tt>Object</tt>.
   --  ------------------------------
   procedure Increment (Plugin  : in out Counter_Module;
                        Counter : in Counter_Index_Type;
                        Object  : in ADO.Objects.Object_Ref'Class) is
   begin
      if Plugin.Counters.Need_Flush (Plugin.Counter_Limit, Plugin.Age_Limit) then
         Plugin.Flush;
      end if;
      Plugin.Counters.Increment (Counter, Object);
   end Increment;

   --  ------------------------------
   --  Get the current counter value.
   --  ------------------------------
   procedure Get_Counter (Plugin  : in out Counter_Module;
                          Counter : in AWA.Counters.Counter_Index_Type;
                          Object  : in ADO.Objects.Object_Ref'Class;
                          Result  : out Natural) is
      Id   : constant ADO.Identifier := ADO.Objects.Get_Value (Object.Get_Key);
      DB   : ADO.Sessions.Session := Plugin.Get_Session;
      Stmt : ADO.Statements.Query_Statement
        := DB.Create_Statement ("SELECT SUM(counter) FROM awa_counter WHERE "
                                & "object_id = :id AND definition_id = :definition_id");
      Def_Id : Natural;
   begin
      Plugin.Counters.Get_Definition (Counter, Def_Id);
      Stmt.Bind_Param ("id", Id);
      Stmt.Bind_Param ("definition_id", Def_Id);
      Stmt.Execute;
      Result := Stmt.Get_Result_Integer;
   end Get_Counter;

   protected body Counter_Table is

      --  ------------------------------
      --  Increment the counter identified by <tt>Counter</tt> and associated with the
      --  database object <tt>Object</tt>.
      --  ------------------------------
      procedure Increment (Counter : in Counter_Index_Type;
                           Object  : in ADO.Objects.Object_Ref'Class) is

         procedure Increment (Key     : in ADO.Objects.Object_Key;
                              Element : in out Positive);

         procedure Increment (Key     : in ADO.Objects.Object_Key;
                              Element : in out Positive) is
            pragma Unreferenced (Key);
         begin
            Element := Element + 1;
         end Increment;

         Key : constant ADO.Objects.Object_Key := Object.Get_Key;
         Pos : Counter_Maps.Cursor;
      begin
         if Counters = null then
            Counters := new Counter_Map_Array (1 .. Counter_Arrays.Get_Last);
            Day := Ada.Calendar.Clock;
            Day_End := Util.Dates.Get_Day_End (Day);
         end if;
         Pos := Counters (Counter).Find (Key);
         if Counter_Maps.Has_Element (Pos) then
            Counters (Counter).Update_Element (Pos, Increment'Access);
         else
            Counters (Counter).Insert (Key, 1);
            Nb_Counters := Nb_Counters + 1;
         end if;
      end Increment;

      --  ------------------------------
      --  Get the counters that have been collected with the date and prepare to collect
      --  new counters.
      --  ------------------------------
      procedure Steal_Counters (Result : out Counter_Map_Array_Access;
                                Date   : out Ada.Calendar.Time) is
      begin
         Result      := Counters;
         Date        := Day;
         Counters    := null;
         Nb_Counters := 0;
      end Steal_Counters;

      --  ------------------------------
      --  Check if we must flush the counters.
      --  ------------------------------
      function Need_Flush (Limit   : in Natural;
                           Seconds : in Duration) return Boolean is
         use type Ada.Calendar.Time;
      begin
         if Counters = null then
            return False;
         elsif Nb_Counters > Limit then
            return True;
         else
            declare
               Now : constant Ada.Calendar.Time := Ada.Calendar.Clock;
            begin
               return Now > Day_End or Now - Day >= Seconds;
            end;
         end if;
      end Need_Flush;

      --  ------------------------------
      --  Get the definition ID associated with the counter.
      --  ------------------------------
      procedure Get_Definition (Counter : in Counter_Index_Type;
                                Result  : out Natural) is
      begin
         if Definitions = null then
            Definitions := new Definition_Array_Type (1 .. Counter_Arrays.Get_Last);
            Definitions.all := (others => 0);
         end if;
         if Definitions (Counter) = 0 then
            declare
               Ctx     : constant ASC.Service_Context_Access := ASC.Current;
               Session : ADO.Sessions.Master_Session := ASC.Get_Master_Session (Ctx);
            begin
               Load_Definition (Session, Counter_Arrays.Get_Element (Counter).all,
                                Definitions (Counter));
            end;
         end if;
         Result := Definitions (Counter);
      end Get_Definition;

   end Counter_Table;

   procedure Load_Definition (DB     : in out ADO.Sessions.Master_Session;
                              Def    : in Counter_Def;
                              Result : out Natural) is

      Def_Db : AWA.Counters.Models.Counter_Definition_Ref;
      Query  : ADO.SQL.Query;
      Found  : Boolean;
   begin
      if Def.Table = null then
         Query.Set_Filter ("name = :name AND entity_type IS NULL");
      else
         Query.Set_Filter ("name = :name AND entity_type = :entity_type");
         ADO.Sessions.Entities.Bind_Param (Params  => Query,
                                           Name    => "entity_type",
                                           Table   => Def.Table,
                                           Session => DB);
      end if;
      Query.Bind_Param ("name", Def.Field.all);
      Def_Db.Find (DB, Query, Found);
      if not Found then
         if Def.Table /= null then
            Def_Db.Set_Entity_Type (ADO.Sessions.Entities.Find_Entity_Type (DB, Def.Table));
         end if;
         Def_Db.Set_Name (Def.Field.all);
         Def_Db.Save (DB);
      end if;
      Result := Natural (Def_Db.Get_Id);
   end Load_Definition;

   procedure Flush (DB       : in out ADO.Sessions.Master_Session;
                    Counter  : in Counter_Def;
                    Def_Id   : in Natural;
                    Counters : in Counter_Maps.Map;
                    Date     : in Ada.Calendar.Time) is
      Query  : ADO.Queries.Context;
      Stmt   : ADO.Statements.Query_Statement;
      Update : ADO.Statements.Query_Statement;
      Iter   : Counter_Maps.Cursor := Counters.First;
      Id     : ADO.Identifier;
   begin
      Query.Set_Query (AWA.Counters.Models.Query_Counter_Update);
      Stmt := DB.Create_Statement (Query);
      if Counter.Table /= null then
         Query.Set_Query (AWA.Counters.Models.Query_Counter_Update_Field);
         Update := DB.Create_Statement (Counter.Table);
         Update.Bind_Param ("table", Counter.Table.Table.all);
         Update.Bind_Param ("field", Counter.Field.all);
      end if;
      while Counter_Maps.Has_Element (Iter) loop
         Id := ADO.Objects.Get_Value (Counter_Maps.Key (Iter));
         Stmt.Bind_Param ("date", Date);
         Stmt.Bind_Param ("id", Id);
         Stmt.Bind_Param ("counter", Counter_Maps.Element (Iter));
         Stmt.Bind_Param ("definition", Integer (Def_Id));
         Stmt.Execute;
         if Counter.Table /= null then
            Update.Bind_Param ("counter", Counter_Maps.Element (Iter));
            Update.Bind_Param ("id", Id);
            Update.Execute;
         end if;
         Counter_Maps.Next (Iter);
      end loop;
   end Flush;

   --  ------------------------------
   --  Flush the existing counters and update all the database records refered to them.
   --  ------------------------------
   procedure Flush (Plugin : in out Counter_Module) is
      procedure Free is new
        Ada.Unchecked_Deallocation (Object => Counter_Map_Array,
                                    Name   => Counter_Map_Array_Access);

      Day      : Ada.Calendar.Time;
      Counters : Counter_Map_Array_Access;
   begin
      Plugin.Counters.Steal_Counters (Counters, Day);
      if Counters = null then
         return;
      end if;
      declare
         DB     : ADO.Sessions.Master_Session := Plugin.Get_Master_Session;
         Date   : constant Ada.Calendar.Time := Util.Dates.Get_Day_Start (Day);
         Def_Id : Natural;
      begin
         DB.Begin_Transaction;
         for I in Counters'Range loop
            if not Counters (I).Is_Empty then
               declare
                  Counter : constant Counter_Def := Counter_Arrays.Get_Element (I).all;
               begin
                  Plugin.Counters.Get_Definition (I, Def_Id);
                  Flush (DB, Counter, Def_Id, Counters (I), Date);
               end;
            end if;
         end loop;
         DB.Commit;
      end;
      Free (Counters);
   end Flush;

end AWA.Counters.Modules;

Implement the Get_Counter procedure

Implement the Get_Counter procedure


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

with ADO.Testsuite;
with ADO.Drivers.Initializer;
with Regtests;

with Util.Tests;
with Util.Properties;
procedure ADO_Harness is

   procedure Initialize (Props : in Util.Properties.Manager);

   procedure Harness is new Util.Tests.Harness (ADO.Testsuite.Suite,
                                               Initialize);

   procedure Init_Drivers is new ADO.Drivers.Initializer (Util.Properties.Manager'Class,
                                                          ADO.Drivers.Initialize);

   --  ------------------------------
   --  Initialization procedure: setup the database
   --  ------------------------------
   procedure Initialize (Props : in Util.Properties.Manager) is
      DB : constant String := Props.Get ("test.database",
                                         "sqlite:///regtests.db");
   begin
      Init_Drivers (Props);
      Regtests.Initialize (DB);
   end Initialize;

begin
   Harness ("ado-tests.xml");
end ADO_Harness;

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

with ADO.Testsuite;
with ADO.Drivers;
with Regtests;

with Util.Tests;
with Util.Properties;
procedure ADO_Harness is

   procedure Initialize (Props : in Util.Properties.Manager);

   procedure Harness is new Util.Tests.Harness (ADO.Testsuite.Suite,
                                               Initialize);

   --  ------------------------------
   --  Initialization procedure: setup the database
   --  ------------------------------
   procedure Initialize (Props : in Util.Properties.Manager) is
      DB : constant String := Props.Get ("test.database",
                                         "sqlite:///regtests.db");
   begin
      ADO.Drivers.Initialize (Props);
      Regtests.Initialize (DB);
   end Initialize;

begin
   Harness ("ado-tests.xml");
end ADO_Harness;

Fix the initialization of the database drivers


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

with Ada.Finalization;

with Util.Strings.Maps;
with Security.Permissions;

--  == Security Context ==
--  The security context provides contextual information for a security controller to
--  verify that a permission is granted.
--  This security context is used as follows:
--
--   * An instance of the security context is declared within a function/procedure as
--   a local variable
--   * This instance will be associated with the current thread through a task attribute
--   * The security context is populated with information to identify the current user,
--   his roles, permissions and other information that could be used by security controllers
--   * To verify a permission, the current security context is retrieved and the
--   Has_Permission operation is called,
--   * The Has_Permission will first look in a small cache stored in the security context.
--   * When not present in the cache, it will use the security manager to find the
--   security controller associated with the permission to verify
--   * The security controller will be called with the security context to check the permission.
--   The whole job of checking the permission is done by the security controller.
--   The security controller retrieves information from the security context to decide
--   whether the permission is granted or not.
--   * The result produced by the security controller is then saved in the local cache.
--
package Security.Contexts is

   Invalid_Context : exception;

   type Security_Context is new Ada.Finalization.Limited_Controlled with private;
   type Security_Context_Access is access all Security_Context'Class;

   --  Get the application associated with the current service operation.
   function Get_User_Principal (Context : in Security_Context'Class)
                                return Security.Permissions.Principal_Access;
   pragma Inline_Always (Get_User_Principal);

   --  Get the permission manager.
   function Get_Permission_Manager (Context : in Security_Context'Class)
                                    return Security.Permissions.Permission_Manager_Access;
   pragma Inline_Always (Get_Permission_Manager);

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in Security.Permissions.Permission_Index;
                             Result     : out Boolean);

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in String;
                             Result     : out Boolean);

   --  Initializes the service context.  By creating the Security_Context variable,
   --  the instance will be associated with the current task attribute.  If the current task
   --  already has a security context, the new security context is installed, the old one
   --  being kept.
   overriding
   procedure Initialize (Context : in out Security_Context);

   --  Finalize the security context releases any object.  The previous security context is
   --  restored to the current task attribute.
   overriding
   procedure Finalize (Context : in out Security_Context);

   --  Set the current application and user context.
   procedure Set_Context (Context   : in out Security_Context;
                          Manager   : in Security.Permissions.Permission_Manager_Access;
                          Principal : in Security.Permissions.Principal_Access);

   --  Add a context information represented by Value under the name identified by
   --  Name in the security context Context.
   procedure Add_Context (Context   : in out Security_Context;
                          Name      : in String;
                          Value     : in String);

   --  Get the context information registered under the name Name in the security
   --  context Context.
   --  Raises Invalid_Context if there is no such information.
   function Get_Context (Context  : in Security_Context;
                         Name     : in String) return String;

   --  Returns True if a context information was registered under the name Name.
   function Has_Context (Context : in Security_Context;
                         Name    : in String) return Boolean;

   --  Get the current security context.
   --  Returns null if the current thread is not associated with any security context.
   function Current return Security_Context_Access;
   pragma Inline_Always (Current);

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   function Has_Permission (Permission : in Security.Permissions.Permission_Index) return Boolean;

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   function Has_Permission (Permission : in String) return Boolean;

private

   type Permission_Cache is record
      Perm   : Security.Permissions.Permission_Type;
      Result : Boolean;
   end record;

   type Security_Context is new Ada.Finalization.Limited_Controlled with record
      Previous    : Security_Context_Access := null;
      Manager     : Security.Permissions.Permission_Manager_Access := null;
      Principal   : Security.Permissions.Principal_Access := null;
      Context     : Util.Strings.Maps.Map;
   end record;

end Security.Contexts;

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

with Ada.Finalization;

with Util.Strings.Maps;
with Security.Permissions;

--  == Security Context ==
--  The security context provides contextual information for a security controller to
--  verify that a permission is granted.
--  This security context is used as follows:
--
--    * An instance of the security context is declared within a function/procedure as
--      a local variable
--
--    * This instance will be associated with the current thread through a task attribute
--
--    * The security context is populated with information to identify the current user,
--      his roles, permissions and other information that could be used by security controllers
--
--    * To verify a permission, the current security context is retrieved and the
--      Has_Permission operation is called,
--
--    * The Has_Permission will first look in a small cache stored in the security context.
--
--    * When not present in the cache, it will use the security manager to find the
--      security controller associated with the permission to verify
--
--    * The security controller will be called with the security context to check the permission.
--      The whole job of checking the permission is done by the security controller.
--      The security controller retrieves information from the security context to decide
--      whether the permission is granted or not.
--
--    * The result produced by the security controller is then saved in the local cache.
--
package Security.Contexts is

   Invalid_Context : exception;

   type Security_Context is new Ada.Finalization.Limited_Controlled with private;
   type Security_Context_Access is access all Security_Context'Class;

   --  Get the application associated with the current service operation.
   function Get_User_Principal (Context : in Security_Context'Class)
                                return Security.Permissions.Principal_Access;
   pragma Inline_Always (Get_User_Principal);

   --  Get the permission manager.
   function Get_Permission_Manager (Context : in Security_Context'Class)
                                    return Security.Permissions.Permission_Manager_Access;
   pragma Inline_Always (Get_Permission_Manager);

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in Security.Permissions.Permission_Index;
                             Result     : out Boolean);

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in String;
                             Result     : out Boolean);

   --  Initializes the service context.  By creating the Security_Context variable,
   --  the instance will be associated with the current task attribute.  If the current task
   --  already has a security context, the new security context is installed, the old one
   --  being kept.
   overriding
   procedure Initialize (Context : in out Security_Context);

   --  Finalize the security context releases any object.  The previous security context is
   --  restored to the current task attribute.
   overriding
   procedure Finalize (Context : in out Security_Context);

   --  Set the current application and user context.
   procedure Set_Context (Context   : in out Security_Context;
                          Manager   : in Security.Permissions.Permission_Manager_Access;
                          Principal : in Security.Permissions.Principal_Access);

   --  Add a context information represented by Value under the name identified by
   --  Name in the security context Context.
   procedure Add_Context (Context   : in out Security_Context;
                          Name      : in String;
                          Value     : in String);

   --  Get the context information registered under the name Name in the security
   --  context Context.
   --  Raises Invalid_Context if there is no such information.
   function Get_Context (Context  : in Security_Context;
                         Name     : in String) return String;

   --  Returns True if a context information was registered under the name Name.
   function Has_Context (Context : in Security_Context;
                         Name    : in String) return Boolean;

   --  Get the current security context.
   --  Returns null if the current thread is not associated with any security context.
   function Current return Security_Context_Access;
   pragma Inline_Always (Current);

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   function Has_Permission (Permission : in Security.Permissions.Permission_Index) return Boolean;

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   function Has_Permission (Permission : in String) return Boolean;

private

   type Permission_Cache is record
      Perm   : Security.Permissions.Permission_Type;
      Result : Boolean;
   end record;

   type Security_Context is new Ada.Finalization.Limited_Controlled with record
      Previous    : Security_Context_Access := null;
      Manager     : Security.Permissions.Permission_Manager_Access := null;
      Principal   : Security.Permissions.Principal_Access := null;
      Context     : Util.Strings.Maps.Map;
   end record;

end Security.Contexts;

Fix comment style for dynamo

Fix comment style for dynamo


-----------------------------------------------------------------------
--  security-policies -- Security 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 Ada.Unchecked_Deallocation;

with Util.Log.Loggers;

with Security.Controllers;
with Security.Contexts;

package body Security.Policies is

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

   procedure Free is
     new Ada.Unchecked_Deallocation (Security.Controllers.Controller'Class,
                                     Controller_Access);

   --  ------------------------------
   --  Get the policy index.
   --  ------------------------------
   function Get_Policy_Index (From : in Policy'Class) return Policy_Index is
   begin
      return From.Index;
   end Get_Policy_Index;

   --  ------------------------------
   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   --  ------------------------------
   procedure Add_Permission (Manager    : in out Policy;
                             Name       : in String;
                             Permission : in Controller_Access) is
   begin
      Manager.Manager.Add_Permission (Name, Permission);
   end Add_Permission;

   --  ------------------------------
   --  Get the policy with the name Name registered in the policy manager.
   --  Returns null if there is no such policy.
   --  ------------------------------
   function Get_Policy (Manager : in Policy_Manager;
                        Name    : in String) return Policy_Access is
   begin
      for I in Manager.Policies'Range loop
         if Manager.Policies (I) = null then
            return null;
         elsif Manager.Policies (I).Get_Name = Name then
            return Manager.Policies (I);
         end if;
      end loop;
      return null;
   end Get_Policy;

   --  ------------------------------
   --  Add the policy to the policy manager.  After a policy is added in the manager,
   --  it can participate in the security policy.
   --  Raises Policy_Error if the policy table is full.
   --  ------------------------------
   procedure Add_Policy (Manager : in out Policy_Manager;
                         Policy  : in Policy_Access) is
      Name : constant String := Policy.Get_Name;
   begin
      Log.Info ("Adding policy {0}", Name);

      for I in Manager.Policies'Range loop
         if Manager.Policies (I) = null then
            Manager.Policies (I) := Policy;
            Policy.Manager := Manager'Unchecked_Access;
            Policy.Index   := I;
            return;
         end if;
      end loop;
      Log.Error ("Policy table is full, increase policy manager table to {0} to add policy {1}",
                 Policy_Index'Image (Manager.Max_Policies + 1), Name);
      raise Policy_Error;
   end Add_Policy;

   --  ------------------------------
   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   --  ------------------------------
   procedure Add_Permission (Manager    : in out Policy_Manager;
                             Name       : in String;
                             Permission : in Controller_Access) is
      use type Permissions.Permission_Index;

      Index : Permission_Index;
   begin
      Log.Info ("Adding permission {0}", Name);

      Permissions.Add_Permission (Name, Index);
      if Index >= Manager.Last_Index then
         declare
            Count : constant Permission_Index := Index + 32;
            Perms : constant Controller_Access_Array_Access
              := new Controller_Access_Array (0 .. Count);
         begin
            if Manager.Permissions /= null then
               Perms (Manager.Permissions'Range) := Manager.Permissions.all;
            end if;
            Manager.Permissions := Perms;
            Manager.Last_Index := Count;
         end;
      end if;

      --  If the permission has a controller, release it.
      if Manager.Permissions (Index) /= null then
         Log.Warn ("Permission {0} is redefined", Name);
         Free (Manager.Permissions (Index));
      end if;

      Manager.Permissions (Index) := Permission;
   end Add_Permission;

   --  ------------------------------
   --  Checks whether the permission defined by the Permission is granted
   --  for the security context passed in Context.
   --  Returns true if such permission is granted.
   --  ------------------------------
   function Has_Permission (Manager    : in Policy_Manager;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean is
      use type Permissions.Permission_Index;
   begin
      if Permission.Id >= Manager.Last_Index then
         return False;
      end if;
      declare
         C : constant Controller_Access := Manager.Permissions (Permission.Id);
      begin
         if C = null then
            return False;
         else
            return C.Has_Permission (Context, Permission);
         end if;
      end;
   end Has_Permission;

   --  ------------------------------
   --  Create the policy contexts to be associated with the security context.
   --  ------------------------------
   function Create_Policy_Contexts (Manager : in Policy_Manager)
                                    return Policy_Context_Array_Access is
   begin
      return new Policy_Context_Array (1 .. Manager.Max_Policies);
   end Create_Policy_Contexts;

   --  Read the policy file
   procedure Read_Policy (Manager : in out Policy_Manager;
                          File    : in String) is

      use Util;

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

      package Policy_Config is
        new Reader_Config (Reader, Manager'Unchecked_Access);
      pragma Warnings (Off, Policy_Config);
   begin
      Log.Info ("Reading policy file {0}", File);

      --  Prepare the reader to parse the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Prepare_Config (Reader);
      end loop;

      --  Read the configuration file.
      Reader.Parse (File);

      --  Finish the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Finish_Config (Reader);
      end loop;

   end Read_Policy;

   --  ------------------------------
   --  Initialize the policy manager.
   --  ------------------------------
   overriding
   procedure Initialize (Manager : in out Policy_Manager) is
   begin
      null;
   end Initialize;

   --  ------------------------------
   --  Finalize the policy manager.
   --  ------------------------------
   overriding
   procedure Finalize (Manager : in out Policy_Manager) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Controller_Access_Array,
                                        Controller_Access_Array_Access);
      procedure Free is
        new Ada.Unchecked_Deallocation (Policy'Class,
                                        Policy_Access);

   begin
      --  Release the security controllers.
      if Manager.Permissions /= null then
         for I in Manager.Permissions.all'Range loop
            if Manager.Permissions (I) /= null then
               --  SCz 2011-12-03: GNAT 2011 reports a compilation error:
               --  'missing "with" clause on package "Security.Controllers"'
               --  if we use the 'Security.Controller_Access' type, even if this "with"
               --  clause exist.
               --  gcc 4.4.3 under Ubuntu does not have this issue.
               --  We use the 'Security.Controllers.Controller_Access' type to avoid the compiler
               --  bug but we have to use a temporary variable and do some type conversion...
               declare
                  P : Controller_Access := Manager.Permissions (I).all'Access;
               begin
                  Free (P);
                  Manager.Permissions (I) := null;
               end;
            end if;
         end loop;
         Free (Manager.Permissions);
      end if;

      --  Release the policy instances.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Free (Manager.Policies (I));
      end loop;

   end Finalize;

end Security.Policies;

-----------------------------------------------------------------------
--  security-policies -- Security 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 Ada.Unchecked_Deallocation;

with Util.Log.Loggers;

with Security.Controllers;
with Security.Contexts;

package body Security.Policies is

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

   procedure Free is
     new Ada.Unchecked_Deallocation (Security.Controllers.Controller'Class,
                                     Controller_Access);

   --  ------------------------------
   --  Get the policy index.
   --  ------------------------------
   function Get_Policy_Index (From : in Policy'Class) return Policy_Index is
   begin
      return From.Index;
   end Get_Policy_Index;

   --  ------------------------------
   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   --  ------------------------------
   procedure Add_Permission (Manager    : in out Policy;
                             Name       : in String;
                             Permission : in Controller_Access) is
   begin
      Manager.Manager.Add_Permission (Name, Permission);
   end Add_Permission;

   --  ------------------------------
   --  Get the policy with the name Name registered in the policy manager.
   --  Returns null if there is no such policy.
   --  ------------------------------
   function Get_Policy (Manager : in Policy_Manager;
                        Name    : in String) return Policy_Access is
   begin
      for I in Manager.Policies'Range loop
         if Manager.Policies (I) = null then
            return null;
         elsif Manager.Policies (I).Get_Name = Name then
            return Manager.Policies (I);
         end if;
      end loop;
      return null;
   end Get_Policy;

   --  ------------------------------
   --  Add the policy to the policy manager.  After a policy is added in the manager,
   --  it can participate in the security policy.
   --  Raises Policy_Error if the policy table is full.
   --  ------------------------------
   procedure Add_Policy (Manager : in out Policy_Manager;
                         Policy  : in Policy_Access) is
      Name : constant String := Policy.Get_Name;
   begin
      Log.Info ("Adding policy {0}", Name);

      for I in Manager.Policies'Range loop
         if Manager.Policies (I) = null then
            Manager.Policies (I) := Policy;
            Policy.Manager := Manager'Unchecked_Access;
            Policy.Index   := I;
            return;
         end if;
      end loop;
      Log.Error ("Policy table is full, increase policy manager table to {0} to add policy {1}",
                 Policy_Index'Image (Manager.Max_Policies + 1), Name);
      raise Policy_Error;
   end Add_Policy;

   --  ------------------------------
   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   --  ------------------------------
   procedure Add_Permission (Manager    : in out Policy_Manager;
                             Name       : in String;
                             Permission : in Controller_Access) is
      use type Permissions.Permission_Index;

      Index : Permission_Index;
   begin
      Log.Info ("Adding permission {0}", Name);

      Permissions.Add_Permission (Name, Index);
      if Index >= Manager.Last_Index then
         declare
            Count : constant Permission_Index := Index + 32;
            Perms : constant Controller_Access_Array_Access
              := new Controller_Access_Array (0 .. Count);
         begin
            if Manager.Permissions /= null then
               Perms (Manager.Permissions'Range) := Manager.Permissions.all;
            end if;
            Manager.Permissions := Perms;
            Manager.Last_Index := Count;
         end;
      end if;

      --  If the permission has a controller, release it.
      if Manager.Permissions (Index) /= null then
         Log.Warn ("Permission {0} is redefined", Name);
         Free (Manager.Permissions (Index));
      end if;

      Manager.Permissions (Index) := Permission;
   end Add_Permission;

   --  ------------------------------
   --  Checks whether the permission defined by the Permission is granted
   --  for the security context passed in Context.
   --  Returns true if such permission is granted.
   --  ------------------------------
   function Has_Permission (Manager    : in Policy_Manager;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean is
      use type Permissions.Permission_Index;
   begin
      if Permission.Id >= Manager.Last_Index then
         return False;
      end if;
      declare
         C : constant Controller_Access := Manager.Permissions (Permission.Id);
      begin
         if C = null then
            return False;
         else
            return C.Has_Permission (Context, Permission);
         end if;
      end;
   end Has_Permission;

   --  ------------------------------
   --  Create the policy contexts to be associated with the security context.
   --  ------------------------------
   function Create_Policy_Contexts (Manager : in Policy_Manager)
                                    return Policy_Context_Array_Access is
   begin
      return new Policy_Context_Array (1 .. Manager.Max_Policies);
   end Create_Policy_Contexts;

   --  ------------------------------
   --  Prepare the XML parser to read the policy configuration.
   --  ------------------------------
   procedure Prepare_Config (Manager : in out Policy_Manager;
                             Reader  : in out Util.Serialize.IO.XML.Parser) is
   begin
      --  Prepare the reader to parse the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Prepare_Config (Reader);
      end loop;
   end Prepare_Config;

   --  ------------------------------
   --  Finish reading the XML policy configuration.  The security policy implementation can use
   --  this procedure to perform any configuration setup after the configuration is parsed.
   --  ------------------------------
   procedure Finish_Config (Manager : in out Policy_Manager;
                            Reader  : in out Util.Serialize.IO.XML.Parser) is
   begin
      --  Finish the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Finish_Config (Reader);
      end loop;
   end Finish_Config;

   --  Read the policy file
   procedure Read_Policy (Manager : in out Policy_Manager;
                          File    : in String) is

      use Util;

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

      package Policy_Config is
        new Reader_Config (Reader, Manager'Unchecked_Access);
      pragma Warnings (Off, Policy_Config);
   begin
      Log.Info ("Reading policy file {0}", File);

      --  Read the configuration file.
      Reader.Parse (File);

   end Read_Policy;

   --  ------------------------------
   --  Initialize the policy manager.
   --  ------------------------------
   overriding
   procedure Initialize (Manager : in out Policy_Manager) is
   begin
      null;
   end Initialize;

   --  ------------------------------
   --  Finalize the policy manager.
   --  ------------------------------
   overriding
   procedure Finalize (Manager : in out Policy_Manager) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Controller_Access_Array,
                                        Controller_Access_Array_Access);
      procedure Free is
        new Ada.Unchecked_Deallocation (Policy'Class,
                                        Policy_Access);

   begin
      --  Release the security controllers.
      if Manager.Permissions /= null then
         for I in Manager.Permissions.all'Range loop
            if Manager.Permissions (I) /= null then
               --  SCz 2011-12-03: GNAT 2011 reports a compilation error:
               --  'missing "with" clause on package "Security.Controllers"'
               --  if we use the 'Security.Controller_Access' type, even if this "with"
               --  clause exist.
               --  gcc 4.4.3 under Ubuntu does not have this issue.
               --  We use the 'Security.Controllers.Controller_Access' type to avoid the compiler
               --  bug but we have to use a temporary variable and do some type conversion...
               declare
                  P : Controller_Access := Manager.Permissions (I).all'Access;
               begin
                  Free (P);
                  Manager.Permissions (I) := null;
               end;
            end if;
         end loop;
         Free (Manager.Permissions);
      end if;

      --  Release the policy instances.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Free (Manager.Policies (I));
      end loop;

   end Finalize;

end Security.Policies;

Implement the new procedure Prepare_Config and Finish_Config Call them in Read_Policy


with HAL;           use HAL;
with Virtual_File_System; use Virtual_File_System;
with HAL.Filesystem; use HAL.Filesystem;
with Semihosting;
with Semihosting.Filesystem; use Semihosting.Filesystem;
with File_Block_Drivers; use File_Block_Drivers;
with Partitions; use Partitions;

procedure Main is

   procedure List_Dir (FS : in out FS_Driver'Class;
                       Path : Pathname);
   procedure List_Partitions (FS : in out FS_Driver'Class;
                              Path_To_Disk_Image : Pathname);

   --------------
   -- List_Dir --
   --------------

   procedure List_Dir (FS : in out FS_Driver'Class; Path : Pathname) is
      Status : Status_Kind;
      DH : Directory_Handle_Ref;
   begin
      Status := FS.Open_Directory (Path, DH);
      if Status /= Status_Ok then
         Semihosting.Log_Line ("Open Directory '" & Path & "' Error: " & Status'Img);
      else
         declare
            Ent : Directory_Entry;
            Index : Positive := 1;
         begin

            Semihosting.Log_Line ("Listing '" & Path & "' content:");
            loop
               Status := DH.Read_Entry (Index, Ent);
               if Status = Status_Ok then
                  Semihosting.Log_Line (" - '" & DH.Entry_Name (Index) & "'");
                  Semihosting.Log_Line ("   Kind: " & Ent.Entry_Type'Img);
               else
                  exit;
               end if;
               Index := Index + 1;
            end loop;
         end;
      end if;
   end List_Dir;

   ---------------------
   -- List_Partitions --
   ---------------------

   procedure List_Partitions (FS : in out FS_Driver'Class;
                              Path_To_Disk_Image : Pathname)
   is
      File : File_Handle_Ref;
   begin
      if FS.Open (Path_To_Disk_Image, File) /= Status_Ok then
         Semihosting.Log_Line ("Cannot open disk image '" &
                                 Path_To_Disk_Image & "'");
         return;
      end if;

      declare
         Disk    : aliased File_Block_Driver (File);
         Nbr     : Natural;
         P_Entry : Partition_Entry;
      begin
         Nbr := Number_Of_Partitions (Disk'Unchecked_Access);
         Semihosting.Log_Line ("Disk '" & Path_To_Disk_Image & "' has " &
                                 Nbr'Img & " parition(s)");

         for Id in 1 .. Nbr loop
            if Get_Partition_Entry (Disk'Unchecked_Access,
                                    Id,
                                    P_Entry) /= Status_Ok
            then
               Semihosting.Log_Line ("Cannot read partition :" & Id'Img);
            else
               Semihosting.Log_Line (" - partition :" & Id'Img);
               Semihosting.Log_Line ("      Status:" & P_Entry.Status'Img);
               Semihosting.Log_Line ("      Kind: " & P_Entry.Kind'Img);
               Semihosting.Log_Line ("      LBA: " & P_Entry.First_Sector_LBA'Img);
               Semihosting.Log_Line ("      Number of sectors: " & P_Entry.Number_Of_Sectors'Img);

            end if;
         end loop;
      end;
   end List_Partitions;

   My_VFS : VFS;
   My_VFS2 : aliased VFS;
   My_VFS3 : aliased VFS;
   My_SHFS : aliased SHFS;
   Status : Status_Kind;
   FH : File_Handle_Ref;
   Data : Byte_Array (1 .. 10);

begin

   Status := My_VFS.Mount (Path       => "test1",
                           Filesystem => My_VFS2'Unchecked_Access);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Mount Error: " & Status'Img);
   end if;
   Status := My_VFS2.Mount (Path       => "test2",
                            Filesystem => My_VFS3'Unchecked_Access);

   if Status /= Status_Ok then
      Semihosting.Log_Line ("Mount Error: " & Status'Img);
   end if;

   Status := My_VFS.Mount (Path       => "host",
                            Filesystem => My_SHFS'Unchecked_Access);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Mount Error: " & Status'Img);
   end if;

   List_Partitions (My_VFS, "/host/tmp/disk_8_partitions.img");

   Status := My_VFS.Unlink ("/test1/no_file");
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Unlink Error: " & Status'Img);
   end if;
   Status := My_VFS.Unlink ("//test1/no_file");
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Unlink Error: " & Status'Img);
   end if;
   Status := My_VFS.Unlink ("/test1//no_file");
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Unlink Error: " & Status'Img);
   end if;
   Status := My_VFS.Unlink ("/test1/test2/no_file");
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Unlink Error: " & Status'Img);
   end if;

   Status := My_VFS.Open ("/host/tmp/test.shfs", FH);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Open Error: " & Status'Img);
   end if;

   Status := FH.Read (Data);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Read Error: " & Status'Img);
   end if;

   for C of Data loop
      Semihosting.Log (Character'Val (Integer (C)));
   end loop;
   Semihosting.Log_New_Line;

   Status := FH.Seek (10);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Seek Error: " & Status'Img);
   end if;

   Status := FH.Read (Data);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Read Error: " & Status'Img);
   end if;

   for C of Data loop
      Semihosting.Log (Character'Val (Integer (C)));
   end loop;
   Semihosting.Log_New_Line;

   Status := FH.Close;
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Close Error: " & Status'Img);
   end if;

   List_Dir (My_VFS, "/");
   List_Dir (My_VFS, "/test1");
   List_Dir (My_VFS, "/test1/");
end Main;

with HAL;           use HAL;
with Virtual_File_System; use Virtual_File_System;
with HAL.Filesystem; use HAL.Filesystem;
with Semihosting;
with Semihosting.Filesystem; use Semihosting.Filesystem;
with File_Block_Drivers; use File_Block_Drivers;
with Partitions; use Partitions;

procedure Main is

   procedure List_Dir (FS : in out FS_Driver'Class;
                       Path : Pathname);
   --  List files in directory

   procedure List_Partitions (FS : in out FS_Driver'Class;
                              Path_To_Disk_Image : Pathname);
   --  List partition in a disk file

   --------------
   -- List_Dir --
   --------------

   procedure List_Dir (FS : in out FS_Driver'Class; Path : Pathname) is
      Status : Status_Kind;
      DH : Directory_Handle_Ref;
   begin
      Status := FS.Open_Directory (Path, DH);
      if Status /= Status_Ok then
         Semihosting.Log_Line ("Open Directory '" & Path & "' Error: " & Status'Img);
      else
         declare
            Ent : Directory_Entry;
            Index : Positive := 1;
         begin

            Semihosting.Log_Line ("Listing '" & Path & "' content:");
            loop
               Status := DH.Read_Entry (Index, Ent);
               if Status = Status_Ok then
                  Semihosting.Log_Line (" - '" & DH.Entry_Name (Index) & "'");
                  Semihosting.Log_Line ("   Kind: " & Ent.Entry_Type'Img);
               else
                  exit;
               end if;
               Index := Index + 1;
            end loop;
         end;
      end if;
   end List_Dir;

   ---------------------
   -- List_Partitions --
   ---------------------

   procedure List_Partitions (FS : in out FS_Driver'Class;
                              Path_To_Disk_Image : Pathname)
   is
      File : File_Handle_Ref;
   begin
      if FS.Open (Path_To_Disk_Image, File) /= Status_Ok then
         Semihosting.Log_Line ("Cannot open disk image '" &
                                 Path_To_Disk_Image & "'");
         return;
      end if;

      declare
         Disk    : aliased File_Block_Driver (File);
         Nbr     : Natural;
         P_Entry : Partition_Entry;
      begin
         Nbr := Number_Of_Partitions (Disk'Unchecked_Access);
         Semihosting.Log_Line ("Disk '" & Path_To_Disk_Image & "' has " &
                                 Nbr'Img & " parition(s)");

         for Id in 1 .. Nbr loop
            if Get_Partition_Entry (Disk'Unchecked_Access,
                                    Id,
                                    P_Entry) /= Status_Ok
            then
               Semihosting.Log_Line ("Cannot read partition :" & Id'Img);
            else
               Semihosting.Log_Line (" - partition :" & Id'Img);
               Semihosting.Log_Line ("      Status:" & P_Entry.Status'Img);
               Semihosting.Log_Line ("      Kind: " & P_Entry.Kind'Img);
               Semihosting.Log_Line ("      LBA: " & P_Entry.First_Sector_LBA'Img);
               Semihosting.Log_Line ("      Number of sectors: " & P_Entry.Number_Of_Sectors'Img);
            end if;
         end loop;
      end;
   end List_Partitions;

   My_VFS : VFS;
   My_VFS2 : aliased VFS;
   My_VFS3 : aliased VFS;
   My_SHFS : aliased SHFS;
   Status : Status_Kind;
   FH : File_Handle_Ref;
   Data : Byte_Array (1 .. 10);

begin

   --  Mount My_VFS2 in My_VFS1
   Status := My_VFS.Mount (Path       => "vfs2",
                           Filesystem => My_VFS2'Unchecked_Access);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Mount Error: " & Status'Img);
   end if;

      --  Mount My_VFS3 in My_VFS2
   Status := My_VFS2.Mount (Path       => "vfs3",
                            Filesystem => My_VFS3'Unchecked_Access);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Mount Error: " & Status'Img);
   end if;

   --  Mount semi-hosting filesystem in My_VFS1
   Status := My_VFS.Mount (Path       => "host",
                            Filesystem => My_SHFS'Unchecked_Access);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Mount Error: " & Status'Img);
   end if;

   --  List all partitions of a disk image on the host
   List_Partitions (My_VFS, "/host/tmp/disk_8_partitions.img");

   --  Try to unlink a file that doesn't exist in My_VFS2
   Status := My_VFS.Unlink ("/vfs2/no_file");
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Unlink Error: " & Status'Img);
   end if;

   --  Try to unlink a file that doesn't exist in My_VFS3
   Status := My_VFS.Unlink ("/vfs2/vfs3/no_file");
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Unlink Error: " & Status'Img);
   end if;

   --  Open a file on the host
   Status := My_VFS.Open ("/host/tmp/test.shfs", FH);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Open Error: " & Status'Img);
   end if;

   --  Read the first 10 characters
   Status := FH.Read (Data);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Read Error: " & Status'Img);
   end if;

   for C of Data loop
      Semihosting.Log (Character'Val (Integer (C)));
   end loop;
   Semihosting.Log_New_Line;

   --  Move file cursor
   Status := FH.Seek (10);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Seek Error: " & Status'Img);
   end if;

   --  Read 10 characters again
   Status := FH.Read (Data);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Read Error: " & Status'Img);
   end if;

   for C of Data loop
      Semihosting.Log (Character'Val (Integer (C)));
   end loop;
   Semihosting.Log_New_Line;

   Status := FH.Close;
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Close Error: " & Status'Img);
   end if;

   --  Test directory listing
   List_Dir (My_VFS, "/");
   List_Dir (My_VFS, "/vfs2");
   List_Dir (My_VFS, "/vfs2/");
end Main;

Add a few comments

examples/filesystem: Add a few comments