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

with Ada.Strings.Unbounded;

with Util.Http.Mockups;
with Util.Http.Clients.Mockups;

with Util.Test_Caller;
with Ada.Text_IO;
package body Security.Auth.Tests is

   use Util.Tests;

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

   procedure Check_Discovery (T    : in out Test;
                              Name : in String;
                              URI  : in String);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Security.OpenID.Discover",
                       Test_Discovery'Access);
      Caller.Add_Test (Suite, "Test Security.OpenID.Verify_Signature",
                       Test_Verify_Signature'Access);
   end Add_Tests;

   overriding
   function Get_Parameter (Params : in Test_Parameters;
                           Name   : in String) return String is
   begin
      if Params.Params.Contains (Name) then
         return Params.Params.Element (Name);
      else
         return "";
      end if;
   end Get_Parameter;

   procedure Set_Parameter (Params : in out Test_Parameters;
                            Name   : in String;
                            Value  : in String) is
   begin
      Params.Params.Include (Name, Value);
   end Set_Parameter;

   procedure Setup (M : in out Manager;
                    Name : in String) is
      Params : Test_Parameters;
   begin
      Params.Set_Parameter ("auth.provider.google", "openid");
      Params.Set_Parameter ("auth.provider.openid", "openid");
      Params.Set_Parameter ("openid.realm", "http://localhost/verify");
      Params.Set_Parameter ("openid.callback_url", "http://localhost/openId");
      M.Initialize (Params, Name);
   end Setup;

   procedure Check_Discovery (T    : in out Test;
                              Name : in String;
                              URI  : in String) is
      pragma Unreferenced (URI, T);

      M      : Manager;
      Dir    : constant String := "regtests/files/discover/";
      Path   : constant String := Util.Tests.Get_Path (Dir);
      Result : End_Point;
   begin
      Setup (M, "openid");
      Util.Http.Clients.Mockups.Register;
      Util.Http.Clients.Mockups.Set_File (Path & Name & ".xrds");
      M.Discover (Name   => Name,
                  Result => Result);
      Ada.Text_IO.Put_Line ("Result: " & To_String (Result));
   end Check_Discovery;

   --  ------------------------------
   --  Test Yadis discovery using static files
   --  ------------------------------
   procedure Test_Discovery (T : in out Test) is
   begin
      Check_Discovery (T, "google", "https://www.google.com/accounts/o8/ud");
      Check_Discovery (T, "yahoo", "https://open.login.yahooapis.com/openid/op/auth");
      Check_Discovery (T, "claimid", "");
      Check_Discovery (T, "livejournal", "");
      Check_Discovery (T, "myopenid", "");
      Check_Discovery (T, "myspace", "");
      Check_Discovery (T, "orange", "");
      Check_Discovery (T, "verisign", "");
      Check_Discovery (T, "steamcommunity", "");
   end Test_Discovery;

   --  ------------------------------
   --  Test the OpenID verify signature process
   --  ------------------------------
   procedure Test_Verify_Signature (T : in out Test) is
      Assoc  : Association;
      Req    : Test_Parameters;
      M      : Manager;
      Result : Authentication;
   begin
      Setup (M, "openid");

--        M.Return_To := To_Unbounded_String ("http://localhost/openId");

      --  Below is a part of the authentication process on Google OpenId.
      --  In theory, you cannot use the following information to authenticate again...
      Assoc.Session_Type := To_Unbounded_String ("no-encryption");
      Assoc.Assoc_Type   := To_Unbounded_String ("HMAC-SHA1");
      Assoc.Assoc_Handle := To_Unbounded_String ("AOQobUdTfNDRSgJLi_0mQQnCCstOsefQadOiW9LNSp4JFO815iHCHsRk");
      Assoc.Mac_Key      := To_Unbounded_String ("NGFpR6vWfe7O8YIhhnXQMjL0goI=");

      Req.Set_Parameter ("openid.ns", "http://specs.openid.net/auth/2.0");
      Req.Set_Parameter ("openid.mode", "id_res");
      Req.Set_Parameter ("openid.op_endpoint", "https://www.google.com/accounts/o8/ud");
      Req.Set_Parameter ("openid.response_nonce", "2011-04-26T20:08:22ZJ_neiVqR0e1wZw");
      Req.Set_Parameter ("openid.return_to", "http://localhost/openId");
      Req.Set_Parameter ("openid.assoc_handle", "AOQobUdTfNDRSgJLi_0mQQnCCstOsefQadOiW9LNSp4JFO815iHCHsRk");
      Req.Set_Parameter ("openid.signed", "op_endpoint,claimed_id,identity,return_to,response_nonce,assoc_handle,ns.ext1,ext1.mode,ext1.type.firstname,ext1.value.firstname,ext1.type.email,ext1.value.email,ext1.type.language,ext1.value.language,ext1.type.lastname,ext1.value.lastname");
      Req.Set_Parameter ("openid.sig", "pV8cmScjrmgKvFn2F6Wxh/qBiIE=");
      Req.Set_Parameter ("openid.identity", "https://www.google.com/accounts/o8/id?id=AItOawm4O6C695XlWrS7MUWC-_V_R2zC-Ol993E");
      Req.Set_Parameter ("openid.claimed_id", "https://www.google.com/accounts/o8/id?id=AItOawm4O6C695XlWrS7MUWC-_V_R2zC-Ol993E");
      Req.Set_Parameter ("openid.ns.ext1", "http://openid.net/srv/ax/1.0");
      Req.Set_Parameter ("openid.ext1.mode", "fetch_response");
      Req.Set_Parameter ("openid.ext1.type.firstname", "http://axschema.org/namePerson/first");
      Req.Set_Parameter ("openid.ext1.value.firstname", "Stephane");
      Req.Set_Parameter ("openid.ext1.type.email", "http://axschema.org/contact/email");
      Req.Set_Parameter ("openid.ext1.value.email", "stephane.carrez@gmail.com");
      Req.Set_Parameter ("openid.ext1.type.language", "http://axschema.org/pref/language");
      Req.Set_Parameter ("openid.ext1.value.language", "fr");
      Req.Set_Parameter ("openid.ext1.type.lastname", "http://axschema.org/namePerson/last");
      Req.Set_Parameter ("openid.ext1.value.lastname", "Carrez");

      M.Verify (Assoc, Req, Result);

      --  If the verification is succeeds, the signature is correct, we should be authenticated.
      T.Assert (Get_Status (Result) = AUTHENTICATED, "Authentication status is not authenticated");
      Assert_Equals (T, "stephane.carrez@gmail.com", Get_Email (Result), "Invalid email");
   end Test_Verify_Signature;

end Security.Auth.Tests;

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

with Ada.Strings.Unbounded;

with Util.Http.Clients.Mockups;

with Util.Test_Caller;
with Ada.Text_IO;
package body Security.Auth.Tests is

   use Util.Tests;

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

   procedure Check_Discovery (T    : in out Test;
                              Name : in String;
                              URI  : in String);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Security.OpenID.Discover",
                       Test_Discovery'Access);
      Caller.Add_Test (Suite, "Test Security.OpenID.Verify_Signature",
                       Test_Verify_Signature'Access);
   end Add_Tests;

   overriding
   function Get_Parameter (Params : in Test_Parameters;
                           Name   : in String) return String is
   begin
      if Params.Params.Contains (Name) then
         return Params.Params.Element (Name);
      else
         return "";
      end if;
   end Get_Parameter;

   procedure Set_Parameter (Params : in out Test_Parameters;
                            Name   : in String;
                            Value  : in String) is
   begin
      Params.Params.Include (Name, Value);
   end Set_Parameter;

   procedure Setup (M : in out Manager;
                    Name : in String) is
      Params : Test_Parameters;
   begin
      Params.Set_Parameter ("auth.provider.google", "openid");
      Params.Set_Parameter ("auth.provider.openid", "openid");
      Params.Set_Parameter ("openid.realm", "http://localhost/verify");
      Params.Set_Parameter ("openid.callback_url", "http://localhost/openId");
      M.Initialize (Params, Name);
   end Setup;

   procedure Check_Discovery (T    : in out Test;
                              Name : in String;
                              URI  : in String) is
      pragma Unreferenced (URI, T);

      M      : Manager;
      Dir    : constant String := "regtests/files/discover/";
      Path   : constant String := Util.Tests.Get_Path (Dir);
      Result : End_Point;
   begin
      Setup (M, "openid");
      Util.Http.Clients.Mockups.Register;
      Util.Http.Clients.Mockups.Set_File (Path & Name & ".xrds");
      M.Discover (Name   => Name,
                  Result => Result);
      Ada.Text_IO.Put_Line ("Result: " & To_String (Result));
   end Check_Discovery;

   --  ------------------------------
   --  Test Yadis discovery using static files
   --  ------------------------------
   procedure Test_Discovery (T : in out Test) is
   begin
      Check_Discovery (T, "google", "https://www.google.com/accounts/o8/ud");
      Check_Discovery (T, "yahoo", "https://open.login.yahooapis.com/openid/op/auth");
      Check_Discovery (T, "claimid", "");
      Check_Discovery (T, "livejournal", "");
      Check_Discovery (T, "myopenid", "");
      Check_Discovery (T, "myspace", "");
      Check_Discovery (T, "orange", "");
      Check_Discovery (T, "verisign", "");
      Check_Discovery (T, "steamcommunity", "");
   end Test_Discovery;

   --  ------------------------------
   --  Test the OpenID verify signature process
   --  ------------------------------
   procedure Test_Verify_Signature (T : in out Test) is
      Assoc  : Association;
      Req    : Test_Parameters;
      M      : Manager;
      Result : Authentication;
   begin
      Setup (M, "openid");

--        M.Return_To := To_Unbounded_String ("http://localhost/openId");

      --  Below is a part of the authentication process on Google OpenId.
      --  In theory, you cannot use the following information to authenticate again...
      Assoc.Session_Type := To_Unbounded_String ("no-encryption");
      Assoc.Assoc_Type   := To_Unbounded_String ("HMAC-SHA1");
      Assoc.Assoc_Handle := To_Unbounded_String ("AOQobUdTfNDRSgJLi_0mQQnCCstOsefQadOiW9LNSp4JFO815iHCHsRk");
      Assoc.Mac_Key      := To_Unbounded_String ("NGFpR6vWfe7O8YIhhnXQMjL0goI=");

      Req.Set_Parameter ("openid.ns", "http://specs.openid.net/auth/2.0");
      Req.Set_Parameter ("openid.mode", "id_res");
      Req.Set_Parameter ("openid.op_endpoint", "https://www.google.com/accounts/o8/ud");
      Req.Set_Parameter ("openid.response_nonce", "2011-04-26T20:08:22ZJ_neiVqR0e1wZw");
      Req.Set_Parameter ("openid.return_to", "http://localhost/openId");
      Req.Set_Parameter ("openid.assoc_handle", "AOQobUdTfNDRSgJLi_0mQQnCCstOsefQadOiW9LNSp4JFO815iHCHsRk");
      Req.Set_Parameter ("openid.signed", "op_endpoint,claimed_id,identity,return_to,response_nonce,assoc_handle,ns.ext1,ext1.mode,ext1.type.firstname,ext1.value.firstname,ext1.type.email,ext1.value.email,ext1.type.language,ext1.value.language,ext1.type.lastname,ext1.value.lastname");
      Req.Set_Parameter ("openid.sig", "pV8cmScjrmgKvFn2F6Wxh/qBiIE=");
      Req.Set_Parameter ("openid.identity", "https://www.google.com/accounts/o8/id?id=AItOawm4O6C695XlWrS7MUWC-_V_R2zC-Ol993E");
      Req.Set_Parameter ("openid.claimed_id", "https://www.google.com/accounts/o8/id?id=AItOawm4O6C695XlWrS7MUWC-_V_R2zC-Ol993E");
      Req.Set_Parameter ("openid.ns.ext1", "http://openid.net/srv/ax/1.0");
      Req.Set_Parameter ("openid.ext1.mode", "fetch_response");
      Req.Set_Parameter ("openid.ext1.type.firstname", "http://axschema.org/namePerson/first");
      Req.Set_Parameter ("openid.ext1.value.firstname", "Stephane");
      Req.Set_Parameter ("openid.ext1.type.email", "http://axschema.org/contact/email");
      Req.Set_Parameter ("openid.ext1.value.email", "stephane.carrez@gmail.com");
      Req.Set_Parameter ("openid.ext1.type.language", "http://axschema.org/pref/language");
      Req.Set_Parameter ("openid.ext1.value.language", "fr");
      Req.Set_Parameter ("openid.ext1.type.lastname", "http://axschema.org/namePerson/last");
      Req.Set_Parameter ("openid.ext1.value.lastname", "Carrez");

      M.Verify (Assoc, Req, Result);

      --  If the verification is succeeds, the signature is correct, we should be authenticated.
      T.Assert (Get_Status (Result) = AUTHENTICATED, "Authentication status is not authenticated");
      Assert_Equals (T, "stephane.carrez@gmail.com", Get_Email (Result), "Invalid email");
   end Test_Verify_Signature;

end Security.Auth.Tests;

Fix compilation warning: unused with clause


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

with Util.Tests;
package Util.Encoders.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new Util.Tests.Test with null record;

   procedure Test_Hex (T : in out Test);
   procedure Test_Base64_Encode (T : in out Test);
   procedure Test_Base64_Decode (T : in out Test);
   procedure Test_Base64_URL_Encode (T : in out Test);
   procedure Test_Base64_URL_Decode (T : in out Test);
   procedure Test_Encoder (T : in out Test;
                           C : in Util.Encoders.Encoder;
                           D : in Util.Encoders.Decoder);
   procedure Test_Base64_Benchmark (T : in out Test);
   procedure Test_SHA1_Encode (T : in out Test);
   procedure Test_SHA256_Encode (T : in out Test);

   --  Benchmark test for SHA1
   procedure Test_SHA1_Benchmark (T : in out Test);

   --  Test HMAC-SHA1
   procedure Test_HMAC_SHA1_RFC2202_T1 (T : in out Test);
   procedure Test_HMAC_SHA1_RFC2202_T2 (T : in out Test);
   procedure Test_HMAC_SHA1_RFC2202_T3 (T : in out Test);
   procedure Test_HMAC_SHA1_RFC2202_T4 (T : in out Test);
   procedure Test_HMAC_SHA1_RFC2202_T5 (T : in out Test);
   procedure Test_HMAC_SHA1_RFC2202_T6 (T : in out Test);
   procedure Test_HMAC_SHA1_RFC2202_T7 (T : in out Test);

   --  Test HMAC-SHA256
   procedure Test_HMAC_SHA256_RFC4231_T1 (T : in out Test);
   procedure Test_HMAC_SHA256_RFC4231_T2 (T : in out Test);
   procedure Test_HMAC_SHA256_RFC4231_T3 (T : in out Test);
   procedure Test_HMAC_SHA256_RFC4231_T4 (T : in out Test);
   procedure Test_HMAC_SHA256_RFC4231_T5 (T : in out Test);
   procedure Test_HMAC_SHA256_RFC4231_T6 (T : in out Test);
   procedure Test_HMAC_SHA256_RFC4231_T7 (T : in out Test);

   --  Test encoding leb128.
   procedure Test_LEB128 (T : in out Test);

   --  Test encoding leb128 + base64url.
   procedure Test_Base64_LEB128 (T : in out Test);

   --  Test encrypt and decrypt operations.
   procedure Test_AES (T : in out Test);

   --  Test encrypt and decrypt operations.
   procedure Test_Encrypt_Decrypt_Secret (T : in out Test);

end Util.Encoders.Tests;

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

with Util.Tests;
package Util.Encoders.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new Util.Tests.Test with null record;

   procedure Test_Hex (T : in out Test);
   procedure Test_Base64_Encode (T : in out Test);
   procedure Test_Base64_Decode (T : in out Test);
   procedure Test_Base64_URL_Encode (T : in out Test);
   procedure Test_Base64_URL_Decode (T : in out Test);
   procedure Test_Encoder (T : in out Test;
                           C : in Util.Encoders.Encoder;
                           D : in Util.Encoders.Decoder);
   procedure Test_Base64_Benchmark (T : in out Test);
   procedure Test_SHA1_Encode (T : in out Test);
   procedure Test_SHA256_Encode (T : in out Test);

   --  Benchmark test for SHA1
   procedure Test_SHA1_Benchmark (T : in out Test);

   --  Test HMAC-SHA1
   procedure Test_HMAC_SHA1_RFC2202_T1 (T : in out Test);
   procedure Test_HMAC_SHA1_RFC2202_T2 (T : in out Test);
   procedure Test_HMAC_SHA1_RFC2202_T3 (T : in out Test);
   procedure Test_HMAC_SHA1_RFC2202_T4 (T : in out Test);
   procedure Test_HMAC_SHA1_RFC2202_T5 (T : in out Test);
   procedure Test_HMAC_SHA1_RFC2202_T6 (T : in out Test);
   procedure Test_HMAC_SHA1_RFC2202_T7 (T : in out Test);

   --  Test HMAC-SHA256
   procedure Test_HMAC_SHA256_RFC4231_T1 (T : in out Test);
   procedure Test_HMAC_SHA256_RFC4231_T2 (T : in out Test);
   procedure Test_HMAC_SHA256_RFC4231_T3 (T : in out Test);
   procedure Test_HMAC_SHA256_RFC4231_T4 (T : in out Test);
   procedure Test_HMAC_SHA256_RFC4231_T5 (T : in out Test);
   procedure Test_HMAC_SHA256_RFC4231_T6 (T : in out Test);
   procedure Test_HMAC_SHA256_RFC4231_T7 (T : in out Test);

   --  Test encoding leb128.
   procedure Test_LEB128 (T : in out Test);

   --  Test encoding leb128 + base64url.
   procedure Test_Base64_LEB128 (T : in out Test);

   --  Test encrypt and decrypt operations.
   procedure Test_AES (T : in out Test);

   --  Test encrypt and decrypt operations.
   procedure Test_Encrypt_Decrypt_Secret (T : in out Test);

   --  Test Decode Quoted-Printable encoding.
   procedure Test_Decode_Quoted_Printable (T : in out Test);

end Util.Encoders.Tests;

Declare the Test_Decode_Quoted_Printable procedure


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

   type Justify_Type is (J_LEFT,           --  Justify left   |item    |
                         J_RIGHT,          --  Justify right  |    item|
                         J_CENTER,         --  Justify center |  item  |
                         J_RIGHT_NO_FILL   --  Justify right  |item|
                        );

   type Console_Type is abstract tagged limited private;
   type Console_Access is access all Console_Type'Class;

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

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

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

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

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

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

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

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

   --  Print the title for the given field and setup the associated field size.
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String;
                          Length  : in Positive);

   --  Format the integer and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Integer;
                          Justify : in Justify_Type := J_LEFT);

   --  Format the integer and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Ada.Strings.Unbounded.Unbounded_String;
                          Justify : in Justify_Type := J_LEFT);

   --  Get the field count that was setup through the Print_Title calls.
   function Get_Field_Count (Console : in Console_Type) return Natural;

   --  Reset the field count.
   procedure Clear_Fields (Console : in out Console_Type);

