-----------------------------------------------------------------------
--  security-policies-urls -- URL security policy
--  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.Containers.Hashed_Maps;
with Ada.Containers.Vectors;

with Util.Refs;
with Util.Strings;
with Util.Serialize.IO.XML;

with GNAT.Regexp;

--  == URL Security Policy ==
--  The <tt>Security.Policies.Urls</tt> implements a security policy intended to be used
--  in web servers.  It allows to protect an URL by defining permissions that must be granted
--  for a user to get access to the URL.  A typical example is a web server that has a set of
--  administration pages, these pages should be accessed by users having some admin permission.
--
--  === Policy creation ===
--  An instance of the <tt>URL_Policy</tt> must be created and registered in the policy manager.
--  Get or declare the following variables:
--
--    Manager : Security.Policies.Policy_Manager;
--    Policy  : Security.Policies.Urls.URL_Policy_Access;
--
--  Create the URL policy and register it in the policy manager as follows:
--
--    Policy := new URL_Policy;
--    Manager.Add_Policy (Policy.all'Access);
--
--  === Policy Configuration ===
--  Once the URL policy is registered, the policy manager can read and process the following
--  XML configuration:
--
--    <policy-rules>
--      <url-policy id='1'>
--        <permission>create-workspace</permission>
--        <permission>admin</permission>
--        <url-pattern>/workspace/create</url-pattern>
--        <url-pattern>/workspace/setup/*</url-pattern>
--      </url-policy>
--      ...
--    </policy-rules>
--
--  This policy gives access to the URL that match one of the URL pattern if the
--  security context has the permission create-workspace or admin.
--  These two permissions are checked according to another security policy.
--  The XML configuration can define several <tt>url-policy</tt>.  They are checked in
--  the order defined in the XML.  In other words, the first <tt>url-policy</tt> that matches
--  the URL is used to verify the permission.
--
--  The <tt>url-policy</tt> definition can contain several <tt>permission</tt>.
--  The first permission that is granted gives access to the URL.
--
--  === Checking for permission ===
--  To check a URL permission, you must declare a <tt>URL_Permission</tt> object with the URL.
--
--     URL    : constant String := ...;
--     Perm   : constant Policies.URLs.URL_Permission (URL'Length)
--               := URL_Permission '(Len => URI'Length, URL => URL);
--
--  Then, we can check the permission:
--
--     Result : Boolean := Security.Contexts.Has_Permission (Perm);
--
package Security.Policies.URLs is

   NAME : constant String := "URL-Policy";

   package P_URL is new Security.Permissions.Definition ("url");

   --  ------------------------------
   --  URL Permission
   --  ------------------------------
   --  Represents a permission to access a given URL.
   type URL_Permission (Len : Natural) is new Permissions.Permission (P_URL.Permission) with record
      URL : String (1 .. Len);
   end record;

   --  ------------------------------
   --  URL policy
   --  ------------------------------
   type URL_Policy is new Policy with private;
   type URL_Policy_Access is access all URL_Policy'Class;

   Invalid_Name : exception;

   --  Get the policy name.
   overriding
   function Get_Name (From : in URL_Policy) return String;

   --  Returns True if the user has the permission to access the given URI permission.
   function Has_Permission (Manager    : in URL_Policy;
                            Context    : in Security_Context_Access;
                            Permission : in URL_Permission'Class) return Boolean;

   --  Grant the permission to access to the given URI to users having the To
   --  permissions.
   procedure Grant_URI_Permission (Manager : in out URL_Policy;
                                   URI     : in String;
                                   To      : in String);

   --  Initialize the permission manager.
   overriding
   procedure Initialize (Manager : in out URL_Policy);

   --  Finalize the permission manager.
   overriding
   procedure Finalize (Manager : in out URL_Policy);

   --  Setup the XML parser to read the policy description.
   overriding
   procedure Prepare_Config (Policy : in out URL_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser);

   --  Get the URL policy associated with the given policy manager.
   --  Returns the URL policy instance or null if it was not registered in the policy manager.
   function Get_URL_Policy (Manager : in Security.Policies.Policy_Manager'Class)
                            return URL_Policy_Access;

private

   use Util.Strings;

   --  The Access_Rule represents a list of permissions to verify to grant
   --  access to the resource.  To make it simple, the user must have one of the
   --  permission from the list.  Each permission will refer to a specific permission
   --  controller.
   type Access_Rule (Count : Natural) is new Util.Refs.Ref_Entity with record
      Permissions : Permission_Index_Array (1 .. Count);
   end record;
   type Access_Rule_Access is access all Access_Rule;

   package Access_Rule_Refs is
     new Util.Refs.Indefinite_References (Element_Type   => Access_Rule,
                                          Element_Access => Access_Rule_Access);
   subtype Access_Rule_Ref is Access_Rule_Refs.Ref;

   --  Find the access rule of the policy that matches the given URI.
   --  Returns the No_Rule value (disable access) if no rule is found.
   function Find_Access_Rule (Manager : in URL_Policy;
                              URI     : in String) return Access_Rule_Ref;

   --  The Policy defines the access rules that are applied on a given
   --  URL, set of URLs or files.
   type Policy is record
      Id      : Natural;
      Pattern : GNAT.Regexp.Regexp;
      Rule    : Access_Rule_Ref;
   end record;

   --  The Policy_Vector represents the whole permission policy.  The order of
   --  policy in the list is important as policies can override each other.
   package Policy_Vector is new Ada.Containers.Vectors (Index_Type   => Positive,
                                                        Element_Type => Policy);

   package Rules_Maps is new Ada.Containers.Hashed_Maps (Key_Type        => String_Ref,
                                                         Element_Type    => Access_Rule_Ref,
                                                         Hash            => Hash,
                                                         Equivalent_Keys => Equivalent_Keys,
                                                         "="             => Access_Rule_Refs."=");

   type Rules is new Util.Refs.Ref_Entity with record
      Map : Rules_Maps.Map;
   end record;
   type Rules_Access is access all Rules;

   package Rules_Ref is new Util.Refs.References (Rules, Rules_Access);

   type Rules_Ref_Access is access Rules_Ref.Atomic_Ref;

   type Controller_Access_Array_Access is access all Controller_Access_Array;

   type URL_Policy is new Security.Policies.Policy with record
      Cache        : Rules_Ref_Access;
      Policies     : Policy_Vector.Vector;
      Id           : Natural := 0;
      Permissions  : Util.Beans.Objects.Vectors.Vector;
      Patterns     : Util.Beans.Objects.Vectors.Vector;
   end record;

end Security.Policies.URLs;

-----------------------------------------------------------------------
--  security-policies-urls -- URL security policy
--  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.Containers.Hashed_Maps;
with Ada.Containers.Vectors;

with Util.Refs;
with Util.Strings;
with Util.Serialize.IO.XML;

with GNAT.Regexp;

with Security.Contexts;

--  == URL Security Policy ==
--  The <tt>Security.Policies.Urls</tt> implements a security policy intended to be used
--  in web servers.  It allows to protect an URL by defining permissions that must be granted
--  for a user to get access to the URL.  A typical example is a web server that has a set of
--  administration pages, these pages should be accessed by users having some admin permission.
--
--  === Policy creation ===
--  An instance of the <tt>URL_Policy</tt> must be created and registered in the policy manager.
--  Get or declare the following variables:
--
--    Manager : Security.Policies.Policy_Manager;
--    Policy  : Security.Policies.Urls.URL_Policy_Access;
--
--  Create the URL policy and register it in the policy manager as follows:
--
--    Policy := new URL_Policy;
--    Manager.Add_Policy (Policy.all'Access);
--
--  === Policy Configuration ===
--  Once the URL policy is registered, the policy manager can read and process the following
--  XML configuration:
--
--    <policy-rules>
--      <url-policy id='1'>
--        <permission>create-workspace</permission>
--        <permission>admin</permission>
--        <url-pattern>/workspace/create</url-pattern>
--        <url-pattern>/workspace/setup/*</url-pattern>
--      </url-policy>
--      ...
--    </policy-rules>
--
--  This policy gives access to the URL that match one of the URL pattern if the
--  security context has the permission create-workspace or admin.
--  These two permissions are checked according to another security policy.
--  The XML configuration can define several <tt>url-policy</tt>.  They are checked in
--  the order defined in the XML.  In other words, the first <tt>url-policy</tt> that matches
--  the URL is used to verify the permission.
--
--  The <tt>url-policy</tt> definition can contain several <tt>permission</tt>.
--  The first permission that is granted gives access to the URL.
--
--  === Checking for permission ===
--  To check a URL permission, you must declare a <tt>URL_Permission</tt> object with the URL.
--
--     URL    : constant String := ...;
--     Perm   : constant Policies.URLs.URL_Permission (URL'Length)
--               := URL_Permission '(Len => URI'Length, URL => URL);
--
--  Then, we can check the permission:
--
--     Result : Boolean := Security.Contexts.Has_Permission (Perm);
--
package Security.Policies.URLs is

   NAME : constant String := "URL-Policy";

   package P_URL is new Security.Permissions.Definition ("url");

   --  ------------------------------
   --  URL Permission
   --  ------------------------------
   --  Represents a permission to access a given URL.
   type URL_Permission (Len : Natural) is new Permissions.Permission (P_URL.Permission) with record
      URL : String (1 .. Len);
   end record;

   --  ------------------------------
   --  URL policy
   --  ------------------------------
   type URL_Policy is new Policy with private;
   type URL_Policy_Access is access all URL_Policy'Class;

   Invalid_Name : exception;

   --  Get the policy name.
   overriding
   function Get_Name (From : in URL_Policy) return String;

   --  Returns True if the user has the permission to access the given URI permission.
   function Has_Permission (Manager    : in URL_Policy;
                            Context    : in Contexts.Security_Context'Class;
                            Permission : in URL_Permission'Class) return Boolean;

   --  Grant the permission to access to the given URI to users having the To
   --  permissions.
   procedure Grant_URI_Permission (Manager : in out URL_Policy;
                                   URI     : in String;
                                   To      : in String);

   --  Initialize the permission manager.
   overriding
   procedure Initialize (Manager : in out URL_Policy);

   --  Finalize the permission manager.
   overriding
   procedure Finalize (Manager : in out URL_Policy);

   --  Setup the XML parser to read the policy description.
   overriding
   procedure Prepare_Config (Policy : in out URL_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser);

   --  Get the URL policy associated with the given policy manager.
   --  Returns the URL policy instance or null if it was not registered in the policy manager.
   function Get_URL_Policy (Manager : in Security.Policies.Policy_Manager'Class)
                            return URL_Policy_Access;

private

   use Util.Strings;

   --  The Access_Rule represents a list of permissions to verify to grant
   --  access to the resource.  To make it simple, the user must have one of the
   --  permission from the list.  Each permission will refer to a specific permission
   --  controller.
   type Access_Rule (Count : Natural) is new Util.Refs.Ref_Entity with record
      Permissions : Permission_Index_Array (1 .. Count);
   end record;
   type Access_Rule_Access is access all Access_Rule;

   package Access_Rule_Refs is
     new Util.Refs.Indefinite_References (Element_Type   => Access_Rule,
                                          Element_Access => Access_Rule_Access);
   subtype Access_Rule_Ref is Access_Rule_Refs.Ref;

   --  Find the access rule of the policy that matches the given URI.
   --  Returns the No_Rule value (disable access) if no rule is found.
   function Find_Access_Rule (Manager : in URL_Policy;
                              URI     : in String) return Access_Rule_Ref;

   --  The Policy defines the access rules that are applied on a given
   --  URL, set of URLs or files.
   type Policy is record
      Id      : Natural;
      Pattern : GNAT.Regexp.Regexp;
      Rule    : Access_Rule_Ref;
   end record;

   --  The Policy_Vector represents the whole permission policy.  The order of
   --  policy in the list is important as policies can override each other.
   package Policy_Vector is new Ada.Containers.Vectors (Index_Type   => Positive,
                                                        Element_Type => Policy);

   package Rules_Maps is new Ada.Containers.Hashed_Maps (Key_Type        => String_Ref,
                                                         Element_Type    => Access_Rule_Ref,
                                                         Hash            => Hash,
                                                         Equivalent_Keys => Equivalent_Keys,
                                                         "="             => Access_Rule_Refs."=");

   type Rules is new Util.Refs.Ref_Entity with record
      Map : Rules_Maps.Map;
   end record;
   type Rules_Access is access all Rules;

   package Rules_Ref is new Util.Refs.References (Rules, Rules_Access);

   type Rules_Ref_Access is access Rules_Ref.Atomic_Ref;

   type Controller_Access_Array_Access is access all Controller_Access_Array;

   type URL_Policy is new Security.Policies.Policy with record
      Cache        : Rules_Ref_Access;
      Policies     : Policy_Vector.Vector;
      Id           : Natural := 0;
      Permissions  : Util.Beans.Objects.Vectors.Vector;
      Patterns     : Util.Beans.Objects.Vectors.Vector;
   end record;

end Security.Policies.URLs;

Change Has_Permission to get a Security Context class as parameter


--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

with Utilities;
with Ada.Characters.Latin_1;
with HelperText;

package body Port_Specification.Json is

   package LAT renames Ada.Characters.Latin_1;
   package UTL renames Utilities;
   package HT  renames HelperText;

   --------------------------------------------------------------------------------------------
   --  describe_port
   --------------------------------------------------------------------------------------------
   procedure describe_port
     (specs   : Portspecs;
      dossier : TIO.File_Type;
      bucket  : String;
      index   : Positive)
   is
      fpcval : constant String := fpc_value (specs.generated, specs.equivalent_fpc_port);
      nvar   : constant Natural := specs.get_number_of_variants;
   begin
      TIO.Put
        (dossier,
           UTL.json_object (True, 3, index) &
           UTL.json_nvpair_string  ("bucket",   bucket, 1, pad) &
           UTL.json_nvpair_string  ("namebase", specs.get_namebase, 2, pad) &
           UTL.json_nvpair_string  ("version",  specs.get_field_value (sp_version), 3, pad) &
           homepage_line (specs) &
           UTL.json_nvpair_string  ("FPC",      fpcval, 3, pad) &
           UTL.json_nvpair_complex ("keywords", describe_keywords (specs), 3, pad) &
           UTL.json_nvpair_complex ("distfile", describe_distfiles (specs), 3, pad) &
           specs.get_json_contacts &
           describe_Common_Platform_Enumeration (specs) &
           UTL.json_name_complex   ("variants", 4, pad) &
           UTL.json_array (True, pad + 1)
        );
      for x in 1 .. nvar loop
         declare
            varstr : constant String := specs.get_list_item (Port_Specification.sp_variants, x);
            sdesc  : constant String := specs.get_tagline (varstr);
            spray  : constant String := describe_subpackages (specs, varstr);
         begin
            TIO.Put
              (dossier,
               UTL.json_object (True, pad + 2, x) &
                 UTL.json_nvpair_string  ("label", varstr, 1, pad + 3) &
                 UTL.json_nvpair_string  ("sdesc", sdesc, 2, pad + 3) &
                 UTL.json_nvpair_complex ("spkgs", spray, 3, pad + 3) &
                 UTL.json_object (False, pad + 2, x)
              );
         end;
      end loop;
      TIO.Put
        (dossier,
           UTL.json_array (False, pad + 1) &
           UTL.json_object (False, 3, index)
        );

   end describe_port;

   --------------------------------------------------------------------------------------------
   --  fpc_value
   --------------------------------------------------------------------------------------------
   function fpc_value (is_generated : Boolean; raw_value : String) return String is
   begin
      if is_generated then
         return "generated";
      else
         return raw_value;
      end if;
   end fpc_value;

   --------------------------------------------------------------------------------------------
   --  describe_keywords
   --------------------------------------------------------------------------------------------
   function describe_keywords (specs : Portspecs) return String
   is
      raw : constant String := specs.get_field_value (Port_Specification.sp_keywords);
      innerquote : constant String :=
        HT.replace_char
          (S         => HT.replace_char (raw, LAT.Comma, LAT.Quotation & LAT.Comma),
           focus     => LAT.Space,
           substring => LAT.Space & LAT.Quotation);
   begin
      return "[ " & LAT.Quotation & innerquote  & LAT.Quotation & " ]";
   end describe_keywords;

   --------------------------------------------------------------------------------------------
   --  describe_distfiles
   --------------------------------------------------------------------------------------------
   function describe_distfiles (specs : Portspecs) return String
   is
      numfiles : constant Natural := specs.get_list_length (Port_Specification.sp_distfiles);
      result   : HT.Text := HT.SUS ("[ ");
   begin
      for x in 1 .. numfiles loop
         if x > 1 then
            HT.SU.Append (result, ", ");
         end if;
         HT.SU.Append (result, LAT.Quotation & specs.get_repology_distfile (x) & LAT.Quotation);
      end loop;
      return HT.USS (result) & " ]";
   end describe_distfiles;

   --------------------------------------------------------------------------------------------
   --  describe_subpackages
   --------------------------------------------------------------------------------------------
   function describe_subpackages (specs : Portspecs; variant : String) return String
   is
      numpkg : constant Natural := specs.get_subpackage_length (variant);
      result   : HT.Text := HT.SUS ("[ ");
   begin
      for x in 1 .. numpkg loop
         if x > 1 then
            HT.SU.Append (result, ", ");
         end if;
         HT.SU.Append (result, LAT.Quotation &
                         specs.get_subpackage_item (variant, x) & LAT.Quotation);
      end loop;
      return HT.USS (result) & " ]";
   end describe_subpackages;

   --------------------------------------------------------------------------------------------
   --  homepage_line
   --------------------------------------------------------------------------------------------
   function homepage_line (specs : Portspecs) return String
   is
      homepage : constant String := specs.get_field_value (sp_homepage);
   begin
      if homepage = homepage_none or else
        specs.repology_sucks
      then
         return "";
      end if;
      return UTL.json_nvpair_string  ("homepage", specs.get_field_value (sp_homepage), 3, pad);
   end homepage_line;

   --------------------------------------------------------------------------------------------
   --  describe_Common_Platform_Enumeration
   --------------------------------------------------------------------------------------------
   function describe_Common_Platform_Enumeration (specs : Portspecs) return String
   is
      function retrieve (key : String; default_value : String) return String;
      function form_object return String;
      procedure maybe_push (json_key, cpe_key, default_value : String);
      procedure always_push (json_key, value : String);

      pairs : string_crate.Vector;

      function retrieve (key : String; default_value : String) return String
      is
         key_text : HT.Text := HT.SUS (key);
      begin
         if specs.catch_all.Contains (key_text) then
            return HT.USS (specs.catch_all.Element (key_text).list.First_Element);
         else
            return default_value;
         end if;
      end retrieve;

      procedure always_push (json_key, value : String) is
      begin
         pairs.Append (HT.SUS (json_key & "=" & value));
      end always_push;

      procedure maybe_push (json_key, cpe_key, default_value : String)
      is
         cpe_key_text : HT.Text := HT.SUS (cpe_key);
         cpe_value    : HT.Text;
      begin
         if specs.catch_all.Contains (cpe_key_text) then
            cpe_value := specs.catch_all.Element (cpe_key_text).list.First_Element;
            if not HT.equivalent (cpe_value, default_value) then
               pairs.Append (HT.SUS (json_key & "=" & HT.USS (cpe_value)));
            end if;
         end if;
      end maybe_push;

      function form_object return String
      is
         procedure dump (position : string_crate.Cursor);

         tracker : Natural := 0;
         guts    : HT.Text;

         procedure dump (position : string_crate.Cursor)
         is
            both  : String := HT.USS (string_crate.Element (position));
            key   : String := HT.part_1 (both, "=");
            value : String := HT.part_2 (both, "=");
            data  : String := UTL.json_nvpair_string (key, value, 1, 0);  -- trailing LF
         begin
            tracker := tracker + 1;
            if tracker > 1 then
               HT.SU.Append (guts, LAT.Comma);
            end if;
            HT.SU.Append (guts, data (data'First .. data'Last - 1));
         end dump;
      begin
         pairs.Iterate (dump'Access);
         return "{" & HT.USS (guts) & " }";
      end form_object;
   begin
      if not specs.uses.Contains (HT.SUS ("cpe")) then
         return "";
      end if;

      maybe_push  ("part", "CPE_PART", "a");

      declare
         cpe_product : String := retrieve ("CPE_PRODUCT", HT.lowercase (specs.get_namebase));
         cpe_vendor  : String := retrieve ("CPE_VENDOR", cpe_product);
      begin
         --  probably should be vendor then product, but this was the original order
         --  of repology json.  Maintain order to avoid massive diff.
         always_push ("product", cpe_product);
         always_push ("vendor", cpe_vendor);
      end;

      maybe_push ("version", "CPE_VERSION", HT.USS (specs.version));
      maybe_push ("update", "CPE_UPDATE", "");
      maybe_push ("edition", "CPE_EDITION", "");
      maybe_push ("lang", "CPE_LANG", "");
      maybe_push ("sw_edition", "CPE_SW_EDITION", "");
      maybe_push ("target_sw", "CPE_TARGET_SW", "take-anything");
      maybe_push ("target_hw", "CPE_TARGET_HW", "x86-x86-arm64");
      maybe_push ("other", "CPE_OTHER",  HT.USS (specs.version));

      return UTL.json_nvpair_complex ("cpe", form_object, 3, pad);
   end describe_Common_Platform_Enumeration;

end Port_Specification.Json;

--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

with Utilities;
with Ada.Characters.Latin_1;
with HelperText;

package body Port_Specification.Json is

   package LAT renames Ada.Characters.Latin_1;
   package UTL renames Utilities;
   package HT  renames HelperText;

   --------------------------------------------------------------------------------------------
   --  describe_port
   --------------------------------------------------------------------------------------------
   procedure describe_port
     (specs   : Portspecs;
      dossier : TIO.File_Type;
      bucket  : String;
      index   : Positive)
   is
      fpcval : constant String := fpc_value (specs.generated, specs.equivalent_fpc_port);
      nvar   : constant Natural := specs.get_number_of_variants;
   begin
      TIO.Put
        (dossier,
           UTL.json_object (True, 3, index) &
           UTL.json_nvpair_string  ("bucket",   bucket, 1, pad) &
           UTL.json_nvpair_string  ("namebase", specs.get_namebase, 2, pad) &
           UTL.json_nvpair_string  ("version",  specs.get_field_value (sp_version), 3, pad) &
           homepage_line (specs) &
           UTL.json_nvpair_string  ("FPC",      fpcval, 3, pad) &
           UTL.json_nvpair_complex ("keywords", describe_keywords (specs), 3, pad) &
           UTL.json_nvpair_complex ("distfile", describe_distfiles (specs), 3, pad) &
           specs.get_json_contacts &
           describe_Common_Platform_Enumeration (specs) &
           UTL.json_name_complex   ("variants", 4, pad) &
           UTL.json_array (True, pad + 1)
        );
      for x in 1 .. nvar loop
         declare
            varstr : constant String := specs.get_list_item (Port_Specification.sp_variants, x);
            sdesc  : constant String := specs.get_tagline (varstr);
            spray  : constant String := describe_subpackages (specs, varstr);
         begin
            TIO.Put
              (dossier,
               UTL.json_object (True, pad + 2, x) &
                 UTL.json_nvpair_string  ("label", varstr, 1, pad + 3) &
                 UTL.json_nvpair_string  ("sdesc", sdesc, 2, pad + 3) &
                 UTL.json_nvpair_complex ("spkgs", spray, 3, pad + 3) &
                 UTL.json_object (False, pad + 2, x)
              );
         end;
      end loop;
      TIO.Put
        (dossier,
           UTL.json_array (False, pad + 1) &
           UTL.json_object (False, 3, index)
        );

   end describe_port;

   --------------------------------------------------------------------------------------------
   --  fpc_value
   --------------------------------------------------------------------------------------------
   function fpc_value (is_generated : Boolean; raw_value : String) return String is
   begin
      if is_generated then
         return "generated";
      else
         return raw_value;
      end if;
   end fpc_value;

   --------------------------------------------------------------------------------------------
   --  describe_keywords
   --------------------------------------------------------------------------------------------
   function describe_keywords (specs : Portspecs) return String
   is
      raw : constant String := specs.get_field_value (Port_Specification.sp_keywords);
      innerquote : constant String :=
        HT.replace_char
          (S         => HT.replace_char (raw, LAT.Comma, LAT.Quotation & LAT.Comma),
           focus     => LAT.Space,
           substring => LAT.Space & LAT.Quotation);
   begin
      return "[ " & LAT.Quotation & innerquote  & LAT.Quotation & " ]";
   end describe_keywords;

   --------------------------------------------------------------------------------------------
   --  describe_distfiles
   --------------------------------------------------------------------------------------------
   function describe_distfiles (specs : Portspecs) return String
   is
      numfiles : constant Natural := specs.get_list_length (Port_Specification.sp_distfiles);
      result   : HT.Text := HT.SUS ("[ ");
   begin
      for x in 1 .. numfiles loop
         if x > 1 then
            HT.SU.Append (result, ", ");
         end if;
         HT.SU.Append (result, LAT.Quotation & specs.get_repology_distfile (x) & LAT.Quotation);
      end loop;
      return HT.USS (result) & " ]";
   end describe_distfiles;

   --------------------------------------------------------------------------------------------
   --  describe_subpackages
   --------------------------------------------------------------------------------------------
   function describe_subpackages (specs : Portspecs; variant : String) return String
   is
      numpkg : constant Natural := specs.get_subpackage_length (variant);
      result   : HT.Text := HT.SUS ("[ ");
   begin
      for x in 1 .. numpkg loop
         if x > 1 then
            HT.SU.Append (result, ", ");
         end if;
         HT.SU.Append (result, LAT.Quotation &
                         specs.get_subpackage_item (variant, x) & LAT.Quotation);
      end loop;
      return HT.USS (result) & " ]";
   end describe_subpackages;

   --------------------------------------------------------------------------------------------
   --  homepage_line
   --------------------------------------------------------------------------------------------
   function homepage_line (specs : Portspecs) return String
   is
      homepage : constant String := specs.get_field_value (sp_homepage);
   begin
      if homepage = homepage_none or else
        specs.repology_sucks
      then
         return "";
      end if;
      return UTL.json_nvpair_string  ("homepage", specs.get_field_value (sp_homepage), 3, pad);
   end homepage_line;

   --------------------------------------------------------------------------------------------
   --  describe_Common_Platform_Enumeration
   --------------------------------------------------------------------------------------------
   function describe_Common_Platform_Enumeration (specs : Portspecs) return String
   is
      function retrieve (key : String; default_value : String) return String;
      function form_object return String;
      procedure maybe_push (json_key, cpe_key, default_value : String);
      procedure always_push (json_key, value : String);

      pairs : string_crate.Vector;

      function retrieve (key : String; default_value : String) return String
      is
         key_text : HT.Text := HT.SUS (key);
      begin
         if specs.catch_all.Contains (key_text) then
            return HT.USS (specs.catch_all.Element (key_text).list.First_Element);
         else
            return default_value;
         end if;
      end retrieve;

      procedure always_push (json_key, value : String) is
      begin
         pairs.Append (HT.SUS (json_key & "=" & value));
      end always_push;

      procedure maybe_push (json_key, cpe_key, default_value : String)
      is
         cpe_key_text : HT.Text := HT.SUS (cpe_key);
         cpe_value    : HT.Text;
      begin
         if specs.catch_all.Contains (cpe_key_text) then
            cpe_value := specs.catch_all.Element (cpe_key_text).list.First_Element;
            if not HT.equivalent (cpe_value, default_value) then
               pairs.Append (HT.SUS (json_key & "=" & HT.USS (cpe_value)));
            end if;
         end if;
      end maybe_push;

      function form_object return String
      is
         procedure dump (position : string_crate.Cursor);

         tracker : Natural := 0;
         guts    : HT.Text;

         procedure dump (position : string_crate.Cursor)
         is
            both  : String := HT.USS (string_crate.Element (position));
            key   : String := HT.part_1 (both, "=");
            value : String := HT.part_2 (both, "=");
            data  : String := UTL.json_nvpair_string (key, value, 1, 0);  -- trailing LF
         begin
            tracker := tracker + 1;
            if tracker > 1 then
               HT.SU.Append (guts, LAT.Comma);
            end if;
            HT.SU.Append (guts, data (data'First .. data'Last - 1));
         end dump;
      begin
         pairs.Iterate (dump'Access);
         return "{" & HT.USS (guts) & " }";
      end form_object;
   begin
      if not specs.uses.Contains (HT.SUS ("cpe")) then
         return "";
      end if;

      --  maybe_push  ("part", "CPE_PART", "a");

      declare
         cpe_product : String := retrieve ("CPE_PRODUCT", HT.lowercase (specs.get_namebase));
         cpe_vendor  : String := retrieve ("CPE_VENDOR", cpe_product);
      begin
         --  probably should be vendor then product, but this was the original order
         --  of repology json.  Maintain order to avoid massive diff.
         always_push ("product", cpe_product);
         always_push ("vendor", cpe_vendor);
      end;

      --  maybe_push ("version", "CPE_VERSION", HT.USS (specs.version));
      --  maybe_push ("update", "CPE_UPDATE", "");
      maybe_push ("edition", "CPE_EDITION", "");
      maybe_push ("lang", "CPE_LANG", "");
      maybe_push ("sw_edition", "CPE_SW_EDITION", "");
      maybe_push ("target_sw", "CPE_TARGET_SW", "take-anything");
      maybe_push ("target_hw", "CPE_TARGET_HW", "x86-x86-arm64");
      maybe_push ("other", "CPE_OTHER",  HT.USS (specs.version));

      return UTL.json_nvpair_complex ("cpe", form_object, 3, pad);
   end describe_Common_Platform_Enumeration;

end Port_Specification.Json;

Disable 3 CPE fields from repology.json

Disable 3 CPE fields from repology.json

These are not parsed by repology so there is no need to publish them.


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

with Ada.Strings.Unbounded;

--  == Role Based Security Policy ==
--  The <tt>Security.Policies.Roles</tt> package implements a role based security policy.
--
--  A role is represented by a name in security configuration files.
package Security.Policies.Roles is

   --  Each role is represented by a Role_Type number to provide a fast
   --  and efficient role check.
   type Role_Type is new Natural range 0 .. 63;
   for Role_Type'Size use 8;

   type Role_Type_Array is array (Positive range <>) of Role_Type;

   --  The Role_Map represents a set of roles which are assigned to a user.
   --  Each role is represented by a boolean in the map.  The implementation is limited
   --  to 64 roles (the number of different permissions can be higher).
   type Role_Map is array (Role_Type'Range) of Boolean;
   pragma Pack (Role_Map);

   --  ------------------------------
   --  Role based policy
   --  ------------------------------
   type Role_Policy is new Policy with private;

   Invalid_Name : exception;

   --  Each permission is represented by a Permission_Type number to provide a fast
   --  and efficient permission check.
   type Permission_Type is new Natural range 0 .. 63;

   --  The Permission_Map represents a set of permissions which are granted to a user.
   --  Each permission is represented by a boolean in the map.  The implementation is limited
   --  to 64 permissions.
   type Permission_Map is array (Permission_Type'Range) of Boolean;
   pragma Pack (Permission_Map);

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------
   --  The Permission_Manager verifies through some policy that a permission
   --  is granted to a user.

   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type;

   --  Get the role name.
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String;

   --  Create a role
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type);

   --  Get or add a role type for the given name.
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type);

private

   type Role_Name_Array is
     array (Role_Type'Range) of Ada.Strings.Unbounded.String_Access;

   type Role_Policy is new Policy with record
      Names        : Role_Name_Array;
      Next_Role    : Role_Type := Role_Type'First;
   end record;

   type Controller_Config is record
      Name    : Util.Beans.Objects.Object;
      Roles   : Permissions.Role_Type_Array (1 .. Integer (Permissions.Role_Type'Last));
      Count   : Natural := 0;
      Manager : Security.Permissions.Permission_Manager_Access;
   end record;

   --  Setup the XML parser to read the role-permission description.  For example:
   --
   --  <security-role>
   --    <role-name>admin</role-name>
   --  </security-role>
   --  <role-permission>
   --     <name>create-workspace</name>
   --     <role>admin</role>
   --     <role>manager</role>
   --  </role-permission>
   --
   --  This defines a permission create-workspace that will be granted if the
   --  user has either the admin or the manager role.
   overriding
   procedure Set_Reader_Config (Pol     : in out Policy;
                                Reader  : in out Util.Serialize.IO.XML.Parser);

end Security.Policies.Roles;

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

with Ada.Strings.Unbounded;

--  == Role Based Security Policy ==
--  The <tt>Security.Policies.Roles</tt> package implements a role based security policy.
--
--  A role is represented by a name in security configuration files.
package Security.Policies.Roles is

   --  Each role is represented by a Role_Type number to provide a fast
   --  and efficient role check.
   type Role_Type is new Natural range 0 .. 63;
   for Role_Type'Size use 8;

   type Role_Type_Array is array (Positive range <>) of Role_Type;

   --  The Role_Map represents a set of roles which are assigned to a user.
   --  Each role is represented by a boolean in the map.  The implementation is limited
   --  to 64 roles (the number of different permissions can be higher).
   type Role_Map is array (Role_Type'Range) of Boolean;
   pragma Pack (Role_Map);

   --  ------------------------------
   --  Role based policy
   --  ------------------------------
   type Role_Policy is new Policy with private;

   Invalid_Name : exception;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------
   --  The Permission_Manager verifies through some policy that a permission
   --  is granted to a user.

   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type;

   --  Get the role name.
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String;

   --  Create a role
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type);

   --  Get or add a role type for the given name.
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type);

private

   type Role_Name_Array is
     array (Role_Type'Range) of Ada.Strings.Unbounded.String_Access;

   type Role_Policy is new Policy with record
      Names        : Role_Name_Array;
      Next_Role    : Role_Type := Role_Type'First;
   end record;

   type Controller_Config is record
      Name    : Util.Beans.Objects.Object;
      Roles   : Permissions.Role_Type_Array (1 .. Integer (Permissions.Role_Type'Last));
      Count   : Natural := 0;
      Manager : Security.Permissions.Permission_Manager_Access;
   end record;

   --  Setup the XML parser to read the role-permission description.  For example:
   --
   --  <security-role>
   --    <role-name>admin</role-name>
   --  </security-role>
   --  <role-permission>
   --     <name>create-workspace</name>
   --     <role>admin</role>
   --     <role>manager</role>
   --  </role-permission>
   --
   --  This defines a permission create-workspace that will be granted if the
   --  user has either the admin or the manager role.
   overriding
   procedure Set_Reader_Config (Pol     : in out Policy;
                                Reader  : in out Util.Serialize.IO.XML.Parser);

end Security.Policies.Roles;

Remove Permission_Type and Permission_Map


-----------------------------------------------------------------------
--  AWA - Unit tests
--  Copyright (C) 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 AWA.Testsuite;

with Util.Tests;
with AWA.Tests;
procedure AWA_Harness is

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

begin
   Harness ("awa-tests.xml");
end AWA_Harness;

-----------------------------------------------------------------------
--  AWA - Unit tests
--  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 AWA.Testsuite;

with Util.Tests;
with AWA.Tests;
procedure AWA_Harness is

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

begin
   Harness ("awa-tests.xml");
end AWA_Harness;

Call the Finish procedure after executing the testsuite Finish will destroy the AWA application that was allocated dynamically


-----------------------------------------------------------------------
--  ado-schemas-tests -- Test loading of database schema
--  Copyright (C) 2009, 2010, 2011, 2012, 2015, 2017, 2018, 2019 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.Directories;

with Util.Test_Caller;
with Util.Strings.Vectors;
with Util.Strings.Transforms;

with ADO.Parameters;
with ADO.Schemas.Databases;
with ADO.Sessions.Sources;
with ADO.Sessions.Entities;
with ADO.Schemas.Entities;

with Regtests;
with Regtests.Audits.Model;
with Regtests.Simple.Model;
package body ADO.Schemas.Tests is

   use Util.Tests;

   function To_Lower_Case (S : in String) return String
     renames Util.Strings.Transforms.To_Lower_Case;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type",
                       Test_Find_Entity_Type'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type (error)",
                       Test_Find_Entity_Type_Error'Access);
      Caller.Add_Test (Suite, "Test ADO.Sessions.Load_Schema",
                       Test_Load_Schema'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table",
                       Test_Table_Iterator'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table (Empty schema)",
                       Test_Empty_Schema'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Databases.Create_Database",
                       Test_Create_Schema'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading the entity cache and the Find_Entity_Type operation
   --  ------------------------------
   procedure Test_Find_Entity_Type (T : in out Test) is
      S   : ADO.Sessions.Session := Regtests.Get_Database;
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      ADO.Schemas.Entities.Initialize (Cache   => C,
                                       Session => S);

      declare
         T4 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.ALLOCATE_TABLE);
         T5 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
         T1 : constant ADO.Entity_Type
           := Sessions.Entities.Find_Entity_Type (Session => S,
                                                  Table   => Regtests.Audits.Model.AUDIT_TABLE);
         T2 : constant ADO.Entity_Type
           := Sessions.Entities.Find_Entity_Type (Session => S,
                                                  Table   => Regtests.Audits.Model.EMAIL_TABLE);
         T3 : constant ADO.Entity_Type
           := Sessions.Entities.Find_Entity_Type (Session => S,
                                                  Name    => "audit_property");
      begin
         T.Assert (T1 > 0, "T1 must be positive");
         T.Assert (T2 > 0, "T2 must be positive");
         T.Assert (T3 > 0, "T3 must be positive");
         T.Assert (T4 > 0, "T4 must be positive");
         T.Assert (T5 > 0, "T5 must be positive");

         T.Assert (T1 /= T2, "Two distinct tables have different entity types (T1, T2)");
         T.Assert (T2 /= T3, "Two distinct tables have different entity types (T2, T3)");
         T.Assert (T3 /= T4, "Two distinct tables have different entity types (T3, T4)");
         T.Assert (T4 /= T5, "Two distinct tables have different entity types (T4, T5)");
         T.Assert (T5 /= T1, "Two distinct tables have different entity types (T5, T1)");
      end;
   end Test_Find_Entity_Type;

   --  ------------------------------
   --  Test calling Find_Entity_Type with an invalid table.
   --  ------------------------------
   procedure Test_Find_Entity_Type_Error (T : in out Test) is
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      declare
         R : ADO.Entity_Type;
         pragma Unreferenced (R);
      begin
         R := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
         T.Assert (False, "Find_Entity_Type did not raise the No_Entity_Type exception");

      exception
         when ADO.Schemas.Entities.No_Entity_Type =>
            null;
      end;

      declare
         P : ADO.Parameters.Parameter
           := ADO.Parameters.Parameter'(T => ADO.Parameters.T_INTEGER, Num => 0,
                                        Len => 0, Value_Len => 0, Position => 0, Name => "");
      begin
         P := C.Expand ("something");
         T.Assert (False, "Expand did not raise the No_Entity_Type exception");

      exception
         when ADO.Schemas.Entities.No_Entity_Type =>
            null;
      end;
   end Test_Find_Entity_Type_Error;

   --  ------------------------------
   --  Test the Load_Schema operation and check the result schema.
   --  ------------------------------
   procedure Test_Load_Schema (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
   begin
      S.Load_Schema (Schema);

      Table := ADO.Schemas.Find_Table (Schema, "allocate");
      T.Assert (Table /= null, "Table schema for test_allocate not found");

      Assert_Equals (T, "allocate", Get_Name (Table));

      declare
         C : Column_Cursor := Get_Columns (Table);
         Nb_Columns : Integer := 0;
      begin
         while Has_Element (C) loop
            Nb_Columns := Nb_Columns + 1;
            Next (C);
         end loop;
         Assert_Equals (T, 3, Nb_Columns, "Invalid number of columns");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "ID");
      begin
         T.Assert (C /= null, "Cannot find column 'id' in table schema");
         Assert_Equals (T, "id", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_LONG_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
         T.Assert (Is_Primary (C), "Column must be a primary key");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "NAME");
      begin
         T.Assert (C /= null, "Cannot find column 'NAME' in table schema");
         Assert_Equals (T, "name", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_VARCHAR, "Invalid column type");
         T.Assert (Is_Null (C), "Column is null");
         T.Assert (not Is_Primary (C), "Column must not be a primary key");
         Assert_Equals (T, 255, Get_Size (C), "Column has invalid size");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "version");
      begin
         T.Assert (C /= null, "Cannot find column 'version' in table schema");
         Assert_Equals (T, "version", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "this_column_does_not_exist");
      begin
         T.Assert (C = null, "Find_Column must return null for an unknown column");
      end;
   end Test_Load_Schema;

   --  ------------------------------
   --  Test the Table_Cursor operations and check the result schema.
   --  ------------------------------
   procedure Test_Table_Iterator (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
      Driver : constant String := S.Get_Driver.Get_Driver_Name;
   begin
      S.Load_Schema (Schema);

      declare
         Iter  : Table_Cursor := Schema.Get_Tables;
         Count : Natural := 0;
      begin
         T.Assert (Has_Element (Iter), "The Get_Tables returns an empty iterator");
         while Has_Element (Iter) loop
            Table := Element (Iter);
            T.Assert (Table /= null, "Element function must not return null");
            declare
               Col_Iter : Column_Cursor := Get_Columns (Table);
            begin
               --  T.Assert (Has_Element (Col_Iter), "Table has a column");
               while Has_Element (Col_Iter) loop
                  T.Assert (Element (Col_Iter) /= null, "Element function must not return null");
                  Next (Col_Iter);
               end loop;
            end;
            Count := Count + 1;
            Next (Iter);
         end loop;
         if Driver = "sqlite" then
            Util.Tests.Assert_Equals (T, 21, Count,
                                      "Invalid number of tables found in the schema");
         elsif Driver = "mysql" then
            Util.Tests.Assert_Equals (T, 11, Count,
                                      "Invalid number of tables found in the schema");
         elsif Driver = "postgresql" then
            Util.Tests.Assert_Equals (T, 11, Count,
                                      "Invalid number of tables found in the schema");
         end if;
      end;
   end Test_Table_Iterator;

   --  ------------------------------
   --  Test the Table_Cursor operations on an empty schema.
   --  ------------------------------
   procedure Test_Empty_Schema (T : in out Test) is
      Schema : Schema_Definition;
      Iter   : constant Table_Cursor := Schema.Get_Tables;
   begin
      T.Assert (not Has_Element (Iter), "The Get_Tables must return an empty iterator");
      T.Assert (Schema.Find_Table ("test") = null, "The Find_Table must return null");
   end Test_Empty_Schema;

   --  ------------------------------
   --  Test the creation of database.
   --  ------------------------------
   procedure Test_Create_Schema (T : in out Test) is
      use ADO.Sessions.Sources;

      Msg      : Util.Strings.Vectors.Vector;
      Cfg      : Data_Source := Data_Source (Regtests.Get_Controller);
      Driver   : constant String := Cfg.Get_Driver;
      Database : constant String := Cfg.Get_Database;
      Path     : constant String :=
        "db/regtests/" & Cfg.Get_Driver & "/create-ado-" & Driver & ".sql";

      pragma Unreferenced (Msg);
   begin
      if Driver = "sqlite" then
         if Ada.Directories.Exists (Database & ".test") then
            Ada.Directories.Delete_File (Database & ".test");
         end if;
         Cfg.Set_Database (Database & ".test");
         ADO.Schemas.Databases.Create_Database (Admin       => Cfg,
                                                Config      => Cfg,
                                                Schema_Path => Path,
                                                Messages    => Msg);
         T.Assert (Ada.Directories.Exists (Database & ".test"),
                   "The sqlite database was not created");
      else
         ADO.Schemas.Databases.Create_Database (Admin       => Cfg,
                                                Config      => Cfg,
                                                Schema_Path => Path,
                                                Messages    => Msg);
      end if;
   end Test_Create_Schema;

end ADO.Schemas.Tests;

-----------------------------------------------------------------------
--  ado-schemas-tests -- Test loading of database schema
--  Copyright (C) 2009 - 2020 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.Directories;

with Util.Test_Caller;
with Util.Strings.Vectors;
with Util.Strings.Transforms;

with ADO.Parameters;
with ADO.Schemas.Databases;
with ADO.Sessions.Sources;
with ADO.Sessions.Entities;
with ADO.Schemas.Entities;

with Regtests;
with Regtests.Audits.Model;
with Regtests.Simple.Model;
package body ADO.Schemas.Tests is

   use Util.Tests;

   function To_Lower_Case (S : in String) return String
     renames Util.Strings.Transforms.To_Lower_Case;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type",
                       Test_Find_Entity_Type'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type (error)",
                       Test_Find_Entity_Type_Error'Access);
      Caller.Add_Test (Suite, "Test ADO.Sessions.Load_Schema",
                       Test_Load_Schema'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table",
                       Test_Table_Iterator'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table (Empty schema)",
                       Test_Empty_Schema'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Databases.Create_Database",
                       Test_Create_Schema'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading the entity cache and the Find_Entity_Type operation
   --  ------------------------------
   procedure Test_Find_Entity_Type (T : in out Test) is
      S   : ADO.Sessions.Session := Regtests.Get_Database;
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      ADO.Schemas.Entities.Initialize (Cache   => C,
                                       Session => S);

      declare
         T4 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.ALLOCATE_TABLE);
         T5 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
         T1 : constant ADO.Entity_Type
           := Sessions.Entities.Find_Entity_Type (Session => S,
                                                  Table   => Regtests.Audits.Model.AUDIT_TABLE);
         T2 : constant ADO.Entity_Type
           := Sessions.Entities.Find_Entity_Type (Session => S,
                                                  Table   => Regtests.Audits.Model.EMAIL_TABLE);
         T3 : constant ADO.Entity_Type
           := Sessions.Entities.Find_Entity_Type (Session => S,
                                                  Name    => "audit_property");
      begin
         T.Assert (T1 > 0, "T1 must be positive");
         T.Assert (T2 > 0, "T2 must be positive");
         T.Assert (T3 > 0, "T3 must be positive");
         T.Assert (T4 > 0, "T4 must be positive");
         T.Assert (T5 > 0, "T5 must be positive");

         T.Assert (T1 /= T2, "Two distinct tables have different entity types (T1, T2)");
         T.Assert (T2 /= T3, "Two distinct tables have different entity types (T2, T3)");
         T.Assert (T3 /= T4, "Two distinct tables have different entity types (T3, T4)");
         T.Assert (T4 /= T5, "Two distinct tables have different entity types (T4, T5)");
         T.Assert (T5 /= T1, "Two distinct tables have different entity types (T5, T1)");
      end;
   end Test_Find_Entity_Type;

   --  ------------------------------
   --  Test calling Find_Entity_Type with an invalid table.
   --  ------------------------------
   procedure Test_Find_Entity_Type_Error (T : in out Test) is
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      declare
         R : ADO.Entity_Type;
         pragma Unreferenced (R);
      begin
         R := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
         T.Assert (False, "Find_Entity_Type did not raise the No_Entity_Type exception");

      exception
         when ADO.Schemas.Entities.No_Entity_Type =>
            null;
      end;

      declare
         P : ADO.Parameters.Parameter
           := ADO.Parameters.Parameter'(T => ADO.Parameters.T_INTEGER, Num => 0,
                                        Len => 0, Value_Len => 0, Position => 0, Name => "");
      begin
         P := C.Expand ("something");
         T.Assert (False, "Expand did not raise the No_Entity_Type exception");

      exception
         when ADO.Schemas.Entities.No_Entity_Type =>
            null;
      end;
   end Test_Find_Entity_Type_Error;

   --  ------------------------------
   --  Test the Load_Schema operation and check the result schema.
   --  ------------------------------
   procedure Test_Load_Schema (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
   begin
      S.Load_Schema (Schema);

      Table := ADO.Schemas.Find_Table (Schema, "allocate");
      T.Assert (Table /= null, "Table schema for test_allocate not found");

      Assert_Equals (T, "allocate", Get_Name (Table));

      declare
         C : Column_Cursor := Get_Columns (Table);
         Nb_Columns : Integer := 0;
      begin
         while Has_Element (C) loop
            Nb_Columns := Nb_Columns + 1;
            Next (C);
         end loop;
         Assert_Equals (T, 3, Nb_Columns, "Invalid number of columns");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "ID");
      begin
         T.Assert (C /= null, "Cannot find column 'id' in table schema");
         Assert_Equals (T, "id", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_LONG_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
         T.Assert (Is_Primary (C), "Column must be a primary key");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "NAME");
      begin
         T.Assert (C /= null, "Cannot find column 'NAME' in table schema");
         Assert_Equals (T, "name", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_VARCHAR, "Invalid column type");
         T.Assert (Is_Null (C), "Column is null");
         T.Assert (not Is_Primary (C), "Column must not be a primary key");
         Assert_Equals (T, 255, Get_Size (C), "Column has invalid size");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "version");
      begin
         T.Assert (C /= null, "Cannot find column 'version' in table schema");
         Assert_Equals (T, "version", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "this_column_does_not_exist");
      begin
         T.Assert (C = null, "Find_Column must return null for an unknown column");
      end;
   end Test_Load_Schema;

   --  ------------------------------
   --  Test the Table_Cursor operations and check the result schema.
   --  ------------------------------
   procedure Test_Table_Iterator (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
      Driver : constant String := S.Get_Driver.Get_Driver_Name;
   begin
      S.Load_Schema (Schema);

      declare
         Iter  : Table_Cursor := Schema.Get_Tables;
         Count : Natural := 0;
      begin
         T.Assert (Has_Element (Iter), "The Get_Tables returns an empty iterator");
         while Has_Element (Iter) loop
            Table := Element (Iter);
            T.Assert (Table /= null, "Element function must not return null");
            declare
               Col_Iter : Column_Cursor := Get_Columns (Table);
            begin
               --  T.Assert (Has_Element (Col_Iter), "Table has a column");
               while Has_Element (Col_Iter) loop
                  T.Assert (Element (Col_Iter) /= null, "Element function must not return null");
                  Next (Col_Iter);
               end loop;
            end;
            Count := Count + 1;
            Next (Iter);
         end loop;
         if Driver = "sqlite" then
            Util.Tests.Assert_Equals (T, 11, Count,
                                      "Invalid number of tables found in the schema");
         elsif Driver = "mysql" then
            Util.Tests.Assert_Equals (T, 11, Count,
                                      "Invalid number of tables found in the schema");
         elsif Driver = "postgresql" then
            Util.Tests.Assert_Equals (T, 11, Count,
                                      "Invalid number of tables found in the schema");
         end if;
      end;
   end Test_Table_Iterator;

   --  ------------------------------
   --  Test the Table_Cursor operations on an empty schema.
   --  ------------------------------
   procedure Test_Empty_Schema (T : in out Test) is
      Schema : Schema_Definition;
      Iter   : constant Table_Cursor := Schema.Get_Tables;
   begin
      T.Assert (not Has_Element (Iter), "The Get_Tables must return an empty iterator");
      T.Assert (Schema.Find_Table ("test") = null, "The Find_Table must return null");
   end Test_Empty_Schema;

   --  ------------------------------
   --  Test the creation of database.
   --  ------------------------------
   procedure Test_Create_Schema (T : in out Test) is
      use ADO.Sessions.Sources;

      Msg      : Util.Strings.Vectors.Vector;
      Cfg      : Data_Source := Data_Source (Regtests.Get_Controller);
      Driver   : constant String := Cfg.Get_Driver;
      Database : constant String := Cfg.Get_Database;
      Path     : constant String :=
        "db/regtests/" & Cfg.Get_Driver & "/create-ado-" & Driver & ".sql";

      pragma Unreferenced (Msg);
   begin
      if Driver = "sqlite" then
         if Ada.Directories.Exists (Database & ".test") then
            Ada.Directories.Delete_File (Database & ".test");
         end if;
         Cfg.Set_Database (Database & ".test");
         ADO.Schemas.Databases.Create_Database (Admin       => Cfg,
                                                Config      => Cfg,
                                                Schema_Path => Path,
                                                Messages    => Msg);
         T.Assert (Ada.Directories.Exists (Database & ".test"),
                   "The sqlite database was not created");
      else
         ADO.Schemas.Databases.Create_Database (Admin       => Cfg,
                                                Config      => Cfg,
                                                Schema_Path => Path,
                                                Messages    => Msg);
      end if;
   end Test_Create_Schema;

end ADO.Schemas.Tests;

Fix Load_Schema unit test for SQLite after corrections in SQLite driver


------------------------------------------------------------------------------
-- Copyright (c) 2015-2017, 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.Calendar;
with Ada.Command_Line;
with Ada.Text_IO;
with Natools.Time_IO.RFC_3339;
with Natools.Time_Keys;

procedure Timekey is
   procedure Process (Line : in String);
      --  Guess the type of Line and convert it to or from type.

   procedure Process_Input;
      --  Read lines from current input and process them.

   Input_Processed : Boolean := False;
   Empty : Boolean := True;
   Verbose : Boolean := False;
   Subsecond_Digits : Natural := Duration'Aft;

   procedure Process (Line : in String) is
   begin
      if Verbose then
         Ada.Text_IO.Put (Line);
      end if;

      if Natools.Time_Keys.Is_Valid (Line) then
         if Verbose then
            Ada.Text_IO.Put (" => ");
         end if;

         Ada.Text_IO.Put_Line
           (Natools.Time_IO.RFC_3339.Image
              (Natools.Time_Keys.To_Time (Line), Subsecond_Digits, False));

      elsif Natools.Time_IO.RFC_3339.Is_Valid (Line) then
         if Verbose then
            Ada.Text_IO.Put (" => ");
         end if;

         Ada.Text_IO.Put_Line
           (Natools.Time_Keys.To_Key (Natools.Time_IO.RFC_3339.Value (Line)));
      end if;
   end Process;

   procedure Process_Input is
   begin
      if Input_Processed then
         return;
      else
         Input_Processed := True;
      end if;

      begin
         loop
            Process (Ada.Text_IO.Get_Line);
         end loop;
      exception
         when Ada.Text_IO.End_Error => null;
      end;
   end Process_Input;
begin
   for I in 1 .. Ada.Command_Line.Argument_Count loop
      declare
         Arg : constant String := Ada.Command_Line.Argument (I);
      begin
         if Arg = "-" then
            Empty := False;
            Process_Input;
         elsif Arg = "-v" then
            Verbose := True;
         else
            Empty := False;
            Process (Arg);
         end if;
      end;
   end loop;

   if Empty then
      declare
         Now : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      begin
         if Verbose then
            Ada.Text_IO.Put
              (Natools.Time_IO.RFC_3339.Image (Now, Subsecond_Digits, False)
               & " => ");
         end if;

         Ada.Text_IO.Put_Line (Natools.Time_Keys.To_Key (Now));
      end;
   end if;
end Timekey;

------------------------------------------------------------------------------
-- Copyright (c) 2015-2017, 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.Calendar;
with Ada.Command_Line;
with Ada.Text_IO;
with Natools.Time_IO.RFC_3339;
with Natools.Time_Keys;

procedure Timekey is
   procedure Process (Line : in String);
      --  Guess the type of Line and convert it to or from type.

   procedure Process_Input;
      --  Read lines from current input and process them.

   Input_Processed : Boolean := False;
   Empty : Boolean := True;
   Verbose : Boolean := False;
   Subsecond_Digits : Natural := Duration'Aft;

   procedure Process (Line : in String) is
   begin
      if Verbose then
         Ada.Text_IO.Put (Line);
      end if;

      if Natools.Time_Keys.Is_Valid (Line) then
         if Verbose then
            Ada.Text_IO.Put (" => ");
         end if;

         Ada.Text_IO.Put_Line
           (Natools.Time_IO.RFC_3339.Image
              (Natools.Time_Keys.To_Time (Line), Subsecond_Digits, False));

      elsif Natools.Time_IO.RFC_3339.Is_Valid (Line) then
         if Verbose then
            Ada.Text_IO.Put (" => ");
         end if;

         Ada.Text_IO.Put_Line
           (Natools.Time_Keys.To_Key (Natools.Time_IO.RFC_3339.Value (Line)));
      end if;
   end Process;

   procedure Process_Input is
   begin
      if Input_Processed then
         return;
      else
         Input_Processed := True;
      end if;

      begin
         loop
            Process (Ada.Text_IO.Get_Line);
         end loop;
      exception
         when Ada.Text_IO.End_Error => null;
      end;
   end Process_Input;
begin
   for I in 1 .. Ada.Command_Line.Argument_Count loop
      declare
         Arg : constant String := Ada.Command_Line.Argument (I);
      begin
         if Arg = "-" then
            Empty := False;
            Process_Input;
         elsif Arg = "-v" then
            Verbose := True;
         elsif Arg'Length = 2
           and then Arg (Arg'First) = '-'
           and then Arg (Arg'Last) in '0' .. '9'
         then
            Subsecond_Digits := Character'Pos (Arg (Arg'Last))
              - Character'Pos ('0');
         else
            Empty := False;
            Process (Arg);
         end if;
      end;
   end loop;

   if Empty then
      declare
         Now : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      begin
         if Verbose then
            Ada.Text_IO.Put
              (Natools.Time_IO.RFC_3339.Image (Now, Subsecond_Digits, False)
               & " => ");
         end if;

         Ada.Text_IO.Put_Line (Natools.Time_Keys.To_Key (Now));
      end;
   end if;
end Timekey;

tools/timekey: add CLI option to configure numer of subsecond digits


-----------------------------------------------------------------------
--  asf.server -- ASF Server
--  Copyright (C) 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 Util.Strings;

with Ada.Unchecked_Deallocation;
with Ada.Task_Attributes;
package body ASF.Server is

   Null_Context : constant Request_Context := Request_Context'(null, null, null);

   package Task_Context is new Ada.Task_Attributes
     (Request_Context, Null_Context);

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => Binding_Array,
                                     Name   => Binding_Array_Access);

   --  ------------------------------
   --  Get the current registry associated with the current request being processed
   --  by the current thread.  Returns null if there is no current request.
   --  ------------------------------
   function Current return ASF.Servlets.Servlet_Registry_Access is
   begin
      return Task_Context.Value.Application;
   end Current;

   --  ------------------------------
   --  Set the current registry.  This is called by Service once the
   --  registry is identified from the URI.
   --  ------------------------------
   procedure Set_Context (Context : in Request_Context) is
   begin
      Task_Context.Set_Value (Context);
   end Set_Context;

   --  ------------------------------
   --  Give access to the current request and response object to the Process
   --  procedure.  If there is no current request for the thread, do nothing.
   --  ------------------------------
   procedure Update_Context (Process : not null access
                               procedure (Request  : in out Requests.Request'Class;
                                          Response : in out Responses.Response'Class)) is
      Ctx : constant Request_Context := Task_Context.Value;
   begin
      Process (Ctx.Request.all, Ctx.Response.all);
   end Update_Context;

   --  ------------------------------
   --  Register the application to serve requests
   --  ------------------------------
   procedure Register_Application (Server  : in out Container;
                                   URI     : in String;
                                   Context : in ASF.Servlets.Servlet_Registry_Access) is
      Count : constant Natural := Server.Nb_Bindings;
      Apps  : constant Binding_Array_Access := new Binding_Array (1 .. Count + 1);
   begin
      if Server.Applications /= null then
         Apps (1 .. Count) := Server.Applications (1 .. Count);
         Free (Server.Applications);
      end if;
      Server.Nb_Bindings := Count + 1;
      Apps (Apps'Last).Context  := Context;
      Apps (Apps'Last).Base_URI := Ada.Strings.Unbounded.To_Unbounded_String (URI);
      Server.Applications := Apps;

      --  Inform the servlet registry about the base URI.
      Context.Register_Application (URI);
   end Register_Application;

   --  ------------------------------
   --  Start the applications that have been registered.
   --  ------------------------------
   procedure Start (Server : in out Container) is
   begin
      if Server.Applications /= null then
         for I in Server.Applications'Range loop
            Server.Applications (I).Context.Start;
         end loop;
      end if;
   end Start;

   --  ------------------------------
   --  Receives standard HTTP requests from the public service method and dispatches
   --  them to the Do_XXX methods defined in this class. This method is an HTTP-specific
   --  version of the Servlet.service(Request, Response) method. There's no need
   --  to override this method.
   --  ------------------------------
   procedure Service (Server   : in Container;
                      Request  : in out Requests.Request'Class;
                      Response : in out Responses.Response'Class) is

      use Servlets;
      use Util.Strings;
      use type Ada.Strings.Unbounded.Unbounded_String;

      URI        : constant String := Request.Get_Request_URI;
      Slash_Pos  : constant Natural := Index (URI, '/', URI'First + 1);
      Apps       : constant Binding_Array_Access := Server.Applications;
      Prefix_End : Natural;
   begin

      if Apps = null then
         Response.Set_Status (Responses.SC_NOT_FOUND);
         Server.Default.Send_Error_Page (Request, Response);
         return;
      end if;

      --  Find the module and action to invoke
      if Slash_Pos > 1 then
         Prefix_End := Slash_Pos - 1;
      else
         Prefix_End := URI'Last;
      end if;

      for I in Apps.all'Range loop
         if Apps (I).Base_URI = URI (URI'First .. Prefix_End) then
            declare
               Req        : Request_Context;
               Context    : constant Servlet_Registry_Access := Apps (I).Context;
               Page       : constant String := URI (Prefix_End + 1 .. URI'Last);
               Dispatcher : constant Request_Dispatcher := Context.Get_Request_Dispatcher (Page);
            begin
               Req.Request     := Request'Unchecked_Access;
               Req.Response    := Response'Unchecked_Access;
               Req.Application := Context;
               Set_Context (Req);
               Forward (Dispatcher, Request, Response);
               case Response.Get_Status / 100 is
                  when 2 | 3 =>
                     null;

                  when others =>
                     Context.Send_Error_Page (Request, Response);

               end case;
               Set_Context (Null_Context);
               return;

            exception
               when E : others =>
                  Context.Error (Request, Response, E);
                  Set_Context (Null_Context);
                  return;
            end;
         end if;
      end loop;

      Response.Set_Status (Responses.SC_NOT_FOUND);
      Server.Default.Send_Error_Page (Request, Response);

   exception
      when E : others =>
         Server.Default.Error (Request, Response, E);
   end Service;

   --  ------------------------------
   --  Release the storage.
   --  ------------------------------
   overriding
   procedure Finalize (Server : in out Container) is
   begin
      Free (Server.Applications);
   end Finalize;

end ASF.Server;

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

with Util.Strings;

with Ada.Unchecked_Deallocation;
with Ada.Task_Attributes;
package body ASF.Server is

   Null_Context : constant Request_Context := Request_Context'(null, null, null);

   package Task_Context is new Ada.Task_Attributes
     (Request_Context, Null_Context);

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => Binding_Array,
                                     Name   => Binding_Array_Access);

   --  ------------------------------
   --  Get the current registry associated with the current request being processed
   --  by the current thread.  Returns null if there is no current request.
   --  ------------------------------
   function Current return ASF.Servlets.Servlet_Registry_Access is
   begin
      return Task_Context.Value.Application;
   end Current;

   --  ------------------------------
   --  Set the current registry.  This is called by Service once the
   --  registry is identified from the URI.
   --  ------------------------------
   procedure Set_Context (Context : in Request_Context) is
   begin
      Task_Context.Set_Value (Context);
   end Set_Context;

   --  ------------------------------
   --  Give access to the current request and response object to the Process
   --  procedure.  If there is no current request for the thread, do nothing.
   --  ------------------------------
   procedure Update_Context (Process : not null access
                               procedure (Request  : in out Requests.Request'Class;
                                          Response : in out Responses.Response'Class)) is
      Ctx : constant Request_Context := Task_Context.Value;
   begin
      Process (Ctx.Request.all, Ctx.Response.all);
   end Update_Context;

   --  ------------------------------
   --  Register the application to serve requests
   --  ------------------------------
   procedure Register_Application (Server  : in out Container;
                                   URI     : in String;
                                   Context : in ASF.Servlets.Servlet_Registry_Access) is
      Count : constant Natural := Server.Nb_Bindings;
      Apps  : constant Binding_Array_Access := new Binding_Array (1 .. Count + 1);
   begin
      if Server.Applications /= null then
         Apps (1 .. Count) := Server.Applications (1 .. Count);
         Free (Server.Applications);
      end if;
      Server.Nb_Bindings := Count + 1;
      Apps (Count + 1).Context  := Context;
      Apps (Count + 1).Base_URI := Ada.Strings.Unbounded.To_Unbounded_String (URI);
      Server.Applications := Apps;

      --  Inform the servlet registry about the base URI.
      Context.Register_Application (URI);
   end Register_Application;

   --  ------------------------------
   --  Remove the application
   --  ------------------------------
   procedure Remove_Application (Server  : in out Container;
                                 Context : in ASF.Servlets.Servlet_Registry_Access) is
      use type ASF.Servlets.Servlet_Registry_Access;

      Count : constant Natural := Server.Nb_Bindings;
      Apps  : constant Binding_Array_Access := Server.Applications;
   begin
      for I in 1 .. Count loop
         if Apps (I).Context = Context then
            Server.Nb_Bindings := Count - 1;
            if I < Count then
               Apps (I) := Apps (Count);
            end if;
            return;
         end if;
      end loop;
   end Remove_Application;

   --  ------------------------------
   --  Start the applications that have been registered.
   --  ------------------------------
   procedure Start (Server : in out Container) is
   begin
      if Server.Applications /= null then
         for I in Server.Applications'Range loop
            Server.Applications (I).Context.Start;
         end loop;
      end if;
   end Start;

   --  ------------------------------
   --  Receives standard HTTP requests from the public service method and dispatches
   --  them to the Do_XXX methods defined in this class. This method is an HTTP-specific
   --  version of the Servlet.service(Request, Response) method. There's no need
   --  to override this method.
   --  ------------------------------
   procedure Service (Server   : in Container;
                      Request  : in out Requests.Request'Class;
                      Response : in out Responses.Response'Class) is

      use Servlets;
      use Util.Strings;
      use type Ada.Strings.Unbounded.Unbounded_String;

      URI        : constant String := Request.Get_Request_URI;
      Slash_Pos  : constant Natural := Index (URI, '/', URI'First + 1);
      Apps       : constant Binding_Array_Access := Server.Applications;
      Prefix_End : Natural;
   begin

      if Apps = null then
         Response.Set_Status (Responses.SC_NOT_FOUND);
         Server.Default.Send_Error_Page (Request, Response);
         return;
      end if;

      --  Find the module and action to invoke
      if Slash_Pos > 1 then
         Prefix_End := Slash_Pos - 1;
      else
         Prefix_End := URI'Last;
      end if;

      for I in Apps.all'Range loop
         if Apps (I).Base_URI = URI (URI'First .. Prefix_End) then
            declare
               Req        : Request_Context;
               Context    : constant Servlet_Registry_Access := Apps (I).Context;
               Page       : constant String := URI (Prefix_End + 1 .. URI'Last);
               Dispatcher : constant Request_Dispatcher := Context.Get_Request_Dispatcher (Page);
            begin
               Req.Request     := Request'Unchecked_Access;
               Req.Response    := Response'Unchecked_Access;
               Req.Application := Context;
               Set_Context (Req);
               Forward (Dispatcher, Request, Response);
               case Response.Get_Status / 100 is
                  when 2 | 3 =>
                     null;

                  when others =>
                     Context.Send_Error_Page (Request, Response);

               end case;
               Set_Context (Null_Context);
               return;

            exception
               when E : others =>
                  Context.Error (Request, Response, E);
                  Set_Context (Null_Context);
                  return;
            end;
         end if;
      end loop;

      Response.Set_Status (Responses.SC_NOT_FOUND);
      Server.Default.Send_Error_Page (Request, Response);

   exception
      when E : others =>
         Server.Default.Error (Request, Response, E);
   end Service;

   --  ------------------------------
   --  Release the storage.
   --  ------------------------------
   overriding
   procedure Finalize (Server : in out Container) is
   begin
      Free (Server.Applications);
   end Finalize;

end ASF.Server;

Implement Remove_Application procedure

Implement Remove_Application procedure


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

with ADO;

with Util.Beans.Objects;
with Util.Beans.Basic;
with AWA.Storages.Beans;
with AWA.Images.Models;
with AWA.Images.Modules;
package AWA.Images.Beans is

   FOLDER_ID_PARAMETER : constant String := "folderId";

   --  ------------------------------
   --  Image List Bean
   --  ------------------------------
   --  This bean represents a list of images for a given folder.
   type Image_List_Bean is new AWA.Storages.Beans.Storage_List_Bean with record

      --  List of images.
      Image_List       : aliased AWA.Images.Models.Image_Info_List_Bean;
      Image_List_Bean  : AWA.Images.Models.Image_Info_List_Bean_Access;
   end record;
   type Image_List_Bean_Access is access all Image_List_Bean'Class;

   --  Load the list of images associated with the current folder.
   overriding
   procedure Load_Files (Storage : in Image_List_Bean);

   overriding
   function Get_Value (List : in Image_List_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Create the Image_List_Bean bean instance.
   function Create_Image_List_Bean (Module : in AWA.Images.Modules.Image_Module_Access)
                                    return Util.Beans.Basic.Readonly_Bean_Access;

end AWA.Images.Beans;

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

with ADO;

with Util.Beans.Objects;
with Util.Beans.Basic;
with AWA.Storages.Beans;
with AWA.Images.Models;
with AWA.Images.Modules;
package AWA.Images.Beans is

   --  ------------------------------
   --  Image List Bean
   --  ------------------------------
   --  This bean represents a list of images for a given folder.
   type Image_List_Bean is new AWA.Storages.Beans.Storage_List_Bean with record

      --  List of images.
      Image_List       : aliased AWA.Images.Models.Image_Info_List_Bean;
      Image_List_Bean  : AWA.Images.Models.Image_Info_List_Bean_Access;
   end record;
   type Image_List_Bean_Access is access all Image_List_Bean'Class;

   --  Load the list of images associated with the current folder.
   overriding
   procedure Load_Files (Storage : in Image_List_Bean);

   overriding
   function Get_Value (List : in Image_List_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Create the Image_List_Bean bean instance.
   function Create_Image_List_Bean (Module : in AWA.Images.Modules.Image_Module_Access)
                                    return Util.Beans.Basic.Readonly_Bean_Access;

end AWA.Images.Beans;

Remove FOLDER_ID_PARAMETER constant

Remove FOLDER_ID_PARAMETER constant