-----------------------------------------------------------------------
--  security-oauth-jwt -- OAuth Java Web Token
--  Copyright (C) 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.Calendar.Conversions;
with Interfaces.C;

with Util.Encoders;
with Util.Strings;
with Util.Serialize.IO;
with Util.Properties.JSON;
with Util.Log.Loggers;
package body Security.OAuth.JWT is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Security.OAuth.JWT");

   function Get_Time (From : in Util.Properties.Manager;
                      Name : in String) return Ada.Calendar.Time;

   --  Decode the part using base64url and parse the JSON content into the property manager.
   procedure Decode_Part (Into : in out Util.Properties.Manager;
                          Name : in String;
                          Data : in String);

   function Get_Time (From : in Util.Properties.Manager;
                      Name : in String) return Ada.Calendar.Time is
      Value : constant String := From.Get (Name);
   begin
      return Ada.Calendar.Conversions.To_Ada_Time (Interfaces.C.long'Value (Value));
   end Get_Time;

   --  ------------------------------
   --  Get the issuer claim from the token (the "iss" claim).
   --  ------------------------------
   function Get_Issuer (From : in Token) return String is
   begin
      return From.Claims.Get ("iss");
   end Get_Issuer;

   --  ------------------------------
   --  Get the subject claim from the token (the "sub" claim).
   --  ------------------------------
   function Get_Subject (From : in Token) return String is
   begin
      return From.Claims.Get ("sub");
   end Get_Subject;

   --  ------------------------------
   --  Get the audience claim from the token (the "aud" claim).
   --  ------------------------------
   function Get_Audience (From : in Token) return String is
   begin
      return From.Claims.Get ("aud");
   end Get_Audience;

   --  ------------------------------
   --  Get the expiration claim from the token (the "exp" claim).
   --  ------------------------------
   function Get_Expiration (From : in Token) return Ada.Calendar.Time is
   begin
      return Get_Time (From.Claims, "exp");
   end Get_Expiration;

   --  ------------------------------
   --  Get the not before claim from the token (the "nbf" claim).
   --  ------------------------------
   function Get_Not_Before (From : in Token) return Ada.Calendar.Time is
   begin
      return Get_Time (From.Claims, "nbf");
   end Get_Not_Before;

   --  ------------------------------
   --  Get the issued at claim from the token (the "iat" claim).
   --  ------------------------------
   function Get_Issued_At (From : in Token) return Ada.Calendar.Time is
   begin
      return Get_Time (From.Claims, "iat");
   end Get_Issued_At;

   --  ------------------------------
   --  Get the authentication time claim from the token (the "auth_time" claim).
   --  ------------------------------
   function Get_Authentication_Time (From : in Token) return Ada.Calendar.Time is
   begin
      return Get_Time (From.Claims, "auth_time");
   end Get_Authentication_Time;

   --  ------------------------------
   --  Get the JWT ID claim from the token (the "jti" claim).
   --  ------------------------------
   function Get_JWT_ID (From : in Token) return String is
   begin
      return From.Claims.Get ("jti");
   end Get_JWT_ID;

   --  ------------------------------
   --  Get the authorized clients claim from the token (the "azp" claim).
   --  ------------------------------
   function Get_Authorized_Presenters (From : in Token) return String is
   begin
      return From.Claims.Get ("azp");
   end Get_Authorized_Presenters;

   --  ------------------------------
   --  Get the claim with the given name from the token.
   --  ------------------------------
   function Get_Claim (From : in Token;
                       Name : in String) return String is
   begin
      return From.Claims.Get (Name);
   end Get_Claim;

   --  ------------------------------
   --  Decode the part using base64url and parse the JSON content into the property manager.
   --  ------------------------------
   procedure Decode_Part (Into : in out Util.Properties.Manager;
                          Name : in String;
                          Data : in String) is
      Decoder : constant Util.Encoders.Encoder := Util.Encoders.Create (Util.Encoders.BASE_64_URL);
      Content : constant String := Decoder.Decode (Data);
   begin
      Log.Debug ("Decoding {0}: {1}", Name, Content);

      Util.Properties.JSON.Parse_JSON (Into, Content);
   end Decode_Part;

   --  ------------------------------
   --  Decode a string representing an encoded JWT token according to the JWT specification:
   --
   --    Section 7.  Rules for Creating and Validating a JWT
   --
   --  The JWT token is composed of 3 parts encoded in Base64url and separated by '.' .
   --  The first part represents the header, the second part the claims and the last part
   --  the signature.  The <tt>Decode</tt> operation splits the parts, decodes them,
   --  parses the JSON content represented by the header and the claims.
   --  The <tt>Decode</tt> operation does not verify the signature (yet!).
   --
   --  Return the decoded token or raise an exception.
   --  ------------------------------
   function Decode (Content : in String) return Token is
      Pos1   : constant Natural := Util.Strings.Index (Content, '.');
      Pos2   : Natural;
      Result : Token;
   begin
      if Pos1 = 0 then
         Log.Error ("Invalid JWT token: missing '.' separator. JWT: {0}", Content);
         raise Invalid_Token with "Missing header separator";
      end if;
      Pos2 := Util.Strings.Index (Content, '.', Pos1 + 1);
      if Pos2 = 0 then
         Log.Error ("Invalid JWT token: missing second '.' separator. JWT: {0}", Content);
         raise Invalid_Token with "Missing signature separator";
      end if;
      Decode_Part (Result.Header, "header", Content (Content'First .. Pos1 - 1));
      Decode_Part (Result.Claims, "claims", Content (Pos1 + 1 .. Pos2 - 1));
      return Result;

   exception
      when Util.Serialize.IO.Parse_Error =>
         raise Invalid_Token with "Invalid JSON content";
   end Decode;

end Security.OAuth.JWT;

-----------------------------------------------------------------------
--  security-oauth-jwt -- OAuth Java Web Token
--  Copyright (C) 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.Calendar.Conversions;
with Interfaces.C;

with Util.Encoders;
with Util.Strings;
with Util.Serialize.IO;
with Util.Properties.JSON;
with Util.Log.Loggers;
package body Security.OAuth.JWT is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Security.OAuth.JWT");

   function Get_Time (From : in Util.Properties.Manager;
                      Name : in String) return Ada.Calendar.Time;

   --  Decode the part using base64url and parse the JSON content into the property manager.
   procedure Decode_Part (Into : in out Util.Properties.Manager;
                          Name : in String;
                          Data : in String);

   function Get_Time (From : in Util.Properties.Manager;
                      Name : in String) return Ada.Calendar.Time is
      Value : constant String := From.Get (Name);
   begin
      return Ada.Calendar.Conversions.To_Ada_Time (Interfaces.C.long'Value (Value));
   end Get_Time;

   --  ------------------------------
   --  Get the issuer claim from the token (the "iss" claim).
   --  ------------------------------
   function Get_Issuer (From : in Token) return String is
   begin
      return From.Claims.Get ("iss");
   end Get_Issuer;

   --  ------------------------------
   --  Get the subject claim from the token (the "sub" claim).
   --  ------------------------------
   function Get_Subject (From : in Token) return String is
   begin
      return From.Claims.Get ("sub");
   end Get_Subject;

   --  ------------------------------
   --  Get the audience claim from the token (the "aud" claim).
   --  ------------------------------
   function Get_Audience (From : in Token) return String is
   begin
      return From.Claims.Get ("aud");
   end Get_Audience;

   --  ------------------------------
   --  Get the expiration claim from the token (the "exp" claim).
   --  ------------------------------
   function Get_Expiration (From : in Token) return Ada.Calendar.Time is
   begin
      return Get_Time (From.Claims, "exp");
   end Get_Expiration;

   --  ------------------------------
   --  Get the not before claim from the token (the "nbf" claim).
   --  ------------------------------
   function Get_Not_Before (From : in Token) return Ada.Calendar.Time is
   begin
      return Get_Time (From.Claims, "nbf");
   end Get_Not_Before;

   --  ------------------------------
   --  Get the issued at claim from the token (the "iat" claim).
   --  ------------------------------
   function Get_Issued_At (From : in Token) return Ada.Calendar.Time is
   begin
      return Get_Time (From.Claims, "iat");
   end Get_Issued_At;

   --  ------------------------------
   --  Get the authentication time claim from the token (the "auth_time" claim).
   --  ------------------------------
   function Get_Authentication_Time (From : in Token) return Ada.Calendar.Time is
   begin
      return Get_Time (From.Claims, "auth_time");
   end Get_Authentication_Time;

   --  ------------------------------
   --  Get the JWT ID claim from the token (the "jti" claim).
   --  ------------------------------
   function Get_JWT_ID (From : in Token) return String is
   begin
      return From.Claims.Get ("jti");
   end Get_JWT_ID;

   --  ------------------------------
   --  Get the authorized clients claim from the token (the "azp" claim).
   --  ------------------------------
   function Get_Authorized_Presenters (From : in Token) return String is
   begin
      return From.Claims.Get ("azp");
   end Get_Authorized_Presenters;

   --  ------------------------------
   --  Get the claim with the given name from the token.
   --  ------------------------------
   function Get_Claim (From    : in Token;
                       Name    : in String;
                       Default : in String := "") return String is
   begin
      return From.Claims.Get (Name, Default);
   end Get_Claim;

   --  ------------------------------
   --  Decode the part using base64url and parse the JSON content into the property manager.
   --  ------------------------------
   procedure Decode_Part (Into : in out Util.Properties.Manager;
                          Name : in String;
                          Data : in String) is
      Decoder : constant Util.Encoders.Encoder := Util.Encoders.Create (Util.Encoders.BASE_64_URL);
      Content : constant String := Decoder.Decode (Data);
   begin
      Log.Debug ("Decoding {0}: {1}", Name, Content);

      Util.Properties.JSON.Parse_JSON (Into, Content);
   end Decode_Part;

   --  ------------------------------
   --  Decode a string representing an encoded JWT token according to the JWT specification:
   --
   --    Section 7.  Rules for Creating and Validating a JWT
   --
   --  The JWT token is composed of 3 parts encoded in Base64url and separated by '.' .
   --  The first part represents the header, the second part the claims and the last part
   --  the signature.  The <tt>Decode</tt> operation splits the parts, decodes them,
   --  parses the JSON content represented by the header and the claims.
   --  The <tt>Decode</tt> operation does not verify the signature (yet!).
   --
   --  Return the decoded token or raise an exception.
   --  ------------------------------
   function Decode (Content : in String) return Token is
      Pos1   : constant Natural := Util.Strings.Index (Content, '.');
      Pos2   : Natural;
      Result : Token;
   begin
      if Pos1 = 0 then
         Log.Error ("Invalid JWT token: missing '.' separator. JWT: {0}", Content);
         raise Invalid_Token with "Missing header separator";
      end if;
      Pos2 := Util.Strings.Index (Content, '.', Pos1 + 1);
      if Pos2 = 0 then
         Log.Error ("Invalid JWT token: missing second '.' separator. JWT: {0}", Content);
         raise Invalid_Token with "Missing signature separator";
      end if;
      Decode_Part (Result.Header, "header", Content (Content'First .. Pos1 - 1));
      Decode_Part (Result.Claims, "claims", Content (Pos1 + 1 .. Pos2 - 1));
      return Result;

   exception
      when Util.Serialize.IO.Parse_Error =>
         raise Invalid_Token with "Invalid JSON content";
   end Decode;

end Security.OAuth.JWT;

Update Get_Claim to have a default value


-----------------------------------------------------------------------
--  properties -- Generic name/value property management
--  Copyright (C) 2001, 2002, 2003, 2006, 2008, 2009, 2010, 2011, 2012, 2014, 2017 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.Properties.Factories;
with Ada.IO_Exceptions;
with Ada.Strings.Unbounded.Text_IO;
with Interfaces.C.Strings;
package body Util.Properties is

   use Ada.Text_IO;
   use Ada.Strings.Unbounded.Text_IO;
   use Interface_P;

   procedure Load_Property (Name   : out Unbounded_String;
                            Value  : out Unbounded_String;
                            File   : in File_Type;
                            Prefix : in String := "";
                            Strip  : in Boolean := False);
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : in Manager;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      return Util.Beans.Objects.Null_Object;
   end Get_Value;

   --  Set the value identified by the name.
   --  If the map contains the given name, the value changed.
   --  Otherwise name is added to the map and the value associated with it.
   overriding
   procedure Set_Value (From  : in out Manager;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      null;
   end Set_Value;

   function Exists (Self : in Manager'Class;
                    Name : in String) return Boolean is
   begin
      --  There is not yet an implementation, no property
      if Self.Impl = null then
         return False;
      end if;

      return Exists (Self.Impl.all, +Name);
   end Exists;

   function Exists (Self : in Manager'Class;
                    Name : in Value) return Boolean is
   begin
      --  There is not yet an implementation, no property
      if Self.Impl = null then
         return False;
      end if;

      return Exists (Self.Impl.all, Name);
   end Exists;

   function Get (Self : in Manager'Class;
                 Name : in String) return Value is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY with "No property: '" & Name & "'";
      end if;

      return Get (Self.Impl.all, +Name);
   end Get;

   function Get (Self : in Manager'Class;
                 Name : in Value) return Value is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY with "No property: '" & To_String (Name) & "'";
      end if;

      return Get (Self.Impl.all, Name);
   end Get;

   function Get (Self : in Manager'Class;
                 Name : in String) return String is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY with "No property: '" & Name & "'";
      end if;

      return -Get (Self.Impl.all, +Name);
   end Get;

   function Get (Self : in Manager'Class;
                 Name : in Value) return String is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY;
      end if;

      return -Get (Self.Impl.all, Name);
   end Get;

   function Get (Self : in Manager'Class;
                 Name : in String;
                 Default : in String) return String is
      Prop_Name : constant Value := +Name;
   begin
      if Exists (Self, Prop_Name) then
         return Get (Self, Prop_Name);
      else
         return Default;
      end if;
   end Get;

   procedure Check_And_Create_Impl (Self : in out Manager) is
   begin
      if Self.Impl = null then
         Util.Properties.Factories.Initialize (Self);
      elsif Util.Concurrent.Counters.Value (Self.Impl.Count) > 1 then
         declare
            Old     : Interface_P.Manager_Access := Self.Impl;
            Is_Zero : Boolean;
         begin
            Self.Impl := Create_Copy (Self.Impl.all);
            Util.Concurrent.Counters.Increment (Self.Impl.Count);
            Util.Concurrent.Counters.Decrement (Old.Count, Is_Zero);
            if Is_Zero then
               Delete (Old.all, Old);
            end if;
         end;
      end if;
   end Check_And_Create_Impl;

   procedure Insert (Self : in out Manager'Class;
                     Name : in String;
                     Item : in String) is
   begin
      Check_And_Create_Impl (Self);
      Insert (Self.Impl.all, +Name, +Item);
   end Insert;

   --  ------------------------------
   --  Set the value of the property.  The property is created if it
   --  does not exists.
   --  ------------------------------
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in String) is
   begin
      Check_And_Create_Impl (Self);
      Set (Self.Impl.all, +Name, +Item);
   end Set;

   --  ------------------------------
   --  Set the value of the property.  The property is created if it
   --  does not exists.
   --  ------------------------------
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in Value) is
   begin
      Check_And_Create_Impl (Self);
      Set (Self.Impl.all, +Name, Item);
   end Set;

   --  ------------------------------
   --  Set the value of the property.  The property is created if it
   --  does not exists.
   --  ------------------------------
   procedure Set (Self : in out Manager'Class;
                  Name : in Unbounded_String;
                  Item : in Value) is
   begin
      Check_And_Create_Impl (Self);
      Set (Self.Impl.all, Name, Item);
   end Set;

   --  ------------------------------
   --  Remove the property given its name.
   --  ------------------------------
   procedure Remove (Self : in out Manager'Class;
                     Name : in String) is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY;
      end if;
      Check_And_Create_Impl (Self);
      Remove (Self.Impl.all, +Name);
   end Remove;

   --  ------------------------------
   --  Remove the property given its name.
   --  ------------------------------
   procedure Remove (Self : in out Manager'Class;
                     Name : in Value) is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY;
      end if;
      Check_And_Create_Impl (Self);
      Remove (Self.Impl.all, Name);
   end Remove;

   --  ------------------------------
   --  Iterate over the properties and execute the given procedure passing the
   --  property name and its value.
   --  ------------------------------
   procedure Iterate (Self    : in Manager'Class;
                      Process : access procedure (Name, Item : Value)) is
   begin
      if Self.Impl /= null then
         Self.Impl.Iterate (Process);
      end if;
   end Iterate;

   --  ------------------------------
   --  Return the name of the properties defined in the manager.
   --  When a prefix is specified, only the properties starting with
   --  the prefix are returned.
   --  ------------------------------
   function Get_Names (Self  : in Manager;
                       Prefix : in String := "") return Name_Array is
   begin
      if Self.Impl = null then
         declare
            Empty : Name_Array (1 .. 0);
         begin
            return Empty;
         end;
      else
         return Get_Names (Self.Impl.all, Prefix);
      end if;
   end Get_Names;

   procedure Adjust (Object : in out Manager) is
   begin
      if Object.Impl /= null then
         Util.Concurrent.Counters.Increment (Object.Impl.Count);
      end if;
   end Adjust;

   procedure Finalize (Object : in out Manager) is
      Is_Zero : Boolean;
   begin
      if Object.Impl /= null then
         Util.Concurrent.Counters.Decrement (Object.Impl.Count, Is_Zero);
         if Is_Zero then
            Delete (Object.Impl.all, Object.Impl);
         end if;
      end if;
   end Finalize;

   procedure Set_Property_Implementation (Self : in out Manager;
                                          Impl : in Interface_P.Manager_Access) is
   begin
      if Self.Impl = null then
         Self.Impl := Impl;
--           Self.Impl.Count := 1;
      end if;
   end Set_Property_Implementation;

   procedure Load_Property (Name   : out Unbounded_String;
                            Value  : out Unbounded_String;
                            File   : in File_Type;
                            Prefix : in String := "";
                            Strip  : in Boolean := False) is
      pragma Unreferenced (Strip);

      Line : Unbounded_String;
      Pos  : Natural;
      Len  : Natural;
   begin
      while not End_Of_File (File) loop
         Line := Get_Line (File);
         Len  := Length (Line);
         if Len /= 0 and then Element (Line, 1) /= '#' then
            Pos := Index (Line, "=");
            if Pos > 0 and then Prefix'Length > 0 and then Index (Line, Prefix) = 1 then
               Name  := Unbounded_Slice (Line, Prefix'Length + 1, Pos - 1);
               Value := Tail (Line, Len - Pos);
               return;

            elsif Pos > 0 and Prefix'Length = 0 then
               Name  := Head (Line, Pos - 1);
               Value := Tail (Line, Len - Pos);
               return;

            end if;
         end if;
      end loop;
      Name := Null_Unbounded_String;
      Value := Null_Unbounded_String;
   end Load_Property;

   procedure Load_Properties (Self   : in out Manager'Class;
                              File   : in File_Type;
                              Prefix : in String := "";
                              Strip  : in Boolean := False) is
      Name, Value : Unbounded_String;
   begin
      loop
         Load_Property (Name, Value, File, Prefix, Strip);
         exit when Name = Null_Unbounded_String;
         Set (Self, Name, Value);
      end loop;

   exception
      when End_Error =>
         return;
   end Load_Properties;

   procedure Load_Properties (Self   : in out Manager'Class;
                              Path   : in String;
                              Prefix : in String := "";
                              Strip  : in Boolean := False) is
      F : File_Type;
   begin
      Open (F, In_File, Path);
      Load_Properties (Self, F, Prefix, Strip);
      Close (F);
   end Load_Properties;

   --  ------------------------------
   --  Save the properties in the given file path.
   --  ------------------------------
   procedure Save_Properties (Self   : in out Manager'Class;
                              Path   : in String;
                              Prefix : in String := "") is
      procedure Save_Property (Name, Item : in Value);

      Tmp : constant String := Path & ".tmp";
      F : File_Type;

      procedure Save_Property (Name, Item : in Value) is
      begin
         Put (F, Name);
         Put (F, "=");
         Put (F, Item);
         New_Line (F);
      end Save_Property;

      --  Rename a file (the Ada.Directories.Rename does not allow to use the Unix atomic file rename!)
      function Sys_Rename (Oldpath  : in Interfaces.C.Strings.chars_ptr;
                           Newpath  : in Interfaces.C.Strings.chars_ptr) return Integer;
      pragma Import (C, Sys_Rename, "rename");

      Old_Path : Interfaces.C.Strings.chars_ptr;
      New_Path : Interfaces.C.Strings.chars_ptr;
      Result   : Integer;
   begin
      Create (File => F, Name => Tmp);
      Self.Iterate (Save_Property'Access);
      Close (File => F);

      --  Do a system atomic rename of old file in the new file.
      --  Ada.Directories.Rename does not allow this.
      Old_Path := Interfaces.C.Strings.New_String (Tmp);
      New_Path := Interfaces.C.Strings.New_String (Path);
      Result := Sys_Rename (Old_Path, New_Path);
      Interfaces.C.Strings.Free (Old_Path);
      Interfaces.C.Strings.Free (New_Path);
      if Result /= 0 then
         raise Ada.IO_Exceptions.Use_Error with "Cannot rename file";
      end if;
   end Save_Properties;

   --  ------------------------------
   --  Copy the properties from FROM which start with a given prefix.
   --  If the prefix is empty, all properties are copied.  When <b>Strip</b> is True,
   --  the prefix part is removed from the property name.
   --  ------------------------------
   procedure Copy (Self   : in out Manager'Class;
                   From   : in Manager'Class;
                   Prefix : in String := "";
                   Strip  : in Boolean := False) is
      Names : constant Name_Array := From.Get_Names;
   begin
      for I in Names'Range loop
         declare
            Name : Unbounded_String renames Names (I);
         begin
            if Prefix'Length = 0 or else Index (Name, Prefix) = 1 then
               if Strip and Prefix'Length > 0 then
                  declare
                     S : constant String := Slice (Name, Prefix'Length + 1, Length (Name));
                  begin
                     Self.Set (+(S), From.Get (Name));
                  end;
               else
                  Self.Set (Name, From.Get (Name));
               end if;
            end if;
         end;
      end loop;

   end Copy;

end Util.Properties;

-----------------------------------------------------------------------
--  properties -- Generic name/value property management
--  Copyright (C) 2001, 2002, 2003, 2006, 2008, 2009, 2010, 2011, 2012, 2014, 2017 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.Properties.Factories;
with Ada.IO_Exceptions;
with Ada.Strings.Unbounded.Text_IO;
with Interfaces.C.Strings;
with Ada.Unchecked_Deallocation;
package body Util.Properties is

   use Ada.Text_IO;
   use Ada.Strings.Unbounded.Text_IO;
   use Interface_P;
   use Util.Beans.Objects;

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => Interface_P.Manager'Class,
                                     Name   => Interface_P.Manager_Access);

   type Property_Map is new Interface_P.Manager with record
      Props : Util.Beans.Objects.Maps.Map_Bean;
   end record;
   type Property_Map_Access is access all Property_Map;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : in Property_Map;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   --  If the map contains the given name, the value changed.
   --  Otherwise name is added to the map and the value associated with it.
   overriding
   procedure Set_Value (From  : in out Property_Map;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Returns TRUE if the property exists.
   overriding
   function Exists (Self : in Property_Map;
                    Name : in String)
                    return Boolean;

   --  Remove the property given its name.
   overriding
   procedure Remove (Self : in out Property_Map; Name : in Value);

   --  Iterate over the properties and execute the given procedure passing the
   --  property name and its value.
   overriding
   procedure Iterate (Self    : in Property_Map;
                      Process : access procedure (Name, Item : Value));

   --  Deep copy of properties stored in 'From' to 'To'.
   overriding
   function Create_Copy (Self : in Property_Map)
                         return Interface_P.Manager_Access;

   overriding
   function Get_Names (Self   : in Property_Map;
                       Prefix : in String) return Name_Array;

   procedure Load_Property (Name   : out Unbounded_String;
                            Value  : out Unbounded_String;
                            File   : in File_Type;
                            Prefix : in String := "";
                            Strip  : in Boolean := False);

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Property_Map;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      return From.Props.Get_Value (Name);
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  If the map contains the given name, the value changed.
   --  Otherwise name is added to the map and the value associated with it.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Property_Map;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      From.Props.Set_Value (Name, Value);
   end Set_Value;

   --  ------------------------------
   --  Returns TRUE if the property exists.
   --  ------------------------------
   overriding
   function Exists (Self : in Property_Map;
                    Name : in String)
                    return Boolean is
   begin
      return Self.Props.Contains (Name);
   end Exists;

   --  ------------------------------
   --  Remove the property given its name.
   --  ------------------------------
   overriding
   procedure Remove (Self : in out Property_Map; Name : in Value) is
   begin
      null;
   end Remove;

   --  Iterate over the properties and execute the given procedure passing the
   --  property name and its value.
   overriding
   procedure Iterate (Self    : in Property_Map;
                      Process : access procedure (Name, Item : Value)) is
   begin
      null;
   end Iterate;

   --  Deep copy of properties stored in 'From' to 'To'.
   overriding
   function Create_Copy (Self : in Property_Map)
                         return Interface_P.Manager_Access is
      Result : Property_Map_Access := new Property_Map;
   begin
      Result.Props := Self.Props;
      return Result.all'Access;
   end Create_Copy;

   overriding
   function Get_Names (Self   : in Property_Map;
                       Prefix : in String) return Name_Array is
      N : Name_Array (1 .. 0);
   begin
      return N;
   end Get_Names;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Manager;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if From.Impl = null then
         return Util.Beans.Objects.Null_Object;
      else
         return From.Impl.Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  If the map contains the given name, the value changed.
   --  Otherwise name is added to the map and the value associated with it.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Manager;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      Check_And_Create_Impl (From);
      From.Impl.Set_Value (Name, Value);
   end Set_Value;

   function Exists (Self : in Manager'Class;
                    Name : in String) return Boolean is
   begin
      --  There is not yet an implementation, no property
      return Self.Impl /= null and then Self.Impl.Exists (Name);
   end Exists;

   function Exists (Self : in Manager'Class;
                    Name : in Value) return Boolean is
   begin
      --  There is not yet an implementation, no property
      return Self.Impl /= null and then Self.Impl.Exists (-Name);
   end Exists;

   function Get (Self : in Manager'Class;
                 Name : in String) return Value is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY with "No property: '" & Name & "'";
      end if;

      return Value (To_Unbounded_String (Self.Impl.Get_Value (Name)));
   end Get;

   function Get (Self : in Manager'Class;
                 Name : in Value) return Value is
   begin
      return Self.Get (-Name);
   end Get;

   function Get (Self : in Manager'Class;
                 Name : in String) return String is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY with "No property: '" & Name & "'";
      end if;

      return To_String (Self.Impl.Get_Value (Name));
   end Get;

   function Get (Self : in Manager'Class;
                 Name : in Value) return String is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY;
      end if;

      return To_String (Self.Get_Value (-Name));
   end Get;

   function Get (Self : in Manager'Class;
                 Name : in String;
                 Default : in String) return String is
   begin
      if Exists (Self, Name) then
         return Get (Self, Name);
      else
         return Default;
      end if;
   end Get;

   procedure Check_And_Create_Impl (Self : in out Manager) is
   begin
      if Self.Impl = null then
         --  Util.Properties.Factories.Initialize (Self);
         Self.Impl := new Property_Map;
         Util.Concurrent.Counters.Increment (Self.Impl.Count);
      elsif Util.Concurrent.Counters.Value (Self.Impl.Count) > 1 then
         declare
            Old     : Interface_P.Manager_Access := Self.Impl;
            Is_Zero : Boolean;
         begin
            Self.Impl := Create_Copy (Self.Impl.all);
            Util.Concurrent.Counters.Increment (Self.Impl.Count);
            Util.Concurrent.Counters.Decrement (Old.Count, Is_Zero);
            if Is_Zero then
               Free (Old);
            end if;
         end;
      end if;
   end Check_And_Create_Impl;

   --  ------------------------------
   --  Set the value of the property.  The property is created if it
   --  does not exists.
   --  ------------------------------
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in String) is
   begin
      Self.Set_Value (Name, To_Object (Item));
   end Set;

   --  ------------------------------
   --  Set the value of the property.  The property is created if it
   --  does not exists.
   --  ------------------------------
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in Value) is
   begin
      Self.Set_Value (Name, To_Object (Item));
   end Set;

   --  ------------------------------
   --  Set the value of the property.  The property is created if it
   --  does not exists.
   --  ------------------------------
   procedure Set (Self : in out Manager'Class;
                  Name : in Unbounded_String;
                  Item : in Value) is
   begin
      Self.Set_Value (-Name, To_Object (Item));
   end Set;

   --  ------------------------------
   --  Remove the property given its name.
   --  ------------------------------
   procedure Remove (Self : in out Manager'Class;
                     Name : in String) is
   begin
      if Self.Impl = null then
         raise NO_PROPERTY with "No property '" & Name & "'";
      end if;
      Check_And_Create_Impl (Self);
      Remove (Self.Impl.all, +Name);
   end Remove;

   --  ------------------------------
   --  Remove the property given its name.
   --  ------------------------------
   procedure Remove (Self : in out Manager'Class;
                     Name : in Value) is
   begin
      Self.Remove (-Name);
   end Remove;

   --  ------------------------------
   --  Iterate over the properties and execute the given procedure passing the
   --  property name and its value.
   --  ------------------------------
   procedure Iterate (Self    : in Manager'Class;
                      Process : access procedure (Name, Item : Value)) is
   begin
      if Self.Impl /= null then
         Self.Impl.Iterate (Process);
      end if;
   end Iterate;

   --  ------------------------------
   --  Return the name of the properties defined in the manager.
   --  When a prefix is specified, only the properties starting with
   --  the prefix are returned.
   --  ------------------------------
   function Get_Names (Self  : in Manager;
                       Prefix : in String := "") return Name_Array is
   begin
      if Self.Impl = null then
         declare
            Empty : Name_Array (1 .. 0);
         begin
            return Empty;
         end;
      else
         return Get_Names (Self.Impl.all, Prefix);
      end if;
   end Get_Names;

   procedure Adjust (Object : in out Manager) is
   begin
      if Object.Impl /= null then
         Util.Concurrent.Counters.Increment (Object.Impl.Count);
      end if;
   end Adjust;

   procedure Finalize (Object : in out Manager) is
      Is_Zero : Boolean;
   begin
      if Object.Impl /= null then
         Util.Concurrent.Counters.Decrement (Object.Impl.Count, Is_Zero);
         if Is_Zero then
            Free (Object.Impl);
         end if;
      end if;
   end Finalize;

   procedure Set_Property_Implementation (Self : in out Manager;
                                          Impl : in Interface_P.Manager_Access) is
   begin
      if Self.Impl = null then
         Self.Impl := Impl;
--           Self.Impl.Count := 1;
      end if;
   end Set_Property_Implementation;

   procedure Load_Property (Name   : out Unbounded_String;
                            Value  : out Unbounded_String;
                            File   : in File_Type;
                            Prefix : in String := "";
                            Strip  : in Boolean := False) is
      pragma Unreferenced (Strip);

      Line : Unbounded_String;
      Pos  : Natural;
      Len  : Natural;
   begin
      while not End_Of_File (File) loop
         Line := Get_Line (File);
         Len  := Length (Line);
         if Len /= 0 and then Element (Line, 1) /= '#' then
            Pos := Index (Line, "=");
            if Pos > 0 and then Prefix'Length > 0 and then Index (Line, Prefix) = 1 then
               Name  := Unbounded_Slice (Line, Prefix'Length + 1, Pos - 1);
               Value := Tail (Line, Len - Pos);
               return;

            elsif Pos > 0 and Prefix'Length = 0 then
               Name  := Head (Line, Pos - 1);
               Value := Tail (Line, Len - Pos);
               return;

            end if;
         end if;
      end loop;
      Name := Null_Unbounded_String;
      Value := Null_Unbounded_String;
   end Load_Property;

   procedure Load_Properties (Self   : in out Manager'Class;
                              File   : in File_Type;
                              Prefix : in String := "";
                              Strip  : in Boolean := False) is
      Name, Value : Unbounded_String;
   begin
      loop
         Load_Property (Name, Value, File, Prefix, Strip);
         exit when Name = Null_Unbounded_String;
         Set (Self, Name, Value);
      end loop;

   exception
      when End_Error =>
         return;
   end Load_Properties;

   procedure Load_Properties (Self   : in out Manager'Class;
                              Path   : in String;
                              Prefix : in String := "";
                              Strip  : in Boolean := False) is
      F : File_Type;
   begin
      Open (F, In_File, Path);
      Load_Properties (Self, F, Prefix, Strip);
      Close (F);
   end Load_Properties;

   --  ------------------------------
   --  Save the properties in the given file path.
   --  ------------------------------
   procedure Save_Properties (Self   : in out Manager'Class;
                              Path   : in String;
                              Prefix : in String := "") is
      procedure Save_Property (Name, Item : in Value);

      Tmp : constant String := Path & ".tmp";
      F : File_Type;

      procedure Save_Property (Name, Item : in Value) is
      begin
         Put (F, Name);
         Put (F, "=");
         Put (F, Item);
         New_Line (F);
      end Save_Property;

      --  Rename a file (the Ada.Directories.Rename does not allow to use the Unix atomic file rename!)
      function Sys_Rename (Oldpath  : in Interfaces.C.Strings.chars_ptr;
                           Newpath  : in Interfaces.C.Strings.chars_ptr) return Integer;
      pragma Import (C, Sys_Rename, "rename");

      Old_Path : Interfaces.C.Strings.chars_ptr;
      New_Path : Interfaces.C.Strings.chars_ptr;
      Result   : Integer;
   begin
      Create (File => F, Name => Tmp);
      Self.Iterate (Save_Property'Access);
      Close (File => F);

      --  Do a system atomic rename of old file in the new file.
      --  Ada.Directories.Rename does not allow this.
      Old_Path := Interfaces.C.Strings.New_String (Tmp);
      New_Path := Interfaces.C.Strings.New_String (Path);
      Result := Sys_Rename (Old_Path, New_Path);
      Interfaces.C.Strings.Free (Old_Path);
      Interfaces.C.Strings.Free (New_Path);
      if Result /= 0 then
         raise Ada.IO_Exceptions.Use_Error with "Cannot rename file";
      end if;
   end Save_Properties;

   --  ------------------------------
   --  Copy the properties from FROM which start with a given prefix.
   --  If the prefix is empty, all properties are copied.  When <b>Strip</b> is True,
   --  the prefix part is removed from the property name.
   --  ------------------------------
   procedure Copy (Self   : in out Manager'Class;
                   From   : in Manager'Class;
                   Prefix : in String := "";
                   Strip  : in Boolean := False) is
      Names : constant Name_Array := From.Get_Names;
   begin
      for I in Names'Range loop
         declare
            Name : Unbounded_String renames Names (I);
         begin
            if Prefix'Length = 0 or else Index (Name, Prefix) = 1 then
               if Strip and Prefix'Length > 0 then
                  declare
                     S : constant String := Slice (Name, Prefix'Length + 1, Length (Name));
                  begin
                     Self.Set (+(S), From.Get (Name));
                  end;
               else
                  Self.Set (Name, From.Get (Name));
               end if;
            end if;
         end;
      end loop;

   end Copy;

end Util.Properties;

Refactor the Properties implementation (step 1): - Declare the Property_Map type for the property representation - Implement the operations for the Property_Map - Update the Properties operation to use the new interface


-----------------------------------------------------------------------
--  properties -- Generic name/value property management
--  Copyright (C) 2001, 2002, 2003, 2006, 2008, 2009, 2010, 2014, 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Ada.Finalization;
with Ada.Text_IO;
with Util.Beans.Objects;
with Util.Beans.Basic;
private with Util.Concurrent.Counters;
private with Util.Beans.Objects.Maps;
package Util.Properties is

   NO_PROPERTY : exception;

   use Ada.Strings.Unbounded;

   subtype Value is Ada.Strings.Unbounded.Unbounded_String;

   function "+" (S : String) return Value renames To_Unbounded_String;

   function "-" (S : Value) return String renames To_String;

   --  The manager holding the name/value pairs and providing the operations
   --  to get and set the properties.
   type Manager is new Ada.Finalization.Controlled and Util.Beans.Basic.Bean with private;
   type Manager_Access is access all Manager'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : in Manager;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   --  If the map contains the given name, the value changed.
   --  Otherwise name is added to the map and the value associated with it.
   overriding
   procedure Set_Value (From  : in out Manager;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Returns TRUE if the property exists.
   function Exists (Self : in Manager'Class;
                    Name : in Value) return Boolean;

   --  Returns TRUE if the property exists.
   function Exists (Self : in Manager'Class;
                    Name : in String) return Boolean;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in String) return String;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in String) return Value;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in Value) return Value;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in Value) return String;

   --  Returns the property value or Default if it does not exist.
   function Get (Self : in Manager'Class;
                 Name : in String;
                 Default : in String) return String;

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in String);

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in Value);

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in Unbounded_String;
                  Item : in Value);

   --  Remove the property given its name.  If the property does not
   --  exist, raises NO_PROPERTY exception.
   procedure Remove (Self : in out Manager'Class;
                     Name : in String);

   --  Remove the property given its name.  If the property does not
   --  exist, raises NO_PROPERTY exception.
   procedure Remove (Self : in out Manager'Class;
                     Name : in Value);

   --  Iterate over the properties and execute the given procedure passing the
   --  property name and its value.
   procedure Iterate (Self    : in Manager'Class;
                      Process : access procedure (Name, Item : Value));

   type Name_Array is array (Natural range <>) of Value;

   --  Return the name of the properties defined in the manager.
   --  When a prefix is specified, only the properties starting with
   --  the prefix are returned.
   function Get_Names (Self   : in Manager;
                       Prefix : in String := "") return Name_Array;

   --  Load the properties from the file input stream.  The file must follow
   --  the definition of Java property files.  When a prefix is specified, keep
   --  only the properties that starts with the prefix.  When Strip is True,
   --  the prefix part is removed from the property name.
   procedure Load_Properties (Self   : in out Manager'Class;
                              File   : in Ada.Text_IO.File_Type;
                              Prefix : in String := "";
                              Strip  : in Boolean := False);

   --  Load the properties from the file.  The file must follow the
   --  definition of Java property files.  When a prefix is specified, keep
   --  only the properties that starts with the prefix.  When Strip is True,
   --  the prefix part is removed from the property name.
   --  Raises NAME_ERROR if the file does not exist.
   procedure Load_Properties (Self   : in out Manager'Class;
                              Path   : in String;
                              Prefix : in String := "";
                              Strip  : in Boolean := False);

   --  Save the properties in the given file path.
   procedure Save_Properties (Self   : in out Manager'Class;
                              Path   : in String;
                              Prefix : in String := "");

   --  Copy the properties from FROM which start with a given prefix.
   --  If the prefix is empty, all properties are copied.  When Strip is True,
   --  the prefix part is removed from the property name.
   procedure Copy (Self   : in out Manager'Class;
                   From   : in Manager'Class;
                   Prefix : in String := "";
                   Strip  : in Boolean := False);

private

   --  Abstract interface for the implementation of Properties
   --  (this allows to decouples the implementation from the API)
   package Interface_P is

      type Manager is abstract limited new Util.Beans.Basic.Bean with record
         Count : Util.Concurrent.Counters.Counter;
      end record;
      type Manager_Access is access all Manager'Class;

      type Manager_Factory is access function return Manager_Access;

      --  Returns TRUE if the property exists.
      function Exists (Self : in Manager; Name : in String)
                       return Boolean is abstract;

      --  Remove the property given its name.
      procedure Remove (Self : in out Manager; Name : in Value) is abstract;

      --  Iterate over the properties and execute the given procedure passing the
      --  property name and its value.
      procedure Iterate (Self    : in Manager;
                         Process : access procedure (Name, Item : Value)) is abstract;

      --  Deep copy of properties stored in 'From' to 'To'.
      function Create_Copy (Self : in Manager)
                            return Manager_Access is abstract;

      function Get_Names (Self   : in Manager;
                          Prefix : in String) return Name_Array is abstract;

   end Interface_P;

   procedure Set_Property_Implementation (Self : in out Manager;
                                          Impl : in Interface_P.Manager_Access);

   --  Create a property implementation if there is none yet.
   procedure Check_And_Create_Impl (Self : in out Manager);

   type Manager is new Ada.Finalization.Controlled and Util.Beans.Basic.Bean with record
      Impl : Interface_P.Manager_Access := null;
   end record;

   overriding
   procedure Adjust   (Object : in out Manager);

   overriding
   procedure Finalize (Object : in out Manager);

end Util.Properties;

-----------------------------------------------------------------------
--  properties -- Generic name/value property management
--  Copyright (C) 2001, 2002, 2003, 2006, 2008, 2009, 2010, 2014, 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Ada.Finalization;
with Ada.Text_IO;
with Util.Beans.Objects;
with Util.Beans.Basic;
private with Util.Concurrent.Counters;
private with Util.Beans.Objects.Maps;
package Util.Properties is

   NO_PROPERTY : exception;

   use Ada.Strings.Unbounded;

   subtype Value is Ada.Strings.Unbounded.Unbounded_String;

   function "+" (S : String) return Value renames To_Unbounded_String;

   function "-" (S : Value) return String renames To_String;

   --  The manager holding the name/value pairs and providing the operations
   --  to get and set the properties.
   type Manager is new Ada.Finalization.Controlled and Util.Beans.Basic.Bean with private;
   type Manager_Access is access all Manager'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : in Manager;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   --  If the map contains the given name, the value changed.
   --  Otherwise name is added to the map and the value associated with it.
   overriding
   procedure Set_Value (From  : in out Manager;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Returns TRUE if the property exists.
   function Exists (Self : in Manager'Class;
                    Name : in Value) return Boolean;

   --  Returns TRUE if the property exists.
   function Exists (Self : in Manager'Class;
                    Name : in String) return Boolean;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in String) return String;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in String) return Value;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in Value) return Value;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in Value) return String;

   --  Returns the property value or Default if it does not exist.
   function Get (Self : in Manager'Class;
                 Name : in String;
                 Default : in String) return String;

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in String);

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in Value);

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in Unbounded_String;
                  Item : in Value);

   --  Remove the property given its name.  If the property does not
   --  exist, raises NO_PROPERTY exception.
   procedure Remove (Self : in out Manager'Class;
                     Name : in String);

   --  Remove the property given its name.  If the property does not
   --  exist, raises NO_PROPERTY exception.
   procedure Remove (Self : in out Manager'Class;
                     Name : in Value);

   --  Iterate over the properties and execute the given procedure passing the
   --  property name and its value.
   procedure Iterate (Self    : in Manager'Class;
                      Process : access procedure (Name, Item : Value));

   type Name_Array is array (Natural range <>) of Value;

   --  Return the name of the properties defined in the manager.
   --  When a prefix is specified, only the properties starting with
   --  the prefix are returned.
   function Get_Names (Self   : in Manager;
                       Prefix : in String := "") return Name_Array;

   --  Load the properties from the file input stream.  The file must follow
   --  the definition of Java property files.  When a prefix is specified, keep
   --  only the properties that starts with the prefix.  When Strip is True,
   --  the prefix part is removed from the property name.
   procedure Load_Properties (Self   : in out Manager'Class;
                              File   : in Ada.Text_IO.File_Type;
                              Prefix : in String := "";
                              Strip  : in Boolean := False);

   --  Load the properties from the file.  The file must follow the
   --  definition of Java property files.  When a prefix is specified, keep
   --  only the properties that starts with the prefix.  When Strip is True,
   --  the prefix part is removed from the property name.
   --  Raises NAME_ERROR if the file does not exist.
   procedure Load_Properties (Self   : in out Manager'Class;
                              Path   : in String;
                              Prefix : in String := "";
                              Strip  : in Boolean := False);

   --  Save the properties in the given file path.
   procedure Save_Properties (Self   : in out Manager'Class;
                              Path   : in String;
                              Prefix : in String := "");

   --  Copy the properties from FROM which start with a given prefix.
   --  If the prefix is empty, all properties are copied.  When Strip is True,
   --  the prefix part is removed from the property name.
   procedure Copy (Self   : in out Manager'Class;
                   From   : in Manager'Class;
                   Prefix : in String := "";
                   Strip  : in Boolean := False);