private

   type Field_Size_Array is array (Field_Type) of Natural;

   type Field_List_Array is array (1 .. Field_Size_Array'Length) of Field_Type;

   type Console_Type is abstract tagged limited record
      Sizes       : Field_Size_Array := (others => 1);
      Cols        : Field_Size_Array := (others => 1);
      Fields      : Field_List_Array;
      Field_Count : Natural := 0;
   end record;

end Util.Commands.Consoles;

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

   type Justify_Type is (J_LEFT,           --  Justify left   |item    |
                         J_RIGHT,          --  Justify right  |    item|
                         J_CENTER,         --  Justify center |  item  |
                         J_RIGHT_NO_FILL   --  Justify right  |item|
                        );

   type Console_Type is abstract tagged limited private;
   type Console_Access is access all Console_Type'Class;

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

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

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

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

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

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

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

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

   --  Print the title for the given field and setup the associated field size.
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String;
                          Length  : in Positive);

   --  Format the integer and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Integer;
                          Justify : in Justify_Type := J_LEFT);

   --  Format the integer and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Ada.Strings.Unbounded.Unbounded_String;
                          Justify : in Justify_Type := J_LEFT);

   --  Get the field count that was setup through the Print_Title calls.
   function Get_Field_Count (Console : in Console_Type) return Natural;

   --  Reset the field count.
   procedure Clear_Fields (Console : in out Console_Type);

