-----------------------------------------------------------------------
--  Security-oauth-servers-tests - Unit tests for server side OAuth
--  Copyright (C) 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 Util.Test_Caller;

with Security.Auth.Tests;
with Security.OAuth.File_Registry;
package body Security.OAuth.Servers.Tests is

   use Auth.Tests;
   use File_Registry;

   package Caller is new Util.Test_Caller (Test, "Security.OAuth.Servers");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Security.OAuth.Servers.Find_Application",
                       Test_Application_Manager'Access);
      Caller.Add_Test (Suite, "Test Security.OAuth.Servers.Verify",
                       Test_User_Verify'Access);
      Caller.Add_Test (Suite, "Test Security.OAuth.Servers.Token",
                       Test_Token_Password'Access);
      Caller.Add_Test (Suite, "Test Security.OAuth.Servers.Authenticate",
                       Test_Bad_Token'Access);
      Caller.Add_Test (Suite, "Test Security.OAuth.File_Registry.Load",
                       Test_Load_Registry'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test the application manager.
   --  ------------------------------
   procedure Test_Application_Manager (T : in out Test) is
      Manager : File_Application_Manager;
      App     : Application;
   begin
      App.Set_Application_Identifier ("my-app-id");
      App.Set_Application_Secret ("my-secret");
      App.Set_Application_Callback ("my-callback");
      Manager.Add_Application (App);

      --  Check that we can find our application.
      declare
         A : constant Application'Class := Manager.Find_Application ("my-app-id");
      begin
         Util.Tests.Assert_Equals (T, "my-app-id", A.Get_Application_Identifier,
                                   "Invalid application returned by Find");
      end;

      --  Check that an exception is raised for an invalid client ID.
      begin
         declare
            A : constant Application'Class := Manager.Find_Application ("unkown-app-id");
         begin
            Util.Tests.Fail (T, "Found the application " & A.Get_Application_Identifier);
         end;

      exception
         when Invalid_Application =>
            null;
      end;
   end Test_Application_Manager;

   --  ------------------------------
   --  Test the user registration and verification.
   --  ------------------------------
   procedure Test_User_Verify (T : in out Test) is
      Manager : File_Realm_Manager;
      Auth    : Principal_Access;
   begin
      Manager.Add_User ("Gandalf", "Mithrandir");
      Manager.Verify ("Gandalf", "mithrandir", Auth);
      T.Assert (Auth = null, "Verify password should fail with an invalid password");

      Manager.Verify ("Sauron", "Mithrandir", Auth);
      T.Assert (Auth = null, "Verify password should fail with an invalid user");

      Manager.Verify ("Gandalf", "Mithrandir", Auth);
      T.Assert (Auth /= null, "Verify password operation failed for a good user/password");
   end Test_User_Verify;

   --  ------------------------------
   --  Test the token operation that produces an access token from user/password.
   --  RFC 6749: Section 4.3.  Resource Owner Password Credentials Grant
   --  ------------------------------
   procedure Test_Token_Password (T : in out Test) is
      use type Util.Strings.Name_Access;

      Apps       : aliased File_Application_Manager;
      Realm      : aliased File_Realm_Manager;
      Manager    : Auth_Manager;
      App        : Application;
      Grant      : Grant_Type;
      Auth_Grant : Grant_Type;
      Params     : Test_Parameters;
   begin
      --  Add one test application.
      App.Set_Application_Identifier ("my-app-id");
      App.Set_Application_Secret ("my-secret");
      App.Set_Application_Callback ("my-callback");
      Apps.Add_Application (App);

      --  Add one test user.
      Realm.Add_User ("Gandalf", "Mithrandir");

      --  Configure the auth manager.
      Manager.Set_Application_Manager (Apps'Unchecked_Access);
      Manager.Set_Realm_Manager (Realm'Unchecked_Access);
      Manager.Set_Private_Key ("server-private-key-no-so-secure");

      Manager.Token (Params, Grant);
      T.Assert (Grant.Status = Invalid_Grant, "Expecting Invalid_Grant when client_id is missing");

      Params.Set_Parameter (Security.OAuth.CLIENT_ID, "");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Status = Invalid_Grant, "Expecting Invalid_Grant when client_id is empty");

      Params.Set_Parameter (Security.OAuth.CLIENT_ID, "unkown-app");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Status = Invalid_Grant, "Expecting Invalid_Grant when client_id is invalid");

      Params.Set_Parameter (Security.OAuth.CLIENT_ID, "my-app-id");
      Params.Set_Parameter (Security.OAuth.GRANT_TYPE, "");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant when client_id is empty");

      Params.Set_Parameter (Security.OAuth.GRANT_TYPE, "password");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Request = Password_Grant,
                "Expecting Password_Grant for the grant request");
      T.Assert (Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant when the user/password is missing");

      Params.Set_Parameter (Security.OAuth.USERNAME, "Gandalf");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Request = Password_Grant,
                "Expecting Password_Grant for the grant request");
      T.Assert (Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant when the password is missing");

      Params.Set_Parameter (Security.OAuth.PASSWORD, "test");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Request = Password_Grant,
                "Expecting Password_Grant for the grant request");
      T.Assert (Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant when the password is invalid");

      Params.Set_Parameter (Security.OAuth.PASSWORD, "Mithrandir");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Request = Password_Grant,
                "Expecting Password_Grant for the grant request");
      T.Assert (Grant.Status = Valid_Grant,
                "Expecting Valid_Grant when the user/password are correct");
      T.Assert (Grant.Error = null, "Expecting null error");
      T.Assert (Length (Grant.Token) > 20,
                "Expecting a token with some reasonable size");
      T.Assert (Grant.Auth /= null,
                "Expecting a non null auth principal");
      Util.Tests.Assert_Equals (T, "Gandalf", Grant.Auth.Get_Name,
                                "Invalid user name in the principal");

      --  Verify the access token.
      for I in 1 .. 5 loop
         Manager.Authenticate (To_String (Grant.Token), Auth_Grant);
         T.Assert (Auth_Grant.Request = Access_Grant,
                   "Expecting Access_Grant for the authenticate");
         T.Assert (Auth_Grant.Status = Valid_Grant,
                   "Expecting Valid_Grant when the access token is checked");
         T.Assert (Auth_Grant.Error = null, "Expecting null error for access_token");
         T.Assert (Auth_Grant.Auth = Grant.Auth, "Expecting valid auth principal");
      end loop;

      --  Verify the modified access token.
      Manager.Authenticate (To_String (Grant.Token) & "x", Auth_Grant);
      T.Assert (Auth_Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant for the authenticate");

      Manager.Revoke (To_String (Grant.Token));

      --  Verify the access is now denied.
      for I in 1 .. 5 loop
         Manager.Authenticate (To_String (Grant.Token), Auth_Grant);
         T.Assert (Auth_Grant.Status = Revoked_Grant,
                   "Expecting Revoked_Grant for the authenticate");
      end loop;

      --  Change application token expiration time to 1 second.
      App.Expire_Timeout := 1.0;
      Apps.Add_Application (App);

      --  Make the access token.
      Manager.Token (Params, Grant);
      T.Assert (Grant.Status = Valid_Grant,
                "Expecting Valid_Grant when the user/password are correct");

      --  Verify the access token.
      for I in 1 .. 5 loop
         Manager.Authenticate (To_String (Grant.Token), Auth_Grant);
         T.Assert (Auth_Grant.Request = Access_Grant,
                   "Expecting Access_Grant for the authenticate");
         T.Assert (Auth_Grant.Status = Valid_Grant,
                   "Expecting Valid_Grant when the access token is checked");
         T.Assert (Auth_Grant.Error = null,
                   "Expecting null error for access_token");
         T.Assert (Auth_Grant.Auth = Grant.Auth,
                   "Expecting valid auth principal");
      end loop;

      --  Wait for the token to expire.
      delay 2.0;
      for I in 1 .. 5 loop
         Manager.Authenticate (To_String (Grant.Token), Auth_Grant);
         T.Assert (Auth_Grant.Status = Expired_Grant,
                   "Expecting Expired when the access token is checked");
      end loop;

   end Test_Token_Password;

   --  ------------------------------
   --  Test the access token validation with invalid tokens (bad formed).
   --  ------------------------------
   procedure Test_Bad_Token (T : in out Test) is
      Manager    : Auth_Manager;
      Auth_Grant : Grant_Type;
   begin
      Manager.Authenticate ("x", Auth_Grant);
      T.Assert (Auth_Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant for badly formed token");
      Manager.Authenticate (".", Auth_Grant);
      T.Assert (Auth_Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant for badly formed token");
      Manager.Authenticate ("..", Auth_Grant);
      T.Assert (Auth_Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant for badly formed token");
      Manager.Authenticate ("a..", Auth_Grant);
      T.Assert (Auth_Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant for badly formed token");
      Manager.Authenticate ("..b", Auth_Grant);
      T.Assert (Auth_Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant for badly formed token");
      Manager.Authenticate ("a..b", Auth_Grant);
      T.Assert (Auth_Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant for badly formed token");
   end Test_Bad_Token;

   --  ------------------------------
   --  Test the loading configuration files for the File_Registry.
   --  ------------------------------
   procedure Test_Load_Registry (T : in out Test) is
      Apps       : aliased File_Application_Manager;
      Realm      : aliased File_Realm_Manager;
      Manager    : Auth_Manager;
      Grant      : Grant_Type;
      Auth_Grant : Grant_Type;
      Params     : Test_Parameters;
   begin
      Apps.Load (Util.Tests.Get_Path ("regtests/files/user_apps.properties"), "apps");
      Realm.Load (Util.Tests.Get_Path ("regtests/files/user_apps.properties"), "users");

      --  Configure the auth manager.
      Manager.Set_Application_Manager (Apps'Unchecked_Access);
      Manager.Set_Realm_Manager (Realm'Unchecked_Access);
      Manager.Set_Private_Key ("server-private-key-no-so-secure");
      Params.Set_Parameter (Security.OAuth.CLIENT_ID, "app-id-1");
      Params.Set_Parameter (Security.OAuth.CLIENT_SECRET, "app-secret-1");
      Params.Set_Parameter (Security.OAuth.GRANT_TYPE, "password");
      Params.Set_Parameter (Security.OAuth.USERNAME, "joe");
      Params.Set_Parameter (Security.OAuth.PASSWORD, "test");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Request = Password_Grant,
                "Expecting Password_Grant for the grant request");
      T.Assert (Grant.Status = Valid_Grant,
                "Expecting Valid_Grant when the user/password are correct");
   end Test_Load_Registry;

end Security.OAuth.Servers.Tests;

-----------------------------------------------------------------------
--  Security-oauth-servers-tests - Unit tests for server side OAuth
--  Copyright (C) 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 Util.Test_Caller;

with Security.Auth.Tests;
with Security.OAuth.File_Registry;
package body Security.OAuth.Servers.Tests is

   use Auth.Tests;
   use File_Registry;

   package Caller is new Util.Test_Caller (Test, "Security.OAuth.Servers");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Security.OAuth.Servers.Find_Application",
                       Test_Application_Manager'Access);
      Caller.Add_Test (Suite, "Test Security.OAuth.Servers.Verify",
                       Test_User_Verify'Access);
      Caller.Add_Test (Suite, "Test Security.OAuth.Servers.Token",
                       Test_Token_Password'Access);
      Caller.Add_Test (Suite, "Test Security.OAuth.Servers.Authenticate",
                       Test_Bad_Token'Access);
      Caller.Add_Test (Suite, "Test Security.OAuth.File_Registry.Load",
                       Test_Load_Registry'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test the application manager.
   --  ------------------------------
   procedure Test_Application_Manager (T : in out Test) is
      Manager : File_Application_Manager;
      App     : Application;
   begin
      App.Set_Application_Identifier ("my-app-id");
      App.Set_Application_Secret ("my-secret");
      App.Set_Application_Callback ("my-callback");
      Manager.Add_Application (App);

      --  Check that we can find our application.
      declare
         A : constant Application'Class := Manager.Find_Application ("my-app-id");
      begin
         Util.Tests.Assert_Equals (T, "my-app-id", A.Get_Application_Identifier,
                                   "Invalid application returned by Find");
      end;

      --  Check that an exception is raised for an invalid client ID.
      begin
         declare
            A : constant Application'Class := Manager.Find_Application ("unkown-app-id");
         begin
            Util.Tests.Fail (T, "Found the application " & A.Get_Application_Identifier);
         end;

      exception
         when Invalid_Application =>
            null;
      end;
   end Test_Application_Manager;

   --  ------------------------------
   --  Test the user registration and verification.
   --  ------------------------------
   procedure Test_User_Verify (T : in out Test) is
      Manager : File_Realm_Manager;
      Auth    : Principal_Access;
   begin
      Manager.Add_User ("Gandalf", "Mithrandir");
      Manager.Verify ("Gandalf", "mithrandir", Auth);
      T.Assert (Auth = null, "Verify password should fail with an invalid password");

      Manager.Verify ("Sauron", "Mithrandir", Auth);
      T.Assert (Auth = null, "Verify password should fail with an invalid user");

      Manager.Verify ("Gandalf", "Mithrandir", Auth);
      T.Assert (Auth /= null, "Verify password operation failed for a good user/password");
   end Test_User_Verify;

   --  ------------------------------
   --  Test the token operation that produces an access token from user/password.
   --  RFC 6749: Section 4.3.  Resource Owner Password Credentials Grant
   --  ------------------------------
   procedure Test_Token_Password (T : in out Test) is
      use type Util.Strings.Name_Access;

      Apps       : aliased File_Application_Manager;
      Realm      : aliased File_Realm_Manager;
      Manager    : Auth_Manager;
      App        : Application;
      Grant      : Grant_Type;
      Auth_Grant : Grant_Type;
      Params     : Test_Parameters;
   begin
      --  Add one test application.
      App.Set_Application_Identifier ("my-app-id");
      App.Set_Application_Secret ("my-secret");
      App.Set_Application_Callback ("my-callback");
      Apps.Add_Application (App);

      --  Add one test user.
      Realm.Add_User ("Gandalf", "Mithrandir");

      --  Configure the auth manager.
      Manager.Set_Application_Manager (Apps'Unchecked_Access);
      Manager.Set_Realm_Manager (Realm'Unchecked_Access);
      Manager.Set_Private_Key ("server-private-key-no-so-secure");

      Manager.Token (Params, Grant);
      T.Assert (Grant.Status = Invalid_Grant, "Expecting Invalid_Grant when client_id is missing");

      Params.Set_Parameter (Security.OAuth.CLIENT_ID, "");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Status = Invalid_Grant, "Expecting Invalid_Grant when client_id is empty");

      Params.Set_Parameter (Security.OAuth.CLIENT_ID, "unkown-app");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Status = Invalid_Grant, "Expecting Invalid_Grant when client_id is invalid");

      Params.Set_Parameter (Security.OAuth.CLIENT_ID, "my-app-id");
      Params.Set_Parameter (Security.OAuth.GRANT_TYPE, "");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant when client_id is empty");

      Params.Set_Parameter (Security.OAuth.GRANT_TYPE, "password");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Request = Password_Grant,
                "Expecting Password_Grant for the grant request");
      T.Assert (Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant when the user/password is missing");

      Params.Set_Parameter (Security.OAuth.USERNAME, "Gandalf");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Request = Password_Grant,
                "Expecting Password_Grant for the grant request");
      T.Assert (Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant when the password is missing");

      Params.Set_Parameter (Security.OAuth.PASSWORD, "test");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Request = Password_Grant,
                "Expecting Password_Grant for the grant request");
      T.Assert (Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant when the password is invalid");

      Params.Set_Parameter (Security.OAuth.PASSWORD, "Mithrandir");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Request = Password_Grant,
                "Expecting Password_Grant for the grant request");
      T.Assert (Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant when the client_secret is invalid");

      Params.Set_Parameter (Security.OAuth.CLIENT_SECRET, "my-secret");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Request = Password_Grant,
                "Expecting Password_Grant for the grant request");
      T.Assert (Grant.Status = Valid_Grant,
                "Expecting Valid_Grant when the user/password are correct");
      T.Assert (Grant.Error = null, "Expecting null error");
      T.Assert (Length (Grant.Token) > 20,
                "Expecting a token with some reasonable size");
      T.Assert (Grant.Auth /= null,
                "Expecting a non null auth principal");
      Util.Tests.Assert_Equals (T, "Gandalf", Grant.Auth.Get_Name,
                                "Invalid user name in the principal");

      --  Verify the access token.
      for I in 1 .. 5 loop
         Manager.Authenticate (To_String (Grant.Token), Auth_Grant);
         T.Assert (Auth_Grant.Request = Access_Grant,
                   "Expecting Access_Grant for the authenticate");
         T.Assert (Auth_Grant.Status = Valid_Grant,
                   "Expecting Valid_Grant when the access token is checked");
         T.Assert (Auth_Grant.Error = null, "Expecting null error for access_token");
         T.Assert (Auth_Grant.Auth = Grant.Auth, "Expecting valid auth principal");
      end loop;

      --  Verify the modified access token.
      Manager.Authenticate (To_String (Grant.Token) & "x", Auth_Grant);
      T.Assert (Auth_Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant for the authenticate");

      Manager.Revoke (To_String (Grant.Token));

      --  Verify the access is now denied.
      for I in 1 .. 5 loop
         Manager.Authenticate (To_String (Grant.Token), Auth_Grant);
         T.Assert (Auth_Grant.Status = Revoked_Grant,
                   "Expecting Revoked_Grant for the authenticate");
      end loop;

      --  Change application token expiration time to 1 second.
      App.Expire_Timeout := 1.0;
      Apps.Add_Application (App);

      --  Make the access token.
      Manager.Token (Params, Grant);
      T.Assert (Grant.Status = Valid_Grant,
                "Expecting Valid_Grant when the user/password are correct");

      --  Verify the access token.
      for I in 1 .. 5 loop
         Manager.Authenticate (To_String (Grant.Token), Auth_Grant);
         T.Assert (Auth_Grant.Request = Access_Grant,
                   "Expecting Access_Grant for the authenticate");
         T.Assert (Auth_Grant.Status = Valid_Grant,
                   "Expecting Valid_Grant when the access token is checked");
         T.Assert (Auth_Grant.Error = null,
                   "Expecting null error for access_token");
         T.Assert (Auth_Grant.Auth = Grant.Auth,
                   "Expecting valid auth principal");
      end loop;

      --  Wait for the token to expire.
      delay 2.0;
      for I in 1 .. 5 loop
         Manager.Authenticate (To_String (Grant.Token), Auth_Grant);
         T.Assert (Auth_Grant.Status = Expired_Grant,
                   "Expecting Expired when the access token is checked");
      end loop;

   end Test_Token_Password;

   --  ------------------------------
   --  Test the access token validation with invalid tokens (bad formed).
   --  ------------------------------
   procedure Test_Bad_Token (T : in out Test) is
      Manager    : Auth_Manager;
      Auth_Grant : Grant_Type;
   begin
      Manager.Authenticate ("x", Auth_Grant);
      T.Assert (Auth_Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant for badly formed token");
      Manager.Authenticate (".", Auth_Grant);
      T.Assert (Auth_Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant for badly formed token");
      Manager.Authenticate ("..", Auth_Grant);
      T.Assert (Auth_Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant for badly formed token");
      Manager.Authenticate ("a..", Auth_Grant);
      T.Assert (Auth_Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant for badly formed token");
      Manager.Authenticate ("..b", Auth_Grant);
      T.Assert (Auth_Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant for badly formed token");
      Manager.Authenticate ("a..b", Auth_Grant);
      T.Assert (Auth_Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant for badly formed token");
   end Test_Bad_Token;

   --  ------------------------------
   --  Test the loading configuration files for the File_Registry.
   --  ------------------------------
   procedure Test_Load_Registry (T : in out Test) is
      Apps       : aliased File_Application_Manager;
      Realm      : aliased File_Realm_Manager;
      Manager    : Auth_Manager;
      Grant      : Grant_Type;
      Auth_Grant : Grant_Type;
      Params     : Test_Parameters;
   begin
      Apps.Load (Util.Tests.Get_Path ("regtests/files/user_apps.properties"), "apps");
      Realm.Load (Util.Tests.Get_Path ("regtests/files/user_apps.properties"), "users");

      --  Configure the auth manager.
      Manager.Set_Application_Manager (Apps'Unchecked_Access);
      Manager.Set_Realm_Manager (Realm'Unchecked_Access);
      Manager.Set_Private_Key ("server-private-key-no-so-secure");
      Params.Set_Parameter (Security.OAuth.CLIENT_ID, "app-id-1");
      Params.Set_Parameter (Security.OAuth.CLIENT_SECRET, "app-secret-1");
      Params.Set_Parameter (Security.OAuth.GRANT_TYPE, "password");
      Params.Set_Parameter (Security.OAuth.USERNAME, "joe");
      Params.Set_Parameter (Security.OAuth.PASSWORD, "test");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Request = Password_Grant,
                "Expecting Password_Grant for the grant request");
      T.Assert (Grant.Status = Valid_Grant,
                "Expecting Valid_Grant when the user/password are correct");
   end Test_Load_Registry;

end Security.OAuth.Servers.Tests;

Fix unit test to verify the password authenticate


with AdaBase;
with Connect;
with Ada.Text_IO;
with AdaBase.Results.Sets;

procedure Stored_Procs is

   package CON renames Connect;
   package TIO renames Ada.Text_IO;
   package ARS renames AdaBase.Results.Sets;

   stmt_acc : CON.Stmt_Type_access;

   procedure dump_result;
   procedure dump_result
   is
      function pad (S : String) return String;
      function pad (S : String) return String
      is
         field : String (1 .. 15) := (others => ' ');
         len   : Natural := S'Length;
      begin
         field (1 .. len) := S;
         return field;
      end pad;

      row     : ARS.Datarow;
      numcols : constant Natural := stmt_acc.column_count;
   begin
      for c in Natural range 1 .. numcols loop
         TIO.Put (pad (stmt_acc.column_name (c)));
      end loop;
      TIO.Put_Line ("");
      for c in Natural range 1 .. numcols loop
         TIO.Put ("============== ");
      end loop;
      TIO.Put_Line ("");
      loop
         row := stmt_acc.fetch_next;
         exit when row.data_exhausted;
         for c in Natural range 1 .. numcols loop
            TIO.Put (pad (row.column (c).as_string));
         end loop;
         TIO.Put_Line ("");
      end loop;
      TIO.Put_Line ("");
   end dump_result;

   sql         : constant String := "CALL multiple_rowsets";
   set_fetched : Boolean;
   set_present : Boolean;

begin

   CON.connect_database;

   declare
      stmt : aliased CON.Stmt_Type := CON.DR.query (sql);
   begin
      if stmt.successful then
         set_fetched := True;
      else
         TIO.Put_Line ("Stored procedures not supported on " &
            CON.DR.trait_driver);
      end if;
      set_fetched := stmt.successful;
      stmt_acc := stmt'Unchecked_Access;
      loop
         if set_fetched then
            dump_result;
         end if;
         stmt.fetch_next_set (set_present, set_fetched);
         exit when not set_present;
      end loop;
   end;

   CON.DR.disconnect;

end Stored_Procs;

with AdaBase;
with Connect;
with Ada.Text_IO;
with AdaBase.Results.Sets;

procedure Stored_Procs is

   package CON renames Connect;
   package TIO renames Ada.Text_IO;
   package ARS renames AdaBase.Results.Sets;

   stmt_acc : CON.Stmt_Type_access;

   procedure dump_result;
   procedure dump_result
   is
      function pad (S : String) return String;
      function pad (S : String) return String
      is
         field : String (1 .. 15) := (others => ' ');
         len   : Natural := S'Length;
      begin
         field (1 .. len) := S;
         return field;
      end pad;

      row     : ARS.Datarow;
      numcols : constant Natural := stmt_acc.column_count;
   begin
      for c in Natural range 1 .. numcols loop
         TIO.Put (pad (stmt_acc.column_name (c)));
      end loop;
      TIO.Put_Line ("");
      for c in Natural range 1 .. numcols loop
         TIO.Put ("============== ");
      end loop;
      TIO.Put_Line ("");
      loop
         row := stmt_acc.fetch_next;
         exit when row.data_exhausted;
         for c in Natural range 1 .. numcols loop
            TIO.Put (pad (row.column (c).as_string));
         end loop;
         TIO.Put_Line ("");
      end loop;
      TIO.Put_Line ("");
   end dump_result;

   sql         : constant String := "CALL multiple_rowsets";
   set_fetched : Boolean;
   set_present : Boolean;

begin

   CON.connect_database;

   declare
      stmt : aliased CON.Stmt_Type :=
             CON.DR.call_stored_procedure ("multiple_rowsets", "");
   begin
      if stmt.successful then
         set_fetched := True;
      else
         TIO.Put_Line ("Stored procedures not supported on " &
            CON.DR.trait_driver);
      end if;
      set_fetched := stmt.successful;
      stmt_acc := stmt'Unchecked_Access;
      loop
         if set_fetched then
            dump_result;
         end if;
         stmt.fetch_next_set (set_present, set_fetched);
         exit when not set_present;
      end loop;
   end;

   CON.DR.disconnect;

end Stored_Procs;

Modify stored procs testcase to use new call_stored_procedure function


-----------------------------------------------------------------------
--  applications.messages-factory -- Application Message Factory
--  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 Ada.Exceptions;

with Util.Log.Loggers;
with Util.Properties.Bundles;
with Util.Beans.Objects;
with Util.Locales;

with ASF.Locales;
with ASF.Applications.Main;
package body ASF.Applications.Messages.Factory is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("ASF.Applications.Messages.Factory");

   --  ------------------------------
   --  Get a localized message.  The message identifier is composed of a resource bundle name
   --  prefix and a bundle key.  The prefix and key are separated by the first '.'.
   --  If the message identifier does not contain any prefix, the default bundle is "messages".
   --  ------------------------------
   function Get_Message (Context    : in ASF.Contexts.Faces.Faces_Context'Class;
                         Message_Id : in String) return String is
      Pos    : constant Natural := Util.Strings.Index (Message_Id, '.');
      Locale : constant Util.Locales.Locale := Context.Get_Locale;
      App    : constant access ASF.Applications.Main.Application'Class := Context.Get_Application;
      Bundle : ASF.Locales.Bundle;
   begin
      if Pos > 0 then
         App.Load_Bundle (Name   => Message_Id (Message_Id'First .. Pos - 1),
                          Locale => Util.Locales.To_String (Locale),
                          Bundle => Bundle);
         return Bundle.Get (Message_Id (Pos + 1 .. Message_Id'Last),
                            Message_Id (Pos + 1 .. Message_Id'Last));
      else
         App.Load_Bundle (Name   => "messages",
                          Locale => Util.Locales.To_String (Locale),
                          Bundle => Bundle);
         return Bundle.Get (Message_Id, Message_Id);
      end if;

   exception
      when E : Util.Properties.Bundles.NO_BUNDLE =>
         Log.Error ("Cannot localize {0}: {1}", Message_Id, Ada.Exceptions.Exception_Message (E));
         return Message_Id;
   end Get_Message;

   --  ------------------------------
   --  Build a localized message.
   --  ------------------------------
   function Get_Message (Context    : in ASF.Contexts.Faces.Faces_Context'Class;
                         Message_Id : in String;
                         Severity   : in Messages.Severity := ERROR) return Message is
      Msg    : constant String := Get_Message (Context, Message_Id);
      Result : Message;
   begin
      Result.Summary := Ada.Strings.Unbounded.To_Unbounded_String (Msg);
      Result.Kind    := Severity;
      return Result;
   end Get_Message;

   --  ------------------------------
   --  Build a localized message and format the message with one argument.
   --  ------------------------------
   function Get_Message (Context    : in ASF.Contexts.Faces.Faces_Context'Class;
                         Message_Id : in String;
                         Param1     : in String;
                         Severity   : in Messages.Severity := ERROR) return Message is
      Args : ASF.Utils.Object_Array (1 .. 1);
   begin
      Args (1) := Util.Beans.Objects.To_Object (Param1);
      return Get_Message (Context, Message_Id, Args, Severity);
   end Get_Message;

   --  ------------------------------
   --  Build a localized message and format the message with two argument.
   --  ------------------------------
   function Get_Message (Context    : in ASF.Contexts.Faces.Faces_Context'Class;
                         Message_Id : in String;
                         Param1     : in String;
                         Param2     : in String;
                         Severity   : in Messages.Severity := ERROR) return Message is
      Args : ASF.Utils.Object_Array (1 .. 2);
   begin
      Args (1) := Util.Beans.Objects.To_Object (Param1);
      Args (2) := Util.Beans.Objects.To_Object (Param2);
      return Get_Message (Context, Message_Id, Args, Severity);
   end Get_Message;

   --  ------------------------------
   --  Build a localized message and format the message with some arguments.
   --  ------------------------------
   function Get_Message (Context    : in ASF.Contexts.Faces.Faces_Context'Class;
                         Message_Id : in String;
                         Args       : in ASF.Utils.Object_Array;
                         Severity   : in Messages.Severity := ERROR) return Message is
      Msg    : constant String := Get_Message (Context, Message_Id);
      Result : Message;
   begin
      Result.Kind := Severity;
      ASF.Utils.Formats.Format (Msg, Args, Result.Summary);
      return Result;
   end Get_Message;

   --  ------------------------------
   --  Add a localized global message in the faces context.
   --  ------------------------------
   procedure Add_Message (Context    : in out ASF.Contexts.Faces.Faces_Context'Class;
                          Message_Id : in String;
                          Param1     : in String;
                          Severity   : in Messages.Severity := ERROR) is
      Msg     : constant Message := Get_Message (Context, Message_Id, Param1, Severity);
   begin
      Context.Add_Message (Client_Id => "", Message  => Msg);
   end Add_Message;

   --  ------------------------------
   --  Add a localized global message in the faces context.
   --  ------------------------------
   procedure Add_Message (Context    : in out ASF.Contexts.Faces.Faces_Context'Class;
                          Message_Id : in String;
                          Severity   : in Messages.Severity := ERROR) is
      Msg     : constant Message := Get_Message (Context, Message_Id, Severity);
   begin
      Context.Add_Message (Client_Id => "", Message  => Msg);
   end Add_Message;

   --  ------------------------------
   --  Add a localized global message in the current faces context.
   --  ------------------------------
   procedure Add_Message (Message_Id : in String;
                          Severity   : in Messages.Severity := ERROR) is
      Context : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
   begin
      Add_Message (Context.all, Message_Id, Severity);
   end Add_Message;

end ASF.Applications.Messages.Factory;

-----------------------------------------------------------------------
--  applications.messages-factory -- Application Message Factory
--  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 Ada.Exceptions;

with Util.Log.Loggers;
with Util.Properties.Bundles;
with Util.Beans.Objects;
with Util.Locales;

with ASF.Locales;
with ASF.Applications.Main;
package body ASF.Applications.Messages.Factory is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("ASF.Applications.Messages.Factory");

   --  ------------------------------
   --  Get a localized message.  The message identifier is composed of a resource bundle name
   --  prefix and a bundle key.  The prefix and key are separated by the first '.'.
   --  If the message identifier does not contain any prefix, the default bundle is "messages".
   --  ------------------------------
   function Get_Message (Context    : in ASF.Contexts.Faces.Faces_Context'Class;
                         Message_Id : in String) return String is
      Pos    : constant Natural := Util.Strings.Index (Message_Id, '.');
      Locale : constant Util.Locales.Locale := Context.Get_Locale;
      App    : constant access ASF.Applications.Main.Application'Class := Context.Get_Application;
      Bundle : ASF.Locales.Bundle;
   begin
      if Pos > 0 then
         App.Load_Bundle (Name   => Message_Id (Message_Id'First .. Pos - 1),
                          Locale => Util.Locales.To_String (Locale),
                          Bundle => Bundle);
         return Bundle.Get (Message_Id (Pos + 1 .. Message_Id'Last),
                            Message_Id (Pos + 1 .. Message_Id'Last));
      else
         App.Load_Bundle (Name   => "messages",
                          Locale => Util.Locales.To_String (Locale),
                          Bundle => Bundle);
         return Bundle.Get (Message_Id, Message_Id);
      end if;

   exception
      when E : Util.Properties.Bundles.NO_BUNDLE =>
         Log.Error ("Cannot localize {0}: {1}", Message_Id, Ada.Exceptions.Exception_Message (E));
         return Message_Id;
   end Get_Message;

   --  ------------------------------
   --  Build a localized message.
   --  ------------------------------
   function Get_Message (Context    : in ASF.Contexts.Faces.Faces_Context'Class;
                         Message_Id : in String;
                         Severity   : in Messages.Severity := ERROR) return Message is
      Msg    : constant String := Get_Message (Context, Message_Id);
      Result : Message;
   begin
      Result.Summary := Ada.Strings.Unbounded.To_Unbounded_String (Msg);
      Result.Kind    := Severity;
      return Result;
   end Get_Message;

   --  ------------------------------
   --  Build a localized message and format the message with one argument.
   --  ------------------------------
   function Get_Message (Context    : in ASF.Contexts.Faces.Faces_Context'Class;
                         Message_Id : in String;
                         Param1     : in String;
                         Severity   : in Messages.Severity := ERROR) return Message is
      Args : ASF.Utils.Object_Array (1 .. 1);
   begin
      Args (1) := Util.Beans.Objects.To_Object (Param1);
      return Get_Message (Context, Message_Id, Args, Severity);
   end Get_Message;

   --  ------------------------------
   --  Build a localized message and format the message with two argument.
   --  ------------------------------
   function Get_Message (Context    : in ASF.Contexts.Faces.Faces_Context'Class;
                         Message_Id : in String;
                         Param1     : in String;
                         Param2     : in String;
                         Severity   : in Messages.Severity := ERROR) return Message is
      Args : ASF.Utils.Object_Array (1 .. 2);
   begin
      Args (1) := Util.Beans.Objects.To_Object (Param1);
      Args (2) := Util.Beans.Objects.To_Object (Param2);
      return Get_Message (Context, Message_Id, Args, Severity);
   end Get_Message;

   --  ------------------------------
   --  Build a localized message and format the message with some arguments.
   --  ------------------------------
   function Get_Message (Context    : in ASF.Contexts.Faces.Faces_Context'Class;
                         Message_Id : in String;
                         Args       : in ASF.Utils.Object_Array;
                         Severity   : in Messages.Severity := ERROR) return Message is
      Msg    : constant String := Get_Message (Context, Message_Id);
      Result : Message;
   begin
      Result.Kind := Severity;
      ASF.Utils.Formats.Format (Msg, Args, Result.Summary);
      return Result;
   end Get_Message;

   --  ------------------------------
   --  Add a localized global message in the faces context.
   --  ------------------------------
   procedure Add_Message (Context    : in out ASF.Contexts.Faces.Faces_Context'Class;
                          Message_Id : in String;
                          Param1     : in String;
                          Severity   : in Messages.Severity := ERROR) is
      Msg     : constant Message := Get_Message (Context, Message_Id, Param1, Severity);
   begin
      Context.Add_Message (Client_Id => "", Message  => Msg);
   end Add_Message;

   --  ------------------------------
   --  Add a localized global message in the faces context.
   --  ------------------------------
   procedure Add_Message (Context    : in out ASF.Contexts.Faces.Faces_Context'Class;
                          Message_Id : in String;
                          Severity   : in Messages.Severity := ERROR) is
      Msg     : constant Message := Get_Message (Context, Message_Id, Severity);
   begin
      Context.Add_Message (Client_Id => "", Message  => Msg);
   end Add_Message;

   --  ------------------------------
   --  Add a localized global message in the current faces context.
   --  ------------------------------
   procedure Add_Message (Message_Id : in String;
                          Severity   : in Messages.Severity := ERROR) is
      Context : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
   begin
      Add_Message (Context.all, Message_Id, Severity);
   end Add_Message;

   --  ------------------------------
   --  Add a localized field message in the current faces context.  The message is associated
   --  with the component identified by <tt>Client_Id</tt>.
   --  ------------------------------
   procedure Add_Field_Message (Client_Id  : in String;
                                Message_Id : in String;
                                Severity   : in Messages.Severity := ERROR) is
      Context : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      Msg     : constant Message := Get_Message (Context.all, Message_Id, Severity);
   begin
      Context.Add_Message (Client_Id => Client_Id, Message  => Msg);
   end Add_Field_Message;

end ASF.Applications.Messages.Factory;

Implement the Add_Field_Message procedure to associate a message to a component field


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

package body ADO.Utils.Serialize is

   --  ------------------------------
   --  Write the entity to the serialization stream (JSON/XML).
   --  ------------------------------
   procedure Write_Entity (Stream : in out Util.Serialize.IO.Output_Stream'Class;
                           Name   : in String;
                           Value  : in ADO.Identifier) is
   begin
      Stream.Write_Long_Entity (Name, Long_Long_Integer (Value));
   end Write_Entity;

   --  ------------------------------
   --  Write the entity to the serialization stream (JSON/XML).
   --  ------------------------------
   procedure Write_Entity (Stream : in out Util.Serialize.IO.Output_Stream'Class;
                           Name   : in String;
                           Value  : in ADO.Objects.Object_Key) is
   begin
      case Value.Of_Type is
         when ADO.Objects.KEY_INTEGER =>
            Write_Entity (Stream, Name, ADO.Objects.Get_Value (Value));

         when ADO.Objects.KEY_STRING =>
            Stream.Write_Entity (Name, ADO.Objects.Get_Value (Value));

      end case;
   end Write_Entity;

end ADO.Utils.Serialize;

-----------------------------------------------------------------------
--  ado-utils-serialize -- Utility operations for JSON/XML serialization
--  Copyright (C) 2016, 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 ADO.Schemas;
package body ADO.Utils.Serialize is

   --  ------------------------------
   --  Write the entity to the serialization stream (JSON/XML).
   --  ------------------------------
   procedure Write_Entity (Stream : in out Util.Serialize.IO.Output_Stream'Class;
                           Name   : in String;
                           Value  : in ADO.Identifier) is
   begin
      Stream.Write_Long_Entity (Name, Long_Long_Integer (Value));
   end Write_Entity;

   --  ------------------------------
   --  Write the entity to the serialization stream (JSON/XML).
   --  ------------------------------
   procedure Write_Entity (Stream : in out Util.Serialize.IO.Output_Stream'Class;
                           Name   : in String;
                           Value  : in ADO.Objects.Object_Key) is
   begin
      case Value.Of_Type is
         when ADO.Objects.KEY_INTEGER =>
            Write_Entity (Stream, Name, ADO.Objects.Get_Value (Value));

         when ADO.Objects.KEY_STRING =>
            Stream.Write_Entity (Name, ADO.Objects.Get_Value (Value));

      end case;
   end Write_Entity;

   --  ------------------------------
   --  Write the SQL query results to the serialization stream (JSON/XML).
   --  ------------------------------
   procedure Write_Query (Stream : in out Util.Serialize.IO.Output_Stream'Class;
                          Name   : in String;
                          Query  : in out ADO.Statements.Query_Statement) is
      use ADO.Schemas;
      Column_Count : Natural;
   begin
      Stream.Start_Array (Name);
      if Query.Has_Elements then
         Column_Count := Query.Get_Column_Count;
         while Query.Has_Elements loop
            Stream.Start_Entity ("");
            for I in 1 .. Column_Count loop
               declare
                  Name : constant String := Query.Get_Column_Name (I - 1);
               begin
                  if Query.Is_Null (I - 1) then
                     Stream.Write_Null_Entity (Name);
                  else
                     case Query.Get_Column_Type (I - 1) is
                        --  Boolean column
                     when T_BOOLEAN =>
                        Stream.Write_Entity (Name, Query.Get_Boolean (I - 1));

                     when T_TINYINT | T_SMALLINT | T_INTEGER | T_LONG_INTEGER | T_YEAR =>
                        Stream.Write_Entity (Name, Query.Get_Integer (I - 1));

                     when T_FLOAT | T_DOUBLE | T_DECIMAL =>
                        Stream.Write_Null_Entity (Name);

                     when T_ENUM =>
                        Stream.Write_Entity (Name, Query.Get_String (I - 1));

                     when T_TIME | T_DATE | T_DATE_TIME | T_TIMESTAMP =>
                        Stream.Write_Entity (Name, Query.Get_Time (I - 1));

                     when T_CHAR | T_VARCHAR =>
                        Stream.Write_Entity (Name, Query.Get_String (I - 1));

                     when T_BLOB =>
                        Stream.Write_Null_Entity (Name);

                     when T_SET | T_UNKNOWN | T_NULL =>
                        Stream.Write_Null_Entity (Name);

                     end case;

                  end if;
               end;
            end loop;
            Stream.End_Entity ("");
            Query.Next;
         end loop;
      end if;
      Stream.End_Array (Name);
   end Write_Query;

end ADO.Utils.Serialize;

Implement Write_Query to serialize the query statement in a JSON/XML stream


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

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

   use ASF;
   use EL.Objects;

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

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

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

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

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

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

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

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

   Empty : ASF.Components.Base.UIComponent;

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

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

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

end ASF.Components.Root;

-----------------------------------------------------------------------
--  components-root -- ASF Root View Component
--  Copyright (C) 2010, 2011, 2012, 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.Unchecked_Deallocation;

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

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

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

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

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

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

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

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

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

   Empty : ASF.Components.Base.UIComponent;

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

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

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

end ASF.Components.Root;

Remove unused use clauses

Remove unused use clauses


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

with Util.Test_Caller;
with Util.Log.Loggers;
with Util.Measures;
with ASF.Requests.Mockup;
package body ASF.Requests.Tests is

   use Util.Tests;
   use Util.Log;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("ASF.Requests.Tests");

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ASF.Requests.Split_Header",
                       Test_Split_Header'Access);
      Caller.Add_Test (Suite, "Test ASF.Requests.Accept_Locales",
                       Test_Accept_Locales'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test the Split_Header procedure.
   --  ------------------------------
   procedure Test_Split_Header (T : in out Test) is
      procedure Process_Text (Item    : in String;
                              Quality : in Quality_Type);

      Count : Natural := 0;

      procedure Process_Text (Item    : in String;
                              Quality : in Quality_Type) is
      begin
         T.Assert (Item = "text/plain" or Item = "text/html" or Item = "text/x-dvi"
                   or Item = "text/x-c", "Invalid item: " & Item);
         T.Assert (Quality = 0.5 or Quality = 0.8 or Quality = 1.0,
                   "Invalid quality");
         if Item = "text/plain" then
            T.Assert (Quality = 0.5, "Invalid quality for " & Item);

         elsif Item = "text/x-dvi" or Item = "text/html" then
            T.Assert (Quality = 0.8, "Invalid quality for " & Item);

         else
            T.Assert (Quality = 1.0, "Invalid quality for " & Item);
         end if;
         Count := Count + 1;
      end Process_Text;

   begin
      Split_Header ("text/plain; q=0.5, text/html,text/x-dvi; q=0.8, text/x-c",
                    Process_Text'Access);
      Util.Tests.Assert_Equals (T, 4, Count, "Invalid number of items");
   end Test_Split_Header;

   --  ------------------------------
   --  Test the Accept_Locales procedure.
   --  ------------------------------
   procedure Test_Accept_Locales (T : in out Test) is
      procedure Process_Locale (Locale : in Util.Locales.Locale;
                                Quality : in Quality_Type);

      use Util.Locales;

      Req : ASF.Requests.Mockup.Request;

      Count : Natural := 0;

      procedure Process_Locale (Locale : in Util.Locales.Locale;
                                Quality : in Quality_Type) is
         Lang : constant String := Util.Locales.Get_Language (Locale);
      begin
         Log.Info ("Found locale: {0}", Util.Locales.To_String (Locale));

         T.Assert (Lang = "da" or Lang = "en_GB" or Lang = "en",
                   "Invalid lang: " & Lang);

         Count := Count + 1;
      end Process_Locale;

   begin
      Req.Set_Header ("Accept-Language", "da, en-gb;q=0.8, en;q=0.7");
      Req.Accept_Locales (Process_Locale'Access);

      Util.Tests.Assert_Equals (T, 3, Count, "Invalid number of calls");
   end Test_Accept_Locales;

end ASF.Requests.Tests;

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

with Util.Test_Caller;
with Util.Log.Loggers;
with ASF.Requests.Mockup;
package body ASF.Requests.Tests is

   use Util.Tests;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ASF.Requests.Tests");

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ASF.Requests.Split_Header",
                       Test_Split_Header'Access);
      Caller.Add_Test (Suite, "Test ASF.Requests.Accept_Locales",
                       Test_Accept_Locales'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test the Split_Header procedure.
   --  ------------------------------
   procedure Test_Split_Header (T : in out Test) is
      procedure Process_Text (Item    : in String;
                              Quality : in Quality_Type);

      Count : Natural := 0;

      procedure Process_Text (Item    : in String;
                              Quality : in Quality_Type) is
      begin
         T.Assert (Item = "text/plain" or Item = "text/html" or Item = "text/x-dvi"
                   or Item = "text/x-c", "Invalid item: " & Item);
         T.Assert (Quality = 0.5 or Quality = 0.8 or Quality = 1.0,
                   "Invalid quality");
         if Item = "text/plain" then
            T.Assert (Quality = 0.5, "Invalid quality for " & Item);

         elsif Item = "text/x-dvi" or Item = "text/html" then
            T.Assert (Quality = 0.8, "Invalid quality for " & Item);

         else
            T.Assert (Quality = 1.0, "Invalid quality for " & Item);
         end if;
         Count := Count + 1;
      end Process_Text;

   begin
      Split_Header ("text/plain; q=0.5, text/html,text/x-dvi; q=0.8, text/x-c",
                    Process_Text'Access);
      Util.Tests.Assert_Equals (T, 4, Count, "Invalid number of items");
   end Test_Split_Header;

   --  ------------------------------
   --  Test the Accept_Locales procedure.
   --  ------------------------------
   procedure Test_Accept_Locales (T : in out Test) is
      procedure Process_Locale (Locale : in Util.Locales.Locale;
                                Quality : in Quality_Type);

      use Util.Locales;

      Req : ASF.Requests.Mockup.Request;

      Count : Natural := 0;

      procedure Process_Locale (Locale : in Util.Locales.Locale;
                                Quality : in Quality_Type) is
         pragma Unreferenced (Quality);

         Lang : constant String := Util.Locales.Get_Language (Locale);
      begin
         Log.Info ("Found locale: {0}", Util.Locales.To_String (Locale));

         T.Assert (Lang = "da" or Lang = "en_GB" or Lang = "en",
                   "Invalid lang: " & Lang);

         Count := Count + 1;
      end Process_Locale;

   begin
      Req.Set_Header ("Accept-Language", "da, en-gb;q=0.8, en;q=0.7");
      Req.Accept_Locales (Process_Locale'Access);

      Util.Tests.Assert_Equals (T, 3, Count, "Invalid number of calls");
   end Test_Accept_Locales;

end ASF.Requests.Tests;

Fix compilation warning

Fix compilation warning


-----------------------------------------------------------------------
--  ADO Sqlite Database -- SQLite Database connections
--  Copyright (C) 2009, 2010, 2011, 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;
package ADO.Drivers.Connections.Sqlite is

   subtype Sqlite_Access is System.Address;

   --  The database connection manager
   type Sqlite_Driver is limited private;

   --  Initialize the SQLite driver.
   procedure Initialize;

   --  Check for an error after executing a sqlite statement.
   procedure Check_Error (Connection : in Sqlite_Access;
                          Result     : in Interfaces.C.int);

private

   --  Database connection implementation
   type Database_Connection is new ADO.Drivers.Connections.Database_Connection with record
      Server : aliased Sqlite_Access;
      Name   : Unbounded_String;
   end record;
   type Database_Connection_Access is access all Database_Connection'Class;

   --  Get the database driver which manages this connection.
   overriding
   function Get_Driver (Database : in Database_Connection)
                        return Driver_Access;

   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement_Access;

   overriding
   function Create_Statement (Database : in Database_Connection;
                              Query    : in String)
                              return Query_Statement_Access;

   --  Create a delete statement.
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement_Access;

   --  Create an insert statement.
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement_Access;

   --  Create an update statement.
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement_Access;

   --  Start a transaction.
   overriding
   procedure Begin_Transaction (Database : in out Database_Connection);

   --  Commit the current transaction.
   overriding
   procedure Commit (Database : in out Database_Connection);

   --  Rollback the current transaction.
   overriding
   procedure Rollback (Database : in out Database_Connection);

   --  Load the database schema definition for the current database.
   overriding
   procedure Load_Schema (Database : in Database_Connection;
                          Schema   : out ADO.Schemas.Schema_Definition);

   --  Closes the database connection
   overriding
   procedure Close (Database : in out Database_Connection);

   --  Releases the sqlite connection if it is open
   overriding
   procedure Finalize (Database : in out Database_Connection);

   procedure Execute (Database : in out Database_Connection;
                      SQL : in Query_String);

   type Sqlite_Driver is new ADO.Drivers.Connections.Driver with null record;

   --  Create a new SQLite connection using the configuration parameters.
   overriding
   procedure Create_Connection (D      : in out Sqlite_Driver;
                                Config : in Configuration'Class;
                                Result : in out Ref.Ref'Class);

end ADO.Drivers.Connections.Sqlite;

-----------------------------------------------------------------------
--  ADO Sqlite Database -- SQLite Database connections
--  Copyright (C) 2009, 2010, 2011, 2012, 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 Sqlite3_H;
with Interfaces.C;
package ADO.Drivers.Connections.Sqlite is

   subtype Sqlite3 is Sqlite3_H.sqlite3;

   --  The database connection manager
   type Sqlite_Driver is limited private;

   --  Initialize the SQLite driver.
   procedure Initialize;

   --  Check for an error after executing a sqlite statement.
   procedure Check_Error (Connection : access Sqlite3;
                          Result     : in Interfaces.C.int);

private

   --  Database connection implementation
   type Database_Connection is new ADO.Drivers.Connections.Database_Connection with record
      Server : aliased access Sqlite3_H.sqlite3;
      Name   : Unbounded_String;
   end record;
   type Database_Connection_Access is access all Database_Connection'Class;

   --  Get the database driver which manages this connection.
   overriding
   function Get_Driver (Database : in Database_Connection)
                        return Driver_Access;

   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement_Access;

   overriding
   function Create_Statement (Database : in Database_Connection;
                              Query    : in String)
                              return Query_Statement_Access;

   --  Create a delete statement.
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement_Access;

   --  Create an insert statement.
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement_Access;

   --  Create an update statement.
   overriding
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement_Access;

   --  Start a transaction.
   overriding
   procedure Begin_Transaction (Database : in out Database_Connection);

   --  Commit the current transaction.
   overriding
   procedure Commit (Database : in out Database_Connection);

   --  Rollback the current transaction.
   overriding
   procedure Rollback (Database : in out Database_Connection);

   --  Load the database schema definition for the current database.
   overriding
   procedure Load_Schema (Database : in Database_Connection;
                          Schema   : out ADO.Schemas.Schema_Definition);

   --  Closes the database connection
   overriding
   procedure Close (Database : in out Database_Connection);

   --  Releases the sqlite connection if it is open
   overriding
   procedure Finalize (Database : in out Database_Connection);

   procedure Execute (Database : in out Database_Connection;
                      SQL : in Query_String);

   type Sqlite_Driver is new ADO.Drivers.Connections.Driver with null record;

   --  Create a new SQLite connection using the configuration parameters.
   overriding
   procedure Create_Connection (D      : in out Sqlite_Driver;
                                Config : in Configuration'Class;
                                Result : in out Ref.Ref'Class);

end ADO.Drivers.Connections.Sqlite;

Replace Sqlite_Access and System.Address with the access Sqlite3 type


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

with Util.Log.Loggers;

with Ada.Strings.Fixed;
with Ada.Containers.Doubly_Linked_Lists;

package body ADO.Drivers.Connections is

   use Util.Log;
   use Ada.Strings.Fixed;

   Log : constant Loggers.Logger := Loggers.Create ("ADO.Drivers.Connections");

   --  ------------------------------
   --  Set the connection URL to connect to the database.
   --  The driver connection is a string of the form:
   --
   --   driver://[host][:port]/[database][?property1][=value1]...
   --
   --  If the string is invalid or if the driver cannot be found,
   --  the Connection_Error exception is raised.
   --  ------------------------------
   procedure Set_Connection (Controller : in out Configuration;
                             URI        : in String) is

      Pos, Pos2, Slash_Pos, Next : Natural;
   begin
      Log.Info ("Set connection URI: {0}", URI);

      Controller.URI := To_Unbounded_String (URI);
      Pos := Index (URI, "://");
      if Pos <= 1 then
         Log.Error ("Invalid connection URI: {0}", URI);
         raise Connection_Error
           with "Invalid URI: '" & URI & "'";
      end if;
      Controller.Driver := Get_Driver (URI (URI'First .. Pos - 1));
      if Controller.Driver = null then
         Log.Error ("No driver found for connection URI: {0}", URI);
         raise Connection_Error
           with "Driver '" & URI (URI'First .. Pos - 1) & "' not found";
      end if;

      Pos := Pos + 3;
      Slash_Pos := Index (URI, "/", Pos);
      if Slash_Pos < Pos then
         Log.Error ("Invalid connection URI: {0}", URI);
         raise Connection_Error
           with "Invalid connection URI: '" & URI & "'";
      end if;

      --  Extract the server and port.
      Pos2 := Index (URI, ":", Pos);
      if Pos2 > Pos then
         Controller.Server := To_Unbounded_String (URI (Pos .. Pos2 - 1));
         Controller.Port := Integer'Value (URI (Pos2 + 1 .. Slash_Pos - 1));

      else
         Controller.Port := 0;
         Controller.Server := To_Unbounded_String (URI (Pos .. Slash_Pos - 1));
      end if;

      --  Extract the database name.
      Pos := Index (URI, "?", Slash_Pos);
      if Pos - 1 > Slash_Pos + 1 then
         Controller.Database := To_Unbounded_String (URI (Slash_Pos + 1 .. Pos - 1));
      elsif Pos = 0 and Slash_Pos + 1 < URI'Last then
         Controller.Database := To_Unbounded_String (URI (Slash_Pos + 1 .. URI'Last));
      else
         Controller.Database := Null_Unbounded_String;
      end if;

      --  Parse the optional properties
      if Pos > Slash_Pos then
         while Pos < URI'Last loop
            Pos2 := Index (URI, "=", Pos + 1);
            if Pos2 > Pos then
               Next := Index (URI, "&", Pos2 + 1);
               if Next > 0 then
                  Controller.Properties.Set (URI (Pos + 1 .. Pos2 - 1),
                                             URI (Pos2 + 1 .. Next - 1));
                  Pos := Next;
               else
                  Controller.Properties.Set (URI (Pos + 1 .. Pos2 - 1),
                                             URI (Pos2 + 1 .. URI'Last));
                  Pos := URI'Last;
               end if;
            else
               Controller.Properties.Set (URI (Pos + 1 .. URI'Last), "");
               Pos := URI'Last;
            end if;
         end loop;
      end if;
   end Set_Connection;

   --  ------------------------------
   --  Set a property on the datasource for the driver.
   --  The driver can retrieve the property to configure and open
   --  the database connection.
   --  ------------------------------
   procedure Set_Property (Controller : in out Configuration;
                           Name       : in String;
                           Value      : in String) is
   begin
      Controller.Properties.Set (Name, Value);
   end Set_Property;

   --  ------------------------------
   --  Get a property from the datasource configuration.
   --  If the property does not exist, an empty string is returned.
   --  ------------------------------
   function Get_Property (Controller : in Configuration;
                          Name       : in String) return String is
   begin
      return Controller.Properties.Get (Name, "");
   end Get_Property;

   --  ------------------------------
   --  Get the server hostname.
   --  ------------------------------
   function Get_Server (Controller : in Configuration) return String is
   begin
      return To_String (Controller.Server);
   end Get_Server;

   --  ------------------------------
   --  Get the server port.
   --  ------------------------------
   function Get_Port (Controller : in Configuration) return Integer is
   begin
      return Controller.Port;
   end Get_Port;

   --  ------------------------------
   --  Get the database name.
   --  ------------------------------
   function Get_Database (Controller : in Configuration) return String is
   begin
      return To_String (Controller.Database);
   end Get_Database;

   --  ------------------------------
   --  Create a new connection using the configuration parameters.
   --  ------------------------------
   procedure Create_Connection (Config : in Configuration'Class;
                                Result : out Database_Connection_Access) is
   begin
      if Config.Driver = null then
         Log.Error ("No driver found for connection {0}", To_String (Config.URI));
         raise Connection_Error with "Data source is not initialized: driver not found";
      end if;
      Config.Driver.Create_Connection (Config, Result);
      Log.Info ("Created connection to '{0}' -> {1}", Config.URI, Result.Ident);

   exception
      when others =>
         Log.Info ("Failed to create connection to '{0}'", Config.URI);
         raise;

   end Create_Connection;

   package Driver_List is
     new Ada.Containers.Doubly_Linked_Lists (Element_Type => Driver_Access);

   Next_Index : Driver_Index := 1;
   Drivers    : Driver_List.List;

   --  ------------------------------
   --  Get the driver unique index.
   --  ------------------------------
   function Get_Driver_Index (D : in Driver) return Driver_Index is
   begin
      return D.Index;
   end Get_Driver_Index;

   --  ------------------------------
   --  Get the driver name.
   --  ------------------------------
   function Get_Driver_Name (D : in Driver) return String is
   begin
      return D.Name.all;
   end Get_Driver_Name;

   --  ------------------------------
   --  Register a database driver.
   --  ------------------------------
   procedure Register (Driver : in Driver_Access) is
   begin
      Log.Info ("Register driver {0}", Driver.Name.all);

      Driver_List.Prepend (Container => Drivers, New_Item => Driver);
      Driver.Index := Next_Index;
      Next_Index := Next_Index + 1;
   end Register;

   --  ------------------------------
   --  Get a database driver given its name.
   --  ------------------------------
   function Get_Driver (Name : in String) return Driver_Access is
      Iter : Driver_List.Cursor := Driver_List.First (Drivers);
   begin
      Log.Info ("Get driver {0}", Name);

      while Driver_List.Has_Element (Iter) loop
         declare
            D : constant Driver_Access := Driver_List.Element (Iter);
         begin
            if Name = D.Name.all then
               return D;
            end if;
         end;
         Driver_List.Next (Iter);
      end loop;
      return null;
   end Get_Driver;

end ADO.Drivers.Connections;

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

with Util.Log.Loggers;
with Util.Systems.DLLs;

with System;
with Ada.Strings.Fixed;
with Ada.Containers.Doubly_Linked_Lists;
with Ada.Exceptions;

package body ADO.Drivers.Connections is

   use Util.Log;
   use Ada.Strings.Fixed;

   Log : constant Loggers.Logger := Loggers.Create ("ADO.Drivers.Connections");

   --  ------------------------------
   --  Set the connection URL to connect to the database.
   --  The driver connection is a string of the form:
   --
   --   driver://[host][:port]/[database][?property1][=value1]...
   --
   --  If the string is invalid or if the driver cannot be found,
   --  the Connection_Error exception is raised.
   --  ------------------------------
   procedure Set_Connection (Controller : in out Configuration;
                             URI        : in String) is

      Pos, Pos2, Slash_Pos, Next : Natural;
   begin
      Log.Info ("Set connection URI: {0}", URI);

      Controller.URI := To_Unbounded_String (URI);
      Pos := Index (URI, "://");
      if Pos <= 1 then
         Log.Error ("Invalid connection URI: {0}", URI);
         raise Connection_Error
           with "Invalid URI: '" & URI & "'";
      end if;
      Controller.Driver := Get_Driver (URI (URI'First .. Pos - 1));
      if Controller.Driver = null then
         Log.Error ("No driver found for connection URI: {0}", URI);
         raise Connection_Error
           with "Driver '" & URI (URI'First .. Pos - 1) & "' not found";
      end if;

      Pos := Pos + 3;
      Slash_Pos := Index (URI, "/", Pos);
      if Slash_Pos < Pos then
         Log.Error ("Invalid connection URI: {0}", URI);
         raise Connection_Error
           with "Invalid connection URI: '" & URI & "'";
      end if;

      --  Extract the server and port.
      Pos2 := Index (URI, ":", Pos);
      if Pos2 > Pos then
         Controller.Server := To_Unbounded_String (URI (Pos .. Pos2 - 1));
         Controller.Port := Integer'Value (URI (Pos2 + 1 .. Slash_Pos - 1));

      else
         Controller.Port := 0;
         Controller.Server := To_Unbounded_String (URI (Pos .. Slash_Pos - 1));
      end if;

      --  Extract the database name.
      Pos := Index (URI, "?", Slash_Pos);
      if Pos - 1 > Slash_Pos + 1 then
         Controller.Database := To_Unbounded_String (URI (Slash_Pos + 1 .. Pos - 1));
      elsif Pos = 0 and Slash_Pos + 1 < URI'Last then
         Controller.Database := To_Unbounded_String (URI (Slash_Pos + 1 .. URI'Last));
      else
         Controller.Database := Null_Unbounded_String;
      end if;

      --  Parse the optional properties
      if Pos > Slash_Pos then
         while Pos < URI'Last loop
            Pos2 := Index (URI, "=", Pos + 1);
            if Pos2 > Pos then
               Next := Index (URI, "&", Pos2 + 1);
               if Next > 0 then
                  Controller.Properties.Set (URI (Pos + 1 .. Pos2 - 1),
                                             URI (Pos2 + 1 .. Next - 1));
                  Pos := Next;
               else
                  Controller.Properties.Set (URI (Pos + 1 .. Pos2 - 1),
                                             URI (Pos2 + 1 .. URI'Last));
                  Pos := URI'Last;
               end if;
            else
               Controller.Properties.Set (URI (Pos + 1 .. URI'Last), "");
               Pos := URI'Last;
            end if;
         end loop;
      end if;
   end Set_Connection;

   --  ------------------------------
   --  Set a property on the datasource for the driver.
   --  The driver can retrieve the property to configure and open
   --  the database connection.
   --  ------------------------------
   procedure Set_Property (Controller : in out Configuration;
                           Name       : in String;
                           Value      : in String) is
   begin
      Controller.Properties.Set (Name, Value);
   end Set_Property;

   --  ------------------------------
   --  Get a property from the datasource configuration.
   --  If the property does not exist, an empty string is returned.
   --  ------------------------------
   function Get_Property (Controller : in Configuration;
                          Name       : in String) return String is
   begin
      return Controller.Properties.Get (Name, "");
   end Get_Property;

   --  ------------------------------
   --  Get the server hostname.
   --  ------------------------------
   function Get_Server (Controller : in Configuration) return String is
   begin
      return To_String (Controller.Server);
   end Get_Server;

   --  ------------------------------
   --  Get the server port.
   --  ------------------------------
   function Get_Port (Controller : in Configuration) return Integer is
   begin
      return Controller.Port;
   end Get_Port;

   --  ------------------------------
   --  Get the database name.
   --  ------------------------------
   function Get_Database (Controller : in Configuration) return String is
   begin
      return To_String (Controller.Database);
   end Get_Database;

   --  ------------------------------
   --  Create a new connection using the configuration parameters.
   --  ------------------------------
   procedure Create_Connection (Config : in Configuration'Class;
                                Result : out Database_Connection_Access) is
   begin
      if Config.Driver = null then
         Log.Error ("No driver found for connection {0}", To_String (Config.URI));
         raise Connection_Error with "Data source is not initialized: driver not found";
      end if;
      Config.Driver.Create_Connection (Config, Result);
      Log.Info ("Created connection to '{0}' -> {1}", Config.URI, Result.Ident);

   exception
      when others =>
         Log.Info ("Failed to create connection to '{0}'", Config.URI);
         raise;

   end Create_Connection;

   package Driver_List is
     new Ada.Containers.Doubly_Linked_Lists (Element_Type => Driver_Access);

   Next_Index : Driver_Index := 1;
   Drivers    : Driver_List.List;

   --  ------------------------------
   --  Get the driver unique index.
   --  ------------------------------
   function Get_Driver_Index (D : in Driver) return Driver_Index is
   begin
      return D.Index;
   end Get_Driver_Index;

   --  ------------------------------
   --  Get the driver name.
   --  ------------------------------
   function Get_Driver_Name (D : in Driver) return String is
   begin
      return D.Name.all;
   end Get_Driver_Name;

   --  ------------------------------
   --  Register a database driver.
   --  ------------------------------
   procedure Register (Driver : in Driver_Access) is
   begin
      Log.Info ("Register driver {0}", Driver.Name.all);

      Driver_List.Prepend (Container => Drivers, New_Item => Driver);
      Driver.Index := Next_Index;
      Next_Index := Next_Index + 1;
   end Register;

   type Driver_Initialize_Access is not null access procedure;

   procedure Load_Driver (Name : in String) is
      Lib    : constant String := "libada_ado_" & Name & Util.Systems.DLLs.Extension;
      Symbol : constant String := "ado__drivers__connections__" & Name & "__initialize";
      Handle : Util.Systems.DLLs.Handle;
      Addr   : System.Address;

   begin
      Log.Info ("Loading driver {0}", Lib);
      Handle := Util.Systems.DLLs.Load (Lib);
      Addr := Util.Systems.DLLs.Get_Symbol (Handle, Symbol);

      declare
         procedure Init;
         pragma Import (C, Init);
         for Init'Address use Addr;
      begin
         Init;
      end;
   exception
      when Util.Systems.DLLs.Not_Found =>
         Log.Error ("Driver for {0} was loaded but does not define the initialization symbol",
                    Name);

      when E : Util.Systems.DLLs.Load_Error =>
         Log.Error ("Driver for {0} was not found: {1}",
                    Name, Ada.Exceptions.Exception_Message (E));

   end Load_Driver;

   --  ------------------------------
   --  Get a database driver given its name.
   --  ------------------------------
   function Get_Driver (Name : in String) return Driver_Access is
   begin
      Log.Info ("Get driver {0}", Name);

      for Retry in 0 .. 1 loop
         if Retry > 0 then
            Load_Driver (Name);
         end if;
         declare
            Iter : Driver_List.Cursor := Driver_List.First (Drivers);
         begin
            while Driver_List.Has_Element (Iter) loop
               declare
                  D : constant Driver_Access := Driver_List.Element (Iter);
               begin
                  if Name = D.Name.all then
                     return D;
                  end if;
               end;
               Driver_List.Next (Iter);
            end loop;
         end;
      end loop;
      return null;
   end Get_Driver;

end ADO.Drivers.Connections;

Add support to load database drivers dynamically - extract the driver name from the connection string, - load the DLL, - find the driver initialization method and call it