private

   --  Abstract interface for the implementation of Properties
   --  (this allows to decouples the implementation from the API)
   package Interface_P is

      type Manager is abstract limited new Util.Beans.Basic.Bean with record
         Count : Util.Concurrent.Counters.Counter;
      end record;
      type Manager_Access is access all Manager'Class;

      type Manager_Factory is access function return Manager_Access;

      --  Returns TRUE if the property exists.
      function Exists (Self : in Manager; Name : in String)
                       return Boolean is abstract;

      --  Remove the property given its name.
      procedure Remove (Self : in out Manager; Name : in Value) is abstract;

      --  Iterate over the properties and execute the given procedure passing the
      --  property name and its value.
      procedure Iterate (Self    : in Manager;
                         Process : access procedure (Name, Item : Value)) is abstract;

      --  Deep copy of properties stored in 'From' to 'To'.
      function Create_Copy (Self : in Manager)
                            return Manager_Access is abstract;

      function Get_Names (Self   : in Manager;
                          Prefix : in String) return Name_Array is abstract;

   end Interface_P;

   --  Create a property implementation if there is none yet.
   procedure Check_And_Create_Impl (Self : in out Manager);

   type Manager is new Ada.Finalization.Controlled and Util.Beans.Basic.Bean with record
      Impl : Interface_P.Manager_Access := null;
   end record;

   overriding
   procedure Adjust   (Object : in out Manager);

   overriding
   procedure Finalize (Object : in out Manager);

