-----------------------------------------------------------------------
--  util-http-clients-curl -- HTTP Clients with CURL
--  Copyright (C) 2012, 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 System;
with Interfaces.C;
with Interfaces.C.Strings;
with Ada.Strings.Unbounded;
with Util.Http.Mockups;
package Util.Http.Clients.Curl is

   --  Register the CURL Http manager.
   procedure Register;

private

   package C renames Interfaces.C;
   package Strings renames Interfaces.C.Strings;

   use type C.size_t;
   use type C.int;

   --  Define 'Int' and 'Chars_Ptr' with capitals to avoid GNAT warnings due
   --  to Eclipse capitalization.
   subtype Int is C.int;
   subtype Chars_Ptr is Strings.chars_ptr;
   subtype Size_T is C.size_t;

   subtype CURL is System.Address;

   type CURL_Code is new Interfaces.C.int;

   CURLE_OK               : constant CURL_Code := 0;

   type CURL_Info is new Int;

   type Curl_Option is new Int;

   type CURL_Slist;
   type CURL_Slist_Access is access CURL_Slist;

   type CURL_Slist is record
      Data : Chars_Ptr;
      Next : CURL_Slist_Access;
   end record;

   --  Check the CURL result code and report and exception and a log message if
   --  the CURL code indicates an error.
   procedure Check_Code (Code    : in CURL_Code;
                         Message : in String);

   type Curl_Http_Manager is new Http_Manager with null record;
   type Curl_Http_Manager_Access is access all Http_Manager'Class;

   --  Create a new HTTP request associated with the current request manager.
   procedure Create (Manager  : in Curl_Http_Manager;
                     Http     : in out Client'Class);

   overriding
   procedure Do_Get (Manager  : in Curl_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Reply    : out Response'Class);

   overriding
   procedure Do_Post (Manager  : in Curl_Http_Manager;
                      Http     : in Client'Class;
                      URI      : in String;
                      Data     : in String;
                      Reply    : out Response'Class);

   overriding
   procedure Do_Put (Manager  : in Curl_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Data     : in String;
                     Reply    : out Response'Class);

   --  Set the timeout for the connection.
   overriding
   procedure Set_Timeout (Manager : in Curl_Http_Manager;
                          Http    : in Client'Class;
                          Timeout : in Duration);

   type Curl_Http_Request is new Util.Http.Mockups.Mockup_Request with record
      Data         : CURL := System.Null_Address;
      URL          : Chars_Ptr := Interfaces.C.Strings.Null_Ptr;
      Content      : Chars_Ptr := Interfaces.C.Strings.Null_Ptr;
      Curl_Headers : CURL_Slist_Access := null;
   end record;
   type Curl_Http_Request_Access is access all Curl_Http_Request'Class;

   --  Prepare to setup the headers in the request.
   procedure Set_Headers (Request : in out Curl_Http_Request);

   overriding
   procedure Finalize (Request : in out Curl_Http_Request);

   type Curl_Http_Response is new Util.Http.Mockups.Mockup_Response with record
      C : CURL;
      Content : Ada.Strings.Unbounded.Unbounded_String;
      Status  : Natural;
      Parsing_Body : Boolean := False;
   end record;
   type Curl_Http_Response_Access is access all Curl_Http_Response'Class;

   --  Get the response body as a string.
   overriding
   function Get_Body (Reply : in Curl_Http_Response) return String;

   --  Get the response status code.
   overriding
   function Get_Status (Reply : in Curl_Http_Response) return Natural;

   --  Add a string to a CURL slist.
   function Curl_Slist_Append (List  : in CURL_Slist_Access;
                               Value : in Chars_Ptr) return CURL_Slist_Access;
   pragma Import (C, Curl_Slist_Append, "curl_slist_append");

   --  Free an entrire CURL slist.
   procedure Curl_Slist_Free_All (List : in CURL_Slist_Access);
   pragma Import (C, Curl_Slist_Free_All, "curl_slist_free_all");

   --  Start a libcurl easy session.
   function Curl_Easy_Init return CURL;
   pragma Import (C, Curl_Easy_Init, "curl_easy_init");

   --  End a libcurl easy session.
   procedure Curl_Easy_Cleanup (Handle : in CURL);
   pragma Import (C, Curl_Easy_Cleanup, "curl_easy_cleanup");

   --  Perform a file transfer.
   function Curl_Easy_Perform (Handle : in CURL) return CURL_Code;
   pragma Import (C, Curl_Easy_Perform, "curl_easy_perform");

   --  Return the error message which correspond to the given CURL error code.
   function Curl_Easy_Strerror (Code : in CURL_Code) return Chars_Ptr;
   pragma Import (C, Curl_Easy_Strerror, "curl_easy_strerror");

   --  Set options for a curl easy handle.
   function Curl_Easy_Setopt_String (Handle : in CURL;
                                     Option : in Curl_Option;
                                     Value  : in Chars_Ptr) return CURL_Code;
   pragma Import (C, Curl_Easy_Setopt_String, "curl_easy_setopt");

   --  Set options for a curl easy handle.
   function Curl_Easy_Setopt_Slist (Handle : in CURL;
                                     Option : in Curl_Option;
                                     Value  : in CURL_Slist_Access) return CURL_Code;
   pragma Import (C, Curl_Easy_Setopt_Slist, "curl_easy_setopt");

   --  Set options for a curl easy handle.
   function Curl_Easy_Setopt_Long (Handle : in CURL;
                                     Option : in Curl_Option;
                                     Value  : in Interfaces.C.long) return CURL_Code;
   pragma Import (C, Curl_Easy_Setopt_Long, "curl_easy_setopt");

   --  Get information from a CURL handle for an option returning a String.
   function Curl_Easy_Getinfo_String (Handle : in CURL;
                                      Option : in CURL_Info;
                                      Value  : access Chars_Ptr) return CURL_Code;
   pragma Import (C, Curl_Easy_Getinfo_String, "curl_easy_getinfo");

   --  Get information from a CURL handle for an option returning a Long.
   function Curl_Easy_Getinfo_Long (Handle : in CURL;
                                    Option : in CURL_Info;
                                    Value  : access C.long) return CURL_Code;
   pragma Import (C, Curl_Easy_Getinfo_Long, "curl_easy_getinfo");

   function Curl_Easy_Setopt_Write_Callback
     (Handle : in CURL;
      Option : in Curl_Option;
      Func : access function (Data  : in Chars_Ptr;
                              Size  : in Size_T;
                              Nmemb : in Size_T;
                              Ptr   : in Curl_Http_Response_Access) return Size_T)
      return CURL_Code;
   pragma Import (C, Curl_Easy_Setopt_Write_Callback, "curl_easy_setopt");

   --  Set options for a curl easy handle.
   function Curl_Easy_Setopt_Data (Handle : in CURL;
                                   Option : in Curl_Option;
                                   Value  : in Curl_Http_Response_Access) return CURL_Code;
   pragma Import (C, Curl_Easy_Setopt_Data, "curl_easy_setopt");

   function Read_Response (Data     : in Chars_Ptr;
                           Size     : in Size_T;
                           Nmemb    : in Size_T;
                           Response : in Curl_Http_Response_Access) return Size_T;

end Util.Http.Clients.Curl;

-----------------------------------------------------------------------
--  util-http-clients-curl -- HTTP Clients with CURL
--  Copyright (C) 2012, 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 System;
with Interfaces.C;
with Interfaces.C.Strings;
with Ada.Strings.Unbounded;
with Util.Http.Mockups;
package Util.Http.Clients.Curl is

   --  Register the CURL Http manager.
   procedure Register;

private

   package C renames Interfaces.C;
   package Strings renames Interfaces.C.Strings;

   use type C.size_t;
   use type C.int;

   --  Define 'Int' and 'Chars_Ptr' with capitals to avoid GNAT warnings due
   --  to Eclipse capitalization.
   subtype Int is C.int;
   subtype Chars_Ptr is Strings.chars_ptr;
   subtype Size_T is C.size_t;

   subtype CURL is System.Address;

   type CURL_Code is new Interfaces.C.int;

   CURLE_OK               : constant CURL_Code := 0;

   type CURL_Info is new Int;

   type Curl_Option is new Int;

   type CURL_Slist;
   type CURL_Slist_Access is access CURL_Slist;

   type CURL_Slist is record
      Data : Chars_Ptr;
      Next : CURL_Slist_Access;
   end record;

   --  Check the CURL result code and report and exception and a log message if
   --  the CURL code indicates an error.
   procedure Check_Code (Code    : in CURL_Code;
                         Message : in String);

   type Curl_Http_Manager is new Http_Manager with null record;
   type Curl_Http_Manager_Access is access all Http_Manager'Class;

   --  Create a new HTTP request associated with the current request manager.
   procedure Create (Manager  : in Curl_Http_Manager;
                     Http     : in out Client'Class);

   overriding
   procedure Do_Get (Manager  : in Curl_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Reply    : out Response'Class);

   overriding
   procedure Do_Post (Manager  : in Curl_Http_Manager;
                      Http     : in Client'Class;
                      URI      : in String;
                      Data     : in String;
                      Reply    : out Response'Class);

   overriding
   procedure Do_Put (Manager  : in Curl_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Data     : in String;
                     Reply    : out Response'Class);

   --  Set the timeout for the connection.
   overriding
   procedure Set_Timeout (Manager : in Curl_Http_Manager;
                          Http    : in Client'Class;
                          Timeout : in Duration);

   type Curl_Http_Request is new Util.Http.Mockups.Mockup_Request with record
      Data         : CURL := System.Null_Address;
      URL          : Chars_Ptr := Interfaces.C.Strings.Null_Ptr;
      Content      : Chars_Ptr := Interfaces.C.Strings.Null_Ptr;
      Curl_Headers : CURL_Slist_Access := null;
   end record;
   type Curl_Http_Request_Access is access all Curl_Http_Request'Class;

   --  Prepare to setup the headers in the request.
   procedure Set_Headers (Request : in out Curl_Http_Request);

   overriding
   procedure Finalize (Request : in out Curl_Http_Request);

   type Curl_Http_Response is new Util.Http.Mockups.Mockup_Response with record
      C : CURL;
      Content : Ada.Strings.Unbounded.Unbounded_String;
      Status  : Natural;
      Parsing_Body : Boolean := False;
   end record;
   type Curl_Http_Response_Access is access all Curl_Http_Response'Class;

   --  Get the response body as a string.
   overriding
   function Get_Body (Reply : in Curl_Http_Response) return String;

   --  Get the response status code.
   overriding
   function Get_Status (Reply : in Curl_Http_Response) return Natural;

   --  Add a string to a CURL slist.
   function Curl_Slist_Append (List  : in CURL_Slist_Access;
                               Value : in Chars_Ptr) return CURL_Slist_Access;
   pragma Import (C, Curl_Slist_Append, "curl_slist_append");

   --  Free an entrire CURL slist.
   procedure Curl_Slist_Free_All (List : in CURL_Slist_Access);
   pragma Import (C, Curl_Slist_Free_All, "curl_slist_free_all");

   --  Start a libcurl easy session.
   function Curl_Easy_Init return CURL;
   pragma Import (C, Curl_Easy_Init, "curl_easy_init");

   --  End a libcurl easy session.
   procedure Curl_Easy_Cleanup (Handle : in CURL);
   pragma Import (C, Curl_Easy_Cleanup, "curl_easy_cleanup");

   --  Perform a file transfer.
   function Curl_Easy_Perform (Handle : in CURL) return CURL_Code;
   pragma Import (C, Curl_Easy_Perform, "curl_easy_perform");

   --  Return the error message which correspond to the given CURL error code.
   function Curl_Easy_Strerror (Code : in CURL_Code) return Chars_Ptr;
   pragma Import (C, Curl_Easy_Strerror, "curl_easy_strerror");

   --  Set options for a curl easy handle.
   function Curl_Easy_Setopt_String (Handle : in CURL;
                                     Option : in Curl_Option;
                                     Value  : in Chars_Ptr) return CURL_Code;
   pragma Import (C, Curl_Easy_Setopt_String, "curl_easy_setopt");

   --  Set options for a curl easy handle.
   function Curl_Easy_Setopt_Slist (Handle : in CURL;
                                     Option : in Curl_Option;
                                     Value  : in CURL_Slist_Access) return CURL_Code;
   pragma Import (C, Curl_Easy_Setopt_Slist, "curl_easy_setopt");

   --  Set options for a curl easy handle.
   function Curl_Easy_Setopt_Long (Handle : in CURL;
                                     Option : in Curl_Option;
                                     Value  : in Interfaces.C.long) return CURL_Code;
   pragma Import (C, Curl_Easy_Setopt_Long, "curl_easy_setopt");

   --  Get information from a CURL handle for an option returning a String.
   function Curl_Easy_Getinfo_String (Handle : in CURL;
                                      Option : in CURL_Info;
                                      Value  : access Chars_Ptr) return CURL_Code;
   pragma Import (C, Curl_Easy_Getinfo_String, "curl_easy_getinfo");

   --  Get information from a CURL handle for an option returning a Long.
   function Curl_Easy_Getinfo_Long (Handle : in CURL;
                                    Option : in CURL_Info;
                                    Value  : access C.long) return CURL_Code;
   pragma Import (C, Curl_Easy_Getinfo_Long, "curl_easy_getinfo");

   function Curl_Easy_Setopt_Write_Callback
     (Handle : in CURL;
      Option : in Curl_Option;
      Func : access function (Data  : in Chars_Ptr;
                              Size  : in Size_T;
                              Nmemb : in Size_T;
                              Ptr   : in Curl_Http_Response_Access) return Size_T)
      return CURL_Code;
   pragma Import (C, Curl_Easy_Setopt_Write_Callback, "curl_easy_setopt");

   --  Set options for a curl easy handle.
   function Curl_Easy_Setopt_Data (Handle : in CURL;
                                   Option : in Curl_Option;
                                   Value  : in Curl_Http_Response_Access) return CURL_Code;
   pragma Import (C, Curl_Easy_Setopt_Data, "curl_easy_setopt");

   function Read_Response (Data     : in Chars_Ptr;
                           Size     : in Size_T;
                           Nmemb    : in Size_T;
                           Response : in Curl_Http_Response_Access) return Size_T;
   pragma Convention (C, Read_Response);

end Util.Http.Clients.Curl;

Add missing Convention pragma for the Read_Response procedure


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

with Natools.S_Expressions.Atom_Ref_Constructors;
with Natools.S_Expressions.File_Readers;
with Natools.S_Expressions.Interpreter_Loop;

package body Natools.Web.ACL.Sx_Backends is

   type User_Builder is record
      Tokens, Groups : Containers.Unsafe_Atom_Lists.List;
   end record;

   type Backend_Builder is record
      Map : Token_Maps.Unsafe_Maps.Map;
   end record;

   Cookie_Name : constant String := "User-Token";

   procedure Process_User
     (Builder : in out Backend_Builder;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out Natools.S_Expressions.Lockable.Descriptor'Class);

   procedure Process_User_Element
     (Builder : in out User_Builder;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out Natools.S_Expressions.Lockable.Descriptor'Class);

   procedure Read_DB is new S_Expressions.Interpreter_Loop
     (Backend_Builder, Meaningless_Type, Process_User);

   procedure Read_User is new S_Expressions.Interpreter_Loop
     (User_Builder, Meaningless_Type, Process_User_Element);

   --------------------------
   -- Constructor Elements --
   --------------------------

   procedure Process_User
     (Builder : in out Backend_Builder;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out Natools.S_Expressions.Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Context);
      User : User_Builder;
      Identity : Containers.Identity;
   begin
      Read_User (Arguments, User, Meaningless_Value);

      Identity :=
        (User => S_Expressions.Atom_Ref_Constructors.Create (Name),
         Groups => Containers.Create (User.Groups));

      for Token of User.Tokens loop
         Builder.Map.Include (Token, Identity);
      end loop;
   end Process_User;

   procedure Process_User_Element
     (Builder : in out User_Builder;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out Natools.S_Expressions.Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Context);
      S_Name : constant String := S_Expressions.To_String (Name);
   begin
      if S_Name = "tokens" or else S_Name = "token" then
         Containers.Append_Atoms (Builder.Tokens, Arguments);
      elsif S_Name = "groups" or else S_Name = "group" then
         Containers.Append_Atoms (Builder.Groups, Arguments);
      else
         Log (Severities.Error, "Unknown user element """ & S_Name & '"');
      end if;
   end Process_User_Element;

   ----------------------
   -- Public Interface --
   ----------------------

   overriding procedure Authenticate
     (Self : in Backend;
      Exchange : in out Exchanges.Exchange)
   is
      Cursor : constant Token_Maps.Cursor
        := Self.Map.Find (S_Expressions.To_Atom
           (Exchange.Cookie (Cookie_Name)));
      Identity : Containers.Identity;
   begin
      if Token_Maps.Has_Element (Cursor) then
         Identity := Token_Maps.Element (Cursor);
      end if;

      Exchange.Set_Identity (Identity);
   end Authenticate;

   function Create
     (Arguments : in out S_Expressions.Lockable.Descriptor'Class)
     return ACL.Backend'Class
   is
      Builder : Backend_Builder;
   begin
      case Arguments.Current_Event is
         when S_Expressions.Events.Open_List =>
            Read_DB (Arguments, Builder, Meaningless_Value);

         when S_Expressions.Events.Add_Atom =>
            declare
               Reader : S_Expressions.File_Readers.S_Reader
                 := S_Expressions.File_Readers.Reader
                    (S_Expressions.To_String (Arguments.Current_Atom));
            begin
               Read_DB (Reader, Builder, Meaningless_Value);
            end;

         when others =>
            Log (Severities.Error, "Unable to create ACL from S-expression"
              & " starting with " & Arguments.Current_Event'Img);
      end case;

      return Backend'(Map => Token_Maps.Create (Builder.Map),
                      Hashed => <>);
   end Create;

   procedure Register
     (Id : in Character;
      Fn : in Hash_Function) is
   begin
      if Fn = null then
         null;
      elsif Hash_Function_DB.Is_Empty then
         Hash_Function_DB.Replace (new Hash_Function_Array'(Id => Fn));
      elsif Id in Hash_Function_DB.Query.Data.all'Range then
         Hash_Function_DB.Update.Data.all (Id) := Fn;
      else
         declare
            New_First : constant Hash_Id
              := Hash_Id'Min (Id, Hash_Function_DB.Query.Data.all'First);
            New_Last : constant Hash_Id
              := Hash_Id'Max (Id, Hash_Function_DB.Query.Data.all'Last);
            New_Data : constant Hash_Function_Array_Refs.Data_Access
              := new Hash_Function_Array'(New_First .. New_Last => null);
         begin
            New_Data (Hash_Function_DB.Query.Data.all'First
                  ..  Hash_Function_DB.Query.Data.all'Last)
              := Hash_Function_DB.Query.Data.all;
            Hash_Function_DB.Replace (New_Data);
         end;
      end if;
   end Register;

end Natools.Web.ACL.Sx_Backends;

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

with Natools.S_Expressions.Atom_Ref_Constructors;
with Natools.S_Expressions.File_Readers;
with Natools.S_Expressions.Interpreter_Loop;

package body Natools.Web.ACL.Sx_Backends is

   type User_Builder is record
      Tokens, Groups : Containers.Unsafe_Atom_Lists.List;
   end record;

   type Backend_Builder is record
      Map : Token_Maps.Unsafe_Maps.Map;
   end record;

   Cookie_Name : constant String := "User-Token";
   Hash_Mark : constant Character := '$';

   procedure Process_User
     (Builder : in out Backend_Builder;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out Natools.S_Expressions.Lockable.Descriptor'Class);

   procedure Process_User_Element
     (Builder : in out User_Builder;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out Natools.S_Expressions.Lockable.Descriptor'Class);

   procedure Read_DB is new S_Expressions.Interpreter_Loop
     (Backend_Builder, Meaningless_Type, Process_User);

   procedure Read_User is new S_Expressions.Interpreter_Loop
     (User_Builder, Meaningless_Type, Process_User_Element);

   --------------------------
   -- Constructor Elements --
   --------------------------

   procedure Process_User
     (Builder : in out Backend_Builder;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out Natools.S_Expressions.Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Context);
      User : User_Builder;
      Identity : Containers.Identity;
   begin
      Read_User (Arguments, User, Meaningless_Value);

      Identity :=
        (User => S_Expressions.Atom_Ref_Constructors.Create (Name),
         Groups => Containers.Create (User.Groups));

      for Token of User.Tokens loop
         Builder.Map.Include (Token, Identity);
      end loop;
   end Process_User;

   procedure Process_User_Element
     (Builder : in out User_Builder;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out Natools.S_Expressions.Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Context);
      S_Name : constant String := S_Expressions.To_String (Name);
   begin
      if S_Name = "tokens" or else S_Name = "token" then
         Containers.Append_Atoms (Builder.Tokens, Arguments);
      elsif S_Name = "groups" or else S_Name = "group" then
         Containers.Append_Atoms (Builder.Groups, Arguments);
      else
         Log (Severities.Error, "Unknown user element """ & S_Name & '"');
      end if;
   end Process_User_Element;

   ----------------------
   -- Public Interface --
   ----------------------

   overriding procedure Authenticate
     (Self : in Backend;
      Exchange : in out Exchanges.Exchange)
   is
      Cookie : constant String := Exchange.Cookie (Cookie_Name);
      Identity : Containers.Identity;
   begin
      if Cookie'Length > 3
        and then Cookie (Cookie'First) = Hash_Mark
        and then Cookie (Cookie'First + 2) = Hash_Mark
        and then not Self.Hashed.Is_Empty
        and then Cookie (Cookie'First + 1) in Self.Hashed.Query.Data.all'Range
      then
         declare
            Token : constant S_Expressions.Atom
              := S_Expressions.To_Atom
                 (Cookie (Cookie'First + 3 .. Cookie'Last));
            Hash : constant S_Expressions.Atom
              := Hash_Function_DB.Query.Data (Cookie (Cookie'First + 1)).all
                 (Token);
            Cursor : constant Token_Maps.Cursor
              := Self.Hashed.Query.Data (Cookie (Cookie'First + 1)).Find
                 (Hash);
         begin
            if Token_Maps.Has_Element (Cursor) then
               Identity := Token_Maps.Element (Cursor);
            end if;
         end;
      else
         declare
            Cursor : constant Token_Maps.Cursor
              := Self.Map.Find (S_Expressions.To_Atom (Cookie));
         begin
            if Token_Maps.Has_Element (Cursor) then
               Identity := Token_Maps.Element (Cursor);
            end if;
         end;
      end if;

      Exchange.Set_Identity (Identity);
   end Authenticate;

   function Create
     (Arguments : in out S_Expressions.Lockable.Descriptor'Class)
     return ACL.Backend'Class
   is
      Builder : Backend_Builder;
   begin
      case Arguments.Current_Event is
         when S_Expressions.Events.Open_List =>
            Read_DB (Arguments, Builder, Meaningless_Value);

         when S_Expressions.Events.Add_Atom =>
            declare
               Reader : S_Expressions.File_Readers.S_Reader
                 := S_Expressions.File_Readers.Reader
                    (S_Expressions.To_String (Arguments.Current_Atom));
            begin
               Read_DB (Reader, Builder, Meaningless_Value);
            end;

         when others =>
            Log (Severities.Error, "Unable to create ACL from S-expression"
              & " starting with " & Arguments.Current_Event'Img);
      end case;

      return Backend'(Map => Token_Maps.Create (Builder.Map),
                      Hashed => <>);
   end Create;

   procedure Register
     (Id : in Character;
      Fn : in Hash_Function) is
   begin
      if Fn = null then
         null;
      elsif Hash_Function_DB.Is_Empty then
         Hash_Function_DB.Replace (new Hash_Function_Array'(Id => Fn));
      elsif Id in Hash_Function_DB.Query.Data.all'Range then
         Hash_Function_DB.Update.Data.all (Id) := Fn;
      else
         declare
            New_First : constant Hash_Id
              := Hash_Id'Min (Id, Hash_Function_DB.Query.Data.all'First);
            New_Last : constant Hash_Id
              := Hash_Id'Max (Id, Hash_Function_DB.Query.Data.all'Last);
            New_Data : constant Hash_Function_Array_Refs.Data_Access
              := new Hash_Function_Array'(New_First .. New_Last => null);
         begin
            New_Data (Hash_Function_DB.Query.Data.all'First
                  ..  Hash_Function_DB.Query.Data.all'Last)
              := Hash_Function_DB.Query.Data.all;
            Hash_Function_DB.Replace (New_Data);
         end;
      end if;
   end Register;

end Natools.Web.ACL.Sx_Backends;

use hashed tokens to authenticate

acl-sx_backends: use hashed tokens to authenticate


-----------------------------------------------------------------------
--  util-commands-consoles-text - Text console interface
--  Copyright (C) 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.Text_IO;
generic
package Util.Commands.Consoles.Text is

   type Console_Type is new Util.Commands.Consoles.Console_Type with private;

   --  Report an error message.
   overriding
   procedure Error (Console : in out Console_Type;
                    Message : in String);

   --  Report a notice message.
   overriding
   procedure Notice (Console : in out Console_Type;
                     Kind    : in Notice_Type;
                     Message : in String);

   --  Print the field value for the given field.
   overriding
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in String;
                          Justify : in Justify_Type := J_LEFT);

   --  Print the title for the given field.
   overriding
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String);

   --  Start a new title in a report.
   overriding
   procedure Start_Title (Console : in out Console_Type);

   --  Finish a new title in a report.
   procedure End_Title (Console : in out Console_Type);

   --  Start a new row in a report.
   overriding
   procedure Start_Row (Console : in out Console_Type);

   --  Finish a new row in a report.
   overriding
   procedure End_Row (Console : in out Console_Type);

private

   type Console_Type is new Util.Commands.Consoles.Console_Type with record
      File : Ada.Text_IO.File_Type;
   end record;

end Util.Commands.Consoles.Text;

-----------------------------------------------------------------------
--  util-commands-consoles-text -- Text console interface
--  Copyright (C) 2014, 2017, 2018 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Text_IO;
generic
package Util.Commands.Consoles.Text is

   type Console_Type is new Util.Commands.Consoles.Console_Type with private;

   --  Report an error message.
   overriding
   procedure Error (Console : in out Console_Type;
                    Message : in String);

   --  Report a notice message.
   overriding
   procedure Notice (Console : in out Console_Type;
                     Kind    : in Notice_Type;
                     Message : in String);

   --  Print the field value for the given field.
   overriding
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in String;
                          Justify : in Justify_Type := J_LEFT);

   --  Print the title for the given field.
   overriding
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String);

   --  Start a new title in a report.
   overriding
   procedure Start_Title (Console : in out Console_Type);

   --  Finish a new title in a report.
   procedure End_Title (Console : in out Console_Type);

   --  Start a new row in a report.
   overriding
   procedure Start_Row (Console : in out Console_Type);

   --  Finish a new row in a report.
   overriding
   procedure End_Row (Console : in out Console_Type);

private

   type Console_Type is new Util.Commands.Consoles.Console_Type with record
      File : Ada.Text_IO.File_Type;
   end record;

end Util.Commands.Consoles.Text;

Fix header style

Fix header style


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

with Ada.Text_IO;
with Ada.Strings;
with Ada.Strings.Fixed;
with Ada.Strings.Maps;

with Ahven.Runner;

with Ahven_Compat;
with Ahven.AStrings;

package body Ahven.XML_Runner is
   use Ada.Text_IO;
   use Ada.Strings.Fixed;
   use Ada.Strings.Maps;

   use Ahven.Results;
   use Ahven.Framework;
   use Ahven.AStrings;

   function Filter_String (Str : String) return String;

   function Filter_String
     (Str : String;
      Map : Character_Mapping)
      return String;

   procedure Print_Test_Pass (File : File_Type;
                              Parent_Test : String;
                              Info : Result_Info);
   procedure Print_Test_Failure (File : File_Type;
                                 Parent_Test : String;
                                 Info : Result_Info);
   procedure Print_Test_Error (File : File_Type;
                               Parent_Test : String;
                               Info : Result_Info);

   procedure Print_Test_Case (Collection : Result_Collection;
                              Dir : String);

   procedure Print_Log_File (File : File_Type; Filename : String);

   procedure Print_Attribute (File : File_Type; Attr : String;
                              Value : String);

   procedure Start_Testcase_Tag (File : File_Type;
                                 Parent : String; Name : String;
                                 Execution_Time : String);

   procedure End_Testcase_Tag (File : File_Type);

   function Create_Name (Dir : String; Name : String) return String;

   function Filter_String (Str : String) return String is
      Result : String (Str'First .. Str'First + 6 * Str'Length);
      Pos    : Natural := Str'First;
   begin
      for I in Str'Range loop
         if Str (I) = ''' then
            Result (Pos .. Pos + 6 - 1) := "'";
            Pos := Pos + 6;
         elsif Str (I) = '<' then
            Result (Pos .. Pos + 4 - 1) := "<";
            Pos := Pos + 4;
         elsif Str (I) = '>' then
            Result (Pos .. Pos + 4 - 1) := ">";
            Pos := Pos + 4;
         elsif Str (I) = '&' then
            Result (Pos .. Pos + 5 - 1) := "&";
            Pos := Pos + 5;
         elsif Str (I) = '"' then
            Result (Pos) := ''';
            Pos := Pos + 1;
         else
            Result (Pos) := Str (I);
            Pos := Pos + 1;
         end if;
      end loop;

      return Result (Result'First .. Pos - 1);
   end Filter_String;

   function Filter_String
     (Str : String;
      Map : Character_Mapping)
      return String
   is
   begin
      return Translate (Source  => Str,
                        Mapping => Map);
   end Filter_String;

   procedure Print_Attribute (File : File_Type; Attr : String;
                              Value : String) is
   begin
      Put (File, Attr & "=" & '"' & Value & '"');
   end Print_Attribute;

   procedure Start_Testcase_Tag (File : File_Type;
                                 Parent : String; Name : String;
                                 Execution_Time : String) is
   begin
      Put (File, "<testcase ");
      Print_Attribute (File, "classname", Filter_String (Parent));
      Put (File, " ");
      Print_Attribute (File, "name", Filter_String (Name));
      Put (File, " ");
      Print_Attribute (File, "time", Filter_String (Execution_Time));
      Put_Line (File, ">");
   end Start_Testcase_Tag;

   procedure End_Testcase_Tag (File : File_Type) is
   begin
      Put_Line (File, "</testcase>");
   end End_Testcase_Tag;

   function Create_Name (Dir : String; Name : String) return String
   is
      function Filename (Test : String) return String is
         Map : Ada.Strings.Maps.Character_Mapping;
      begin
         Map := To_Mapping (From => " '/\<>:|?*()" & '"',
                            To   => "-___________" & '_');

         return "TEST-" & Filter_String (Test, Map) & ".xml";
      end Filename;
   begin
      if Dir'Length > 0 then
         return Dir & Ahven_Compat.Directory_Separator & Filename (Name);
      else
         return Filename (Name);
      end if;
   end Create_Name;

   procedure Print_Test_Pass (File : File_Type;
                              Parent_Test : String;
                              Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      if Length (Get_Output_File (Info)) > 0 then
         Put (File, "<system-out>");
         Print_Log_File (File, To_String (Get_Output_File (Info)));
         Put_Line (File, "</system-out>");
      end if;
      End_Testcase_Tag (File);
   end Print_Test_Pass;

   procedure Print_Test_Skipped (File : File_Type;
                                 Parent_Test : String;
                                 Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      Put (File, "<skipped ");

      Print_Attribute (File, "message",
                       Filter_String (Trim (Get_Message (Info), Ada.Strings.Both)));
      Put (File, ">");
      Put_Line (File, Get_Message (Info));
      Put_Line (File, "</skipped>");
      End_Testcase_Tag (File);
   end Print_Test_Skipped;

   procedure Print_Test_Failure (File : File_Type;
                                 Parent_Test : String;
                                 Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      Put (File, "<failure ");
      Print_Attribute (File, "type",
                       Filter_String (Trim (Get_Message (Info), Ada.Strings.Both)));
      Put (File, ">");
      Put_Line (File, Get_Message (Info));
      Put_Line (File, "</failure>");
      if Length (Get_Output_File (Info)) > 0 then
         Put (File, "<system-out>");
         Print_Log_File (File, To_String (Get_Output_File (Info)));
         Put_Line (File, "</system-out>");
      end if;
      End_Testcase_Tag (File);
   end Print_Test_Failure;

   procedure Print_Test_Error (File : File_Type;
                               Parent_Test : String;
                               Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      Put (File, "<error ");
      Print_Attribute (File, "type",
        Trim (Get_Message (Info), Ada.Strings.Both));
      Put (File, ">");
      Put_Line (File, Get_Message (Info));
      Put_Line (File, "</error>");
      if Length (Get_Output_File (Info)) > 0 then
         Put (File, "<system-out>");
         Print_Log_File (File, To_String (Get_Output_File (Info)));
         Put_Line (File, "</system-out>");
      end if;
      End_Testcase_Tag (File);
   end Print_Test_Error;

   procedure Print_Test_Case (Collection : Result_Collection;
                              Dir : String) is
      procedure Print (Output : File_Type;
                       Result : Result_Collection);
      -- Internal procedure to print the testcase into given file.

      function Img (Value : Natural) return String is
      begin
         return Trim (Natural'Image (Value), Ada.Strings.Both);
      end Img;

      procedure Print (Output : File_Type;
                       Result : Result_Collection) is
         Position : Result_Info_Cursor;
      begin
         Put_Line (Output, "<?xml version=" & '"' & "1.0" & '"' &
                   " encoding=" & '"' & "iso-8859-1" & '"' &
                   "?>");
         Put (Output, "<testsuite ");
         Print_Attribute (Output, "errors", Img (Error_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "failures", Img (Failure_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "skips", Img (Skipped_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "tests", Img (Test_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "time",
           Trim (Duration'Image (Get_Execution_Time (Result)),
                 Ada.Strings.Both));
         Put (Output, " ");
         Print_Attribute (Output,
           "name", To_String (Get_Test_Name (Result)));
         Put_Line (Output, ">");

         Position := First_Error (Result);
         Error_Loop:
         loop
            exit Error_Loop when not Is_Valid (Position);
            Print_Test_Error (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Error_Loop;

         Position := First_Failure (Result);
         Failure_Loop:
         loop
            exit Failure_Loop when not Is_Valid (Position);
            Print_Test_Failure (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Failure_Loop;

         Position := First_Pass (Result);
         Pass_Loop:
         loop
            exit Pass_Loop when not Is_Valid (Position);
            Print_Test_Pass (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Pass_Loop;

         Position := First_Skipped (Result);
         Skip_Loop:
         loop
            exit Skip_Loop when not Is_Valid (Position);

            Print_Test_Skipped (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Skip_Loop;

         Put_Line (Output, "</testsuite>");
      end Print;

      File : File_Type;
   begin
      if Dir = "-" then
         Print (Standard_Output, Collection);
      else
         Create (File => File, Mode => Ada.Text_IO.Out_File,
           Name => Create_Name (Dir, To_String (Get_Test_Name (Collection))));
         Print (File, Collection);
         Ada.Text_IO.Close (File);
      end if;
   end Print_Test_Case;

   procedure Report_Results (Result : Result_Collection;
                             Dir    : String) is
      Position : Result_Collection_Cursor;
   begin
      Position := First_Child (Result);
      loop
         exit when not Is_Valid (Position);
         if Child_Depth (Data (Position).all) = 0 then
            Print_Test_Case (Data (Position).all, Dir);
         else
            Report_Results (Data (Position).all, Dir);

            -- Handle the test cases in this collection
            if Direct_Test_Count (Result) > 0 then
               Print_Test_Case (Result, Dir);
            end if;
         end if;
         Position := Next (Position);
      end loop;
   end Report_Results;

   -- Print the log by placing the data inside CDATA block.
   procedure Print_Log_File (File : File_Type; Filename : String) is
      type CData_End_State is (NONE, FIRST_BRACKET, SECOND_BRACKET);

      function State_Change (Old_State : CData_End_State)
        return CData_End_State;

      Handle : File_Type;
      Char   : Character := ' ';
      First  : Boolean := True;

      -- We need to escape ]]>, this variable tracks
      -- the characters, so we know when to do the escaping.
      CData_Ending : CData_End_State := NONE;

      function State_Change (Old_State : CData_End_State)
        return CData_End_State
      is
         New_State : CData_End_State := NONE;
         -- By default New_State will be NONE, so there is
         -- no need to set it inside when blocks.
      begin
         case Old_State is
            when NONE =>
               if Char = ']' then
                  New_State := FIRST_BRACKET;
               end if;
            when FIRST_BRACKET =>
               if Char = ']' then
                  New_State := SECOND_BRACKET;
               end if;
            when SECOND_BRACKET =>
               if Char = '>' then
                  Put (File, " ");
               end if;
         end case;
         return New_State;
      end State_Change;
   begin
      Open (Handle, In_File, Filename);
      loop
         exit when End_Of_File (Handle);
         Get (Handle, Char);
         if First then
            Put (File, "<![CDATA[");
            First := False;
         end if;
         CData_Ending := State_Change (CData_Ending);

         Put (File, Char);
         if End_Of_Line (Handle) then
            New_Line (File);
         end if;
      end loop;

      Close (Handle);
      if not First then
         Put_Line (File, "]]>");
      end if;
   end Print_Log_File;

   procedure Do_Report (Test_Results : Results.Result_Collection;
                        Args         : Parameters.Parameter_Info) is
   begin
      Report_Results (Test_Results,
                      Parameters.Result_Dir (Args));
   end Do_Report;

   procedure Run (Suite : in out Framework.Test_Suite'Class) is
   begin
      Runner.Run_Suite (Suite, Do_Report'Access);
   end Run;

   procedure Run (Suite : Framework.Test_Suite_Access) is
   begin
      Run (Suite.all);
   end Run;
end Ahven.XML_Runner;

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

with Ada.Text_IO;
with Ada.Strings;
with Ada.Strings.Fixed;
with Ada.Strings.Maps;

with Ahven.Runner;

with Ahven_Compat;
with Ahven.AStrings;

package body Ahven.XML_Runner is
   use Ada.Text_IO;
   use Ada.Strings.Fixed;
   use Ada.Strings.Maps;

   use Ahven.Results;
   use Ahven.Framework;
   use Ahven.AStrings;

   function Filter_String (Str : String) return String;

   function Filter_String
     (Str : String;
      Map : Character_Mapping)
      return String;

   procedure Print_Test_Pass (File : File_Type;
                              Parent_Test : String;
                              Info : Result_Info);
   procedure Print_Test_Failure (File : File_Type;
                                 Parent_Test : String;
                                 Info : Result_Info);
   procedure Print_Test_Error (File : File_Type;
                               Parent_Test : String;
                               Info : Result_Info);

   procedure Print_Test_Case (Collection : Result_Collection;
                              Dir : String);

   procedure Print_Log_File (File : File_Type; Filename : String);

   procedure Print_Attribute (File : File_Type; Attr : String;
                              Value : String);

   procedure Start_Testcase_Tag (File : File_Type;
                                 Parent : String; Name : String;
                                 Execution_Time : String);

   procedure End_Testcase_Tag (File : File_Type);

   function Create_Name (Dir : String; Name : String) return String;

   function Filter_String (Str : String) return String is
      Result : String (Str'First .. Str'First + 6 * Str'Length);
      Pos    : Natural := Str'First;
   begin
      for I in Str'Range loop
         if Str (I) = ''' then
            Result (Pos .. Pos + 6 - 1) := "'";
            Pos := Pos + 6;
         elsif Str (I) = '<' then
            Result (Pos .. Pos + 4 - 1) := "<";
            Pos := Pos + 4;
         elsif Str (I) = '>' then
            Result (Pos .. Pos + 4 - 1) := ">";
            Pos := Pos + 4;
         elsif Str (I) = '&' then
            Result (Pos .. Pos + 5 - 1) := "&";
            Pos := Pos + 5;
         elsif Str (I) = '"' then
            Result (Pos) := ''';
            Pos := Pos + 1;
         else
            Result (Pos) := Str (I);
            Pos := Pos + 1;
         end if;
      end loop;

      return Result (Result'First .. Pos - 1);
   end Filter_String;

   function Filter_String
     (Str : String;
      Map : Character_Mapping)
      return String
   is
   begin
      return Translate (Source  => Str,
                        Mapping => Map);
   end Filter_String;

   procedure Print_Attribute (File : File_Type; Attr : String;
                              Value : String) is
   begin
      Put (File, Attr & "=" & '"' & Value & '"');
   end Print_Attribute;

   procedure Start_Testcase_Tag (File : File_Type;
                                 Parent : String; Name : String;
                                 Execution_Time : String) is
   begin
      Put (File, "<testcase ");
      Print_Attribute (File, "classname", Filter_String (Parent));
      Put (File, " ");
      Print_Attribute (File, "name", Filter_String (Name));
      Put (File, " ");
      Print_Attribute (File, "time", Filter_String (Execution_Time));
      Put_Line (File, ">");
   end Start_Testcase_Tag;

   procedure End_Testcase_Tag (File : File_Type) is
   begin
      Put_Line (File, "</testcase>");
   end End_Testcase_Tag;

   function Create_Name (Dir : String; Name : String) return String
   is
      function Filename (Test : String) return String is
         Map : Ada.Strings.Maps.Character_Mapping;
      begin
         Map := To_Mapping (From => " '/\<>:|?*()" & '"',
                            To   => "-___________" & '_');

         return "TEST-" & Filter_String (Test, Map) & ".xml";
      end Filename;
   begin
      if Dir'Length > 0 then
         return Dir & Ahven_Compat.Directory_Separator & Filename (Name);
      else
         return Filename (Name);
      end if;
   end Create_Name;

   procedure Print_Test_Pass (File : File_Type;
                              Parent_Test : String;
                              Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      if Length (Get_Output_File (Info)) > 0 then
         Put (File, "<system-out>");
         Print_Log_File (File, To_String (Get_Output_File (Info)));
         Put_Line (File, "</system-out>");
      end if;
      End_Testcase_Tag (File);
   end Print_Test_Pass;

   procedure Print_Test_Skipped (File : File_Type;
                                 Parent_Test : String;
                                 Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      Put (File, "<skipped ");

      Print_Attribute (File, "message",
                       Filter_String (Trim (Get_Message (Info), Ada.Strings.Both)));
      Put (File, ">");
      Put_Line (File, Filter_String (Get_Message (Info)));
      Put_Line (File, "</skipped>");
      End_Testcase_Tag (File);
   end Print_Test_Skipped;

   procedure Print_Test_Failure (File : File_Type;
                                 Parent_Test : String;
                                 Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      Put (File, "<failure ");
      Print_Attribute (File, "type",
                       Filter_String (Trim (Get_Message (Info), Ada.Strings.Both)));
      Put (File, ">");
      Put_Line (File, Filter_String (Get_Message (Info)));
      Put_Line (File, "</failure>");
      if Length (Get_Output_File (Info)) > 0 then
         Put (File, "<system-out>");
         Print_Log_File (File, To_String (Get_Output_File (Info)));
         Put_Line (File, "</system-out>");
      end if;
      End_Testcase_Tag (File);
   end Print_Test_Failure;

   procedure Print_Test_Error (File : File_Type;
                               Parent_Test : String;
                               Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      Put (File, "<error ");
      Print_Attribute (File, "type",
                       Filter_String (Trim (Get_Message (Info), Ada.Strings.Both)));
      Put (File, ">");
      Put_Line (File, Filter_String (Get_Message (Info)));
      Put_Line (File, "</error>");
      if Length (Get_Output_File (Info)) > 0 then
         Put (File, "<system-out>");
         Print_Log_File (File, To_String (Get_Output_File (Info)));
         Put_Line (File, "</system-out>");
      end if;
      End_Testcase_Tag (File);
   end Print_Test_Error;

   procedure Print_Test_Case (Collection : Result_Collection;
                              Dir : String) is
      procedure Print (Output : File_Type;
                       Result : Result_Collection);
      -- Internal procedure to print the testcase into given file.

      function Img (Value : Natural) return String is
      begin
         return Trim (Natural'Image (Value), Ada.Strings.Both);
      end Img;

      procedure Print (Output : File_Type;
                       Result : Result_Collection) is
         Position : Result_Info_Cursor;
      begin
         Put_Line (Output, "<?xml version=" & '"' & "1.0" & '"' &
                   " encoding=" & '"' & "iso-8859-1" & '"' &
                   "?>");
         Put (Output, "<testsuite ");
         Print_Attribute (Output, "errors", Img (Error_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "failures", Img (Failure_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "skips", Img (Skipped_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "tests", Img (Test_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "time",
           Trim (Duration'Image (Get_Execution_Time (Result)),
                 Ada.Strings.Both));
         Put (Output, " ");
         Print_Attribute (Output,
           "name", To_String (Get_Test_Name (Result)));
         Put_Line (Output, ">");

         Position := First_Error (Result);
         Error_Loop:
         loop
            exit Error_Loop when not Is_Valid (Position);
            Print_Test_Error (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Error_Loop;

         Position := First_Failure (Result);
         Failure_Loop:
         loop
            exit Failure_Loop when not Is_Valid (Position);
            Print_Test_Failure (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Failure_Loop;

         Position := First_Pass (Result);
         Pass_Loop:
         loop
            exit Pass_Loop when not Is_Valid (Position);
            Print_Test_Pass (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Pass_Loop;

         Position := First_Skipped (Result);
         Skip_Loop:
         loop
            exit Skip_Loop when not Is_Valid (Position);

            Print_Test_Skipped (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Skip_Loop;

         Put_Line (Output, "</testsuite>");
      end Print;

      File : File_Type;
   begin
      if Dir = "-" then
         Print (Standard_Output, Collection);
      else
         Create (File => File, Mode => Ada.Text_IO.Out_File,
           Name => Create_Name (Dir, To_String (Get_Test_Name (Collection))));
         Print (File, Collection);
         Ada.Text_IO.Close (File);
      end if;
   end Print_Test_Case;

   procedure Report_Results (Result : Result_Collection;
                             Dir    : String) is
      Position : Result_Collection_Cursor;
   begin
      Position := First_Child (Result);
      loop
         exit when not Is_Valid (Position);
         if Child_Depth (Data (Position).all) = 0 then
            Print_Test_Case (Data (Position).all, Dir);
         else
            Report_Results (Data (Position).all, Dir);

            -- Handle the test cases in this collection
            if Direct_Test_Count (Result) > 0 then
               Print_Test_Case (Result, Dir);
            end if;
         end if;
         Position := Next (Position);
      end loop;
   end Report_Results;

   -- Print the log by placing the data inside CDATA block.
   procedure Print_Log_File (File : File_Type; Filename : String) is
      type CData_End_State is (NONE, FIRST_BRACKET, SECOND_BRACKET);

      function State_Change (Old_State : CData_End_State)
        return CData_End_State;

      Handle : File_Type;
      Char   : Character := ' ';
      First  : Boolean := True;

      -- We need to escape ]]>, this variable tracks
      -- the characters, so we know when to do the escaping.
      CData_Ending : CData_End_State := NONE;

      function State_Change (Old_State : CData_End_State)
        return CData_End_State
      is
         New_State : CData_End_State := NONE;
         -- By default New_State will be NONE, so there is
         -- no need to set it inside when blocks.
      begin
         case Old_State is
            when NONE =>
               if Char = ']' then
                  New_State := FIRST_BRACKET;
               end if;
            when FIRST_BRACKET =>
               if Char = ']' then
                  New_State := SECOND_BRACKET;
               end if;
            when SECOND_BRACKET =>
               if Char = '>' then
                  Put (File, " ");
               end if;
         end case;
         return New_State;
      end State_Change;
   begin
      Open (Handle, In_File, Filename);
      loop
         exit when End_Of_File (Handle);
         Get (Handle, Char);
         if First then
            Put (File, "<![CDATA[");
            First := False;
         end if;
         CData_Ending := State_Change (CData_Ending);

         Put (File, Char);
         if End_Of_Line (Handle) then
            New_Line (File);
         end if;
      end loop;

      Close (Handle);
      if not First then
         Put_Line (File, "]]>");
      end if;
   end Print_Log_File;

   procedure Do_Report (Test_Results : Results.Result_Collection;
                        Args         : Parameters.Parameter_Info) is
   begin
      Report_Results (Test_Results,
                      Parameters.Result_Dir (Args));
   end Do_Report;

   procedure Run (Suite : in out Framework.Test_Suite'Class) is
   begin
      Runner.Run_Suite (Suite, Do_Report'Access);
   end Run;

   procedure Run (Suite : Framework.Test_Suite_Access) is
   begin
      Run (Suite.all);
   end Run;
end Ahven.XML_Runner;

Fix other issues when a message contains unclosed XML entities.


-----------------------------------------------------------------------
--  ADO Sequences -- Database sequence generator
--  Copyright (C) 2009, 2010, 2011, 2012, 2015, 2017, 2018 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.Exceptions;
with Ada.Calendar;

with ADO.Statements;
with ADO.Objects;
with ADO.Sessions;
with ADO.Utils;
with Regtests;

with Regtests.Simple.Model;
with Regtests.Images.Model;

with Util.Assertions;
with Util.Measures;
with Util.Log;
with Util.Log.Loggers;
with Util.Beans.Objects;
with Util.Test_Caller;

package body ADO.Tests is

   use Ada.Exceptions;
   use ADO.Statements;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ADO.Tests");

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

   procedure Assert_Has_Message (T : in Test;
                                 E : in Exception_Occurrence);

   procedure Assert_Has_Message (T : in Test;
                                 E : in Exception_Occurrence) is
      Message : constant String := Exception_Message (E);
   begin
      Log.Info ("Exception: {0}", Message);
      T.Assert (Message'Length > 0,
                "Exception " & Exception_Name (E) & " does not have any message");
   end Assert_Has_Message;

   procedure Set_Up (T : in out Test) is
   begin
      null;
   end Set_Up;

   --  ------------------------------
   --  Check:
   --     Object_Ref.Load
   --     Object_Ref.Is_Null
   --  ------------------------------
   procedure Test_Load (T : in out Test) is

      DB  : ADO.Sessions.Session := Regtests.Get_Database;

      Object : Regtests.Simple.Model.User_Ref;
   begin
      T.Assert (Object.Is_Null, "Object_Ref.Is_Null: Empty object must be null");

      Object.Load (DB, -1);
      T.Assert (False, "Object_Ref.Load: Load must raise NOT_FOUND exception");

   exception
      when ADO.Objects.NOT_FOUND =>
         T.Assert (Object.Is_Null, "Object_Ref.Load: Must not change the object");
   end Test_Load;

   --  ------------------------------
   --  Check:
   --    Object_Ref.Load
   --    Object_Ref.Save
   --    <Model>.Set_xxx (Unbounded_String)
   --    <Model>.Create
   --  ------------------------------
   procedure Test_Create_Load (T : in out Test) is

      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;

      Object : Regtests.Simple.Model.User_Ref;
      Check  : Regtests.Simple.Model.User_Ref;
   begin
      --  Initialize and save an object
      Object.Set_Name ("A simple test name");
      Object.Save (DB);

      T.Assert (Object.Get_Id > 0, "Saving an object did not allocate an identifier");

      --  Load the object
      Check.Load (DB, Object.Get_Id);
      T.Assert (not Check.Is_Null, "Object_Ref.Load: Loading the object failed");
   end Test_Create_Load;

   --  ------------------------------
   --  Check:
   --    Various error checks on database connections
   --
   --    Master_Connection.Rollback
   --  ------------------------------
   procedure Test_Not_Open (T : in out Test) is
      DB : ADO.Sessions.Master_Session;
   begin
      begin
         DB.Rollback;
         T.Fail ("Master_Connection.Rollback should raise an exception");

      exception
         when E : ADO.Sessions.Session_Error =>
            Assert_Has_Message (T, E);
      end;

      begin
         DB.Commit;
         T.Fail ("Master_Connection.Commit should raise an exception");

      exception
         when E : ADO.Sessions.Session_Error =>
            Assert_Has_Message (T, E);
      end;

   end Test_Not_Open;

   --  ------------------------------
   --  Check id generation
   --  ------------------------------
   procedure Test_Allocate (T : in out Test) is
      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Key    : ADO.Objects.Object_Key (Of_Type => ADO.Objects.KEY_INTEGER,
                                       Of_Class => Regtests.Simple.Model.ALLOCATE_TABLE);
      PrevId : Identifier := NO_IDENTIFIER;
      S      : Util.Measures.Stamp;
   begin
      for I in 1 .. 200 loop
         declare
            Obj : Regtests.Simple.Model.Allocate_Ref;
         begin
            Obj.Save (DB);
            Key := Obj.Get_Key;
            if PrevId /= NO_IDENTIFIER then
               T.Assert (Objects.Get_Value (Key) = PrevId + 1, "Invalid allocated identifier: "
                         & Objects.To_String (Key) & " previous=" & Identifier'Image (PrevId));
            end if;
            PrevId := Objects.Get_Value (Key);
         end;
      end loop;
      Util.Measures.Report (S, "Allocate 200 ids");
   end Test_Allocate;

   --  ------------------------------
   --  Check:
   --    Object.Save (with creation)
   --    Object.Find
   --    Object.Save (update)
   --  ------------------------------
   procedure Test_Create_Save (T : in out Test) is
      use type ADO.Sessions.Connection_Status;

      DB   : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Ref  : Regtests.Simple.Model.Allocate_Ref;
      Ref2 : Regtests.Simple.Model.Allocate_Ref;
   begin
      T.Assert (DB.Get_Status = ADO.Sessions.OPEN,
                "The database connection is open");

      Ref.Set_Name ("Testing the allocation");
      Ref.Save (DB);
      T.Assert (Ref.Get_Id > 0, "Object must have an id");

      Ref.Set_Name ("Testing the allocation: update");
      Ref.Save (DB);

      Ref2.Load (DB, Ref.Get_Id);

   end Test_Create_Save;

   --  ------------------------------
   --  Check:
   --    Object.Save (with creation)
   --  ------------------------------
   procedure Test_Perf_Create_Save (T : in out Test) is
      DB : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      S  : Util.Measures.Stamp;
   begin
      DB.Begin_Transaction;
      for I in 1 .. 1_000 loop
         declare
            Ref  : Regtests.Simple.Model.Allocate_Ref;
         begin
            Ref.Set_Name ("Testing the allocation");
            Ref.Save (DB);
            T.Assert (Ref.Get_Id > 0, "Object must have an id");
         end;
      end loop;
      DB.Commit;
      Util.Measures.Report (S, "Create 1000 rows");
   end Test_Perf_Create_Save;

   procedure Test_Delete_All (T : in out Test) is

      DB : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Stmt : ADO.Statements.Delete_Statement
        := DB.Create_Statement (Regtests.Simple.Model.ALLOCATE_TABLE);
      Result : Natural;
   begin
      DB.Begin_Transaction;
      Stmt.Execute (Result);
      Log.Info ("Deleted {0} rows", Natural'Image (Result));
      DB.Commit;

      T.Assert (Result > 100, "Too few rows were deleted");
   end Test_Delete_All;

   --  ------------------------------
   --  Test string insert.
   --  ------------------------------
   procedure Test_String (T : in out Test) is
      use Ada.Strings.Unbounded;

      DB   : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      User : Regtests.Simple.Model.User_Ref;
      Usr2 : Regtests.Simple.Model.User_Ref;
      Name : Nullable_String;
   begin
      Name.Is_Null := False;
      for I in 1 .. 127 loop
         Append (Name.Value, Character'Val (I));
      end loop;
      Append (Name.Value, ' ');
      Append (Name.Value, ' ');
      Append (Name.Value, ' ');
      Append (Name.Value, ' ');
      DB.Begin_Transaction;
      User.Set_Name (Name);
      User.Save (DB);
      DB.Commit;

      --  Check that we can load the image and the blob.
      Usr2.Load (DB, User.Get_Id);
      Util.Tests.Assert_Equals (T, To_String (Name.Value), String '(Usr2.Get_Name),
                                "Invalid name inserted for user");
   end Test_String;

   --  ------------------------------
   --  Test blob insert.
   --  ------------------------------
   procedure Test_Blob (T : in out Test) is
      use Ada.Streams;

      procedure Assert_Equals is
        new Util.Assertions.Assert_Equals_T (Ada.Streams.Stream_Element);

      DB   : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Img  : Regtests.Images.Model.Image_Ref;
      Size : constant Natural := 100;
      Data : ADO.Blob_Ref := ADO.Create_Blob (Size);
      Img2 : Regtests.Images.Model.Image_Ref;
   begin
      for I in 1 .. Size loop
         Data.Value.Data (Ada.Streams.Stream_Element_Offset (I)) := Integer'Pos ((64 + I) mod 255);
      end loop;
      DB.Begin_Transaction;
      Img.Set_Image (Data);
      Img.Set_Create_Date (Ada.Calendar.Clock);
      Img.Save (DB);
      DB.Commit;

      --  Check that we can load the image and the blob.
      Img2.Load (DB, Img.Get_Id);
      T.Assert (Img2.Get_Image.Is_Null = False, "No image blob loaded");

      --  And verify that the blob data matches what we inserted.
      Util.Tests.Assert_Equals (T, Size, Integer (Img2.Get_Image.Value.Len),
                                "Invalid blob length");
      for I in 1 .. Data.Value.Len loop
         Assert_Equals (T, Data.Value.Data (I), Img2.Get_Image.Value.Data (I),
                        "Invalid blob content at " & Stream_Element_Offset'Image (I));
      end loop;

      --  Create a blob initialized with a file content.
      Data := ADO.Create_Blob ("Makefile");
      T.Assert (not Data.Is_Null, "Null blob returned by Create_Blob");
      T.Assert (Data.Value.Len > 100, "Blob length initialized from file is too small");

      declare
         Content : Ada.Streams.Stream_Element_Array (1 .. 10);
         Img3    : Regtests.Images.Model.Image_Ref;
      begin
         for I in Content'Range loop
            Content (I) := Ada.Streams.Stream_Element_Offset'Pos (I + 30);
         end loop;
         Data := ADO.Create_Blob (Content);
         T.Assert (not Data.Is_Null, "Null blob returned by Create_Blob (Stream_Element_Array)");
         T.Assert (Data.Value.Len = 10, "Blob length initialized from array is too small");

         DB.Begin_Transaction;
         Img3.Set_Image (Data);
         Img3.Set_Create_Date (Ada.Calendar.Clock);
         Img3.Save (DB);
         DB.Commit;

         --  Check that we can load the image and the blob.
         Img2.Load (DB, Img3.Get_Id);
         T.Assert (Img2.Get_Image.Is_Null = False, "No image blob loaded");

         Img2.Set_Image (ADO.Null_Blob);
         Img2.Save (DB);
         DB.Commit;
      end;
   end Test_Blob;

   --  ------------------------------
   --  Test the To_Object and To_Identifier operations.
   --  ------------------------------
   procedure Test_Identifier_To_Object (T : in out Test) is
      Val : Util.Beans.Objects.Object := ADO.Utils.To_Object (ADO.NO_IDENTIFIER);
   begin
      T.Assert (Util.Beans.Objects.Is_Null (Val),
                "To_Object must return null for ADO.NO_IDENTIFIER");
      T.Assert (ADO.Utils.To_Identifier (Val) = ADO.NO_IDENTIFIER,
                "To_Identifier must return ADO.NO_IDENTIFIER for null");
      Val := ADO.Utils.To_Object (1);
      T.Assert (not Util.Beans.Objects.Is_Null (Val),
                "To_Object must not return null for a valid Identifier");
      T.Assert (ADO.Utils.To_Identifier (Val) = 1,
                "To_Identifier must return the correct identifier");
   end Test_Identifier_To_Object;

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Object_Ref.Load", Test_Load'Access);
      Caller.Add_Test (Suite, "Test Object_Ref.Save", Test_Create_Load'Access);
      Caller.Add_Test (Suite, "Test Master_Connection init error", Test_Not_Open'Access);
      Caller.Add_Test (Suite, "Test Sequences.Factory", Test_Allocate'Access);
      Caller.Add_Test (Suite, "Test Object_Ref.Save/Create/Update",
                       Test_Create_Save'Access);
      Caller.Add_Test (Suite, "Test Object_Ref.Create (DB Insert)",
                       Test_Perf_Create_Save'Access);
      Caller.Add_Test (Suite, "Test Statement.Delete_Statement (delete all)",
                       Test_Delete_All'Access);
      Caller.Add_Test (Suite, "Test insert string",
                       Test_String'Access);
      Caller.Add_Test (Suite, "Test insert blob",
                       Test_Blob'Access);
      Caller.Add_Test (Suite, "Test ADO.Utils.To_Object/To_Identifier",
                       Test_Identifier_To_Object'Access);
   end Add_Tests;

end ADO.Tests;

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

with Ada.Exceptions;
with Ada.Calendar;

with ADO.Statements;
with ADO.Objects;
with ADO.Sessions;
with ADO.Utils;
with Regtests;

with Regtests.Simple.Model;
with Regtests.Images.Model;

with Util.Assertions;
with Util.Measures;
with Util.Log;
with Util.Log.Loggers;
with Util.Beans.Objects;
with Util.Test_Caller;

package body ADO.Tests is

   use Ada.Exceptions;
   use ADO.Statements;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ADO.Tests");

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

   procedure Assert_Has_Message (T : in Test;
                                 E : in Exception_Occurrence);

   procedure Assert_Has_Message (T : in Test;
                                 E : in Exception_Occurrence) is
      Message : constant String := Exception_Message (E);
   begin
      Log.Info ("Exception: {0}", Message);
      T.Assert (Message'Length > 0,
                "Exception " & Exception_Name (E) & " does not have any message");
   end Assert_Has_Message;

   procedure Set_Up (T : in out Test) is
   begin
      null;
   end Set_Up;

   --  ------------------------------
   --  Check:
   --     Object_Ref.Load
   --     Object_Ref.Is_Null
   --  ------------------------------
   procedure Test_Load (T : in out Test) is

      DB  : ADO.Sessions.Session := Regtests.Get_Database;

      Object : Regtests.Simple.Model.User_Ref;
   begin
      T.Assert (Object.Is_Null, "Object_Ref.Is_Null: Empty object must be null");

      Object.Load (DB, -1);
      T.Assert (False, "Object_Ref.Load: Load must raise NOT_FOUND exception");

   exception
      when ADO.Objects.NOT_FOUND =>
         T.Assert (Object.Is_Null, "Object_Ref.Load: Must not change the object");
   end Test_Load;

   --  ------------------------------
   --  Check:
   --    Object_Ref.Load
   --    Object_Ref.Save
   --    <Model>.Set_xxx (Unbounded_String)
   --    <Model>.Create
   --  ------------------------------
   procedure Test_Create_Load (T : in out Test) is

      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;

      Object : Regtests.Simple.Model.User_Ref;
      Check  : Regtests.Simple.Model.User_Ref;
   begin
      --  Initialize and save an object
      Object.Set_Name ("A simple test name");
      Object.Save (DB);

      T.Assert (Object.Get_Id > 0, "Saving an object did not allocate an identifier");

      --  Load the object
      Check.Load (DB, Object.Get_Id);
      T.Assert (not Check.Is_Null, "Object_Ref.Load: Loading the object failed");
   end Test_Create_Load;

   --  ------------------------------
   --  Check:
   --    Various error checks on database connections
   --
   --    Master_Connection.Rollback
   --  ------------------------------
   procedure Test_Not_Open (T : in out Test) is
      DB : ADO.Sessions.Master_Session;
   begin
      begin
         DB.Rollback;
         T.Fail ("Master_Connection.Rollback should raise an exception");

      exception
         when E : ADO.Sessions.Session_Error =>
            Assert_Has_Message (T, E);
      end;

      begin
         DB.Commit;
         T.Fail ("Master_Connection.Commit should raise an exception");

      exception
         when E : ADO.Sessions.Session_Error =>
            Assert_Has_Message (T, E);
      end;

   end Test_Not_Open;

   --  ------------------------------
   --  Check id generation
   --  ------------------------------
   procedure Test_Allocate (T : in out Test) is
      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Key    : ADO.Objects.Object_Key (Of_Type => ADO.Objects.KEY_INTEGER,
                                       Of_Class => Regtests.Simple.Model.ALLOCATE_TABLE);
      PrevId : Identifier := NO_IDENTIFIER;
      S      : Util.Measures.Stamp;
   begin
      for I in 1 .. 200 loop
         declare
            Obj : Regtests.Simple.Model.Allocate_Ref;
         begin
            Obj.Save (DB);
            Key := Obj.Get_Key;
            if PrevId /= NO_IDENTIFIER then
               T.Assert (Objects.Get_Value (Key) = PrevId + 1, "Invalid allocated identifier: "
                         & Objects.To_String (Key) & " previous=" & Identifier'Image (PrevId));
            end if;
            PrevId := Objects.Get_Value (Key);
         end;
      end loop;
      Util.Measures.Report (S, "Allocate 200 ids");
   end Test_Allocate;

   --  ------------------------------
   --  Check:
   --    Object.Save (with creation)
   --    Object.Find
   --    Object.Save (update)
   --  ------------------------------
   procedure Test_Create_Save (T : in out Test) is
      use type ADO.Sessions.Connection_Status;

      DB   : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Ref  : Regtests.Simple.Model.Allocate_Ref;
      Ref2 : Regtests.Simple.Model.Allocate_Ref;
   begin
      T.Assert (DB.Get_Status = ADO.Sessions.OPEN,
                "The database connection is open");

      Ref.Set_Name ("Testing the allocation");
      Ref.Save (DB);
      T.Assert (Ref.Get_Id > 0, "Object must have an id");

      Ref.Set_Name ("Testing the allocation: update");
      Ref.Save (DB);

      Ref2.Load (DB, Ref.Get_Id);

   end Test_Create_Save;

   --  ------------------------------
   --  Check:
   --    Object.Save (with creation)
   --  ------------------------------
   procedure Test_Perf_Create_Save (T : in out Test) is
      DB : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      S  : Util.Measures.Stamp;
   begin
      DB.Begin_Transaction;
      for I in 1 .. 1_000 loop
         declare
            Ref  : Regtests.Simple.Model.Allocate_Ref;
         begin
            Ref.Set_Name ("Testing the allocation");
            Ref.Save (DB);
            T.Assert (Ref.Get_Id > 0, "Object must have an id");
         end;
      end loop;
      DB.Commit;
      Util.Measures.Report (S, "Create 1000 rows");
   end Test_Perf_Create_Save;

   procedure Test_Delete_All (T : in out Test) is

      DB : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Stmt : ADO.Statements.Delete_Statement
        := DB.Create_Statement (Regtests.Simple.Model.ALLOCATE_TABLE);
      Result : Natural;
   begin
      DB.Begin_Transaction;
      Stmt.Execute (Result);
      Log.Info ("Deleted {0} rows", Natural'Image (Result));
      DB.Commit;

      T.Assert (Result > 100, "Too few rows were deleted");
   end Test_Delete_All;

   --  ------------------------------
   --  Test string insert.
   --  ------------------------------
   procedure Test_String (T : in out Test) is
      use Ada.Strings.Unbounded;

      DB   : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      User : Regtests.Simple.Model.User_Ref;
      Usr2 : Regtests.Simple.Model.User_Ref;
      Name : Nullable_String;
   begin
      Name.Is_Null := False;
      for I in 1 .. 127 loop
         Append (Name.Value, Character'Val (I));
      end loop;
      Append (Name.Value, ' ');
      Append (Name.Value, ' ');
      Append (Name.Value, ' ');
      Append (Name.Value, ' ');
      DB.Begin_Transaction;
      User.Set_Name (Name);
      User.Save (DB);
      DB.Commit;

      --  Check that we can load the image and the blob.
      Usr2.Load (DB, User.Get_Id);
      Util.Tests.Assert_Equals (T, To_String (Name.Value), String '(Usr2.Get_Name),
                                "Invalid name inserted for user");

      Usr2.Set_Name (ADO.Null_String);
      Usr2.Save (DB);

      User.Load (DB, Usr2.Get_Id);
      T.Assert (User.Get_Name.Is_Null, "Name must be null after save");
   end Test_String;

   --  ------------------------------
   --  Test blob insert.
   --  ------------------------------
   procedure Test_Blob (T : in out Test) is
      use Ada.Streams;

      procedure Assert_Equals is
        new Util.Assertions.Assert_Equals_T (Ada.Streams.Stream_Element);

      DB   : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Img  : Regtests.Images.Model.Image_Ref;
      Size : constant Natural := 100;
      Data : ADO.Blob_Ref := ADO.Create_Blob (Size);
      Img2 : Regtests.Images.Model.Image_Ref;
   begin
      for I in 1 .. Size loop
         Data.Value.Data (Ada.Streams.Stream_Element_Offset (I)) := Integer'Pos ((64 + I) mod 255);
      end loop;
      DB.Begin_Transaction;
      Img.Set_Image (Data);
      Img.Set_Create_Date (Ada.Calendar.Clock);
      Img.Save (DB);
      DB.Commit;

      --  Check that we can load the image and the blob.
      Img2.Load (DB, Img.Get_Id);
      T.Assert (Img2.Get_Image.Is_Null = False, "No image blob loaded");

      --  And verify that the blob data matches what we inserted.
      Util.Tests.Assert_Equals (T, Size, Integer (Img2.Get_Image.Value.Len),
                                "Invalid blob length");
      for I in 1 .. Data.Value.Len loop
         Assert_Equals (T, Data.Value.Data (I), Img2.Get_Image.Value.Data (I),
                        "Invalid blob content at " & Stream_Element_Offset'Image (I));
      end loop;

      --  Create a blob initialized with a file content.
      Data := ADO.Create_Blob ("Makefile");
      T.Assert (not Data.Is_Null, "Null blob returned by Create_Blob");
      T.Assert (Data.Value.Len > 100, "Blob length initialized from file is too small");

      declare
         Content : Ada.Streams.Stream_Element_Array (1 .. 10);
         Img3    : Regtests.Images.Model.Image_Ref;
      begin
         for I in Content'Range loop
            Content (I) := Ada.Streams.Stream_Element_Offset'Pos (I + 30);
         end loop;
         Data := ADO.Create_Blob (Content);
         T.Assert (not Data.Is_Null, "Null blob returned by Create_Blob (Stream_Element_Array)");
         T.Assert (Data.Value.Len = 10, "Blob length initialized from array is too small");

         DB.Begin_Transaction;
         Img3.Set_Image (Data);
         Img3.Set_Create_Date (Ada.Calendar.Clock);
         Img3.Save (DB);
         DB.Commit;

         --  Check that we can load the image and the blob.
         Img2.Load (DB, Img3.Get_Id);
         T.Assert (Img2.Get_Image.Is_Null = False, "No image blob loaded");

         Img2.Set_Image (ADO.Null_Blob);
         Img2.Save (DB);
         DB.Commit;
      end;
   end Test_Blob;

   --  ------------------------------
   --  Test the To_Object and To_Identifier operations.
   --  ------------------------------
   procedure Test_Identifier_To_Object (T : in out Test) is
      Val : Util.Beans.Objects.Object := ADO.Utils.To_Object (ADO.NO_IDENTIFIER);
   begin
      T.Assert (Util.Beans.Objects.Is_Null (Val),
                "To_Object must return null for ADO.NO_IDENTIFIER");
      T.Assert (ADO.Utils.To_Identifier (Val) = ADO.NO_IDENTIFIER,
                "To_Identifier must return ADO.NO_IDENTIFIER for null");
      Val := ADO.Utils.To_Object (1);
      T.Assert (not Util.Beans.Objects.Is_Null (Val),
                "To_Object must not return null for a valid Identifier");
      T.Assert (ADO.Utils.To_Identifier (Val) = 1,
                "To_Identifier must return the correct identifier");
   end Test_Identifier_To_Object;

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Object_Ref.Load", Test_Load'Access);
      Caller.Add_Test (Suite, "Test Object_Ref.Save", Test_Create_Load'Access);
      Caller.Add_Test (Suite, "Test Master_Connection init error", Test_Not_Open'Access);
      Caller.Add_Test (Suite, "Test Sequences.Factory", Test_Allocate'Access);
      Caller.Add_Test (Suite, "Test Object_Ref.Save/Create/Update",
                       Test_Create_Save'Access);
      Caller.Add_Test (Suite, "Test Object_Ref.Create (DB Insert)",
                       Test_Perf_Create_Save'Access);
      Caller.Add_Test (Suite, "Test Statement.Delete_Statement (delete all)",
                       Test_Delete_All'Access);
      Caller.Add_Test (Suite, "Test insert string",
                       Test_String'Access);
      Caller.Add_Test (Suite, "Test insert blob",
                       Test_Blob'Access);
      Caller.Add_Test (Suite, "Test ADO.Utils.To_Object/To_Identifier",
                       Test_Identifier_To_Object'Access);
   end Add_Tests;

end ADO.Tests;

Update Test_String to cover setting a string back to null


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

--  The <b>AWA.Applications.Configs</b> package reads the application configuration files.
package AWA.Applications.Configs is

   --  XML reader configuration.  By instantiating this generic package, the XML parser
   --  gets initialized to read the configuration for servlets, filters, managed beans,
   --  permissions, events and other configuration elements.
   generic
      Reader  : in out Util.Serialize.IO.XML.Parser;
      App     : in Application_Access;
      Context : in EL.Contexts.Default.Default_Context_Access;
   package Reader_Config is
   end Reader_Config;

   --  Read the application configuration file and configure the application
   procedure Read_Configuration (App     : in out Application'Class;
                                 File    : in String;
                                 Context : in EL.Contexts.Default.Default_Context_Access);

end AWA.Applications.Configs;

-----------------------------------------------------------------------
--  awa-applications-configs -- Read application configuration files
--  Copyright (C) 2011, 2012, 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 EL.Contexts.Default;
with Util.Serialize.IO.XML;

--  The <b>AWA.Applications.Configs</b> package reads the application configuration files.
package AWA.Applications.Configs is

   --  XML reader configuration.  By instantiating this generic package, the XML parser
   --  gets initialized to read the configuration for servlets, filters, managed beans,
   --  permissions, events and other configuration elements.
   generic
      Reader  : in out Util.Serialize.IO.XML.Parser;
      App     : in Application_Access;
      Context : in EL.Contexts.Default.Default_Context_Access;
      Override_Context : in Boolean;
   package Reader_Config is
   end Reader_Config;

   --  Read the application configuration file and configure the application
   procedure Read_Configuration (App     : in out Application'Class;
                                 File    : in String;
                                 Context : in EL.Contexts.Default.Default_Context_Access;
                                 Override_Context : in Boolean);

end AWA.Applications.Configs;

Add an Override_Context parameter for the Reader_Config package to allow or not overriding a <context-param> value


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

with AWA.Testsuite;

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

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

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

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

with AWA.Testsuite;

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

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

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

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