------------------------------------------------------------------------------
-- Copyright (c) 2014, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

with Ada.Directories;
with Natools.S_Expressions.Atom_Ref_Constructors;
with Natools.S_Expressions.File_Readers;
with Natools.S_Expressions.Interpreter_Loop;
with Natools.Static_Maps.Web.Sites;
with Natools.Web.Pages;

package body Natools.Web.Sites is

   procedure Add_Page
     (Builder : in out Site_Builder;
      File_Root : in S_Expressions.Atom;
      Path_Root : in S_Expressions.Atom);

   procedure Add_Page
     (Builder : in out Site_Builder;
      Context : in Meaningless_Type;
      File_Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class);

   procedure Add_Page_Simple
     (Builder : in out Site_Builder;
      Context : in Meaningless_Type;
      Common_Name : in S_Expressions.Atom);

   procedure Get_Page
     (Container : in Page_Maps.Updatable_Map;
      Path : in S_Expressions.Atom;
      Result : out Page_Maps.Cursor;
      Extra_Path_First : out S_Expressions.Offset);

   procedure Execute
     (Builder : in out Site_Builder;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class);

   procedure Set_If_Possible
     (Reference : in out S_Expressions.Atom_Refs.Immutable_Reference;
      Expression : in S_Expressions.Lockable.Descriptor'Class);

   ------------------------------
   -- Local Helper Subprograms --
   ------------------------------

   procedure Get_Page
     (Container : in Page_Maps.Updatable_Map;
      Path : in S_Expressions.Atom;
      Result : out Page_Maps.Cursor;
      Extra_Path_First : out S_Expressions.Offset)
   is
      use type S_Expressions.Atom;
      use type S_Expressions.Octet;
      use type S_Expressions.Offset;
   begin
      Result := Container.Floor (Path);

      if not Page_Maps.Has_Element (Result) then
         Extra_Path_First := 0;
         return;
      end if;

      declare
         Found_Path : constant S_Expressions.Atom := Page_Maps.Key (Result);
      begin
         if Found_Path'Length > Path'Length
           or else Path (Path'First .. Path'First + Found_Path'Length - 1)
              /= Found_Path
         then
            Page_Maps.Clear (Result);
            return;
         end if;

         Extra_Path_First := Path'First + Found_Path'Length;
      end;

      if Extra_Path_First in Path'Range
        and then Path (Extra_Path_First) /= Character'Pos ('/')
      then
         Page_Maps.Clear (Result);
         return;
      end if;
   end Get_Page;

   procedure Set_If_Possible
     (Reference : in out S_Expressions.Atom_Refs.Immutable_Reference;
      Expression : in S_Expressions.Lockable.Descriptor'Class)
   is
      use type S_Expressions.Events.Event;
   begin
      if Expression.Current_Event = S_Expressions.Events.Add_Atom then
         Reference := S_Expressions.Atom_Ref_Constructors.Create
           (Expression.Current_Atom);
      end if;
   end Set_If_Possible;

   ----------------------
   -- Site Interpreter --
   ----------------------

   procedure Add_Page
     (Builder : in out Site_Builder;
      File_Root : in S_Expressions.Atom;
      Path_Root : in S_Expressions.Atom)
   is
      use type S_Expressions.Atom;

      File : constant S_Expressions.Atom
        := Builder.File_Prefix.Query.Data.all
         & File_Root
         & Builder.File_Suffix.Query.Data.all;
      Path : constant S_Expressions.Atom
        := Builder.Path_Prefix.Query.Data.all
         & Path_Root
         & Builder.Path_Suffix.Query.Data.all;
      Page : constant Pages.Page_Ref := Pages.Create (File, Path);
   begin
      Builder.Pages.Insert (Path, Page);
   end Add_Page;

   procedure Add_Page
     (Builder : in out Site_Builder;
      Context : in Meaningless_Type;
      File_Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Context);
      use type S_Expressions.Events.Event;
   begin
      if Arguments.Current_Event = S_Expressions.Events.Add_Atom then
         Add_Page (Builder, File_Name, Arguments.Current_Atom);
      end if;
   end Add_Page;

   procedure Add_Page_Simple
     (Builder : in out Site_Builder;
      Context : in Meaningless_Type;
      Common_Name : in S_Expressions.Atom)
   is
      pragma Unreferenced (Context);
   begin
      Add_Page (Builder, Common_Name, Common_Name);
   end Add_Page_Simple;

   procedure Add_Pages is new S_Expressions.Interpreter_Loop
     (Site_Builder, Meaningless_Type, Add_Page, Add_Page_Simple);

   procedure Execute
     (Builder : in out Site_Builder;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Context);
      package Commands renames Natools.Static_Maps.Web.Sites;
      use type S_Expressions.Events.Event;
   begin
      case Commands.To_Command (S_Expressions.To_String (Name)) is
         when Commands.Error =>
            Log (Severities.Error, "Unknown site command """
              & S_Expressions.To_String (Name) & '"');

         when Commands.Set_Default_Template =>
            Set_If_Possible (Builder.Default_Template, Arguments);

         when Commands.Set_File_Prefix =>
            Set_If_Possible (Builder.File_Prefix, Arguments);

         when Commands.Set_File_Suffix =>
            Set_If_Possible (Builder.File_Suffix, Arguments);

         when Commands.Set_Path_Prefix =>
            Set_If_Possible (Builder.Path_Prefix, Arguments);

         when Commands.Set_Path_Suffix =>
            Set_If_Possible (Builder.Path_Suffix, Arguments);

         when Commands.Set_Static_Paths =>
            Containers.Append_Atoms (Builder.Static, Arguments);

         when Commands.Set_Template_File =>
            if Arguments.Current_Event = S_Expressions.Events.Add_Atom then
               declare
                  Reader : S_Expressions.File_Readers.S_Reader
                    := S_Expressions.File_Readers.Reader
                       (S_Expressions.To_String (Arguments.Current_Atom));
               begin
                  Containers.Set_Expressions (Builder.Templates, Reader);
               end;
            end if;

         when Commands.Set_Templates =>
            Containers.Set_Expressions (Builder.Templates, Arguments);

         when Commands.Site_Map =>
            Add_Pages (Arguments, Builder, Meaningless_Value);
      end case;
   end Execute;

   procedure Interpreter is new S_Expressions.Interpreter_Loop
     (Site_Builder, Meaningless_Type, Execute);

   procedure Update
     (Builder : in out Site_Builder;
      Expression : in out S_Expressions.Lockable.Descriptor'Class) is
   begin
      Interpreter (Expression, Builder, Meaningless_Value);
   end Update;

   ---------------------------
   -- Site Public Interface --
   ---------------------------

   function Create (File_Name : String) return Site is
      Result : Site
        := (File_Name => S_Expressions.Atom_Ref_Constructors.Create
                           (S_Expressions.To_Atom (File_Name)),
            others => <>);
   begin
      Reload (Result);
      return Result;
   end Create;

   procedure Reload (Object : in out Site) is
      Reader : S_Expressions.File_Readers.S_Reader
        := S_Expressions.File_Readers.Reader
           (S_Expressions.To_String (Object.File_Name.Query.Data.all));
      Empty_Atom : constant S_Expressions.Atom_Refs.Immutable_Reference
        := S_Expressions.Atom_Ref_Constructors.Create
           (S_Expressions.Null_Atom);
      Builder : Site_Builder
        := (Default_Template
              => S_Expressions.Atom_Refs.Null_Immutable_Reference,
            File_Prefix => Empty_Atom,
            File_Suffix => Empty_Atom,
            Path_Prefix => Empty_Atom,
            Path_Suffix => Empty_Atom,
            Pages | Static | Templates => <>);
   begin
      Update (Builder, Reader);

      Object :=
        (Default_Template => Builder.Default_Template,
         File_Name => Object.File_Name,
         Pages => Page_Maps.Create (Builder.Pages),
         Static => Containers.Create (Builder.Static),
         Templates => Builder.Templates);

      if Object.Default_Template.Is_Empty then
         Object.Default_Template := S_Expressions.Atom_Ref_Constructors.Create
           (S_Expressions.To_Atom ("html"));
      end if;
   end Reload;

   procedure Respond
     (Object : aliased in out Site;
      Exchange : in out Exchanges.Exchange)
   is
      use type S_Expressions.Octet;
      use type S_Expressions.Offset;

      procedure Call_Page
        (Key : in S_Expressions.Atom;
         Page_Object : in out Page'Class);

      procedure Send_File_If_Exists (In_Directory : in S_Expressions.Atom);

      Path : constant S_Expressions.Atom
        := S_Expressions.To_Atom (Exchanges.Path (Exchange));

      procedure Call_Page
        (Key : in S_Expressions.Atom;
         Page_Object : in out Page'Class)
      is
         use type S_Expressions.Atom;
      begin
         pragma Assert (Key'Length <= Path'Length
           and then Key = Path (Path'First .. Path'First + Key'Length - 1));

         Respond (Page_Object, Exchange, Object,
           Path (Path'First + Key'Length .. Path'Last));
      end Call_Page;

      procedure Send_File_If_Exists (In_Directory : in S_Expressions.Atom) is
         use type S_Expressions.Atom;
         Candidate_Name : constant S_Expressions.Atom := In_Directory & Path;
      begin
         if Ada.Directories.Exists
              (S_Expressions.To_String (Candidate_Name))
         then
            Exchanges.Send_File (Exchange, Candidate_Name);
         end if;
      end Send_File_If_Exists;

      Cursor : Page_Maps.Cursor;
      Extra_Path_First : S_Expressions.Offset;
   begin
      if not Object.Static.Is_Empty then
         for Path_Ref of Object.Static.Query.Data.all loop
            Send_File_If_Exists (Path_Ref.Query.Data.all);

            if Exchanges.Has_Response (Exchange) then
               return;
            end if;
         end loop;
      end if;

      Get_Page (Object.Pages, Path, Cursor, Extra_Path_First);

      if not Page_Maps.Has_Element (Cursor) then
         return;
      end if;

      Response_Loop :
      loop
         Object.Pages.Update_Element (Cursor, Call_Page'Access);

         exit Response_Loop when Exchanges.Has_Response (Exchange);

         Find_Parent :
         loop
            Remove_Path_Component :
            loop
               Extra_Path_First := Extra_Path_First - 1;

               exit Response_Loop
                 when Extra_Path_First not in Path'Range;
               exit Remove_Path_Component
                 when Path (Extra_Path_First) = Character'Pos ('/');
            end loop Remove_Path_Component;

            Cursor := Object.Pages.Find
              (Path (Path'First .. Extra_Path_First - 1));
            exit Find_Parent when Page_Maps.Has_Element (Cursor);
         end loop Find_Parent;
      end loop Response_Loop;
   end Respond;

   -------------------------
   -- Site Data Accessors --
   -------------------------

   procedure Get_Template
     (Object : in Site;
      Name : in S_Expressions.Atom;
      Template : out S_Expressions.Caches.Cursor;
      Found : out Boolean)
   is
      Cursor : constant Containers.Expression_Maps.Cursor
        := Object.Templates.Find (Name);
   begin
      Found := Containers.Expression_Maps.Has_Element (Cursor);

      if Found then
         Template := Containers.Expression_Maps.Element (Cursor);
      end if;
   end Get_Template;

   function Default_Template (Object : Site) return S_Expressions.Atom is
   begin
      return Object.Default_Template.Query.Data.all;
   end Default_Template;

end Natools.Web.Sites;

------------------------------------------------------------------------------
-- Copyright (c) 2014, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

with Ada.Directories;
with Natools.S_Expressions.Atom_Ref_Constructors;
with Natools.S_Expressions.File_Readers;
with Natools.S_Expressions.Interpreter_Loop;
with Natools.Static_Maps.Web.Sites;
with Natools.Web.Error_Pages;
with Natools.Web.Pages;

package body Natools.Web.Sites is

   procedure Add_Page
     (Builder : in out Site_Builder;
      File_Root : in S_Expressions.Atom;
      Path_Root : in S_Expressions.Atom);

   procedure Add_Page
     (Builder : in out Site_Builder;
      Context : in Meaningless_Type;
      File_Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class);

   procedure Add_Page_Simple
     (Builder : in out Site_Builder;
      Context : in Meaningless_Type;
      Common_Name : in S_Expressions.Atom);

   procedure Get_Page
     (Container : in Page_Maps.Updatable_Map;
      Path : in S_Expressions.Atom;
      Result : out Page_Maps.Cursor;
      Extra_Path_First : out S_Expressions.Offset);

   procedure Execute
     (Builder : in out Site_Builder;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class);

   procedure Set_If_Possible
     (Reference : in out S_Expressions.Atom_Refs.Immutable_Reference;
      Expression : in S_Expressions.Lockable.Descriptor'Class);

   ------------------------------
   -- Local Helper Subprograms --
   ------------------------------

   procedure Get_Page
     (Container : in Page_Maps.Updatable_Map;
      Path : in S_Expressions.Atom;
      Result : out Page_Maps.Cursor;
      Extra_Path_First : out S_Expressions.Offset)
   is
      use type S_Expressions.Atom;
      use type S_Expressions.Octet;
      use type S_Expressions.Offset;
   begin
      Result := Container.Floor (Path);

      if not Page_Maps.Has_Element (Result) then
         Extra_Path_First := 0;
         return;
      end if;

      declare
         Found_Path : constant S_Expressions.Atom := Page_Maps.Key (Result);
      begin
         if Found_Path'Length > Path'Length
           or else Path (Path'First .. Path'First + Found_Path'Length - 1)
              /= Found_Path
         then
            Page_Maps.Clear (Result);
            return;
         end if;

         Extra_Path_First := Path'First + Found_Path'Length;
      end;

      if Extra_Path_First in Path'Range
        and then Path (Extra_Path_First) /= Character'Pos ('/')
      then
         Page_Maps.Clear (Result);
         return;
      end if;
   end Get_Page;

   procedure Set_If_Possible
     (Reference : in out S_Expressions.Atom_Refs.Immutable_Reference;
      Expression : in S_Expressions.Lockable.Descriptor'Class)
   is
      use type S_Expressions.Events.Event;
   begin
      if Expression.Current_Event = S_Expressions.Events.Add_Atom then
         Reference := S_Expressions.Atom_Ref_Constructors.Create
           (Expression.Current_Atom);
      end if;
   end Set_If_Possible;

   ----------------------
   -- Site Interpreter --
   ----------------------

   procedure Add_Page
     (Builder : in out Site_Builder;
      File_Root : in S_Expressions.Atom;
      Path_Root : in S_Expressions.Atom)
   is
      use type S_Expressions.Atom;

      File : constant S_Expressions.Atom
        := Builder.File_Prefix.Query.Data.all
         & File_Root
         & Builder.File_Suffix.Query.Data.all;
      Path : constant S_Expressions.Atom
        := Builder.Path_Prefix.Query.Data.all
         & Path_Root
         & Builder.Path_Suffix.Query.Data.all;
      Page : constant Pages.Page_Ref := Pages.Create (File, Path);
   begin
      Builder.Pages.Insert (Path, Page);
   end Add_Page;

   procedure Add_Page
     (Builder : in out Site_Builder;
      Context : in Meaningless_Type;
      File_Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Context);
      use type S_Expressions.Events.Event;
   begin
      if Arguments.Current_Event = S_Expressions.Events.Add_Atom then
         Add_Page (Builder, File_Name, Arguments.Current_Atom);
      end if;
   end Add_Page;

   procedure Add_Page_Simple
     (Builder : in out Site_Builder;
      Context : in Meaningless_Type;
      Common_Name : in S_Expressions.Atom)
   is
      pragma Unreferenced (Context);
   begin
      Add_Page (Builder, Common_Name, Common_Name);
   end Add_Page_Simple;

   procedure Add_Pages is new S_Expressions.Interpreter_Loop
     (Site_Builder, Meaningless_Type, Add_Page, Add_Page_Simple);

   procedure Execute
     (Builder : in out Site_Builder;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Context);
      package Commands renames Natools.Static_Maps.Web.Sites;
      use type S_Expressions.Events.Event;
   begin
      case Commands.To_Command (S_Expressions.To_String (Name)) is
         when Commands.Error =>
            Log (Severities.Error, "Unknown site command """
              & S_Expressions.To_String (Name) & '"');

         when Commands.Set_Default_Template =>
            Set_If_Possible (Builder.Default_Template, Arguments);

         when Commands.Set_File_Prefix =>
            Set_If_Possible (Builder.File_Prefix, Arguments);

         when Commands.Set_File_Suffix =>
            Set_If_Possible (Builder.File_Suffix, Arguments);

         when Commands.Set_Path_Prefix =>
            Set_If_Possible (Builder.Path_Prefix, Arguments);

         when Commands.Set_Path_Suffix =>
            Set_If_Possible (Builder.Path_Suffix, Arguments);

         when Commands.Set_Static_Paths =>
            Containers.Append_Atoms (Builder.Static, Arguments);

         when Commands.Set_Template_File =>
            if Arguments.Current_Event = S_Expressions.Events.Add_Atom then
               declare
                  Reader : S_Expressions.File_Readers.S_Reader
                    := S_Expressions.File_Readers.Reader
                       (S_Expressions.To_String (Arguments.Current_Atom));
               begin
                  Containers.Set_Expressions (Builder.Templates, Reader);
               end;
            end if;

         when Commands.Set_Templates =>
            Containers.Set_Expressions (Builder.Templates, Arguments);

         when Commands.Site_Map =>
            Add_Pages (Arguments, Builder, Meaningless_Value);
      end case;
   end Execute;

   procedure Interpreter is new S_Expressions.Interpreter_Loop
     (Site_Builder, Meaningless_Type, Execute);

   procedure Update
     (Builder : in out Site_Builder;
      Expression : in out S_Expressions.Lockable.Descriptor'Class) is
   begin
      Interpreter (Expression, Builder, Meaningless_Value);
   end Update;

   ---------------------------
   -- Site Public Interface --
   ---------------------------

   function Create (File_Name : String) return Site is
      Result : Site
        := (File_Name => S_Expressions.Atom_Ref_Constructors.Create
                           (S_Expressions.To_Atom (File_Name)),
            others => <>);
   begin
      Reload (Result);
      return Result;
   end Create;

   procedure Reload (Object : in out Site) is
      Reader : S_Expressions.File_Readers.S_Reader
        := S_Expressions.File_Readers.Reader
           (S_Expressions.To_String (Object.File_Name.Query.Data.all));
      Empty_Atom : constant S_Expressions.Atom_Refs.Immutable_Reference
        := S_Expressions.Atom_Ref_Constructors.Create
           (S_Expressions.Null_Atom);
      Builder : Site_Builder
        := (Default_Template
              => S_Expressions.Atom_Refs.Null_Immutable_Reference,
            File_Prefix => Empty_Atom,
            File_Suffix => Empty_Atom,
            Path_Prefix => Empty_Atom,
            Path_Suffix => Empty_Atom,
            Pages | Static | Templates => <>);
   begin
      Update (Builder, Reader);

      Object :=
        (Default_Template => Builder.Default_Template,
         File_Name => Object.File_Name,
         Pages => Page_Maps.Create (Builder.Pages),
         Static => Containers.Create (Builder.Static),
         Templates => Builder.Templates);

      if Object.Default_Template.Is_Empty then
         Object.Default_Template := S_Expressions.Atom_Ref_Constructors.Create
           (S_Expressions.To_Atom ("html"));
      end if;
   end Reload;

   procedure Respond
     (Object : aliased in out Site;
      Exchange : in out Exchanges.Exchange)
   is
      use type S_Expressions.Octet;
      use type S_Expressions.Offset;

      procedure Call_Page
        (Key : in S_Expressions.Atom;
         Page_Object : in out Page'Class);

      procedure Send_File_If_Exists (In_Directory : in S_Expressions.Atom);

      Path : constant S_Expressions.Atom
        := S_Expressions.To_Atom (Exchanges.Path (Exchange));

      procedure Call_Page
        (Key : in S_Expressions.Atom;
         Page_Object : in out Page'Class)
      is
         use type S_Expressions.Atom;
      begin
         pragma Assert (Key'Length <= Path'Length
           and then Key = Path (Path'First .. Path'First + Key'Length - 1));

         Respond (Page_Object, Exchange, Object,
           Path (Path'First + Key'Length .. Path'Last));
      end Call_Page;

      procedure Send_File_If_Exists (In_Directory : in S_Expressions.Atom) is
         use type S_Expressions.Atom;
         Candidate_Name : constant S_Expressions.Atom := In_Directory & Path;
      begin
         if Ada.Directories.Exists
              (S_Expressions.To_String (Candidate_Name))
         then
            Exchanges.Send_File (Exchange, Candidate_Name);
         end if;
      end Send_File_If_Exists;

      Cursor : Page_Maps.Cursor;
      Extra_Path_First : S_Expressions.Offset;
   begin
      if not Object.Static.Is_Empty then
         for Path_Ref of Object.Static.Query.Data.all loop
            Send_File_If_Exists (Path_Ref.Query.Data.all);

            if Exchanges.Has_Response (Exchange) then
               return;
            end if;
         end loop;
      end if;

      Get_Page (Object.Pages, Path, Cursor, Extra_Path_First);

      if not Page_Maps.Has_Element (Cursor) then
         Error_Pages.Not_Found (Exchange, Object);
         return;
      end if;

      Response_Loop :
      loop
         Object.Pages.Update_Element (Cursor, Call_Page'Access);

         exit Response_Loop when Exchanges.Has_Response (Exchange);

         Find_Parent :
         loop
            Remove_Path_Component :
            loop
               Extra_Path_First := Extra_Path_First - 1;

               exit Response_Loop
                 when Extra_Path_First not in Path'Range;
               exit Remove_Path_Component
                 when Path (Extra_Path_First) = Character'Pos ('/');
            end loop Remove_Path_Component;

            Cursor := Object.Pages.Find
              (Path (Path'First .. Extra_Path_First - 1));
            exit Find_Parent when Page_Maps.Has_Element (Cursor);
         end loop Find_Parent;
      end loop Response_Loop;

      if not Exchanges.Has_Response (Exchange) then
         Error_Pages.Not_Found (Exchange, Object);
      end if;
   end Respond;

   -------------------------
   -- Site Data Accessors --
   -------------------------

   procedure Get_Template
     (Object : in Site;
      Name : in S_Expressions.Atom;
      Template : out S_Expressions.Caches.Cursor;
      Found : out Boolean)
   is
      Cursor : constant Containers.Expression_Maps.Cursor
        := Object.Templates.Find (Name);
   begin
      Found := Containers.Expression_Maps.Has_Element (Cursor);

      if Found then
         Template := Containers.Expression_Maps.Element (Cursor);
      end if;
   end Get_Template;

   function Default_Template (Object : Site) return S_Expressions.Atom is
   begin
      return Object.Default_Template.Query.Data.all;
   end Default_Template;

end Natools.Web.Sites;

sites: return 404 error when unable to find a responding page


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

with ASF.Contexts.Faces;
with ASF.Contexts.Flash;
with ASF.Sessions;
with ASF.Principals;
with ASF.Cookies;
with ASF.Events.Faces.Actions;
with ASF.Applications.Messages.Factory;

with GNAT.MD5;

with Security.Openid;
with Security.Filters;

with Util.Strings.Transforms;
package body Users is

   use Ada.Strings.Unbounded;
   use Security.Openid;
   use type ASF.Principals.Principal_Access;
   use type ASF.Contexts.Faces.Faces_Context_Access;

   --  ------------------------------
   --  Given an Email address, return the Gravatar link to the user image.
   --  (See http://en.gravatar.com/site/implement/hash/ and
   --  http://en.gravatar.com/site/implement/images/)
   --  ------------------------------
   function Get_Gravatar_Link (Email : in String) return String is
      E : constant String := Util.Strings.Transforms.To_Lower_Case (Email);
      C : constant GNAT.MD5.Message_Digest := GNAT.MD5.Digest (E);
   begin
      return "http://www.gravatar.com/avatar/" & C;
   end Get_Gravatar_Link;

   --  ------------------------------
   --  Get the user information identified by the given name.
   --  ------------------------------
   function Get_Value (From : in User_Info;
                       Name : in String) return Util.Beans.Objects.Object is
      pragma Unreferenced (From);

      F : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      S : ASF.Sessions.Session;
      P : ASF.Principals.Principal_Access := null;
      U : Security.Openid.Principal_Access := null;
   begin
      if F /= null then
         S := F.Get_Session;
         if S.Is_Valid then
            P := S.Get_Principal;
            if P /= null then
               U := Security.Openid.Principal'Class (P.all)'Access;
            end if;
         end if;
      end if;
      if Name = "authenticated" then
         return Util.Beans.Objects.To_Object (U /= null);
      end if;
      if U = null then
         return Util.Beans.Objects.Null_Object;
      end if;
      if Name = "email" then
         return Util.Beans.Objects.To_Object (U.Get_Email);
      end if;
      if Name = "language" then
         return Util.Beans.Objects.To_Object (Get_Language (U.Get_Authentication));
      end if;
      if Name = "first_name" then
         return Util.Beans.Objects.To_Object (Get_First_Name (U.Get_Authentication));
      end if;
      if Name = "last_name" then
         return Util.Beans.Objects.To_Object (Get_Last_Name (U.Get_Authentication));
      end if;
      if Name = "full_name" then
         return Util.Beans.Objects.To_Object (Get_Full_Name (U.Get_Authentication));
      end if;
      if Name = "id" then
         return Util.Beans.Objects.To_Object (Get_Claimed_Id (U.Get_Authentication));
      end if;
      if Name = "country" then
         return Util.Beans.Objects.To_Object (Get_Country (U.Get_Authentication));
      end if;
      if Name = "sessionId" then
         return Util.Beans.Objects.To_Object (S.Get_Id);
      end if;
      if Name = "gravatar" then
         return Util.Beans.Objects.To_Object (Get_Gravatar_Link (U.Get_Email));
      end if;

      return Util.Beans.Objects.To_Object (U.Get_Name);
   end Get_Value;

   --  ------------------------------
   --  Helper to send a remove cookie in the current response
   --  ------------------------------
   procedure Remove_Cookie (Name : in String) is
      Ctx : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      C   : ASF.Cookies.Cookie := ASF.Cookies.Create (Name, "");
   begin
      ASF.Cookies.Set_Path (C, Ctx.Get_Request.Get_Context_Path);
      ASF.Cookies.Set_Max_Age (C, 0);
      Ctx.Get_Response.Add_Cookie (Cookie => C);
   end Remove_Cookie;

   --  ------------------------------
   --  Logout by dropping the user session.
   --  ------------------------------
   procedure Logout (From    : in out User_Info;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (From);

      F : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      S : ASF.Sessions.Session := F.Get_Session;
      P : ASF.Principals.Principal_Access := null;
      U : Security.Openid.Principal_Access := null;
   begin
      if S.Is_Valid then
         P := S.Get_Principal;
         if P /= null then
            U := Security.Openid.Principal'Class (P.all)'Access;
         end if;
         S.Invalidate;
      end if;
      if U /= null then
         F.Get_Flash.Set_Keep_Messages (True);
         ASF.Applications.Messages.Factory.Add_Message (F.all, "samples.openid_logout_message",
                                                        Get_Full_Name (U.Get_Authentication));
      end if;
      Remove_Cookie (Security.Filters.SID_COOKIE);
      Outcome := Ada.Strings.Unbounded.To_Unbounded_String ("logout_success");
   end Logout;

   package Logout_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => User_Info,
                                                      Method => Logout,
                                                      Name   => "logout");

   Binding_Array : aliased constant Util.Beans.Methods.Method_Binding_Array
     := (1 => Logout_Binding.Proxy'Unchecked_Access);

   --  ------------------------------
   --  This bean provides some methods that can be used in a Method_Expression
   --  ------------------------------
   overriding
   function Get_Method_Bindings (From : in User_Info)
                                 return Util.Beans.Methods.Method_Binding_Array_Access is
      pragma Unreferenced (From);
   begin
      return Binding_Array'Access;
   end Get_Method_Bindings;

end Users;

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

with ASF.Contexts.Faces;
with ASF.Contexts.Flash;
with ASF.Sessions;
with ASF.Principals;
with ASF.Cookies;
with ASF.Events.Faces.Actions;
with ASF.Applications.Messages.Factory;

with GNAT.MD5;

with Security.Openid;
with ASF.Security.Filters;

with Util.Strings.Transforms;
package body Users is

   use Ada.Strings.Unbounded;
   use Security.Openid;
   use type ASF.Principals.Principal_Access;
   use type ASF.Contexts.Faces.Faces_Context_Access;

   --  ------------------------------
   --  Given an Email address, return the Gravatar link to the user image.
   --  (See http://en.gravatar.com/site/implement/hash/ and
   --  http://en.gravatar.com/site/implement/images/)
   --  ------------------------------
   function Get_Gravatar_Link (Email : in String) return String is
      E : constant String := Util.Strings.Transforms.To_Lower_Case (Email);
      C : constant GNAT.MD5.Message_Digest := GNAT.MD5.Digest (E);
   begin
      return "http://www.gravatar.com/avatar/" & C;
   end Get_Gravatar_Link;

   --  ------------------------------
   --  Get the user information identified by the given name.
   --  ------------------------------
   function Get_Value (From : in User_Info;
                       Name : in String) return Util.Beans.Objects.Object is
      pragma Unreferenced (From);

      F : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      S : ASF.Sessions.Session;
      P : ASF.Principals.Principal_Access := null;
      U : Security.Openid.Principal_Access := null;
   begin
      if F /= null then
         S := F.Get_Session;
         if S.Is_Valid then
            P := S.Get_Principal;
            if P /= null then
               U := Security.Openid.Principal'Class (P.all)'Access;
            end if;
         end if;
      end if;
      if Name = "authenticated" then
         return Util.Beans.Objects.To_Object (U /= null);
      end if;
      if U = null then
         return Util.Beans.Objects.Null_Object;
      end if;
      if Name = "email" then
         return Util.Beans.Objects.To_Object (U.Get_Email);
      end if;
      if Name = "language" then
         return Util.Beans.Objects.To_Object (Get_Language (U.Get_Authentication));
      end if;
      if Name = "first_name" then
         return Util.Beans.Objects.To_Object (Get_First_Name (U.Get_Authentication));
      end if;
      if Name = "last_name" then
         return Util.Beans.Objects.To_Object (Get_Last_Name (U.Get_Authentication));
      end if;
      if Name = "full_name" then
         return Util.Beans.Objects.To_Object (Get_Full_Name (U.Get_Authentication));
      end if;
      if Name = "id" then
         return Util.Beans.Objects.To_Object (Get_Claimed_Id (U.Get_Authentication));
      end if;
      if Name = "country" then
         return Util.Beans.Objects.To_Object (Get_Country (U.Get_Authentication));
      end if;
      if Name = "sessionId" then
         return Util.Beans.Objects.To_Object (S.Get_Id);
      end if;
      if Name = "gravatar" then
         return Util.Beans.Objects.To_Object (Get_Gravatar_Link (U.Get_Email));
      end if;

      return Util.Beans.Objects.To_Object (U.Get_Name);
   end Get_Value;

   --  ------------------------------
   --  Helper to send a remove cookie in the current response
   --  ------------------------------
   procedure Remove_Cookie (Name : in String) is
      Ctx : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      C   : ASF.Cookies.Cookie := ASF.Cookies.Create (Name, "");
   begin
      ASF.Cookies.Set_Path (C, Ctx.Get_Request.Get_Context_Path);
      ASF.Cookies.Set_Max_Age (C, 0);
      Ctx.Get_Response.Add_Cookie (Cookie => C);
   end Remove_Cookie;

   --  ------------------------------
   --  Logout by dropping the user session.
   --  ------------------------------
   procedure Logout (From    : in out User_Info;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (From);

      F : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      S : ASF.Sessions.Session := F.Get_Session;
      P : ASF.Principals.Principal_Access := null;
      U : Security.Openid.Principal_Access := null;
   begin
      if S.Is_Valid then
         P := S.Get_Principal;
         if P /= null then
            U := Security.Openid.Principal'Class (P.all)'Access;
         end if;
         S.Invalidate;
      end if;
      if U /= null then
         F.Get_Flash.Set_Keep_Messages (True);
         ASF.Applications.Messages.Factory.Add_Message (F.all, "samples.openid_logout_message",
                                                        Get_Full_Name (U.Get_Authentication));
      end if;
      Remove_Cookie (ASF.Security.Filters.SID_COOKIE);
      Outcome := Ada.Strings.Unbounded.To_Unbounded_String ("logout_success");
   end Logout;

   package Logout_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => User_Info,
                                                      Method => Logout,
                                                      Name   => "logout");

   Binding_Array : aliased constant Util.Beans.Methods.Method_Binding_Array
     := (1 => Logout_Binding.Proxy'Unchecked_Access);

   --  ------------------------------
   --  This bean provides some methods that can be used in a Method_Expression
   --  ------------------------------
   overriding
   function Get_Method_Bindings (From : in User_Info)
                                 return Util.Beans.Methods.Method_Binding_Array_Access is
      pragma Unreferenced (From);
   begin
      return Binding_Array'Access;
   end Get_Method_Bindings;

end Users;

Fix compilation after Ada Security integration


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

with Ada.Strings.Hash;

--  The Locales package defines the Locale type to represent
--  the language, country and variant.
--
--  The language is a valid ISO language code.  This is a two-letter
--  lower case code defined by IS-639
--  See http://www.loc.gov/standards/iso639-2/englangn.html
--
--  The country is a valid ISO country code.  These codes are
--  a two letter upper-case code defined by ISO-3166.
--  See http://www.iso.ch/iso/en/prods-services/iso3166ma/02iso-3166-code-lists/list-en1.html
--
--  The variant part is a vendor or browser specific code.
--
--  The Locales package tries to follow the Java Locale class.
package body Util.Locales is

   --  ------------------------------
   --  Get the lowercase two-letter ISO-639 code.
   --  ------------------------------
   function Get_Language (Loc : in Locale) return String is
   begin
      if Loc = null then
         return "";
      else
         return Loc (1 .. 2);
      end if;
   end Get_Language;

   --  ------------------------------
   --  Get the ISO 639-2 language code.
   --  ------------------------------
   function Get_ISO3_Language (Loc : in Locale) return String is
   begin
      if Loc = null or else Loc'Length <= 3 then
         return "";
      end if;
      if Loc'Length <= 6 then
         return Loc (4 .. 6);
      end if;
      return Loc (7 .. 9);
   end Get_ISO3_Language;

   --  ------------------------------
   --  Get the uppercase two-letter ISO-3166 code.
   --  ------------------------------
   function Get_Country (Loc : in Locale) return String is
   begin
      if Loc = null or else Loc'Length <= 2 or else Loc (3) /= '_' then
         return "";
      else
         return Loc (4 .. 5);
      end if;
   end Get_Country;

   --  ------------------------------
   --  Get the ISO-3166-2 country code.
   --  ------------------------------
   function Get_ISO3_Country (Loc : in Locale) return String is
   begin
      if Loc = null or else Loc'Length <= 5 then
         return "";
      else
         return Loc (10 .. Loc'Last);
      end if;
   end Get_ISO3_Country;

   --  ------------------------------
   --  Get the variant code
   --  ------------------------------
   function Get_Variant (Loc : in Locale) return String is
   begin
      if Loc = null or else Loc'Length <= 13 then
         return "";
      else
         return Loc (7 .. 8);
      end if;
   end Get_Variant;

   --  ------------------------------
   --  Get the locale for the given language code
   --  ------------------------------
   function Get_Locale (Language : in String) return Locale is
      Length : constant Natural := Language'Length;
      Lower  : Natural := Locales'First;
      Upper  : Natural := Locales'Last;
      Pos    : Natural;
      Result : Locale;
   begin
      while Lower <= Upper loop
         Pos := (Lower + Upper) / 2;
         Result := Locales (Pos);
         if Result'Length < Length then
            if Result.all < Language (Language'First .. Language'First + Result'Length - 1) then
               Lower := Pos + 1;
            else
               Upper := Pos - 1;
            end if;
         elsif Result'Length > Length and then Result (Length + 1) = '.'
           and then Result (1 .. Length) = Language then
            return Result;
         elsif Result (1 .. Length) < Language then
            Lower := Pos + 1;
         else
            Upper := Pos - 1;
         end if;
      end loop;
      return NULL_LOCALE;
   end Get_Locale;

   --  ------------------------------
   --  Get the locale for the given language and country code
   --  ------------------------------
   function Get_Locale (Language : in String;
                        Country  : in String) return Locale is
   begin
      if Language'Length /= 2 or else (Country'Length /= 0 and Country'Length /= 2) then
         return NULL_LOCALE;
      elsif Country'Length = 0 then
         return Get_Locale (Language);
      else
         return Get_Locale (Language & "_" & Country);
      end if;
   end Get_Locale;

   --  ------------------------------
   --  Get the locale for the given language, country and variant code
   --  ------------------------------
   function Get_Locale (Language : in String;
                        Country  : in String;
                        Variant  : in String) return Locale is
   begin
      if Language'Length /= 2
        or else (Country'Length /= 0 and Country'Length /= 2)
        or else (Variant'Length /= 0 and Variant'Length /= 2) then
         return NULL_LOCALE;
      end if;
      if Country'Length = 0 and Variant'Length = 0 then
         return Get_Locale (Language);
      elsif Variant'Length = 0 then
         return Get_Locale (Language, Country);
      else
         return Get_Locale (Language & "_" & Country & "_" & Variant);
      end if;
   end Get_Locale;

   --  ------------------------------
   --  Get the locale code in the form language_country_variant.
   --  ------------------------------
   function To_String (Loc : in Locale) return String is
   begin
      if Loc = null then
         return "";
      elsif Loc'Length > 3 and Loc (3) = '.' then
         return Loc (1 .. 2);
      elsif Loc'Length > 6 and Loc (6) = '.' then
         return Loc (1 .. 5);
      else
         return Loc (1 .. 8);
      end if;
   end To_String;

   --  ------------------------------
   --  Compute the hash value of the locale.
   --  ------------------------------
   function Hash (Loc : in Locale) return Ada.Containers.Hash_Type is
      use type Ada.Containers.Hash_Type;
   begin
      return Ada.Strings.Hash (Loc.all);
   end Hash;

end Util.Locales;

-----------------------------------------------------------------------
--  Util.Locales -- Locale
--  Copyright (C) 2001, 2002, 2003, 2009, 2010, 2011, 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.Strings.Hash;

--  The Locales package defines the Locale type to represent
--  the language, country and variant.
--
--  The language is a valid ISO language code.  This is a two-letter
--  lower case code defined by IS-639
--  See http://www.loc.gov/standards/iso639-2/englangn.html
--
--  The country is a valid ISO country code.  These codes are
--  a two letter upper-case code defined by ISO-3166.
--  See http://www.iso.ch/iso/en/prods-services/iso3166ma/02iso-3166-code-lists/list-en1.html
--
--  The variant part is a vendor or browser specific code.
--
--  The Locales package tries to follow the Java Locale class.
package body Util.Locales is

   --  ------------------------------
   --  Get the lowercase two-letter ISO-639 code.
   --  ------------------------------
   function Get_Language (Loc : in Locale) return String is
   begin
      if Loc = null then
         return "";
      else
         return Loc (1 .. 2);
      end if;
   end Get_Language;

   --  ------------------------------
   --  Get the ISO 639-2 language code.
   --  ------------------------------
   function Get_ISO3_Language (Loc : in Locale) return String is
   begin
      if Loc = null or else Loc'Length <= 3 then
         return "";
      end if;
      if Loc'Length <= 6 then
         return Loc (4 .. 6);
      end if;
      return Loc (7 .. 9);
   end Get_ISO3_Language;

   --  ------------------------------
   --  Get the uppercase two-letter ISO-3166 code.
   --  ------------------------------
   function Get_Country (Loc : in Locale) return String is
   begin
      if Loc = null or else Loc'Length <= 2 or else Loc (3) /= '_' then
         return "";
      else
         return Loc (4 .. 5);
      end if;
   end Get_Country;

   --  ------------------------------
   --  Get the ISO-3166-2 country code.
   --  ------------------------------
   function Get_ISO3_Country (Loc : in Locale) return String is
   begin
      if Loc = null or else Loc'Length <= 5 then
         return "";
      else
         return Loc (10 .. Loc'Last);
      end if;
   end Get_ISO3_Country;

   --  ------------------------------
   --  Get the variant code
   --  ------------------------------
   function Get_Variant (Loc : in Locale) return String is
   begin
      if Loc = null or else Loc'Length <= 13 then
         return "";
      else
         return Loc (7 .. 8);
      end if;
   end Get_Variant;

   --  ------------------------------
   --  Get the locale for the given language code
   --  ------------------------------
   function Get_Locale (Language : in String) return Locale is
      Length : constant Natural := Language'Length;
      Lower  : Natural := Locales'First;
      Upper  : Natural := Locales'Last;
      Pos    : Natural;
      Result : Locale;
   begin
      while Lower <= Upper loop
         Pos := (Lower + Upper) / 2;
         Result := Locales (Pos);
         if Result'Length < Length then
            if Result.all < Language (Language'First .. Language'First + Result'Length - 1) then
               Lower := Pos + 1;
            else
               Upper := Pos - 1;
            end if;
         elsif Result'Length > Length and then Result (Length + 1) = '.'
           and then Result (1 .. Length) = Language
         then
            return Result;
         elsif Result (1 .. Length) < Language then
            Lower := Pos + 1;
         else
            Upper := Pos - 1;
         end if;
      end loop;
      return NULL_LOCALE;
   end Get_Locale;

   --  ------------------------------
   --  Get the locale for the given language and country code
   --  ------------------------------
   function Get_Locale (Language : in String;
                        Country  : in String) return Locale is
   begin
      if Language'Length /= 2 or else (Country'Length /= 0 and Country'Length /= 2) then
         return NULL_LOCALE;
      elsif Country'Length = 0 then
         return Get_Locale (Language);
      else
         return Get_Locale (Language & "_" & Country);
      end if;
   end Get_Locale;

   --  ------------------------------
   --  Get the locale for the given language, country and variant code
   --  ------------------------------
   function Get_Locale (Language : in String;
                        Country  : in String;
                        Variant  : in String) return Locale is
   begin
      if Language'Length /= 2
        or else (Country'Length /= 0 and Country'Length /= 2)
        or else (Variant'Length /= 0 and Variant'Length /= 2)
      then
         return NULL_LOCALE;
      end if;
      if Country'Length = 0 and Variant'Length = 0 then
         return Get_Locale (Language);
      elsif Variant'Length = 0 then
         return Get_Locale (Language, Country);
      else
         return Get_Locale (Language & "_" & Country & "_" & Variant);
      end if;
   end Get_Locale;

   --  ------------------------------
   --  Get the locale code in the form language_country_variant.
   --  ------------------------------
   function To_String (Loc : in Locale) return String is
   begin
      if Loc = null then
         return "";
      elsif Loc'Length > 3 and Loc (3) = '.' then
         return Loc (1 .. 2);
      elsif Loc'Length > 6 and Loc (6) = '.' then
         return Loc (1 .. 5);
      else
         return Loc (1 .. 8);
      end if;
   end To_String;

   --  ------------------------------
   --  Compute the hash value of the locale.
   --  ------------------------------
   function Hash (Loc : in Locale) return Ada.Containers.Hash_Type is
      use type Ada.Containers.Hash_Type;
   begin
      return Ada.Strings.Hash (Loc.all);
   end Hash;

end Util.Locales;

Fix compilation style warning

Fix compilation style warning


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

with Util.Test_Caller;
with Util.Texts.Builders;
with Util.Measures;

package body Util.Texts.Builders_Tests is

   package String_Builder is new Util.Texts.Builders (Element_Type => Character,
                                                      Input        => String,
                                                      Chunk_Size   => 100);

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Texts.Builders.Length",
                       Test_Length'Access);
      Caller.Add_Test (Suite, "Test Util.Texts.Builders.Append",
                       Test_Append'Access);
      Caller.Add_Test (Suite, "Test Util.Texts.Builders.Clear",
                       Test_Clear'Access);
      Caller.Add_Test (Suite, "Test Util.Texts.Builders.Iterate",
                       Test_Iterate'Access);
      Caller.Add_Test (Suite, "Test Util.Texts.Builders.Tail",
                       Test_Tail'Access);
      Caller.Add_Test (Suite, "Test Util.Texts.Builders.Perf",
                       Test_Perf'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test the length operation.
   --  ------------------------------
   procedure Test_Length (T : in out Test) is
      B : String_Builder.Builder (10);
   begin
      Util.Tests.Assert_Equals (T, 0, String_Builder.Length (B), "Invalid length");
      Util.Tests.Assert_Equals (T, 10, String_Builder.Capacity (B), "Invalid capacity");
   end Test_Length;

   --  ------------------------------
   --  Test the append operation.
   --  ------------------------------
   procedure Test_Append (T : in out Test) is
      S : constant String := "0123456789";
      B : String_Builder.Builder (3);
   begin
      String_Builder.Append (B, "a string");
      Util.Tests.Assert_Equals (T, 8, String_Builder.Length (B), "Invalid length");
      Util.Tests.Assert_Equals (T, "a string", String_Builder.To_Array (B), "Invalid content");
      Util.Tests.Assert_Equals (T, 100 + 3, String_Builder.Capacity (B), "Invalid capacity");

      --  Append new string and check content.
      String_Builder.Append (B, " b string");
      Util.Tests.Assert_Equals (T, 17, String_Builder.Length (B), "Invalid length");
      Util.Tests.Assert_Equals (T, "a string b string", String_Builder.To_Array (B),
                                "Invalid content");
      Util.Tests.Assert_Equals (T, 100 + 3, String_Builder.Capacity (B), "Invalid capacity");

      String_Builder.Clear (B);
      for I in S'Range loop
         String_Builder.Append (B, S (I));
      end loop;
      Util.Tests.Assert_Equals (T, 10, String_Builder.Length (B), "Invalid length");
      Util.Tests.Assert_Equals (T, S, String_Builder.To_Array (B), "Invalid append");
   end Test_Append;

   --  ------------------------------
   --  Test the clear operation.
   --  ------------------------------
   procedure Test_Clear (T : in out Test) is
      B : String_Builder.Builder (7);
   begin
      for I in 1 .. 10 loop
         String_Builder.Append (B, "a string");
      end loop;
      Util.Tests.Assert_Equals (T, 8 * 10, String_Builder.Length (B), "Invalid length");
      Util.Tests.Assert_Equals (T, 100 + 7, String_Builder.Capacity (B), "Invalid capacity");

      String_Builder.Clear (B);
      Util.Tests.Assert_Equals (T, 0, String_Builder.Length (B), "Invalid length after clear");
      Util.Tests.Assert_Equals (T, 7, String_Builder.Capacity (B), "Invalid capacity after clear");
   end Test_Clear;

   --  ------------------------------
   --  Test the tail operation.
   --  ------------------------------
   procedure Test_Tail (T : in out Test) is

      procedure Check_Tail (Min : in Positive;
                            Max : in Positive;
                            L   : in Natural);

      procedure Check_Tail (Min : in Positive;
                            Max : in Positive;
                            L   : in Natural) is
         P : constant String := "0123456789";
         B : String_Builder.Builder (Min);
      begin
         for I in 1 .. Max loop
            String_Builder.Append (B, P (1 + (I mod 10)));
         end loop;
         declare
            S  : constant String := String_Builder.Tail (B, L);
            S2 : constant String := String_Builder.To_Array (B);
         begin
            Util.Tests.Assert_Equals (T, Max, S2'Length, "Invalid length");
            if L >= Max then
               Util.Tests.Assert_Equals (T, S2, S, "Invalid Tail result");
            else
               Util.Tests.Assert_Equals (T, S2 (S2'Last - L + 1 .. S2'Last), S,
                                         "Invalid Tail result {"
                                         & Positive'Image (Min) & ","
                                         & Positive'Image (Max) & ","
                                         & Positive'Image (L) & "]");
            end if;
         end;
      end Check_Tail;

   begin
      for I in 1 .. 100 loop
         for J in 1 .. 8 loop
            for K in 1 .. I + 3 loop
               Check_Tail (J, I, K);
            end loop;
         end loop;
      end loop;
   end Test_Tail;

   --  ------------------------------
   --  Test the iterate operation.
   --  ------------------------------
   procedure Test_Iterate (T : in out Test) is
      procedure Process (S : in String);
      procedure Process2 (S : in String);

      B  : String_Builder.Builder (13);
      R  : Ada.Strings.Unbounded.Unbounded_String;
      R2 : Ada.Strings.Unbounded.Unbounded_String;

      procedure Process (S : in String) is
      begin
         Ada.Strings.Unbounded.Append (R, S);
      end Process;

      procedure Process2 (S : in String) is
      begin
         Ada.Strings.Unbounded.Append (R2, S);
      end Process2;

      procedure Get is new String_Builder.Inline_Iterate (Process2);
   begin
      for I in 1 .. 100 loop
         String_Builder.Append (B, "The Iterate procedure avoids the string copy "
                                & "on the secondary stack");
      end loop;
      String_Builder.Iterate (B, Process'Access);
      Util.Tests.Assert_Equals (T, String_Builder.Length (B), Ada.Strings.Unbounded.Length (R),
                                "Invalid length in iterate string");
      Util.Tests.Assert_Equals (T, String_Builder.To_Array (B),
                                Ada.Strings.Unbounded.To_String (R), "Invalid Iterate");

      Get (B);
      Util.Tests.Assert_Equals (T, String_Builder.To_Array (B),
                                Ada.Strings.Unbounded.To_String (R2), "Invalid Inline_Iterate");
   end Test_Iterate;

   --  ------------------------------
   --  Test the append and iterate performance.
   --  ------------------------------
   procedure Test_Perf (T : in out Test) is
      Perf : Ada.Text_IO.File_Type;
   begin
      Ada.Text_IO.Create (File => Perf,
                          Name => Util.Tests.Get_Test_Path ("string-append.csv"));
      Ada.Text_IO.Put_Line (Perf, "Block_Size,Append Time,To_Array Time,Iterate Time");
      for Block_Size in 1 .. 300 loop
         declare
            B : String_Builder.Builder (10);
            N : constant String := Natural'Image (Block_Size * 10) & ",";
         begin
            String_Builder.Set_Block_Size (B, Block_Size * 10);
            declare
               S : Util.Measures.Stamp;
            begin
               for I in 1 .. 1000 loop
                  String_Builder.Append (B, "some item");
               end loop;
               Util.Measures.Report (S, Perf, N, Util.Measures.Microseconds);
            end;
            declare
               S : Util.Measures.Stamp;
               R : constant String := String_Builder.To_Array (B);
            begin
               Util.Measures.Report (S, Perf, ",", Util.Measures.Microseconds);
               T.Assert (R'Length > 0, "Invalid string length");
            end;

            declare
               Count : Natural := 0;

               procedure Process (Item : in String);

               procedure Process (Item : in String) is
                  pragma Unreferenced (Item);
               begin
                  Count := Count + 1;
               end Process;

               S : Util.Measures.Stamp;
            begin
               String_Builder.Iterate (B, Process'Access);
               Util.Measures.Report (S, Perf, ",", Util.Measures.Microseconds);
               T.Assert (Count > 0, "The string builder was empty");
            end;
         end;
         Ada.Text_IO.New_Line (Perf);
      end loop;
      Ada.Text_IO.Close (Perf);

      Ada.Text_IO.Create (File => Perf,
                          Name => Util.Tests.Get_Test_Path ("string.csv"));
      Ada.Text_IO.Put_Line (Perf, "Size,Append (100),Append (512),"
                            & "Append (1024),Unbounded,Iterate Time");
      for I in 1 .. 4000 loop
         declare
            N  : constant String := Natural'Image (I) & ",";
            B  : String_Builder.Builder (10);
            B2 : String_Builder.Builder (10);
            B3 : String_Builder.Builder (10);
            U  : Ada.Strings.Unbounded.Unbounded_String;
            S  : Util.Measures.Stamp;
         begin
            for J in 1 .. I loop
               String_Builder.Append (B, "some item");
            end loop;
            Util.Measures.Report (S, Perf, N, Util.Measures.Microseconds);

            String_Builder.Set_Block_Size (B2, 512);
            for J in 1 .. I loop
               String_Builder.Append (B2, "some item");
            end loop;
            Util.Measures.Report (S, Perf, ",", Util.Measures.Microseconds);

            String_Builder.Set_Block_Size (B3, 1024);
            for J in 1 .. I loop
               String_Builder.Append (B3, "some item");
            end loop;
            Util.Measures.Report (S, Perf, ",", Util.Measures.Microseconds);

            for J in 1 .. I loop
               Ada.Strings.Unbounded.Append (U, "some item");
            end loop;
            Util.Measures.Report (S, Perf, ",", Util.Measures.Microseconds);

            declare
               R : constant String := String_Builder.To_Array (B);
               pragma Unreferenced (R);
            begin
               Util.Measures.Report (S, Perf, ",", Util.Measures.Microseconds);
            end;

            declare
               R : constant String := Ada.Strings.Unbounded.To_String (U);
               pragma Unreferenced (R);
            begin
               Util.Measures.Report (S, Perf, ",", Util.Measures.Microseconds);
            end;
         end;
         Ada.Text_IO.New_Line (Perf);
      end loop;
   end Test_Perf;

end Util.Texts.Builders_Tests;

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

with Util.Test_Caller;
with Util.Texts.Builders;
with Util.Measures;

package body Util.Texts.Builders_Tests is

   package String_Builder is new Util.Texts.Builders (Element_Type => Character,
                                                      Input        => String,
                                                      Chunk_Size   => 100);

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Texts.Builders.Length",
                       Test_Length'Access);
      Caller.Add_Test (Suite, "Test Util.Texts.Builders.Append",
                       Test_Append'Access);
      Caller.Add_Test (Suite, "Test Util.Texts.Builders.Clear",
                       Test_Clear'Access);
      Caller.Add_Test (Suite, "Test Util.Texts.Builders.Iterate",
                       Test_Iterate'Access);
      Caller.Add_Test (Suite, "Test Util.Texts.Builders.Inline_Iterate",
                       Test_Inline_Iterate'Access);
      Caller.Add_Test (Suite, "Test Util.Texts.Builders.Tail",
                       Test_Tail'Access);
      Caller.Add_Test (Suite, "Test Util.Texts.Builders.Perf",
                       Test_Perf'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test the length operation.
   --  ------------------------------
   procedure Test_Length (T : in out Test) is
      B : String_Builder.Builder (10);
   begin
      Util.Tests.Assert_Equals (T, 0, String_Builder.Length (B), "Invalid length");
      Util.Tests.Assert_Equals (T, 10, String_Builder.Capacity (B), "Invalid capacity");
   end Test_Length;

   --  ------------------------------
   --  Test the append operation.
   --  ------------------------------
   procedure Test_Append (T : in out Test) is
      S : constant String := "0123456789";
      B : String_Builder.Builder (3);
   begin
      String_Builder.Append (B, "a string");
      Util.Tests.Assert_Equals (T, 8, String_Builder.Length (B), "Invalid length");
      Util.Tests.Assert_Equals (T, "a string", String_Builder.To_Array (B), "Invalid content");
      Util.Tests.Assert_Equals (T, 100 + 3, String_Builder.Capacity (B), "Invalid capacity");

      --  Append new string and check content.
      String_Builder.Append (B, " b string");
      Util.Tests.Assert_Equals (T, 17, String_Builder.Length (B), "Invalid length");
      Util.Tests.Assert_Equals (T, "a string b string", String_Builder.To_Array (B),
                                "Invalid content");
      Util.Tests.Assert_Equals (T, 100 + 3, String_Builder.Capacity (B), "Invalid capacity");

      String_Builder.Clear (B);
      for I in S'Range loop
         String_Builder.Append (B, S (I));
      end loop;
      Util.Tests.Assert_Equals (T, 10, String_Builder.Length (B), "Invalid length");
      Util.Tests.Assert_Equals (T, S, String_Builder.To_Array (B), "Invalid append");
   end Test_Append;

   --  ------------------------------
   --  Test the clear operation.
   --  ------------------------------
   procedure Test_Clear (T : in out Test) is
      B : String_Builder.Builder (7);
   begin
      for I in 1 .. 10 loop
         String_Builder.Append (B, "a string");
      end loop;
      Util.Tests.Assert_Equals (T, 8 * 10, String_Builder.Length (B), "Invalid length");
      Util.Tests.Assert_Equals (T, 100 + 7, String_Builder.Capacity (B), "Invalid capacity");

      String_Builder.Clear (B);
      Util.Tests.Assert_Equals (T, 0, String_Builder.Length (B), "Invalid length after clear");
      Util.Tests.Assert_Equals (T, 7, String_Builder.Capacity (B), "Invalid capacity after clear");
   end Test_Clear;

   --  ------------------------------
   --  Test the tail operation.
   --  ------------------------------
   procedure Test_Tail (T : in out Test) is

      procedure Check_Tail (Min : in Positive;
                            Max : in Positive;
                            L   : in Natural);

      procedure Check_Tail (Min : in Positive;
                            Max : in Positive;
                            L   : in Natural) is
         P : constant String := "0123456789";
         B : String_Builder.Builder (Min);
      begin
         for I in 1 .. Max loop
            String_Builder.Append (B, P (1 + (I mod 10)));
         end loop;
         declare
            S  : constant String := String_Builder.Tail (B, L);
            S2 : constant String := String_Builder.To_Array (B);
         begin
            Util.Tests.Assert_Equals (T, Max, S2'Length, "Invalid length");
            if L >= Max then
               Util.Tests.Assert_Equals (T, S2, S, "Invalid Tail result");
            else
               Util.Tests.Assert_Equals (T, S2 (S2'Last - L + 1 .. S2'Last), S,
                                         "Invalid Tail result {"
                                         & Positive'Image (Min) & ","
                                         & Positive'Image (Max) & ","
                                         & Positive'Image (L) & "]");
            end if;
         end;
      end Check_Tail;

   begin
      for I in 1 .. 100 loop
         for J in 1 .. 8 loop
            for K in 1 .. I + 3 loop
               Check_Tail (J, I, K);
            end loop;
         end loop;
      end loop;
   end Test_Tail;

   --  ------------------------------
   --  Test the iterate operation.
   --  ------------------------------
   procedure Test_Iterate (T : in out Test) is
      procedure Process (S : in String);

      B  : String_Builder.Builder (13);
      R  : Ada.Strings.Unbounded.Unbounded_String;

      procedure Process (S : in String) is
      begin
         Ada.Strings.Unbounded.Append (R, S);
      end Process;
   begin
      for I in 1 .. 100 loop
         String_Builder.Append (B, "The Iterate procedure avoids the string copy "
                                & "on the secondary stack");
      end loop;
      String_Builder.Iterate (B, Process'Access);
      Util.Tests.Assert_Equals (T, String_Builder.Length (B), Ada.Strings.Unbounded.Length (R),
                                "Invalid length in iterate string");
      Util.Tests.Assert_Equals (T, String_Builder.To_Array (B),
                                Ada.Strings.Unbounded.To_String (R), "Invalid Iterate");
   end Test_Iterate;

   --  ------------------------------
   --  Test the iterate operation.
   --  ------------------------------
   procedure Test_Inline_Iterate (T : in out Test) is
      procedure Process (S : in String);

      B  : String_Builder.Builder (13);
      R  : Ada.Strings.Unbounded.Unbounded_String;

      procedure Process (S : in String) is
      begin
         Ada.Strings.Unbounded.Append (R, S);
      end Process;

      procedure Get is new String_Builder.Inline_Iterate (Process);
   begin
      for I in 1 .. 100 loop
         String_Builder.Append (B, "The Iterate procedure avoids the string copy "
                                & "on the secondary stack");
      end loop;
      Get (B);
      Util.Tests.Assert_Equals (T, String_Builder.Length (B), Ada.Strings.Unbounded.Length (R),
                                "Invalid length in iterate string");
      Util.Tests.Assert_Equals (T, String_Builder.To_Array (B),
                                Ada.Strings.Unbounded.To_String (R), "Invalid Iterate");
   end Test_Inline_Iterate;

   --  ------------------------------
   --  Test the append and iterate performance.
   --  ------------------------------
   procedure Test_Perf (T : in out Test) is
      Perf : Ada.Text_IO.File_Type;
   begin
      Ada.Text_IO.Create (File => Perf,
                          Name => Util.Tests.Get_Test_Path ("string-append.csv"));
      Ada.Text_IO.Put_Line (Perf, "Block_Size,Append Time,To_Array Time,Iterate Time");
      for Block_Size in 1 .. 300 loop
         declare
            B : String_Builder.Builder (10);
            N : constant String := Natural'Image (Block_Size * 10) & ",";
         begin
            String_Builder.Set_Block_Size (B, Block_Size * 10);
            declare
               S : Util.Measures.Stamp;
            begin
               for I in 1 .. 1000 loop
                  String_Builder.Append (B, "some item");
               end loop;
               Util.Measures.Report (S, Perf, N, Util.Measures.Microseconds);
            end;
            declare
               S : Util.Measures.Stamp;
               R : constant String := String_Builder.To_Array (B);
            begin
               Util.Measures.Report (S, Perf, ",", Util.Measures.Microseconds);
               T.Assert (R'Length > 0, "Invalid string length");
            end;

            declare
               Count : Natural := 0;

               procedure Process (Item : in String);

               procedure Process (Item : in String) is
                  pragma Unreferenced (Item);
               begin
                  Count := Count + 1;
               end Process;

               S : Util.Measures.Stamp;
            begin
               String_Builder.Iterate (B, Process'Access);
               Util.Measures.Report (S, Perf, ",", Util.Measures.Microseconds);
               T.Assert (Count > 0, "The string builder was empty");
            end;
         end;
         Ada.Text_IO.New_Line (Perf);
      end loop;
      Ada.Text_IO.Close (Perf);

      Ada.Text_IO.Create (File => Perf,
                          Name => Util.Tests.Get_Test_Path ("string.csv"));
      Ada.Text_IO.Put_Line (Perf, "Size,Append (100),Append (512),"
                            & "Append (1024),Unbounded,Iterate Time");
      for I in 1 .. 4000 loop
         declare
            N  : constant String := Natural'Image (I) & ",";
            B  : String_Builder.Builder (10);
            B2 : String_Builder.Builder (10);
            B3 : String_Builder.Builder (10);
            U  : Ada.Strings.Unbounded.Unbounded_String;
            S  : Util.Measures.Stamp;
         begin
            for J in 1 .. I loop
               String_Builder.Append (B, "some item");
            end loop;
            Util.Measures.Report (S, Perf, N, Util.Measures.Microseconds);

            String_Builder.Set_Block_Size (B2, 512);
            for J in 1 .. I loop
               String_Builder.Append (B2, "some item");
            end loop;
            Util.Measures.Report (S, Perf, ",", Util.Measures.Microseconds);

            String_Builder.Set_Block_Size (B3, 1024);
            for J in 1 .. I loop
               String_Builder.Append (B3, "some item");
            end loop;
            Util.Measures.Report (S, Perf, ",", Util.Measures.Microseconds);

            for J in 1 .. I loop
               Ada.Strings.Unbounded.Append (U, "some item");
            end loop;
            Util.Measures.Report (S, Perf, ",", Util.Measures.Microseconds);

            declare
               R : constant String := String_Builder.To_Array (B);
               pragma Unreferenced (R);
            begin
               Util.Measures.Report (S, Perf, ",", Util.Measures.Microseconds);
            end;

            declare
               R : constant String := Ada.Strings.Unbounded.To_String (U);
               pragma Unreferenced (R);
            begin
               Util.Measures.Report (S, Perf, ",", Util.Measures.Microseconds);
            end;
         end;
         Ada.Text_IO.New_Line (Perf);
      end loop;
   end Test_Perf;

end Util.Texts.Builders_Tests;

Add new test and register it for execution


-----------------------------------------------------------------------
--  security-controllers -- Controllers to verify a security permission
--  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 Security.Contexts;

--  == Security Controller ==
--  The Security.Controllers package defines the security controller used to
--  verify that a given permission is granted.  A security controller uses the security
--  context and other controller specific and internal data to verify that the permission
--  is granted.
--
--  To implement a new security controller, one must:
--

--
Define a type that implements the Controller interface with the
--        Has_Permission operation
--
Write a function to allocate instances of the given Controller type
--
Register the function under a unique name by using Register_Controller
--

--
--  Security controller instances are created when the security policy rules are parsed.
--  These instances are shared accross possibly several concurrent requests.
package Security.Controllers is

   Invalid_Controller : exception;

   --  ------------------------------
   --  Security Controller interface
   --  ------------------------------
   type Controller is limited interface;
   type Controller_Access is access all Controller'Class;

   --  Checks whether the permission defined by the Handler controller data is granted
   --  by the security context passed in Context.
   --  Returns true if such permission is granted.
   function Has_Permission (Handler : in Controller;
                            Context : in Security.Contexts.Security_Context'Class)
                            return Boolean is abstract;

   type Controller_Factory is not null access function return Controller_Access;

   --  To keep this implementation simple, a maximum of 32 security controller factory
   --  can be registered.  ASF provides one based on roles.  AWA provides another one
   --  based on entity ACLs.
   MAX_CONTROLLER_FACTORY : constant Positive := 32;

   --  Register in a global table the controller factory under the name Name.
   --  When this factory is used, the Factory operation will be called to
   --  create new instances of the controller.
   procedure Register_Controller (Name    : in String;
                                  Factory : in Controller_Factory);

   --  Create a security controller by using the controller factory registered under
   --  the name Name.
   --  Raises Invalid_Controller if the name is not recognized.
   function Create_Controller (Name : in String) return Controller_Access;

end Security.Controllers;

-----------------------------------------------------------------------
--  security-controllers -- Controllers to verify a security permission
--  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 Security.Contexts;

--  == Security Controller ==
--  The Security.Controllers package defines the security controller used to
--  verify that a given permission is granted.  A security controller uses the security
--  context and other controller specific and internal data to verify that the permission
--  is granted.
--
--  To implement a new security controller, one must:
--

--
Define a type that implements the Controller interface with the
--        Has_Permission operation
--
Write a function to allocate instances of the given Controller type
--
Register the function under a unique name by using Register_Controller
--

--
--  Security controller instances are created when the security policy rules are parsed.
--  These instances are shared across possibly several concurrent requests.
package Security.Controllers is

   Invalid_Controller : exception;

   --  ------------------------------
   --  Security Controller interface
   --  ------------------------------
   type Controller is limited interface;
   type Controller_Access is access all Controller'Class;

   --  Checks whether the permission defined by the Handler controller data is granted
   --  by the security context passed in Context.
   --  Returns true if such permission is granted.
   function Has_Permission (Handler : in Controller;
                            Context : in Security.Contexts.Security_Context'Class)
                            return Boolean is abstract;

   type Controller_Factory is not null access function return Controller_Access;

   --  To keep this implementation simple, a maximum of 32 security controller factory
   --  can be registered.  ASF provides one based on roles.  AWA provides another one
   --  based on entity ACLs.
   MAX_CONTROLLER_FACTORY : constant Positive := 32;

   --  Register in a global table the controller factory under the name Name.
   --  When this factory is used, the Factory operation will be called to
   --  create new instances of the controller.
   procedure Register_Controller (Name    : in String;
                                  Factory : in Controller_Factory);

   --  Create a security controller by using the controller factory registered under
   --  the name Name.
   --  Raises Invalid_Controller if the name is not recognized.
   function Create_Controller (Name : in String) return Controller_Access;

end Security.Controllers;

Fix typo in comment

Fix typo in comment