end Util.Properties;

Refactor the Properties implementation (step 2): - Remove Set_Property_Implementation procedure


with Ada.Integer_Text_IO;
with Ada.Text_IO;
with PrimeInstances;
package body Problem_12 is
   package IO renames Ada.Text_IO;
   package I_IO renames Ada.Integer_Text_IO;
   procedure Solve is
      package Integer_Primes renames PrimeInstances.Integer_Primes;
      sieve : constant Integer_Primes.Sieve := Integer_Primes.Generate_Sieve(15_000);
      -- We actually have the count one higher than the actual count because
      -- that's what we end up multiplying since '0' of the number is a choice.
      type Factor_Array is Array (sieve'Range) of Positive;
      function total_factors(factors: in Factor_Array) return Positive is
         permutations : Positive := 1;
      begin
         for index in factors'Range loop
            declare
               count : constant Natural := factors(index);
            begin
               permutations := permutations * count;
            end;
         end loop;
         return permutations;
      end total_factors;
      procedure generate_factors(num : in Positive; factors: out Factor_Array) is
         quotient : Positive := num;
      begin
         for index in Factor_Array'Range loop
            factors(index) := 1;
         end loop;
         for prime_index in sieve'Range loop
            declare
               prime : constant Positive := sieve(prime_index);
               count : Natural := 1;
            begin
               while quotient mod prime = 0 loop
                  count := count + 1;
                  quotient := quotient / prime;
               end loop;
               if count > factors(prime_index) then
                  factors(prime_index) := count;
               end if;
            end;
         end loop;
         null;
      end generate_factors;
      factors : Factor_Array;
      triangle : Positive := 1;
   begin
      for x in 2 .. sieve(sieve'Last) loop
         triangle := triangle + x;
         generate_factors(triangle, factors);
         if total_factors(factors) > 500 then
            I_IO.Put(triangle);
            IO.New_Line;
            exit;
         end if;
      end loop;
   end Solve;
end Problem_12;

with Ada.Integer_Text_IO;
with Ada.Text_IO;
with PrimeInstances;
package body Problem_12 is
   package IO renames Ada.Text_IO;
   package I_IO renames Ada.Integer_Text_IO;
   procedure Solve is
      package Integer_Primes renames PrimeInstances.Integer_Primes;
      sieve : constant Integer_Primes.Sieve := Integer_Primes.Generate_Sieve(15_000);
      -- We actually have the count one higher than the actual count because
      -- that's what we end up multiplying since '0' of the number is a choice.
      type Factor_Array is Array (sieve'Range) of Positive;
      function total_factors(max_prime_index : Positive; factors: in Factor_Array) return Positive is
         permutations : Positive := 1;
      begin
         for index in factors'First .. max_prime_index loop
            declare
               count : constant Natural := factors(index);
            begin
               permutations := permutations * count;
            end;
         end loop;
         return permutations;
      end total_factors;
      procedure generate_factors(num : in Positive; factors: in out Factor_Array; max_prime_index: out Positive) is
         quotient : Positive := num;
      begin
         for prime_index in sieve'Range loop
            declare
               prime : constant Positive := sieve(prime_index);
               count : Natural := 1;
            begin
               while quotient mod prime = 0 loop
                  max_prime_index := prime_index;
                  count := count + 1;
                  quotient := quotient / prime;
               end loop;
               if count > factors(prime_index) then
                  factors(prime_index) := count;
               end if;
            end;
         end loop;
      end generate_factors;
      factors : Factor_Array;
      triangle : Positive := 1;
      max_prime_index : Positive;
   begin
      for index in Factor_Array'Range loop
         factors(index) := 1;
      end loop;
      for x in 2 .. sieve(sieve'Last) loop
         triangle := triangle + x;
         generate_factors(triangle, factors, max_prime_index);
         if total_factors(max_prime_index, factors) > 500 then
            I_IO.Put(triangle);
            IO.New_Line;
            exit;
         end if;
         for index in factors'First .. max_prime_index loop
            factors(index) := 1;
         end loop;
      end loop;
   end Solve;
end Problem_12;

Make problem 12 twice as fast by limiting how far it proceeds through the permutations. I saw the problem on a random post about erlange so I decided to optimize mine until it could beat the haskell version someone posted. Still not there because this was a trivial change, but doubling speed is always good.


-----------------------------------------------------------------------
--  awa -- Ada Web Application
--  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 Util.Serialize.IO;

with ASF.Applications.Main;
with ASF.Applications.Main.Configs;
with ADO.Sessions.Factory;
with AWA.Modules;
with AWA.Events;
with AWA.Events.Services;
package AWA.Applications is

   --  Directories where the configuration files are searched.
   package P_Module_Dir is
     new ASF.Applications.Main.Configs.Parameter ("app.modules.dir",
                                                  "#{fn:composePath(app_search_dirs,'config')}");

   --  A list of configuration files separated by ';'.  These files are searched in
   --  'app.modules.dir' and loaded in the order specified.
   package P_Config_File is
     new ASF.Applications.Main.Configs.Parameter ("app.config", "awa.xml");

   --  Module manager
   --
   --  The Module_Manager represents the root of the logic manager

   type Application is new ASF.Applications.Main.Application with private;
   type Application_Access is access all Application'Class;

   --  Initialize the application
   overriding
   procedure Initialize (App     : in out Application;
                         Conf    : in ASF.Applications.Config;
                         Factory : in out ASF.Applications.Main.Application_Factory'Class);

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

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

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

   --  Initialize the ASF components provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the component factories used by the application.
   overriding
   procedure Initialize_Components (App : in out Application);

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

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

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

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

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

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

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

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

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

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

   --  Get the current application from the servlet context or service context.
   function Current return Application_Access;

private

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

   type Application is new ASF.Applications.Main.Application with record
      DB_Factory : ADO.Sessions.Factory.Session_Factory;
      Modules    : aliased AWA.Modules.Module_Registry;
      Events     : aliased AWA.Events.Services.Event_Manager;
   end record;

end AWA.Applications;

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

with ASF.Applications.Main;
with ASF.Applications.Main.Configs;
with ADO.Sessions.Factory;
with AWA.Modules;
with AWA.Events;
with AWA.Events.Services;
package AWA.Applications is

   --  Directories where the configuration files are searched.
   package P_Module_Dir is
     new ASF.Applications.Main.Configs.Parameter ("app.modules.dir",
                                                  "#{fn:composePath(app_search_dirs,'config')}");

   --  A list of configuration files separated by ';'.  These files are searched in
   --  'app.modules.dir' and loaded in the order specified before the application modules.
   package P_Config_File is
     new ASF.Applications.Main.Configs.Parameter ("app.config", "awa.xml");

   --  A list of configuration files separated by ';'.  These files are searched in
   --  'app.modules.dir' and loaded in the order specified after all the application modules
   --  are initialized.
   package P_Plugin_Config_File is
     new ASF.Applications.Main.Configs.Parameter ("app.config.plugins", "");

   --  Module manager
   --
   --  The Module_Manager represents the root of the logic manager

   type Application is new ASF.Applications.Main.Application with private;
   type Application_Access is access all Application'Class;

   --  Initialize the application
   overriding
   procedure Initialize (App     : in out Application;
                         Conf    : in ASF.Applications.Config;
                         Factory : in out ASF.Applications.Main.Application_Factory'Class);

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

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

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

   --  Initialize the ASF components provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the component factories used by the application.
   overriding
   procedure Initialize_Components (App : in out Application);

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

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

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

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

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

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

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

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

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

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

   --  Get the current application from the servlet context or service context.
   function Current return Application_Access;

private

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

   type Application is new ASF.Applications.Main.Application with record
      DB_Factory : ADO.Sessions.Factory.Session_Factory;
      Modules    : aliased AWA.Modules.Module_Registry;
      Events     : aliased AWA.Events.Services.Event_Manager;
   end record;

end AWA.Applications;

Change Load_Configuration to allow reading a custom configuration file New configuration property to define a configuration file for plugins


-----------------------------------------------------------------------
--  security-auth-oauth -- OAuth based authentication
--  Copyright (C) 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 Util.Log.Loggers;
with Security.OAuth.Clients;
package body Security.Auth.OAuth is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Security.Auth.OAuth");

   --  ------------------------------
   --  OAuth Manager
   --  ------------------------------
   --  The Manager provides the core operations for the OAuth authorization process.

   --  ------------------------------
   --  Initialize the authentication realm.
   --  ------------------------------
   overriding
   procedure Initialize (Realm     : in out Manager;
                         Params    : in Parameters'Class;
                         Provider  : in String := PROVIDER_OPENID) is
   begin
      Realm.App.Set_Application_Identifier (Params.Get_Parameter (Provider & ".client_id"));
      Realm.App.Set_Application_Secret (Params.Get_Parameter (Provider & ".secret"));
      Realm.App.Set_Application_Callback (Params.Get_Parameter (Provider & ".callback_url"));
      Realm.App.Set_Provider_URI (Params.Get_Parameter (Provider & ".request_url"));
      Realm.Realm := To_Unbounded_String (Params.Get_Parameter (Provider & ".realm"));
      Realm.Scope := To_Unbounded_String (Params.Get_Parameter (Provider & ".scope"));
   end Initialize;

   --  ------------------------------
   --  Discover the OpenID provider that must be used to authenticate the user.
   --  The Name can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.
   --  Read the XRDS document from the URI and initialize the OpenID provider end point.
   --  (See OpenID Section 7.3 Discovery)
   --  ------------------------------
   overriding
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point) is
   begin
      Result.URL := To_Unbounded_String (Name);
   end Discover;

   --  ------------------------------
   --  Associate the application (relying party) with the OpenID provider.
   --  The association can be cached.
   --  (See OpenID Section 8 Establishing Associations)
   --  ------------------------------
   overriding
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association) is
   begin
      Result.Assoc_Handle := To_Unbounded_String ("nonce-generator");
   end Associate;

   --  ------------------------------
   --  Get the authentication URL to which the user must be redirected for authentication
   --  by the authentication server.
   --  ------------------------------
   overriding
   function Get_Authentication_URL (Realm : in Manager;
                                    OP    : in End_Point;
                                    Assoc : in Association) return String is
      Result : Unbounded_String := OP.URL;
      State  : constant String := Realm.App.Get_State (To_String (Assoc.Assoc_Handle));
      Params : constant String := Realm.App.Get_Auth_Params (State, To_String (Realm.Scope));
   begin
      if Index (Result, "?") > 0 then
         Append (Result, "&");
      else
         Append (Result, "?");
      end if;
      Append (Result, Params);
      Append (Result, "&");
      Append (Result, Security.OAuth.Response_Type);
      Append (Result, "=code");

      Log.Debug ("Params = {0}", Params);
      return To_String (Result);
   end Get_Authentication_URL;

   --  ------------------------------
   --  Verify the authentication result
   --  ------------------------------
   overriding
   procedure Verify (Realm   : in out Manager;
                     Assoc   : in Association;
                     Request : in Parameters'Class;
                     Result  : out Authentication) is
      State : constant String := Request.Get_Parameter (Security.OAuth.State);
      Code  : constant String := Request.Get_Parameter (Security.OAuth.Code);
      Error : constant String := Request.Get_Parameter (Security.OAuth.Error_Description);
   begin
      if Error'Length /= 0 then
         Set_Result (Result, CANCEL, "Authentication refused: " & Error);
         return;
      end if;

      --  First, verify that the state parameter matches our internal state.
      if not Realm.App.Is_Valid_State (To_String (Assoc.Assoc_Handle), State) then
         Set_Result (Result, INVALID_SIGNATURE, "invalid OAuth state parameter");
         return;
      end if;

      --  Get the access token from the authorization code.
      declare
         use type Security.OAuth.Clients.Access_Token_Access;

         Acc : constant Security.OAuth.Clients.Access_Token_Access
           := Realm.App.Request_Access_Token (Code);
      begin
         if Acc = null then
            Set_Result (Result, INVALID_SIGNATURE, "cannot change the code to an access_token");
            return;
         end if;

         --  Last step, verify the access token and get the user identity.
         Manager'Class (Realm).Verify_Access_Token (Assoc, Request, Acc, Result);
      end;

   end Verify;

end Security.Auth.OAuth;

-----------------------------------------------------------------------
--  security-auth-oauth -- OAuth based authentication
--  Copyright (C) 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 Util.Log.Loggers;
with Security.OAuth.Clients;
package body Security.Auth.OAuth is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Security.Auth.OAuth");

   --  ------------------------------
   --  OAuth Manager
   --  ------------------------------
   --  The Manager provides the core operations for the OAuth authorization process.

   --  ------------------------------
   --  Initialize the authentication realm.
   --  ------------------------------
   overriding
   procedure Initialize (Realm     : in out Manager;
                         Params    : in Parameters'Class;
                         Provider  : in String := PROVIDER_OPENID) is
   begin
      Realm.App.Set_Application_Identifier (Params.Get_Parameter (Provider & ".client_id"));
      Realm.App.Set_Application_Secret (Params.Get_Parameter (Provider & ".secret"));
      Realm.App.Set_Application_Callback (Params.Get_Parameter (Provider & ".callback_url"));
      Realm.App.Set_Provider_URI (Params.Get_Parameter (Provider & ".request_url"));
      Realm.Realm := To_Unbounded_String (Params.Get_Parameter (Provider & ".realm"));
      Realm.Scope := To_Unbounded_String (Params.Get_Parameter (Provider & ".scope"));
      Realm.Issuer := To_Unbounded_String (Params.Get_Parameter (Provider & ".issuer"));
   end Initialize;

   --  ------------------------------
   --  Discover the OpenID provider that must be used to authenticate the user.
   --  The Name can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.
   --  Read the XRDS document from the URI and initialize the OpenID provider end point.
   --  (See OpenID Section 7.3 Discovery)
   --  ------------------------------
   overriding
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point) is
   begin
      Result.URL := To_Unbounded_String (Name);
   end Discover;

   --  ------------------------------
   --  Associate the application (relying party) with the OpenID provider.
   --  The association can be cached.
   --  (See OpenID Section 8 Establishing Associations)
   --  ------------------------------
   overriding
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association) is
   begin
      Result.Assoc_Handle := To_Unbounded_String ("nonce-generator");
   end Associate;

   --  ------------------------------
   --  Get the authentication URL to which the user must be redirected for authentication
   --  by the authentication server.
   --  ------------------------------
   overriding
   function Get_Authentication_URL (Realm : in Manager;
                                    OP    : in End_Point;
                                    Assoc : in Association) return String is
      Result : Unbounded_String := OP.URL;
      State  : constant String := Realm.App.Get_State (To_String (Assoc.Assoc_Handle));
      Params : constant String := Realm.App.Get_Auth_Params (State, To_String (Realm.Scope));
   begin
      if Index (Result, "?") > 0 then
         Append (Result, "&");
      else
         Append (Result, "?");
      end if;
      Append (Result, Params);
      Append (Result, "&");
      Append (Result, Security.OAuth.Response_Type);
      Append (Result, "=code");

      Log.Debug ("Params = {0}", Params);
      return To_String (Result);
   end Get_Authentication_URL;

   --  ------------------------------
   --  Verify the authentication result
   --  ------------------------------
   overriding
   procedure Verify (Realm   : in out Manager;
                     Assoc   : in Association;
                     Request : in Parameters'Class;
                     Result  : out Authentication) is
      State : constant String := Request.Get_Parameter (Security.OAuth.State);
      Code  : constant String := Request.Get_Parameter (Security.OAuth.Code);
      Error : constant String := Request.Get_Parameter (Security.OAuth.Error_Description);
   begin
      if Error'Length /= 0 then
         Set_Result (Result, CANCEL, "Authentication refused: " & Error);
         return;
      end if;

      --  First, verify that the state parameter matches our internal state.
      if not Realm.App.Is_Valid_State (To_String (Assoc.Assoc_Handle), State) then
         Set_Result (Result, INVALID_SIGNATURE, "invalid OAuth state parameter");
         return;
      end if;

      --  Get the access token from the authorization code.
      declare
         use type Security.OAuth.Clients.Access_Token_Access;

         Acc : constant Security.OAuth.Clients.Access_Token_Access
           := Realm.App.Request_Access_Token (Code);
      begin
         if Acc = null then
            Set_Result (Result, INVALID_SIGNATURE, "cannot change the code to an access_token");
            return;
         end if;

         --  Last step, verify the access token and get the user identity.
         Manager'Class (Realm).Verify_Access_Token (Assoc, Request, Acc, Result);
      end;

   end Verify;

end Security.Auth.OAuth;

Initialize the issuer from the parameters