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

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

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

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

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

   --  Get the application identifier.
   function Get_Application_Identifier (App : in Application) return String;

   --  Set the application identifier used by the OAuth authorization server
   --  to identify the application (for example, the App ID in Facebook).
   procedure Set_Application_Identifier (App    : in out Application;
                                         Client : in String);

   --  Set the application secret defined in the OAuth authorization server
   --  for the application (for example, the App Secret in Facebook).
   procedure Set_Application_Secret (App    : in out Application;
                                     Secret : in String);

   --  Set the redirection callback that will be used to redirect the user
   --  back to the application after the OAuth authorization is finished.
   procedure Set_Application_Callback (App : in out Application;
                                       URI : in String);

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

   --  OAuth 2.0 Section 4.1.1  Authorization Request

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

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

   --  OAuth 2.0 Section 4.1.2  Authorization Response

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

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

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

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

private

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

   type Application is tagged record
      Client_Id   : Ada.Strings.Unbounded.Unbounded_String;
      Secret      : Ada.Strings.Unbounded.Unbounded_String;
      Callback    : Ada.Strings.Unbounded.Unbounded_String;
      Request_URI : Ada.Strings.Unbounded.Unbounded_String;
      Protect     : Ada.Strings.Unbounded.Unbounded_String;
      Key         : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end Security.OAuth.Clients;

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

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

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

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

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

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

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

   --  Get the application identifier.
   function Get_Application_Identifier (App : in Application) return String;

   --  Set the application identifier used by the OAuth authorization server
   --  to identify the application (for example, the App ID in Facebook).
   procedure Set_Application_Identifier (App    : in out Application;
                                         Client : in String);

   --  Set the application secret defined in the OAuth authorization server
   --  for the application (for example, the App Secret in Facebook).
   procedure Set_Application_Secret (App    : in out Application;
                                     Secret : in String);

   --  Set the redirection callback that will be used to redirect the user
   --  back to the application after the OAuth authorization is finished.
   procedure Set_Application_Callback (App : in out Application;
                                       URI : in String);

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

   --  OAuth 2.0 Section 4.1.1  Authorization Request

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

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

   --  OAuth 2.0 Section 4.1.2  Authorization Response

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

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

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

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

private

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

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

   type Application is tagged record
      Client_Id   : Ada.Strings.Unbounded.Unbounded_String;
      Secret      : Ada.Strings.Unbounded.Unbounded_String;
      Callback    : Ada.Strings.Unbounded.Unbounded_String;
      Request_URI : Ada.Strings.Unbounded.Unbounded_String;
      Protect     : Ada.Strings.Unbounded.Unbounded_String;
      Key         : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end Security.OAuth.Clients;

Add support for OpenID Connect token

Add support for OpenID Connect token


-----------------------------------------------------------------------
--  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.Unchecked_Deallocation;

with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.Mappers;
with Util.Serialize.Mappers.Record_Mapper;

with Security.Contexts;