private

   type Field_Size_Array is array (Field_Type) of Natural;

   type Field_List_Array is array (1 .. Field_Size_Array'Length) of Field_Type;

   type Console_Type is abstract tagged limited record
      Sizes       : Field_Size_Array := (others => 0);
      Cols        : Field_Size_Array := (others => 1);
      Fields      : Field_List_Array;
      Field_Count : Natural := 0;
   end record;

end Util.Commands.Consoles;

Initialize the sizes to 0 by default

Initialize the sizes to 0 by default


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

   use Ada.Strings.Unbounded;
   use AWA.Applications;

   function "-" (Message : in String) return String is (Message);

   Help_Command            : aliased AWA.Commands.Drivers.Help_Command_Type;

   --  ------------------------------
   --  Setup the command before parsing the arguments and executing it.
   --  ------------------------------
   overriding
   procedure Setup (Command : in out Command_Type;
                    Config  : in out GNAT.Command_Line.Command_Line_Configuration;
                    Context : in out Context_Type) is
   begin
      GC.Set_Usage (Config => Config,
                    Usage  => Command.Get_Name & " [arguments]",
                    Help   => Command.Get_Description);
      AWA.Commands.Setup_Command (Config, Context);
   end Setup;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Command   : in out Command_Type;
                   Name      : in String;
                   Context   : in out Context_Type) is
      pragma Unreferenced (Command, Context);
   begin
      null;
   end Help;

   --  ------------------------------
   --  Setup the command before parsing the arguments and executing it.
   --  ------------------------------
   overriding
   procedure Setup (Command : in out Application_Command_Type;
                    Config  : in out GNAT.Command_Line.Command_Line_Configuration;
                    Context : in out Context_Type) is
   begin
      GC.Define_Switch (Config => Config,
                        Output => Command.Application_Name'Access,
                        Switch => "-a:",
                        Long_Switch => "--application=",
                        Argument => "NAME",
                        Help   => -("Defines the name or URI of the application"));
      AWA.Commands.Setup_Command (Config, Context);
   end Setup;

   function Is_Application (Command : in Application_Command_Type;
                            URI     : in String) return Boolean is
   begin
      return Command.Application_Name.all = URI;
   end Is_Application;

   overriding
   procedure Execute (Command   : in out Application_Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
      procedure Find (URI : in String;
                      App : in Servlet.Core.Servlet_Registry_Access);

      Count    : Natural := 0;
      Selected : Application_Access;
      App_Name : Unbounded_String;

      procedure Find (URI : in String;
                      App : in Servlet.Core.Servlet_Registry_Access) is
      begin
         if App.all in Application'Class then
            if Command.Is_Application (URI) then
               App_Name := To_Unbounded_String (URI (URI'First + 1 .. URI'Last));
               Selected := Application'Class (App.all)'Unchecked_Access;
               Count := Count + 1;
            elsif Command.Application_Name'Length = 0 then
               App_Name := To_Unbounded_String (URI (URI'First + 1 .. URI'Last));
               Selected := Application'Class (App.all)'Unchecked_Access;
               Count := Count + 1;
            end if;
         end if;
      end Find;

   begin
      WS.Iterate (Find'Access);
      if Count /= 1 then
         Context.Console.Notice (N_ERROR, -("No application found"));
         return;
      end if;

      Configure (Selected.all, To_String (App_Name), Context);
      Application_Command_Type'Class (Command).Execute (Selected.all, Args, Context);
   end Execute;

   --  ------------------------------
   --  Print the command usage.
   --  ------------------------------
   procedure Usage (Args    : in Argument_List'Class;
                    Context : in out Context_Type;
                    Name    : in String := "") is
   begin
      GC.Display_Help (Context.Command_Config);
      if Name'Length > 0 then
         Driver.Usage (Args, Context, Name);
      end if;
      Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
   end Usage;

   --  ------------------------------
   --  Execute the command with its arguments.
   --  ------------------------------
   procedure Execute (Name    : in String;
                      Args    : in Argument_List'Class;
                      Context : in out Context_Type) is
   begin
      Driver.Execute (Name, Args, Context);
   end Execute;

   procedure Run (Context   : in out Context_Type;
                  Arguments : out Util.Commands.Dynamic_Argument_List) is
   begin
      GC.Getopt (Config => Context.Command_Config);
      Util.Commands.Parsers.GNAT_Parser.Get_Arguments (Arguments, GC.Get_Argument);

      --if Context.Debug or Context.Verbose or Context.Dump then
      --   AKT.Configure_Logs (Debug   => Context.Debug,
      --                       Dump    => Context.Dump,
      --                       Verbose => Context.Verbose);
      --end if;

      if Context.Config_File'Length > 0 then
         Context.Load_Configuration (Context.Config_File.all);
      else
         Context.Load_Configuration (Driver_Name & ".properties");
      end if;

      declare
         Cmd_Name : constant String := Arguments.Get_Command_Name;
      begin
         if Cmd_Name'Length = 0 then
            Context.Console.Notice (N_ERROR, -("Missing command name to execute."));
            Usage (Arguments, Context);
            Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
            return;
         end if;
         Execute (Cmd_Name, Arguments, Context);

      exception
         when GNAT.Command_Line.Invalid_Parameter =>
            Context.Console.Notice (N_ERROR, -("Missing option parameter"));
            raise Error;
      end;

   end Run;

begin
   Driver.Add_Command ("help",
                       -("print some help"),
                       Help_Command'Access);
end AWA.Commands.Drivers;

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

   use Ada.Strings.Unbounded;
   use AWA.Applications;

   function "-" (Message : in String) return String is (Message);

   Help_Command            : aliased AWA.Commands.Drivers.Help_Command_Type;

   --  ------------------------------
   --  Setup the command before parsing the arguments and executing it.
   --  ------------------------------
   overriding
   procedure Setup (Command : in out Command_Type;
                    Config  : in out GNAT.Command_Line.Command_Line_Configuration;
                    Context : in out Context_Type) is
   begin
      GC.Set_Usage (Config => Config,
                    Usage  => Command.Get_Name & " [arguments]",
                    Help   => Command.Get_Description);
      AWA.Commands.Setup_Command (Config, Context);
   end Setup;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Command   : in out Command_Type;
                   Name      : in String;
                   Context   : in out Context_Type) is
      pragma Unreferenced (Command, Context);
   begin
      null;
   end Help;

   --  ------------------------------
   --  Setup the command before parsing the arguments and executing it.
   --  ------------------------------
   overriding
   procedure Setup (Command : in out Application_Command_Type;
                    Config  : in out GNAT.Command_Line.Command_Line_Configuration;
                    Context : in out Context_Type) is
   begin
      GC.Define_Switch (Config => Config,
                        Output => Command.Application_Name'Access,
                        Switch => "-a:",
                        Long_Switch => "--application=",
                        Argument => "NAME",
                        Help   => -("Defines the name or URI of the application"));
      AWA.Commands.Setup_Command (Config, Context);
   end Setup;

   function Is_Application (Command : in Application_Command_Type;
                            URI     : in String) return Boolean is
   begin
      return Command.Application_Name.all = URI;
   end Is_Application;

   overriding
   procedure Execute (Command   : in out Application_Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
      procedure Find (URI : in String;
                      App : in Servlet.Core.Servlet_Registry_Access);

      Count    : Natural := 0;
      Selected : Application_Access;
      App_Name : Unbounded_String;

      procedure Find (URI : in String;
                      App : in Servlet.Core.Servlet_Registry_Access) is
      begin
         if App.all in Application'Class then
            if Command.Is_Application (URI) then
               App_Name := To_Unbounded_String (URI (URI'First + 1 .. URI'Last));
               Selected := Application'Class (App.all)'Unchecked_Access;
               Count := Count + 1;
            elsif Command.Application_Name'Length = 0 then
               App_Name := To_Unbounded_String (URI (URI'First + 1 .. URI'Last));
               Selected := Application'Class (App.all)'Unchecked_Access;
               Count := Count + 1;
            end if;
         end if;
      end Find;

   begin
      WS.Iterate (Find'Access);
      if Count /= 1 then
         Context.Console.Notice (N_ERROR, -("No application found"));
         return;
      end if;

      Configure (Selected.all, To_String (App_Name), Context);
      Application_Command_Type'Class (Command).Execute (Selected.all, Args, Context);
   end Execute;

   --  ------------------------------
   --  Print the command usage.
   --  ------------------------------
   procedure Usage (Args    : in Argument_List'Class;
                    Context : in out Context_Type;
                    Name    : in String := "") is
   begin
      GC.Display_Help (Context.Command_Config);
      if Name'Length > 0 then
         Driver.Usage (Args, Context, Name);
      end if;
      Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
   end Usage;

   --  ------------------------------
   --  Execute the command with its arguments.
   --  ------------------------------
   procedure Execute (Name    : in String;
                      Args    : in Argument_List'Class;
                      Context : in out Context_Type) is
   begin
      Driver.Execute (Name, Args, Context);
   end Execute;

   procedure Run (Context   : in out Context_Type;
                  Arguments : out Util.Commands.Dynamic_Argument_List) is
   begin
      GC.Getopt (Config => Context.Command_Config);
      Util.Commands.Parsers.GNAT_Parser.Get_Arguments (Arguments, GC.Get_Argument);

      if Context.Config_File'Length > 0 then
         Context.Load_Configuration (Context.Config_File.all);
      else
         Context.Load_Configuration (Driver_Name & ".properties");
      end if;

      if Context.Debug or Context.Verbose or Context.Dump then
         Configure_Logs (Root    => Context.File_Config.Get ("log4j.rootCategory", ""),
                         Debug   => Context.Debug,
                         Dump    => Context.Dump,
                         Verbose => Context.Verbose);
      end if;

      declare
         Cmd_Name : constant String := Arguments.Get_Command_Name;
      begin
         if Cmd_Name'Length = 0 then
            Context.Console.Notice (N_ERROR, -("Missing command name to execute."));
            Usage (Arguments, Context);
            Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
            return;
         end if;
         Execute (Cmd_Name, Arguments, Context);

      exception
         when GNAT.Command_Line.Invalid_Parameter =>
            Context.Console.Notice (N_ERROR, -("Missing option parameter"));
            raise Error;
      end;

   end Run;

begin
   Driver.Add_Command ("help",
                       -("print some help"),
                       Help_Command'Access);
end AWA.Commands.Drivers;

Configure the logs with Configure_Logs

Configure the logs with Configure_Logs


-----------------------------------------------------------------------
--  security-policies-roles -- Role based policies
--  Copyright (C) 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 Util.Log.Loggers;
with Util.Serialize.Mappers.Record_Mapper;
with Util.Strings.Tokenizers;

with Security.Controllers;
with Security.Controllers.Roles;

package body Security.Policies.Roles is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Security.Policies.Roles");

   --  ------------------------------
   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   --  ------------------------------
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in Role_Map) is
      Policy : constant Security.Policies.Policy_Access := Context.Get_Policy (NAME);
      Data   : Role_Policy_Context_Access;
   begin
      if Policy = null then
         Log.Error ("There is no security policy: " & NAME);
      end if;
      Data := new Role_Policy_Context;
      Data.Roles := Roles;

      Context.Set_Policy_Context (Policy, Data.all'Access);
   end Set_Role_Context;

   --  ------------------------------
   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   --  ------------------------------
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in String) is
      Policy : constant Security.Policies.Policy_Access := Context.Get_Policy (NAME);
      Data   : Role_Policy_Context_Access;
      Map    : Role_Map;
   begin
      if Policy = null then
         Log.Error ("There is no security policy: " & NAME);
      end if;
      Role_Policy'Class (Policy.all).Set_Roles (Roles, Map);
      Data := new Role_Policy_Context;
      Data.Roles := Map;

      Context.Set_Policy_Context (Policy, Data.all'Access);
   end Set_Role_Context;

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

   --  ------------------------------
   --  Get the role name.
   --  ------------------------------
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      if Manager.Names (Role) = null then
         return "";
      else
         return Manager.Names (Role).all;
      end if;
   end Get_Role_Name;

   --  ------------------------------
   --  Get the roles that grant the given permission.
   --  ------------------------------
   function Get_Grants (Manager    : in Role_Policy;
                        Permission : in Permissions.Permission_Index) return Role_Map is
   begin
      return Manager.Grants (Permission);
   end Get_Grants;

   --  ------------------------------
   --  Get the number of roles set in the map.
   --  ------------------------------
   function Get_Count (Map : in Role_Map) return Natural is
      Count : Natural := 0;
   begin
      for R of Map loop
         if R then
            Count := Count + 1;
         end if;
      end loop;
      return Count;
   end Get_Count;

   --  ------------------------------
   --  Get the list of role names that are defined by the role map.
   --  ------------------------------
   function Get_Role_Names (Manager : in Role_Policy;
                            Map     : in Role_Map) return Role_Name_Array is
      Result : Role_Name_Array (1 .. Get_Count (Map));
      Pos    : Positive := 1;
   begin
      for Role in Map'Range loop
         if Map (Role) then
            Result (Pos) := Manager.Names (Role);
            Pos := Pos + 1;
         end if;
      end loop;
      return Result;
   end Get_Role_Names;

   --  ------------------------------
   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   --  ------------------------------
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      Log.Debug ("Searching role {0}", Name);

      for I in Role_Type'First .. Manager.Next_Role loop
         exit when Manager.Names (I) = null;
         if Name = Manager.Names (I).all then
            return I;
         end if;
      end loop;

      Log.Debug ("Role {0} not found", Name);
      raise Invalid_Name;
   end Find_Role;

   --  ------------------------------
   --  Create a role
   --  ------------------------------
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type) is
   begin
      Role := Manager.Next_Role;
      Log.Info ("Role {0} is {1}", Name, Role_Type'Image (Role));

      if Manager.Next_Role = Role_Type'Last then
         Log.Error ("Too many roles allocated.  Number of roles is {0}",
                    Role_Type'Image (Role_Type'Last));
      else
         Manager.Next_Role := Manager.Next_Role + 1;
      end if;
      Manager.Names (Role) := new String '(Name);
   end Create_Role;

   --  ------------------------------
   --  Get or build a permission type for the given name.
   --  ------------------------------
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type) is
   begin
      Result := Manager.Find_Role (Name);

   exception
      when Invalid_Name =>
         Manager.Create_Role (Name, Result);
   end Add_Role_Type;

   --  ------------------------------
   --  Set the roles specified in the <tt>Roles</tt> parameter.  Each role is represented by
   --  its name and multiple roles are separated by ','.
   --  Raises Invalid_Name if a role was not found.
   --  ------------------------------
   procedure Set_Roles (Manager : in Role_Policy;
                        Roles   : in String;
                        Into    : out Role_Map) is
      procedure Process (Role : in String;
                         Done : out Boolean);

      procedure Process (Role : in String;
                         Done : out Boolean) is
      begin
         Into (Manager.Find_Role (Role)) := True;
         Done := False;
      end Process;

   begin
      Into := (others => False);
      Util.Strings.Tokenizers.Iterate_Tokens (Content => Roles,
                                              Pattern => ",",
                                              Process => Process'Access,
                                              Going   => Ada.Strings.Forward);
   end Set_Roles;

   type Config_Fields is (FIELD_NAME, FIELD_ROLE, FIELD_ROLE_PERMISSION, FIELD_ROLE_NAME);

   procedure Set_Member (Into  : in out Role_Policy'Class;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Called while parsing the XML policy file when the <name>, <role> and <role-permission>
   --  XML entities are found.  Create the new permission when the complete permission definition
   --  has been parsed and save the permission in the security manager.
   --  ------------------------------
   procedure Set_Member (Into  : in out Role_Policy'Class;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use Security.Controllers.Roles;
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_ROLE =>
            declare
               Role : constant String := Util.Beans.Objects.To_String (Value);
            begin
               Into.Roles (Into.Count + 1) := Into.Find_Role (Role);
               Into.Count := Into.Count + 1;

            exception
               when Invalid_Name =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid role: " & Role;
            end;

         when FIELD_ROLE_PERMISSION =>
            if Into.Count = 0 then
               raise Util.Serialize.Mappers.Field_Error with "Missing at least one role";
            end if;
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Name);
               Perm : constant Role_Controller_Access
                 := new Role_Controller '(Count => Into.Count,
                                          Roles => Into.Roles (1 .. Into.Count));
               Index : Permission_Index;
            begin
               Security.Permissions.Add_Permission (Name, Index);
               for I in 1 .. Into.Count loop
                  Into.Grants (Index) (Into.Roles (I)) := True;
               end loop;
               Into.Manager.Add_Permission (Name, Perm.all'Access);
               Into.Count := 0;
            end;

         when FIELD_ROLE_NAME =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
               Role : Role_Type;
            begin
               Into.Add_Role_Type (Name, Role);
            end;
      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Role_Policy'Class,
                                               Element_Type_Access => Role_Policy_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Mapper : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the role-permission description.
   --  ------------------------------
   procedure Prepare_Config (Policy : in out Role_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser) is
   begin
      Reader.Add_Mapping ("policy-rules", Mapper'Access);
      Reader.Add_Mapping ("module", Mapper'Access);
      Config_Mapper.Set_Context (Reader, Policy'Unchecked_Access);
   end Prepare_Config;

   --  ------------------------------
   --  Finalize the policy manager.
   --  ------------------------------
   overriding
   procedure Finalize (Policy : in out Role_Policy) is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      for I in Policy.Names'Range loop
         exit when Policy.Names (I) = null;
         Ada.Strings.Unbounded.Free (Policy.Names (I));
      end loop;
   end Finalize;

   --  ------------------------------
   --  Get the role policy associated with the given policy manager.
   --  Returns the role policy instance or null if it was not registered in the policy manager.
   --  ------------------------------
   function Get_Role_Policy (Manager : in Security.Policies.Policy_Manager'Class)
                             return Role_Policy_Access is
      Policy : constant Security.Policies.Policy_Access := Manager.Get_Policy (NAME);
   begin
      if Policy = null or else not (Policy.all in Role_Policy'Class) then
         return null;
      else
         return Role_Policy'Class (Policy.all)'Access;
      end if;
   end Get_Role_Policy;

begin
   Mapper.Add_Mapping ("role-permission", FIELD_ROLE_PERMISSION);
   Mapper.Add_Mapping ("role-permission/name", FIELD_NAME);
   Mapper.Add_Mapping ("role-permission/role", FIELD_ROLE);
   Mapper.Add_Mapping ("security-role/role-name", FIELD_ROLE_NAME);
end Security.Policies.Roles;

-----------------------------------------------------------------------
--  security-policies-roles -- Role based policies
--  Copyright (C) 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 Util.Log.Loggers;
with Util.Serialize.Mappers.Record_Mapper;
with Util.Strings.Tokenizers;
with Util.Strings.Builders;

with Security.Controllers;
with Security.Controllers.Roles;

package body Security.Policies.Roles is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Security.Policies.Roles");

   --  ------------------------------
   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   --  ------------------------------
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in Role_Map) is
      Policy : constant Security.Policies.Policy_Access := Context.Get_Policy (NAME);
      Data   : Role_Policy_Context_Access;
   begin
      if Policy = null then
         Log.Error ("There is no security policy: " & NAME);
      end if;
      Data := new Role_Policy_Context;
      Data.Roles := Roles;

      Context.Set_Policy_Context (Policy, Data.all'Access);
   end Set_Role_Context;

   --  ------------------------------
   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   --  ------------------------------
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in String) is
      Policy : constant Security.Policies.Policy_Access := Context.Get_Policy (NAME);
      Data   : Role_Policy_Context_Access;
      Map    : Role_Map;
   begin
      if Policy = null then
         Log.Error ("There is no security policy: " & NAME);
      end if;
      Role_Policy'Class (Policy.all).Set_Roles (Roles, Map);
      Data := new Role_Policy_Context;
      Data.Roles := Map;

      Context.Set_Policy_Context (Policy, Data.all'Access);
   end Set_Role_Context;

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

   --  ------------------------------
   --  Get the role name.
   --  ------------------------------
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      if Manager.Names (Role) = null then
         return "";
      else
         return Manager.Names (Role).all;
      end if;
   end Get_Role_Name;

   --  ------------------------------
   --  Get the roles that grant the given permission.
   --  ------------------------------
   function Get_Grants (Manager    : in Role_Policy;
                        Permission : in Permissions.Permission_Index) return Role_Map is
   begin
      return Manager.Grants (Permission);
   end Get_Grants;

   --  ------------------------------
   --  Get the number of roles set in the map.
   --  ------------------------------
   function Get_Count (Map : in Role_Map) return Natural is
      Count : Natural := 0;
   begin
      for R of Map loop
         if R then
            Count := Count + 1;
         end if;
      end loop;
      return Count;
   end Get_Count;

   --  ------------------------------
   --  Return the list of role names separated by ','.
   --  ------------------------------
   function To_String (List : in Role_Name_Array) return String is
      use type Ada.Strings.Unbounded.String_Access;

      Buf        : Util.Strings.Builders.Builder (Len => 256);
      Need_Colon : Boolean := False;
   begin
      for Name of List loop
         if Name /= null then
            if Need_Colon then
               Util.Strings.Builders.Append (Buf, ",");
            end if;
            Util.Strings.Builders.Append (Buf, Name.all);
            Need_Colon := True;
         end if;
      end loop;
      return Util.Strings.Builders.To_Array (Buf);
   end To_String;

   --  ------------------------------
   --  Get the list of role names that are defined by the role map.
   --  ------------------------------
   function Get_Role_Names (Manager : in Role_Policy;
                            Map     : in Role_Map) return Role_Name_Array is
      Result : Role_Name_Array (1 .. Get_Count (Map));
      Pos    : Positive := 1;
   begin
      for Role in Map'Range loop
         if Map (Role) then
            Result (Pos) := Manager.Names (Role);
            Pos := Pos + 1;
         end if;
      end loop;
      return Result;
   end Get_Role_Names;

   --  ------------------------------
   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   --  ------------------------------
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      Log.Debug ("Searching role {0}", Name);

      for I in Role_Type'First .. Manager.Next_Role loop
         exit when Manager.Names (I) = null;
         if Name = Manager.Names (I).all then
            return I;
         end if;
      end loop;

      Log.Debug ("Role {0} not found", Name);
      raise Invalid_Name;
   end Find_Role;

   --  ------------------------------
   --  Create a role
   --  ------------------------------
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type) is
   begin
      Role := Manager.Next_Role;
      Log.Info ("Role {0} is {1}", Name, Role_Type'Image (Role));

      if Manager.Next_Role = Role_Type'Last then
         Log.Error ("Too many roles allocated.  Number of roles is {0}",
                    Role_Type'Image (Role_Type'Last));
      else
         Manager.Next_Role := Manager.Next_Role + 1;
      end if;
      Manager.Names (Role) := new String '(Name);
   end Create_Role;

   --  ------------------------------
   --  Get or build a permission type for the given name.
   --  ------------------------------
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type) is
   begin
      Result := Manager.Find_Role (Name);

   exception
      when Invalid_Name =>
         Manager.Create_Role (Name, Result);
   end Add_Role_Type;

   --  ------------------------------
   --  Set the roles specified in the <tt>Roles</tt> parameter.  Each role is represented by
   --  its name and multiple roles are separated by ','.
   --  Raises Invalid_Name if a role was not found.
   --  ------------------------------
   procedure Set_Roles (Manager : in Role_Policy;
                        Roles   : in String;
                        Into    : out Role_Map) is
      procedure Process (Role : in String;
                         Done : out Boolean);

      procedure Process (Role : in String;
                         Done : out Boolean) is
      begin
         Into (Manager.Find_Role (Role)) := True;
         Done := False;
      end Process;

   begin
      Into := (others => False);
      Util.Strings.Tokenizers.Iterate_Tokens (Content => Roles,
                                              Pattern => ",",
                                              Process => Process'Access,
                                              Going   => Ada.Strings.Forward);
   end Set_Roles;

   type Config_Fields is (FIELD_NAME, FIELD_ROLE, FIELD_ROLE_PERMISSION, FIELD_ROLE_NAME);

   procedure Set_Member (Into  : in out Role_Policy'Class;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Called while parsing the XML policy file when the <name>, <role> and <role-permission>
   --  XML entities are found.  Create the new permission when the complete permission definition
   --  has been parsed and save the permission in the security manager.
   --  ------------------------------
   procedure Set_Member (Into  : in out Role_Policy'Class;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use Security.Controllers.Roles;
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_ROLE =>
            declare
               Role : constant String := Util.Beans.Objects.To_String (Value);
            begin
               Into.Roles (Into.Count + 1) := Into.Find_Role (Role);
               Into.Count := Into.Count + 1;

            exception
               when Invalid_Name =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid role: " & Role;
            end;

         when FIELD_ROLE_PERMISSION =>
            if Into.Count = 0 then
               raise Util.Serialize.Mappers.Field_Error with "Missing at least one role";
            end if;
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Name);
               Perm : constant Role_Controller_Access
                 := new Role_Controller '(Count => Into.Count,
                                          Roles => Into.Roles (1 .. Into.Count));
               Index : Permission_Index;
            begin
               Security.Permissions.Add_Permission (Name, Index);
               for I in 1 .. Into.Count loop
                  Into.Grants (Index) (Into.Roles (I)) := True;
               end loop;
               Into.Manager.Add_Permission (Name, Perm.all'Access);
               Into.Count := 0;
            end;

         when FIELD_ROLE_NAME =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
               Role : Role_Type;
            begin
               Into.Add_Role_Type (Name, Role);
            end;
      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Role_Policy'Class,
                                               Element_Type_Access => Role_Policy_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Mapper : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the role-permission description.
   --  ------------------------------
   procedure Prepare_Config (Policy : in out Role_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser) is
   begin
      Reader.Add_Mapping ("policy-rules", Mapper'Access);
      Reader.Add_Mapping ("module", Mapper'Access);
      Config_Mapper.Set_Context (Reader, Policy'Unchecked_Access);
   end Prepare_Config;

   --  ------------------------------
   --  Finalize the policy manager.
   --  ------------------------------
   overriding
   procedure Finalize (Policy : in out Role_Policy) is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      for I in Policy.Names'Range loop
         exit when Policy.Names (I) = null;
         Ada.Strings.Unbounded.Free (Policy.Names (I));
      end loop;
   end Finalize;

   --  ------------------------------
   --  Get the role policy associated with the given policy manager.
   --  Returns the role policy instance or null if it was not registered in the policy manager.
   --  ------------------------------
   function Get_Role_Policy (Manager : in Security.Policies.Policy_Manager'Class)
                             return Role_Policy_Access is
      Policy : constant Security.Policies.Policy_Access := Manager.Get_Policy (NAME);
   begin
      if Policy = null or else not (Policy.all in Role_Policy'Class) then
         return null;
      else
         return Role_Policy'Class (Policy.all)'Access;
      end if;
   end Get_Role_Policy;

begin
   Mapper.Add_Mapping ("role-permission", FIELD_ROLE_PERMISSION);
   Mapper.Add_Mapping ("role-permission/name", FIELD_NAME);
   Mapper.Add_Mapping ("role-permission/role", FIELD_ROLE);
   Mapper.Add_Mapping ("security-role/role-name", FIELD_ROLE_NAME);
end Security.Policies.Roles;

Implement the To_String function

Implement the To_String function