package body Security.Policies.Urls is

   --  ------------------------------
   --  URL policy
   --  ------------------------------

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

   --  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 URI_Permission'Class) return Boolean is
      Name  : constant String_Ref := To_String_Ref (Permission.URI);
      Ref   : constant Rules_Ref.Ref := Manager.Cache.Get;
      Rules : constant Rules_Access := Ref.Value;
      Pos   : constant Rules_Maps.Cursor := Rules.Map.Find (Name);
      Rule  : Access_Rule_Ref;
   begin
      --  If the rule is not in the cache, search for the access rule that
      --  matches our URI.  Update the cache.  This cache update is thread-safe
      --  as the cache map is never modified: a new cache map is installed.
      if not Rules_Maps.Has_Element (Pos) then
         declare
            New_Ref : constant Rules_Ref.Ref := Rules_Ref.Create;
         begin
            Rule := Manager.Find_Access_Rule (Permission.URI);
            New_Ref.Value.all.Map := Rules.Map;
            New_Ref.Value.all.Map.Insert (Name, Rule);
            Manager.Cache.Set (New_Ref);
         end;
      else
         Rule := Rules_Maps.Element (Pos);
      end if;

      --  Check if the user has one of the required permission.
      declare
         P       : constant Access_Rule_Access := Rule.Value;
         Granted : Boolean;
      begin
         if P /= null then
            for I in P.Permissions'Range loop
               Context.Has_Permission (P.Permissions (I), Granted);
               if Granted then
                  return True;
               end if;
            end loop;
         end if;
      end;
      return False;
   end Has_Permission;

   --  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) is
   begin
      null;
   end Grant_URI_Permission;

   --  ------------------------------
   --  Policy Configuration
   --  ------------------------------
   type Policy_Config is record
      Id          : Natural := 0;
      Permissions : Util.Beans.Objects.Vectors.Vector;
      Patterns    : Util.Beans.Objects.Vectors.Vector;
      Manager     : URL_Policy_Access;
   end record;
   type Policy_Config_Access is access all Policy_Config;

   --  Setup the XML parser to read the policy description.  For example:

   --  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 is

      Matched : Boolean := False;
      Result  : Access_Rule_Ref;

      procedure Match (P : in Policy);

      procedure Match (P : in Policy) is
      begin
         if GNAT.Regexp.Match (URI, P.Pattern) then
            Matched := True;
            Result  := P.Rule;
         end if;
      end Match;

      Last : constant Natural := Manager.Policies.Last_Index;
   begin
      for I in 1 .. Last loop
         Manager.Policies.Query_Element (I, Match'Access);
         if Matched then
            return Result;
         end if;
      end loop;
      return Result;
   end Find_Access_Rule;

   --  ------------------------------
   --  Initialize the permission manager.
   --  ------------------------------
   overriding
   procedure Initialize (Manager : in out URL_Policy) is
   begin
      Manager.Cache := new Rules_Ref.Atomic_Ref;
      Manager.Cache.Set (Rules_Ref.Create);
   end Initialize;

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

      procedure Free is
        new Ada.Unchecked_Deallocation (Rules_Ref.Atomic_Ref,
                                        Rules_Ref_Access);
   begin
      Free (Manager.Cache);
--        for I in Manager.Names'Range loop
--           exit when Manager.Names (I) = null;
--           Ada.Strings.Unbounded.Free (Manager.Names (I));
--        end loop;

   end Finalize;

   type Policy_Fields is (FIELD_ID, FIELD_PERMISSION, FIELD_URL_PATTERN, FIELD_POLICY);

   procedure Set_Member (P     : in out URL_Policy'Class;
                         Field : in Policy_Fields;
                         Value : in Util.Beans.Objects.Object);

   procedure Process (Policy : in out URL_Policy'Class);

   procedure Set_Member (P     : in out URL_Policy'Class;
                         Field : in Policy_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_ID =>
            P.Id := Util.Beans.Objects.To_Integer (Value);

         when FIELD_PERMISSION =>
            P.Permissions.Append (Value);

         when FIELD_URL_PATTERN =>
            P.Patterns.Append (Value);

         when FIELD_POLICY =>
            Process (P);
            P.Id := 0;
            P.Permissions.Clear;
            P.Patterns.Clear;

      end case;
   end Set_Member;

   procedure Process (Policy : in out URL_Policy'Class) is
      Pol    : Security.Policies.URLs.Policy;
      Count  : constant Natural := Natural (Policy.Permissions.Length);
      Rule   : constant Access_Rule_Ref := Access_Rule_Refs.Create (new Access_Rule (Count));
      Iter   : Util.Beans.Objects.Vectors.Cursor := Policy.Permissions.First;
      Pos    : Positive := 1;
   begin
      Pol.Rule := Rule;

      --  Step 1: Initialize the list of permission index in Access_Rule from the permission names.
      while Util.Beans.Objects.Vectors.Has_Element (Iter) loop
         declare
            Perm : constant Util.Beans.Objects.Object := Util.Beans.Objects.Vectors.Element (Iter);
            Name : constant String := Util.Beans.Objects.To_String (Perm);
         begin
            Rule.Value.all.Permissions (Pos) := Permissions.Get_Permission_Index (Name);
            Pos := Pos + 1;

         exception
            when Invalid_Name =>
               raise Util.Serialize.Mappers.Field_Error with "Invalid permission: " & Name;
         end;
         Util.Beans.Objects.Vectors.Next (Iter);
      end loop;

      --  Step 2: Create one policy for each URL pattern
      Iter := Policy.Patterns.First;
      while Util.Beans.Objects.Vectors.Has_Element (Iter) loop
         declare
            Pattern : constant Util.Beans.Objects.Object
              := Util.Beans.Objects.Vectors.Element (Iter);
         begin
            Pol.Id   := Policy.Id;
            Pol.Pattern := GNAT.Regexp.Compile (Util.Beans.Objects.To_String (Pattern));
            Policy.Policies.Append (Pol);
         end;
         Util.Beans.Objects.Vectors.Next (Iter);
      end loop;
   end Process;

   package Policy_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => URL_Policy'Class,
                                               Element_Type_Access => URL_Policy_Access,
                                               Fields              => Policy_Fields,
                                               Set_Member          => Set_Member);

   Policy_Mapping        : aliased Policy_Mapper.Mapper;

   --  ------------------------------
   --  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) is
   begin
      Reader.Add_Mapping ("policy-rules", Policy_Mapping'Access);
      Reader.Add_Mapping ("module", Policy_Mapping'Access);
      Policy_Mapper.Set_Context (Reader, Policy'Unchecked_Access);
   end Prepare_Config;

   --  ------------------------------
   --  Finish reading the XML policy configuration.  The security policy implementation can use
   --  this procedure to perform any configuration setup after the configuration is parsed.
   --  ------------------------------
   overriding
   procedure Finish_Config (Into    : in out URL_Policy;
                            Reader  : in out Util.Serialize.IO.XML.Parser) is
   begin
      null;
   end Finish_Config;

   --  ------------------------------
   --  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 is
      Policy : constant Security.Policies.Policy_Access := Manager.Get_Policy (NAME);
   begin
      if Policy = null or else not (Policy.all in URL_Policy'Class) then
         return null;
      else
         return URL_Policy'Class (Policy.all)'Access;
      end if;
   end Get_URL_Policy;

begin
   Policy_Mapping.Add_Mapping ("url-policy", FIELD_POLICY);
   Policy_Mapping.Add_Mapping ("url-policy/@id", FIELD_ID);
   Policy_Mapping.Add_Mapping ("url-policy/permission", FIELD_PERMISSION);
   Policy_Mapping.Add_Mapping ("url-policy/url-pattern", FIELD_URL_PATTERN);
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.Unchecked_Deallocation;

with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.Mappers;
with Util.Serialize.Mappers.Record_Mapper;

with Security.Contexts;

package body Security.Policies.Urls is

   --  ------------------------------
   --  URL policy
   --  ------------------------------

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

   --  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 URI_Permission'Class) return Boolean is
      Name  : constant String_Ref := To_String_Ref (Permission.URI);
      Ref   : constant Rules_Ref.Ref := Manager.Cache.Get;
      Rules : constant Rules_Access := Ref.Value;
      Pos   : constant Rules_Maps.Cursor := Rules.Map.Find (Name);
      Rule  : Access_Rule_Ref;
   begin
      --  If the rule is not in the cache, search for the access rule that
      --  matches our URI.  Update the cache.  This cache update is thread-safe
      --  as the cache map is never modified: a new cache map is installed.
      if not Rules_Maps.Has_Element (Pos) then
         declare
            New_Ref : constant Rules_Ref.Ref := Rules_Ref.Create;
         begin
            Rule := Manager.Find_Access_Rule (Permission.URI);
            New_Ref.Value.all.Map := Rules.Map;
            New_Ref.Value.all.Map.Insert (Name, Rule);
            Manager.Cache.Set (New_Ref);
         end;
      else
         Rule := Rules_Maps.Element (Pos);
      end if;

      --  Check if the user has one of the required permission.
      declare
         P       : constant Access_Rule_Access := Rule.Value;
         Granted : Boolean;
      begin
         if P /= null then
            for I in P.Permissions'Range loop
               Context.Has_Permission (P.Permissions (I), Granted);
               if Granted then
                  return True;
               end if;
            end loop;
         end if;
      end;
      return False;
   end Has_Permission;

   --  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) is
   begin
      null;
   end Grant_URI_Permission;

   --  ------------------------------
   --  Policy Configuration
   --  ------------------------------
   type Policy_Config is record
      Id          : Natural := 0;
      Permissions : Util.Beans.Objects.Vectors.Vector;
      Patterns    : Util.Beans.Objects.Vectors.Vector;
      Manager     : URL_Policy_Access;
   end record;
   type Policy_Config_Access is access all Policy_Config;

   --  Setup the XML parser to read the policy description.  For example:

   --  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 is

      Matched : Boolean := False;
      Result  : Access_Rule_Ref;

      procedure Match (P : in Policy);

      procedure Match (P : in Policy) is
      begin
         if GNAT.Regexp.Match (URI, P.Pattern) then
            Matched := True;
            Result  := P.Rule;
         end if;
      end Match;

      Last : constant Natural := Manager.Policies.Last_Index;
   begin
      for I in 1 .. Last loop
         Manager.Policies.Query_Element (I, Match'Access);
         if Matched then
            return Result;
         end if;
      end loop;
      return Result;
   end Find_Access_Rule;

   --  ------------------------------
   --  Initialize the permission manager.
   --  ------------------------------
   overriding
   procedure Initialize (Manager : in out URL_Policy) is
   begin
      Manager.Cache := new Rules_Ref.Atomic_Ref;
      Manager.Cache.Set (Rules_Ref.Create);
   end Initialize;

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

      procedure Free is
        new Ada.Unchecked_Deallocation (Rules_Ref.Atomic_Ref,
                                        Rules_Ref_Access);
   begin
      Free (Manager.Cache);
--        for I in Manager.Names'Range loop
--           exit when Manager.Names (I) = null;
--           Ada.Strings.Unbounded.Free (Manager.Names (I));
--        end loop;

   end Finalize;

   type Policy_Fields is (FIELD_ID, FIELD_PERMISSION, FIELD_URL_PATTERN, FIELD_POLICY);

   procedure Set_Member (P     : in out URL_Policy'Class;
                         Field : in Policy_Fields;
                         Value : in Util.Beans.Objects.Object);

   procedure Process (Policy : in out URL_Policy'Class);

   procedure Set_Member (P     : in out URL_Policy'Class;
                         Field : in Policy_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_ID =>
            P.Id := Util.Beans.Objects.To_Integer (Value);

         when FIELD_PERMISSION =>
            P.Permissions.Append (Value);

         when FIELD_URL_PATTERN =>
            P.Patterns.Append (Value);

         when FIELD_POLICY =>
            Process (P);
            P.Id := 0;
            P.Permissions.Clear;
            P.Patterns.Clear;

      end case;
   end Set_Member;

   procedure Process (Policy : in out URL_Policy'Class) is
      Pol    : Security.Policies.URLs.Policy;
      Count  : constant Natural := Natural (Policy.Permissions.Length);
      Rule   : constant Access_Rule_Ref := Access_Rule_Refs.Create (new Access_Rule (Count));
      Iter   : Util.Beans.Objects.Vectors.Cursor := Policy.Permissions.First;
      Pos    : Positive := 1;
   begin
      Pol.Rule := Rule;

      --  Step 1: Initialize the list of permission index in Access_Rule from the permission names.
      while Util.Beans.Objects.Vectors.Has_Element (Iter) loop
         declare
            Perm : constant Util.Beans.Objects.Object := Util.Beans.Objects.Vectors.Element (Iter);
            Name : constant String := Util.Beans.Objects.To_String (Perm);
         begin
            Rule.Value.all.Permissions (Pos) := Permissions.Get_Permission_Index (Name);
            Pos := Pos + 1;

         exception
            when Invalid_Name =>
               raise Util.Serialize.Mappers.Field_Error with "Invalid permission: " & Name;
         end;
         Util.Beans.Objects.Vectors.Next (Iter);
      end loop;

      --  Step 2: Create one policy for each URL pattern
      Iter := Policy.Patterns.First;
      while Util.Beans.Objects.Vectors.Has_Element (Iter) loop
         declare
            Pattern : constant Util.Beans.Objects.Object
              := Util.Beans.Objects.Vectors.Element (Iter);
         begin
            Pol.Id   := Policy.Id;
            Pol.Pattern := GNAT.Regexp.Compile (Util.Beans.Objects.To_String (Pattern));
            Policy.Policies.Append (Pol);
         end;
         Util.Beans.Objects.Vectors.Next (Iter);
      end loop;
   end Process;

   package Policy_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => URL_Policy'Class,
                                               Element_Type_Access => URL_Policy_Access,
                                               Fields              => Policy_Fields,
                                               Set_Member          => Set_Member);

   Policy_Mapping        : aliased Policy_Mapper.Mapper;

   --  ------------------------------
   --  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) is
   begin
      Reader.Add_Mapping ("policy-rules", Policy_Mapping'Access);
      Reader.Add_Mapping ("module", Policy_Mapping'Access);
      Policy_Mapper.Set_Context (Reader, Policy'Unchecked_Access);
   end Prepare_Config;

   --  ------------------------------
   --  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 is
      Policy : constant Security.Policies.Policy_Access := Manager.Get_Policy (NAME);
   begin
      if Policy = null or else not (Policy.all in URL_Policy'Class) then
         return null;
      else
         return URL_Policy'Class (Policy.all)'Access;
      end if;
   end Get_URL_Policy;

begin
   Policy_Mapping.Add_Mapping ("url-policy", FIELD_POLICY);
   Policy_Mapping.Add_Mapping ("url-policy/@id", FIELD_ID);
   Policy_Mapping.Add_Mapping ("url-policy/permission", FIELD_PERMISSION);
   Policy_Mapping.Add_Mapping ("url-policy/url-pattern", FIELD_URL_PATTERN);
end Security.Policies.Urls;

Remove Finish_Config

Remove Finish_Config


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

with ASF.Components.Base;
with ASF.Components.Core.Views;
package body ASF.Components.Root is

   use ASF;
   use EL.Objects;

   --  ------------------------------
   --  Get the root node of the view.
   --  ------------------------------
   function Get_Root (UI : in UIViewRoot) return access Base.UIComponent'Class is
   begin
      if UI.Root = null then
         return null;
      elsif UI.Root.Meta = null then
         return UI.Root.View;
      else
         return UI.Root.Meta;
      end if;
   end Get_Root;

   --  ------------------------------
   --  Set the root node of the view.
   --  ------------------------------
   procedure Set_Root (UI   : in out UIViewRoot;
                       Root : access Base.UIComponent'Class;
                       Name : in String) is
   begin
      if UI.Root /= null then
         Finalize (UI);
      end if;

      UI.Root := new Root_Holder '(Ref_Counter => 1,
                                   Len         => Name'Length,
                                   View        => Root,
                                   Meta        => null,
                                   Name        => Name);
   end Set_Root;

   --  ------------------------------
   --  Set the metadata component of the view.
   --  ------------------------------
   procedure Set_Meta (UI   : in out UIViewRoot) is
      Node : access Base.UIComponent'Class;
   begin
      if UI.Root /= null then
         Node := UI.Root.View;
         UI.Root.Meta := Node.Get_Facet (Core.Views.METADATA_FACET_NAME);
         if UI.Root.Meta = null then
            declare
               Iter : Base.Cursor := Base.First (Node.all);
            begin
               while Base.Has_Element (Iter) loop
                  UI.Root.Meta := Base.Element (Iter).Get_Facet (Core.Views.METADATA_FACET_NAME);
                  exit when UI.Root.Meta /= null;
                  Base.Next (Iter);
               end loop;
            end;
         end if;
         if UI.Root.Meta /= null then
            Node.Log_Error ("Found metadata");
         end if;
      end if;
   end Set_Meta;

   --  ------------------------------
   --  Returns True if the view has a metadata component.
   --  ------------------------------
   function Has_Meta (UI : in UIViewRoot) return Boolean is
   begin
      return UI.Root /= null and then UI.Root.Meta /= null;
   end Has_Meta;

   --  ------------------------------
   --  Get the view identifier.
   --  ------------------------------
   function Get_View_Id (UI : in UIViewRoot) return String is
   begin
      return UI.Root.Name;
   end Get_View_Id;

   --  ------------------------------
   --  Create an identifier for a component.
   --  ------------------------------
   procedure Create_Unique_Id (UI : in out UIViewRoot;
                               Id : out Natural) is
   begin
      UI.Last_Id := UI.Last_Id + 1;
      Id := UI.Last_Id;
   end Create_Unique_Id;

   --  ------------------------------
   --  Increment the reference counter.
   --  ------------------------------
   overriding
   procedure Adjust (Object : in out UIViewRoot) is
   begin
      if Object.Root /= null then
         Object.Root.Ref_Counter := Object.Root.Ref_Counter + 1;
      end if;
   end Adjust;

   Empty : ASF.Components.Base.UIComponent;

   --  ------------------------------
   --  Free the memory held by the component tree.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out UIViewRoot) is

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Root_Holder,
                                        Name   => Root_Holder_Access);

   begin
      if Object.Root /= null then
         Object.Root.Ref_Counter := Object.Root.Ref_Counter - 1;
         if Object.Root.Ref_Counter = 0 then
            declare
               C : ASF.Components.Base.UIComponent_Access := Object.Root.View.all'Unchecked_Access;
            begin
               ASF.Components.Base.Steal_Root_Component (Empty, C);
            end;
            Free (Object.Root);
         end if;
      end if;
   end Finalize;

end ASF.Components.Root;

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

with ASF.Components.Base;
with ASF.Components.Core.Views;
package body ASF.Components.Root is

   use ASF;
   use EL.Objects;

   --  ------------------------------
   --  Get the root node of the view.
   --  ------------------------------
   function Get_Root (UI : in UIViewRoot) return access Base.UIComponent'Class is
   begin
      if UI.Root = null then
         return null;
      elsif UI.Root.Meta = null then
         return UI.Root.View;
      else
         return UI.Root.Meta;
      end if;
   end Get_Root;

   --  ------------------------------
   --  Set the root node of the view.
   --  ------------------------------
   procedure Set_Root (UI   : in out UIViewRoot;
                       Root : access Base.UIComponent'Class;
                       Name : in String) is
   begin
      if UI.Root /= null then
         Finalize (UI);
      end if;

      UI.Root := new Root_Holder '(Ref_Counter => 1,
                                   Len         => Name'Length,
                                   View        => Root,
                                   Meta        => null,
                                   Name        => Name);
   end Set_Root;

   --  ------------------------------
   --  Set the metadata component of the view.
   --  ------------------------------
   procedure Set_Meta (UI   : in out UIViewRoot) is
      Node : access Base.UIComponent'Class;
   begin
      if UI.Root /= null then
         Node := UI.Root.View;
         UI.Root.Meta := Node.Get_Facet (Core.Views.METADATA_FACET_NAME);
         if UI.Root.Meta = null then
            declare
               Iter : Base.Cursor := Base.First (Node.all);
            begin
               while Base.Has_Element (Iter) loop
                  UI.Root.Meta := Base.Element (Iter).Get_Facet (Core.Views.METADATA_FACET_NAME);
                  exit when UI.Root.Meta /= null;
                  Base.Next (Iter);
               end loop;
            end;
         end if;
      end if;
   end Set_Meta;

   --  ------------------------------
   --  Returns True if the view has a metadata component.
   --  ------------------------------
   function Has_Meta (UI : in UIViewRoot) return Boolean is
   begin
      return UI.Root /= null and then UI.Root.Meta /= null;
   end Has_Meta;

   --  ------------------------------
   --  Get the view identifier.
   --  ------------------------------
   function Get_View_Id (UI : in UIViewRoot) return String is
   begin
      return UI.Root.Name;
   end Get_View_Id;

   --  ------------------------------
   --  Create an identifier for a component.
   --  ------------------------------
   procedure Create_Unique_Id (UI : in out UIViewRoot;
                               Id : out Natural) is
   begin
      UI.Last_Id := UI.Last_Id + 1;
      Id := UI.Last_Id;
   end Create_Unique_Id;

   --  ------------------------------
   --  Increment the reference counter.
   --  ------------------------------
   overriding
   procedure Adjust (Object : in out UIViewRoot) is
   begin
      if Object.Root /= null then
         Object.Root.Ref_Counter := Object.Root.Ref_Counter + 1;
      end if;
   end Adjust;

   Empty : ASF.Components.Base.UIComponent;

   --  ------------------------------
   --  Free the memory held by the component tree.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out UIViewRoot) is

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Root_Holder,
                                        Name   => Root_Holder_Access);

   begin
      if Object.Root /= null then
         Object.Root.Ref_Counter := Object.Root.Ref_Counter - 1;
         if Object.Root.Ref_Counter = 0 then
            declare
               C : ASF.Components.Base.UIComponent_Access := Object.Root.View.all'Unchecked_Access;
            begin
               ASF.Components.Base.Steal_Root_Component (Empty, C);
            end;
            Free (Object.Root);
         end if;
      end if;
   end Finalize;

end ASF.Components.Root;

Remove a debug message

Remove a debug message


-----------------------------------------------------------------------
--  EL.Contexts -- Default contexts for evaluating an expression
--  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 Ada.Unchecked_Deallocation;
with EL.Variables.Default;
package body EL.Contexts.Default is

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => EL.Variables.Variable_Mapper'Class,
                                     Name   => EL.Variables.Variable_Mapper_Access);

   --  ------------------------------
   --  Retrieves the ELResolver associated with this ELcontext.
   --  ------------------------------
   overriding
   function Get_Resolver (Context : Default_Context) return ELResolver_Access is
   begin
      return Context.Resolver;
   end Get_Resolver;

   --  ------------------------------
   --  Set the ELResolver associated with this ELcontext.
   --  ------------------------------
   procedure Set_Resolver (Context  : in out Default_Context;
                           Resolver : in ELResolver_Access) is
   begin
      Context.Resolver := Resolver;
   end Set_Resolver;

   --  ------------------------------
   --  Retrieves the Variable_Mapper associated with this ELContext.
   --  ------------------------------
   overriding
   function Get_Variable_Mapper (Context : Default_Context)
                                 return access EL.Variables.Variable_Mapper'Class is
   begin
      return Context.Var_Mapper;
   end Get_Variable_Mapper;

   --  ------------------------------
   --  Retrieves the Function_Mapper associated with this ELContext.
   --  The Function_Mapper is only used when parsing an expression.
   --  ------------------------------
   overriding
   function Get_Function_Mapper (Context : Default_Context)
                                 return EL.Functions.Function_Mapper_Access is
   begin
      return Context.Function_Mapper;
   end Get_Function_Mapper;

   --  ------------------------------
   --  Set the function mapper to be used when parsing an expression.
   --  ------------------------------
   overriding
   procedure Set_Function_Mapper (Context : in out Default_Context;
                                  Mapper  : access EL.Functions.Function_Mapper'Class) is
   begin
      if Mapper = null then
         Context.Function_Mapper := null;
      else
         Context.Function_Mapper := Mapper.all'Unchecked_Access;
      end if;
   end Set_Function_Mapper;

   --  ------------------------------
   --  Set the Variable_Mapper associated with this ELContext.
   --  ------------------------------
   overriding
   procedure Set_Variable_Mapper (Context : in out Default_Context;
                                  Mapper  : access EL.Variables.Variable_Mapper'Class) is
      use EL.Variables;
   begin
      if Context.Var_Mapper_Created then
         Free (Context.Var_Mapper);
      end if;
      if Mapper = null then
         Context.Var_Mapper := null;
      else
         Context.Var_Mapper := Mapper.all'Unchecked_Access;
      end if;
   end Set_Variable_Mapper;

   procedure Set_Variable (Context : in out Default_Context;
                           Name    : in String;
                           Value   : access Util.Beans.Basic.Readonly_Bean'Class) is
      use EL.Variables;
   begin
      if Context.Var_Mapper = null then
         Context.Var_Mapper := new EL.Variables.Default.Default_Variable_Mapper;
         Context.Var_Mapper_Created := True;
      end if;
      Context.Var_Mapper.Bind (Name, EL.Objects.To_Object (Value, EL.Objects.STATIC));
   end Set_Variable;

   --  Handle the exception during expression evaluation.
   overriding
   procedure Handle_Exception (Context : in Default_Context;
                               Ex      : in Ada.Exceptions.Exception_Occurrence) is
   begin
      null;
   end Handle_Exception;

   --  ------------------------------
   --  Guarded Context
   --  ------------------------------

   --  ------------------------------
   --  Retrieves the ELResolver associated with this ELcontext.
   --  ------------------------------
   overriding
   function Get_Resolver (Context : in Guarded_Context) return ELResolver_Access is
   begin
      return Context.Context.Get_Resolver;
   end Get_Resolver;

   --  ------------------------------
   --  Retrieves the Variable_Mapper associated with this ELContext.
   --  ------------------------------
   overriding
   function Get_Variable_Mapper (Context : in Guarded_Context)
                                 return access EL.Variables.Variable_Mapper'Class is
   begin
      return Context.Context.Get_Variable_Mapper;
   end Get_Variable_Mapper;

   --  ------------------------------
   --  Retrieves the Function_Mapper associated with this ELContext.
   --  The Function_Mapper is only used when parsing an expression.
   --  ------------------------------
   overriding
   function Get_Function_Mapper (Context : in Guarded_Context)
                                 return EL.Functions.Function_Mapper_Access is
   begin
      return Context.Context.Get_Function_Mapper;
   end Get_Function_Mapper;

   --  ------------------------------
   --  Set the function mapper to be used when parsing an expression.
   --  ------------------------------
   overriding
   procedure Set_Function_Mapper (Context : in out Guarded_Context;
                                  Mapper  : access EL.Functions.Function_Mapper'Class) is
   begin
      Context.Context.Set_Function_Mapper (Mapper);
   end Set_Function_Mapper;

   --  ------------------------------
   --  Set the Variable_Mapper associated with this ELContext.
   --  ------------------------------
   overriding
   procedure Set_Variable_Mapper (Context : in out Guarded_Context;
                                  Mapper  : access EL.Variables.Variable_Mapper'Class) is
   begin
      Context.Context.Set_Variable_Mapper (Mapper);
   end Set_Variable_Mapper;

   --  ------------------------------
   --  Handle the exception during expression evaluation.
   --  ------------------------------
   overriding
   procedure Handle_Exception (Context : in Guarded_Context;
                               Ex      : in Ada.Exceptions.Exception_Occurrence) is
   begin
      Context.Handler.all (Ex);
   end Handle_Exception;

   --  ------------------------------
   --  Get the value associated with a base object and a given property.
   --  ------------------------------
   overriding
   function Get_Value (Resolver : Default_ELResolver;
                       Context  : ELContext'Class;
                       Base     : access Util.Beans.Basic.Readonly_Bean'Class;
                       Name     : Unbounded_String) return Object is
      pragma Unreferenced (Context);
   begin
      if Base /= null then
         return Base.Get_Value (To_String (Name));
      end if;

      declare
         Pos : constant Objects.Maps.Cursor := Resolver.Map.Find (Name);
      begin
         if Objects.Maps.Has_Element (Pos) then
            return Objects.Maps.Element (Pos);
         end if;
      end;
      return Util.Beans.Objects.Null_Object;
   end Get_Value;

   --  ------------------------------
   --  Set the value associated with a base object and a given property.
   --  ------------------------------
   overriding
   procedure Set_Value (Resolver : in out Default_ELResolver;
                        Context  : in ELContext'Class;
                        Base     : access Util.Beans.Basic.Bean'Class;
                        Name     : in Unbounded_String;
                        Value    : in Object) is
   begin
      null;
   end Set_Value;

   --  ------------------------------
   --  Register the value under the given name.
   --  ------------------------------
   procedure Register (Resolver : in out Default_ELResolver;
                       Name     : in Unbounded_String;
                       Value    : access Util.Beans.Basic.Readonly_Bean'Class) is
   begin
      Resolver.Register (Name, To_Object (Value));
   end Register;

   --  ------------------------------
   --  Register the value under the given name.
   --  ------------------------------
   procedure Register (Resolver : in out Default_ELResolver;
                       Name     : in Unbounded_String;
                       Value    : in EL.Objects.Object) is
   begin
      Objects.Maps.Include (Resolver.Map, Name, Value);
   end Register;

   overriding
   procedure Finalize (Obj : in out Default_Context) is
   begin
      if Obj.Var_Mapper_Created then
         Free (Obj.Var_Mapper);
      end if;
   end Finalize;

end EL.Contexts.Default;

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

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => EL.Variables.Variable_Mapper'Class,
                                     Name   => EL.Variables.Variable_Mapper_Access);

   --  ------------------------------
   --  Retrieves the ELResolver associated with this ELcontext.
   --  ------------------------------
   overriding
   function Get_Resolver (Context : Default_Context) return ELResolver_Access is
   begin
      return Context.Resolver;
   end Get_Resolver;

   --  ------------------------------
   --  Set the ELResolver associated with this ELcontext.
   --  ------------------------------
   procedure Set_Resolver (Context  : in out Default_Context;
                           Resolver : in ELResolver_Access) is
   begin
      Context.Resolver := Resolver;
   end Set_Resolver;

   --  ------------------------------
   --  Retrieves the Variable_Mapper associated with this ELContext.
   --  ------------------------------
   overriding
   function Get_Variable_Mapper (Context : Default_Context)
                                 return access EL.Variables.Variable_Mapper'Class is
   begin
      return Context.Var_Mapper;
   end Get_Variable_Mapper;

   --  ------------------------------
   --  Retrieves the Function_Mapper associated with this ELContext.
   --  The Function_Mapper is only used when parsing an expression.
   --  ------------------------------
   overriding
   function Get_Function_Mapper (Context : Default_Context)
                                 return EL.Functions.Function_Mapper_Access is
   begin
      return Context.Function_Mapper;
   end Get_Function_Mapper;

   --  ------------------------------
   --  Set the function mapper to be used when parsing an expression.
   --  ------------------------------
   overriding
   procedure Set_Function_Mapper (Context : in out Default_Context;
                                  Mapper  : access EL.Functions.Function_Mapper'Class) is
   begin
      if Mapper = null then
         Context.Function_Mapper := null;
      else
         Context.Function_Mapper := Mapper.all'Unchecked_Access;
      end if;
   end Set_Function_Mapper;

   --  ------------------------------
   --  Set the Variable_Mapper associated with this ELContext.
   --  ------------------------------
   overriding
   procedure Set_Variable_Mapper (Context : in out Default_Context;
                                  Mapper  : access EL.Variables.Variable_Mapper'Class) is
      use EL.Variables;
   begin
      if Context.Var_Mapper_Created then
         Free (Context.Var_Mapper);
      end if;
      if Mapper = null then
         Context.Var_Mapper := null;
      else
         Context.Var_Mapper := Mapper.all'Unchecked_Access;
      end if;
   end Set_Variable_Mapper;

   procedure Set_Variable (Context : in out Default_Context;
                           Name    : in String;
                           Value   : access Util.Beans.Basic.Readonly_Bean'Class) is
      use EL.Variables;
   begin
      if Context.Var_Mapper = null then
         Context.Var_Mapper := new EL.Variables.Default.Default_Variable_Mapper;
         Context.Var_Mapper_Created := True;
      end if;
      Context.Var_Mapper.Bind (Name, EL.Objects.To_Object (Value, EL.Objects.STATIC));
   end Set_Variable;

   --  Handle the exception during expression evaluation.
   overriding
   procedure Handle_Exception (Context : in Default_Context;
                               Ex      : in Ada.Exceptions.Exception_Occurrence) is
   begin
      null;
   end Handle_Exception;

   --  ------------------------------
   --  Guarded Context
   --  ------------------------------

   --  ------------------------------
   --  Retrieves the ELResolver associated with this ELcontext.
   --  ------------------------------
   overriding
   function Get_Resolver (Context : in Guarded_Context) return ELResolver_Access is
   begin
      return Context.Context.Get_Resolver;
   end Get_Resolver;

   --  ------------------------------
   --  Retrieves the Variable_Mapper associated with this ELContext.
   --  ------------------------------
   overriding
   function Get_Variable_Mapper (Context : in Guarded_Context)
                                 return access EL.Variables.Variable_Mapper'Class is
   begin
      return Context.Context.Get_Variable_Mapper;
   end Get_Variable_Mapper;

   --  ------------------------------
   --  Retrieves the Function_Mapper associated with this ELContext.
   --  The Function_Mapper is only used when parsing an expression.
   --  ------------------------------
   overriding
   function Get_Function_Mapper (Context : in Guarded_Context)
                                 return EL.Functions.Function_Mapper_Access is
   begin
      return Context.Context.Get_Function_Mapper;
   end Get_Function_Mapper;

   --  ------------------------------
   --  Set the function mapper to be used when parsing an expression.
   --  ------------------------------
   overriding
   procedure Set_Function_Mapper (Context : in out Guarded_Context;
                                  Mapper  : access EL.Functions.Function_Mapper'Class) is
   begin
      Context.Context.Set_Function_Mapper (Mapper);
   end Set_Function_Mapper;

   --  ------------------------------
   --  Set the Variable_Mapper associated with this ELContext.
   --  ------------------------------
   overriding
   procedure Set_Variable_Mapper (Context : in out Guarded_Context;
                                  Mapper  : access EL.Variables.Variable_Mapper'Class) is
   begin
      Context.Context.Set_Variable_Mapper (Mapper);
   end Set_Variable_Mapper;

   --  ------------------------------
   --  Handle the exception during expression evaluation.
   --  ------------------------------
   overriding
   procedure Handle_Exception (Context : in Guarded_Context;
                               Ex      : in Ada.Exceptions.Exception_Occurrence) is
   begin
      Context.Handler.all (Ex);
   end Handle_Exception;

   --  ------------------------------
   --  Get the value associated with a base object and a given property.
   --  ------------------------------
   overriding
   function Get_Value (Resolver : Default_ELResolver;
                       Context  : ELContext'Class;
                       Base     : access Util.Beans.Basic.Readonly_Bean'Class;
                       Name     : Unbounded_String) return Object is
      pragma Unreferenced (Context);

      Key : constant String := To_String (Name);
   begin
      if Base /= null then
         return Base.Get_Value (Key);
      end if;

      declare
         Pos : constant Objects.Maps.Cursor := Resolver.Map.Find (Key);
      begin
         if Objects.Maps.Has_Element (Pos) then
            return Objects.Maps.Element (Pos);
         end if;
      end;
      return Util.Beans.Objects.Null_Object;
   end Get_Value;

   --  ------------------------------
   --  Set the value associated with a base object and a given property.
   --  ------------------------------
   overriding
   procedure Set_Value (Resolver : in out Default_ELResolver;
                        Context  : in ELContext'Class;
                        Base     : access Util.Beans.Basic.Bean'Class;
                        Name     : in Unbounded_String;
                        Value    : in Object) is
   begin
      null;
   end Set_Value;

   --  ------------------------------
   --  Register the value under the given name.
   --  ------------------------------
   procedure Register (Resolver : in out Default_ELResolver;
                       Name     : in Unbounded_String;
                       Value    : access Util.Beans.Basic.Readonly_Bean'Class) is
   begin
      Resolver.Register (Name, To_Object (Value));
   end Register;

   --  ------------------------------
   --  Register the value under the given name.
   --  ------------------------------
   procedure Register (Resolver : in out Default_ELResolver;
                       Name     : in Unbounded_String;
                       Value    : in EL.Objects.Object) is
      Key : constant String := To_String (Name);
   begin
      Objects.Maps.Include (Resolver.Map, Key, Value);
   end Register;

   overriding
   procedure Finalize (Obj : in out Default_Context) is
   begin
      if Obj.Var_Mapper_Created then
         Free (Obj.Var_Mapper);
      end if;
   end Finalize;

end EL.Contexts.Default;

Update implementation to use the Object.Maps with a String as a key


-----------------------------------------------------------------------
--  util-systems-dlls -- Windows shared library support
--  Copyright (C) 2013, 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 Interfaces.C.Strings;
with Util.Systems.Os;
package body Util.Systems.DLLs is

   function Sys_Load_Library (Path  : in Interfaces.C.Strings.chars_ptr) return Handle;
   pragma Import (Stdcall, Sys_Load_Library, "LoadLibraryA");

   function Sys_Free_Library (Lib : in Handle) return Interfaces.C.int;
   pragma Import (Stdcall, Sys_Free_Library, "FreeLibrary");

   function Sys_Get_Proc_Address (Lib    : in Handle;
                                  Symbol : in Interfaces.C.Strings.chars_ptr)
                                  return System.Address;
   pragma Import (Stdcall, Sys_Get_Proc_Address, "GetProcAddress");

   function Error_Message return String is
      Err : constant Integer := Util.Systems.Os.Get_Last_Error;
   begin
      return Integer'Image (Err);
   end Error_Message;

   --  -----------------------
   --  Load the shared library with the given name or path and return a library handle.
   --  Raises the <tt>Load_Error</tt> exception if the library cannot be loaded.
   --  -----------------------
   function Load (Path : in String;
                  Mode : in Flags := 0) return Handle is
      pragma Unreferenced (Mode);

      Lib    : Interfaces.C.Strings.chars_ptr := Interfaces.C.Strings.New_String (Path);
      Result : constant Handle := Sys_Load_Library (Lib);
   begin
      Interfaces.C.Strings.Free (Lib);
      if Result = Null_Handle then
         raise Load_Error with Error_Message;
      else
         return Result;
      end if;
   end Load;

   --  -----------------------
   --  Unload the shared library.
   --  -----------------------
   procedure Unload (Lib : in Handle) is
      Result : Interfaces.C.Int with Unreferenced;
   begin
      if Lib /= Null_Handle then
         Result := Sys_Free_Library (Lib);
      end if;
   end Unload;

   --  -----------------------
   --  Get a global symbol with the given name in the library.
   --  Raises the <tt>Not_Found</tt> exception if the symbol does not exist.
   --  -----------------------
   function Get_Symbol (Lib  : in Handle;
                        Name : in String) return System.Address is
      use type System.Address;

      Symbol : Interfaces.C.Strings.chars_ptr := Interfaces.C.Strings.New_String (Name);
      Result : constant System.Address := Sys_Get_Proc_Address (Lib, Symbol);
   begin
      Interfaces.C.Strings.Free (Symbol);
      if Result = System.Null_Address then
         raise Not_Found with Error_Message;
      else
         return Result;
      end if;
   end Get_Symbol;

end Util.Systems.DLLs;

-----------------------------------------------------------------------
--  util-systems-dlls -- Windows shared library support
--  Copyright (C) 2013, 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 Interfaces.C.Strings;
with Util.Systems.Os;
package body Util.Systems.DLLs is

   function Sys_Load_Library (Path  : in Interfaces.C.Strings.chars_ptr) return Handle
     with Import => True, Convention => Stdcall, Link_Name => "LoadLibraryA";

   function Sys_Free_Library (Lib : in Handle) return Interfaces.C.int
     with Import => True, Convention => Stdcall, Link_Name => "FreeLibrary";

   function Sys_Get_Proc_Address (Lib    : in Handle;
                                  Symbol : in Interfaces.C.Strings.chars_ptr)
                                  return System.Address
     with Import => True, Convention => Stdcall, Link_Name => "GetProcAddress";

   function Error_Message return String;

   function Error_Message return String is
      Err : constant Integer := Util.Systems.Os.Get_Last_Error;
   begin
      return Integer'Image (Err);
   end Error_Message;

   --  -----------------------
   --  Load the shared library with the given name or path and return a library handle.
   --  Raises the <tt>Load_Error</tt> exception if the library cannot be loaded.
   --  -----------------------
   function Load (Path : in String;
                  Mode : in Flags := 0) return Handle is
      pragma Unreferenced (Mode);

      Lib    : Interfaces.C.Strings.chars_ptr := Interfaces.C.Strings.New_String (Path);
      Result : constant Handle := Sys_Load_Library (Lib);
   begin
      Interfaces.C.Strings.Free (Lib);
      if Result = Null_Handle then
         raise Load_Error with Error_Message;
      else
         return Result;
      end if;
   end Load;

   --  -----------------------
   --  Unload the shared library.
   --  -----------------------
   procedure Unload (Lib : in Handle) is
      Result : Interfaces.C.int with Unreferenced;
   begin
      if Lib /= Null_Handle then
         Result := Sys_Free_Library (Lib);
      end if;
   end Unload;

   --  -----------------------
   --  Get a global symbol with the given name in the library.
   --  Raises the <tt>Not_Found</tt> exception if the symbol does not exist.
   --  -----------------------
   function Get_Symbol (Lib  : in Handle;
                        Name : in String) return System.Address is
      use type System.Address;

      Symbol : Interfaces.C.Strings.chars_ptr := Interfaces.C.Strings.New_String (Name);
      Result : constant System.Address := Sys_Get_Proc_Address (Lib, Symbol);
   begin
      Interfaces.C.Strings.Free (Symbol);
      if Result = System.Null_Address then
         raise Not_Found with Error_Message;
      else
         return Result;
      end if;
   end Get_Symbol;

end Util.Systems.DLLs;

Fix compilation warnings

Fix compilation warnings


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

with Util.Strings;

with ASF.Parts.Web;
package body ASF.Requests.Web is

   function Get_Parameter (R : Request; Name : String) return String is
   begin
      return AWS.Status.Parameter (R.Data.all, Name);
   end Get_Parameter;

   --  ------------------------------
   --  Iterate over the request parameters and executes the Process procedure.
   --  ------------------------------
   procedure Iterate_Parameters (Req     : in Request;
                                 Process : not null access
                                   procedure (Name  : in String;
                                              Value : in String)) is
      procedure Process_Wrapper (Name, Value : in String);

      procedure Process_Wrapper (Name, Value : in String) is
         Last : Natural := Value'First;
         Pos  : Natural;
      begin
         while Last <= Value'Last loop
            Pos := Util.Strings.Index (Value, ASCII.NUL, Last);
            if Pos > 0 then
               Process (Name, Value (Last .. Pos - 1));
               Last := Pos + 1;
            else
               Process (Name, Value (Last .. Value'Last));
               return;
            end if;
         end loop;
      end Process_Wrapper;

      P : constant AWS.Parameters.List := AWS.Status.Parameters (Req.Data.all);
   begin
      AWS.Containers.Tables.Iterate_Names (AWS.Containers.Tables.Table_Type (P),
                                           "" & ASCII.NUL, Process_Wrapper'Access);
   end Iterate_Parameters;

   --  ------------------------------
   --  Set the AWS data received to initialize the request object.
   --  ------------------------------
   procedure Set_Request (Req  : in out Request;
                          Data : access AWS.Status.Data) is
   begin
      Req.Data    := Data;
      Req.Headers := AWS.Status.Header (Data.all);
   end Set_Request;

   --  ------------------------------
   --  Returns the name of the HTTP method with which this request was made,
   --  for example, GET, POST, or PUT. Same as the value of the CGI variable
   --  REQUEST_METHOD.
   --  ------------------------------
   function Get_Method (Req : in Request) return String is
   begin
      return AWS.Status.Method (Req.Data.all);
   end Get_Method;

   --  ------------------------------
   --  Returns the name and version of the protocol the request uses in the form
   --  protocol/majorVersion.minorVersion, for example, HTTP/1.1. For HTTP servlets,
   --  the value returned is the same as the value of the CGI variable SERVER_PROTOCOL.
   --  ------------------------------
   function Get_Protocol (Req : in Request) return String is
   begin
      return AWS.Status.HTTP_Version (Req.Data.all);
   end Get_Protocol;

   --  ------------------------------
   --  Returns the part of this request's URL from the protocol name up to the query
   --  string in the first line of the HTTP request. The web container does not decode
   --  this String. For example:
   --  First line of HTTP request    Returned Value
   --  POST /some/path.html HTTP/1.1        /some/path.html
   --  GET http://foo.bar/a.html HTTP/1.0       /a.html
   --  HEAD /xyz?a=b HTTP/1.1       /xyz
   --  ------------------------------
   function Get_Request_URI (Req : in Request) return String is
   begin
      return AWS.Status.URI (Req.Data.all);
   end Get_Request_URI;

   --  ------------------------------
   --  Returns the value of the specified request header as a String. If the request
   --  did not include a header of the specified name, this method returns null.
   --  If there are multiple headers with the same name, this method returns the
   --  first head in the request. The header name is case insensitive. You can use
   --  this method with any request header.
   --  ------------------------------
   function Get_Header (Req  : in Request;
                        Name : in String) return String is
      Values : constant AWS.Headers.VString_Array := AWS.Headers.Get_Values (Req.Headers, Name);
   begin
      if Values'Length > 0 then
         return To_String (Values (Values'First));
      else
         return "";
      end if;
   end Get_Header;

   --  ------------------------------
   --  Iterate over the request headers and executes the Process procedure.
   --  ------------------------------
   procedure Iterate_Headers (Req     : in Request;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String)) is
   begin
      Req.Headers.Iterate_Names (Coupler => ", ",
                                 Process => Process);
   end Iterate_Headers;

   --  ------------------------------
   --  Returns all the values of the specified request header as an Enumeration
   --  of String objects.
   --
   --  Some headers, such as Accept-Language can be sent by clients as several headers
   --  each with a different value rather than sending the header as a comma
   --  separated list.
   --
   --  If the request did not include any headers of the specified name, this method
   --  returns an empty Enumeration. The header name is case insensitive. You can use
   --  this method with any request header.
   --  ------------------------------
   function Get_Headers (Req  : in Request;
                         Name : in String) return String is
   begin
      return AWS.Headers.Get_Values (Req.Headers, Name);
   end Get_Headers;

   --  ------------------------------
   --  Returns the Internet Protocol (IP) address of the client or last proxy that
   --  sent the request. For HTTP servlets, same as the value of the CGI variable
   --  REMOTE_ADDR.
   --  ------------------------------
   function Get_Remote_Addr (Req : in Request) return String is
   begin
      return AWS.Status.Peername (Req.Data.all);
   end Get_Remote_Addr;

   --  ------------------------------
   --  Get the number of parts included in the request.
   --  ------------------------------
   function Get_Part_Count (Req : in Request) return Natural is
   begin
      return AWS.Attachments.Count (AWS.Status.Attachments (Req.Data.all));
   end Get_Part_Count;

   --  ------------------------------
   --  Process the part at the given position and executes the Process operation
   --  with the part object.
   --  ------------------------------
   procedure Process_Part (Req      : in out Request;
                           Position : in Positive;
                           Process  : not null access
                             procedure (Data : in ASF.Parts.Part'Class)) is
      Attachs : constant AWS.Attachments.List := AWS.Status.Attachments (Req.Data.all);
   begin
      ASF.Parts.Web.Process_Part (AWS.Attachments.Get (Attachs, Position), Process);
   end Process_Part;

   --  ------------------------------
   --  Process the part identifed by Id and executes the Process operation
   --  with the part object.
   --  ------------------------------
   procedure Process_Part (Req      : in out Request;
                           Id       : in String;
                           Process  : not null access
                             procedure (Data : in ASF.Parts.Part'Class)) is
      procedure Process_Part (E : in AWS.Attachments.Element);

      procedure Process_Part (E : in AWS.Attachments.Element) is
         Name : constant String := AWS.Attachments.Extend.Get_Name (E);
      begin
         if Id = Name then
            ASF.Parts.Web.Process_Part (E, Process);
         end if;
      end Process_Part;

      Attachs : constant AWS.Attachments.List := AWS.Status.Attachments (Req.Data.all);
   begin
      AWS.Attachments.Iterate (Attachs, Process_Part'Access);
--        ASF.Parts.Web.Process_Part (AWS.Attachments.Get (Attachs, Id), Process);
   end Process_Part;

end ASF.Requests.Web;

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

with Util.Strings;

with ASF.Parts.Web;
package body ASF.Requests.Web is

   function Get_Parameter (R : Request; Name : String) return String is
   begin
      return AWS.Status.Parameter (R.Data.all, Name);
   end Get_Parameter;

   --  ------------------------------
   --  Iterate over the request parameters and executes the Process procedure.
   --  ------------------------------
   procedure Iterate_Parameters (Req     : in Request;
                                 Process : not null access
                                   procedure (Name  : in String;
                                              Value : in String)) is
      procedure Process_Wrapper (Name, Value : in String);

      procedure Process_Wrapper (Name, Value : in String) is
         Last : Natural := Value'First;
         Pos  : Natural;
      begin
         while Last <= Value'Last loop
            Pos := Util.Strings.Index (Value, ASCII.NUL, Last);
            if Pos > 0 then
               Process (Name, Value (Last .. Pos - 1));
               Last := Pos + 1;
            else
               Process (Name, Value (Last .. Value'Last));
               return;
            end if;
         end loop;
      end Process_Wrapper;

      P : constant AWS.Parameters.List := AWS.Status.Parameters (Req.Data.all);
   begin
      AWS.Containers.Tables.Iterate_Names (AWS.Containers.Tables.Table_Type (P),
                                           "" & ASCII.NUL, Process_Wrapper'Access);
   end Iterate_Parameters;

   --  ------------------------------
   --  Set the AWS data received to initialize the request object.
   --  ------------------------------
   procedure Set_Request (Req  : in out Request;
                          Data : access AWS.Status.Data) is
   begin
      Req.Data    := Data;
      Req.Headers := AWS.Status.Header (Data.all);
   end Set_Request;

   --  ------------------------------
   --  Returns the name of the HTTP method with which this request was made,
   --  for example, GET, POST, or PUT. Same as the value of the CGI variable
   --  REQUEST_METHOD.
   --  ------------------------------
   function Get_Method (Req : in Request) return String is
   begin
      return AWS.Status.Method (Req.Data.all);
   end Get_Method;

   --  ------------------------------
   --  Returns the name and version of the protocol the request uses in the form
   --  protocol/majorVersion.minorVersion, for example, HTTP/1.1. For HTTP servlets,
   --  the value returned is the same as the value of the CGI variable SERVER_PROTOCOL.
   --  ------------------------------
   function Get_Protocol (Req : in Request) return String is
   begin
      return AWS.Status.HTTP_Version (Req.Data.all);
   end Get_Protocol;

   --  ------------------------------
   --  Returns the part of this request's URL from the protocol name up to the query
   --  string in the first line of the HTTP request. The web container does not decode
   --  this String. For example:
   --  First line of HTTP request    Returned Value
   --  POST /some/path.html HTTP/1.1        /some/path.html
   --  GET http://foo.bar/a.html HTTP/1.0       /a.html
   --  HEAD /xyz?a=b HTTP/1.1       /xyz
   --  ------------------------------
   function Get_Request_URI (Req : in Request) return String is
   begin
      return AWS.Status.URI (Req.Data.all);
   end Get_Request_URI;

   --  ------------------------------
   --  Returns the value of the specified request header as a String. If the request
   --  did not include a header of the specified name, this method returns null.
   --  If there are multiple headers with the same name, this method returns the
   --  first head in the request. The header name is case insensitive. You can use
   --  this method with any request header.
   --  ------------------------------
   function Get_Header (Req  : in Request;
                        Name : in String) return String is
      Values : constant AWS.Headers.VString_Array := AWS.Headers.Get_Values (Req.Headers, Name);
   begin
      if Values'Length > 0 then
         return To_String (Values (Values'First));
      else
         return "";
      end if;
   end Get_Header;

   --  ------------------------------
   --  Iterate over the request headers and executes the Process procedure.
   --  ------------------------------
   procedure Iterate_Headers (Req     : in Request;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String)) is
   begin
      Req.Headers.Iterate_Names (", ",
                                 Process => Process);
   end Iterate_Headers;

   --  ------------------------------
   --  Returns all the values of the specified request header as an Enumeration
   --  of String objects.
   --
   --  Some headers, such as Accept-Language can be sent by clients as several headers
   --  each with a different value rather than sending the header as a comma
   --  separated list.
   --
   --  If the request did not include any headers of the specified name, this method
   --  returns an empty Enumeration. The header name is case insensitive. You can use
   --  this method with any request header.
   --  ------------------------------
   function Get_Headers (Req  : in Request;
                         Name : in String) return String is
   begin
      return AWS.Headers.Get_Values (Req.Headers, Name);
   end Get_Headers;

   --  ------------------------------
   --  Returns the Internet Protocol (IP) address of the client or last proxy that
   --  sent the request. For HTTP servlets, same as the value of the CGI variable
   --  REMOTE_ADDR.
   --  ------------------------------
   function Get_Remote_Addr (Req : in Request) return String is
   begin
      return AWS.Status.Peername (Req.Data.all);
   end Get_Remote_Addr;

   --  ------------------------------
   --  Get the number of parts included in the request.
   --  ------------------------------
   function Get_Part_Count (Req : in Request) return Natural is
   begin
      return AWS.Attachments.Count (AWS.Status.Attachments (Req.Data.all));
   end Get_Part_Count;

   --  ------------------------------
   --  Process the part at the given position and executes the Process operation
   --  with the part object.
   --  ------------------------------
   procedure Process_Part (Req      : in out Request;
                           Position : in Positive;
                           Process  : not null access
                             procedure (Data : in ASF.Parts.Part'Class)) is
      Attachs : constant AWS.Attachments.List := AWS.Status.Attachments (Req.Data.all);
   begin
      ASF.Parts.Web.Process_Part (AWS.Attachments.Get (Attachs, Position), Process);
   end Process_Part;

   --  ------------------------------
   --  Process the part identifed by Id and executes the Process operation
   --  with the part object.
   --  ------------------------------
   procedure Process_Part (Req      : in out Request;
                           Id       : in String;
                           Process  : not null access
                             procedure (Data : in ASF.Parts.Part'Class)) is
      procedure Process_Part (E : in AWS.Attachments.Element);

      procedure Process_Part (E : in AWS.Attachments.Element) is
         Name : constant String := AWS.Attachments.Extend.Get_Name (E);
      begin
         if Id = Name then
            ASF.Parts.Web.Process_Part (E, Process);
         end if;
      end Process_Part;

      Attachs : constant AWS.Attachments.List := AWS.Status.Attachments (Req.Data.all);
   begin
      AWS.Attachments.Iterate (Attachs, Process_Part'Access);
--        ASF.Parts.Web.Process_Part (AWS.Attachments.Get (Attachs, Id), Process);
   end Process_Part;

end ASF.Requests.Web;

Fix build with AWS 3.3 that changed the name of a parameter in Iterate_Names procedure


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

   pragma Preelaborate;

   subtype Uint8 is Interfaces.Unsigned_8;

   subtype Uint16 is Interfaces.Unsigned_16;

   subtype Uint32 is Interfaces.Unsigned_32;

   subtype Uint64 is Interfaces.Unsigned_64;

   subtype Target_Addr is Interfaces.Unsigned_64;

   subtype Target_Size is Interfaces.Unsigned_64;

   subtype Target_Offset is Interfaces.Unsigned_64;

   type Target_Tick_Ref is new Uint64;

   type Target_Thread_Ref is new Uint32;

   subtype Target_Process_Ref is Uint32;

   subtype Target_Time is Target_Tick_Ref;

   --  Return an hexadecimal string representation of the value.
   function Hex_Image (Value : in Uint32;
                       Length : in Positive := 8) return String;

   --  Return an hexadecimal string representation of the value.
   function Hex_Image (Value  : in Uint64;
                       Length : in Positive := 16) return String;

   --  Format the target time to a printable representation.
   function Tick_Image (Value : in Target_Tick_Ref) return String;

   --  Convert the hexadecimal string into an unsigned integer.
   function Hex_Value (Value : in String) return Uint64;

end MAT.Types;

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

   pragma Preelaborate;

   subtype Uint8 is Interfaces.Unsigned_8;

   subtype Uint16 is Interfaces.Unsigned_16;

   subtype Uint32 is Interfaces.Unsigned_32;

   subtype Uint64 is Interfaces.Unsigned_64;

   subtype Target_Addr is Interfaces.Unsigned_64;

   subtype Target_Size is Interfaces.Unsigned_64;

   subtype Target_Offset is Interfaces.Unsigned_64;

   type Target_Tick_Ref is new Uint64;

   type Target_Thread_Ref is new Uint32;

   subtype Target_Process_Ref is Uint32;

   subtype Target_Time is Target_Tick_Ref;

   --  Return an hexadecimal string representation of the value.
   function Hex_Image (Value : in Uint32;
                       Length : in Positive := 8) return String;

   --  Return an hexadecimal string representation of the value.
   function Hex_Image (Value  : in Uint64;
                       Length : in Positive := 16) return String;

   --  Format the target time to a printable representation.
   function Tick_Image (Value : in Target_Tick_Ref) return String;

   --  Convert the string in the form NN.MM into a tick value.
   function Tick_Value (Value : in String) return Target_Tick_Ref;

   --  Convert the hexadecimal string into an unsigned integer.
   function Hex_Value (Value : in String) return Uint64;

end MAT.Types;

Declare the Tick_Value function

Declare the Tick_Value function