-----------------------------------------------------------------------
--  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);
   procedure Test_Encrypt_Decrypt_Secret_OFB (T : in out Test);
   procedure Test_Encrypt_Decrypt_Secret_CFB (T : in out Test);
   procedure Test_Encrypt_Decrypt_Secret_CTR (T : in out Test);

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

end Util.Encoders.Tests;

-----------------------------------------------------------------------
--  util-encodes-tests - Test for encoding
--  Copyright (C) 2009 - 2022 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);
   procedure Test_Encrypt_Decrypt_Secret_OFB (T : in out Test);
   procedure Test_Encrypt_Decrypt_Secret_CFB (T : in out Test);
   procedure Test_Encrypt_Decrypt_Secret_CTR (T : in out Test);

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

   --  Test the percent URI encoding.
   procedure Test_Encode_URI (T : in out Test);

end Util.Encoders.Tests;

Declare the Test_Encode_URI procedure

Declare the Test_Encode_URI procedure


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

with ASF.Requests;
with ASF.Contexts.Writer;
package body ASF.Components.Widgets.Likes is

   FB_LAYOUT_ATTR      : aliased constant String := "data-layout";
   FB_SHOW_FACES_ATTR  : aliased constant String := "data-show-faces";
   FB_WIDTH_ATTR       : aliased constant String := "data-width";
   FB_ACTION_ATTR      : aliased constant String := "data-action";
   FB_FONT_ATTR        : aliased constant String := "data-font";
   FB_COlORSCHEME_ATTR : aliased constant String := "data-colorscheme";
   FB_REF_ATTR         : aliased constant String := "data-ref";
   FB_KIDS_ATTR        : aliased constant String := "data-kid_directed_site";

   FACEBOOK_ATTRIBUTE_NAMES : Util.Strings.String_Set.Set;
   FACEBOOK_SCRIPT_ATTRIBUTE : constant String := "asf.widgets.facebook.script";

   type Like_Generator_Binding is record
      Name      : Util.Strings.Name_Access;
      Generator : Like_Generator_Access;
   end record;

   type Like_Generator_Array is array (1 .. MAX_LIKE_GENERATOR) of Like_Generator_Binding;

   FB_NAME      : aliased constant String := "facebook";
   FB_GENERATOR : aliased Facebook_Like_Generator;

   Generators : Like_Generator_Array := (1 => (FB_NAME'Access, FB_GENERATOR'Access),
                                         others => (null, null));

   --  ------------------------------
   --  Render the facebook like button according to the component attributes.
   --  ------------------------------
   overriding
   procedure Render_Like (Generator : in Facebook_Like_Generator;
                          UI        : in UILike'Class;
                          Href      : in String;
                          Context   : in out ASF.Contexts.Faces.Faces_Context'Class) is
      Writer  : constant Contexts.Writer.Response_Writer_Access := Context.Get_Response_Writer;
      Request : constant ASF.Requests.Request_Access := Context.Get_Request;
   begin
      if not Context.Is_Ajax_Request and then
        Util.Beans.Objects.Is_Null (Request.Get_Attribute (FACEBOOK_SCRIPT_ATTRIBUTE)) then

         Request.Set_Attribute (FACEBOOK_SCRIPT_ATTRIBUTE, Util.Beans.Objects.To_Object (True));
         Writer.Queue_Script ("(function(d, s, id) { var js, fjs = d.getElementsByTagName(s)[0];"
                              & "if (d.getElementById(id)) return;"
                              & "js = d.createElement(s); js.id = id;"
                              & "js.src = ""//connect.facebook.net/");
         Writer.Queue_Script (Util.Locales.To_String (Context.Get_Locale));
         Writer.Queue_Script ("/all.js#xfbml=1&;appId=116337738505130");
         Writer.Queue_Script (Generator.App_Id);
         Writer.Queue_Script (""";fjs.parentNode.insertBefore(js, fjs);"
                              & "}(document, 'script', 'facebook-jssdk'));");
         Writer.Start_Element ("div");
         Writer.Write_Attribute ("id", "fb-root");
         Writer.End_Element ("div");
      end if;
      Writer.Start_Element ("div");
      Writer.Write_Attribute ("class", "fb-like");
      Writer.Write_Attribute ("data-href", Href);
      Writer.Write_Attribute ("data-send", "true");
      UI.Render_Attributes (Context, FACEBOOK_ATTRIBUTE_NAMES, Writer);
      Writer.End_Element ("div");
   end Render_Like;

   --  ------------------------------
   --  Get the link to submit in the like action.
   --  ------------------------------
   function Get_Link (UI      : in UILike;
                      Context : in ASF.Contexts.Faces.Faces_Context'Class) return String is
      Href : constant String := UI.Get_Attribute ("href", Context, "");
   begin
      if Href'Length > 0 then
         return Href;
      else
         return Context.Get_Request.Get_Request_URI;
      end if;
   end Get_Link;

   --  ------------------------------
   --  Render an image with the source link created from an email address to the Gravatars service.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UILike;
                           Context : in out ASF.Contexts.Faces.Faces_Context'Class) is

   begin
      if UI.Is_Rendered (Context) then
         declare
            Kind : constant String := UI.Get_Attribute ("type", Context, "");
            Href : constant String := UILike'Class (UI).Get_Link (Context);

            procedure Render (Name : in String; Done : out Boolean);

            procedure Render (Name : in String;
                              Done : out Boolean) is
               use type Util.Strings.Name_Access;
            begin
               Done := False;
               for I in Generators'Range loop
                  exit when Generators (I).Name = null;
                  if Generators (I).Name.all = Name then
                     Generators (I).Generator.Render_Like (UI, Href, Context);
                     return;
                  end if;
               end loop;
               UI.Log_Error ("Like type {0} is not recognized", Name);
            end Render;

         begin
            if Kind'Length = 0 then
               UI.Log_Error ("The like type is empty.");
            else
               Util.Strings.Tokenizers.Iterate_Tokens (Content => Kind, Pattern => ",",
                                                       Process => Render'Access);
            end if;
         end;
      end if;
   end Encode_Begin;

   --  ------------------------------
   --  Register the like generator under the given name.
   --  ------------------------------
   procedure Register_Like (Name      : in Util.Strings.Name_Access;
                            Generator : in Like_Generator_Access) is
      use type Util.Strings.Name_Access;
   begin
      for I in Generators'Range loop
         if Generators (I).Name = null then
            Generators (I).Name := Name;
            Generators (I).Generator := Generator;
            return;
         end if;
      end loop;
   end Register_Like;

begin
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_LAYOUT_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_SHOW_FACES_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_WIDTH_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_ACTION_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_FONT_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_COlORSCHEME_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_REF_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_KIDS_ATTR'Access);
end ASF.Components.Widgets.Likes;

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

with ASF.Requests;
with ASF.Contexts.Writer;
package body ASF.Components.Widgets.Likes is

   FB_LAYOUT_ATTR      : aliased constant String := "data-layout";
   FB_SHOW_FACES_ATTR  : aliased constant String := "data-show-faces";
   FB_WIDTH_ATTR       : aliased constant String := "data-width";
   FB_ACTION_ATTR      : aliased constant String := "data-action";
   FB_FONT_ATTR        : aliased constant String := "data-font";
   FB_COlORSCHEME_ATTR : aliased constant String := "data-colorscheme";
   FB_REF_ATTR         : aliased constant String := "data-ref";
   FB_KIDS_ATTR        : aliased constant String := "data-kid_directed_site";

   FACEBOOK_ATTRIBUTE_NAMES  : Util.Strings.String_Set.Set;
   FACEBOOK_SCRIPT_ATTRIBUTE : constant String := "asf.widgets.facebook.script";

   GOOGLE_ATTRIBUTE_NAMES    : Util.Strings.String_Set.Set;
   GOOGLE_SCRIPT_ATTRIBUTE   : constant String := "asf.widgets.google.script";

   type Like_Generator_Binding is record
      Name      : Util.Strings.Name_Access;
      Generator : Like_Generator_Access;
   end record;

   type Like_Generator_Array is array (1 .. MAX_LIKE_GENERATOR) of Like_Generator_Binding;

   FB_NAME      : aliased constant String := "facebook";
   FB_GENERATOR : aliased Facebook_Like_Generator;

   G_NAME       : aliased constant String := "google+";
   G_GENERATOR  : aliased Google_Like_Generator;

   Generators : Like_Generator_Array := (1 => (FB_NAME'Access, FB_GENERATOR'Access),
                                         2 => (G_NAME'Access, G_GENERATOR'Access),
                                         others => (null, null));

   --  ------------------------------
   --  Render the facebook like button according to the component attributes.
   --  ------------------------------
   overriding
   procedure Render_Like (Generator : in Facebook_Like_Generator;
                          UI        : in UILike'Class;
                          Href      : in String;
                          Context   : in out ASF.Contexts.Faces.Faces_Context'Class) is
      Writer  : constant Contexts.Writer.Response_Writer_Access := Context.Get_Response_Writer;
      Request : constant ASF.Requests.Request_Access := Context.Get_Request;
   begin
      if not Context.Is_Ajax_Request and then
        Util.Beans.Objects.Is_Null (Request.Get_Attribute (FACEBOOK_SCRIPT_ATTRIBUTE)) then

         Request.Set_Attribute (FACEBOOK_SCRIPT_ATTRIBUTE, Util.Beans.Objects.To_Object (True));
         Writer.Queue_Script ("(function(d, s, id) { var js, fjs = d.getElementsByTagName(s)[0];"
                              & "if (d.getElementById(id)) return;"
                              & "js = d.createElement(s); js.id = id;"
                              & "js.src = ""//connect.facebook.net/");
         Writer.Queue_Script (Util.Locales.To_String (Context.Get_Locale));
         Writer.Queue_Script ("/all.js#xfbml=1&;appId=116337738505130");
         Writer.Queue_Script (Generator.App_Id);
         Writer.Queue_Script (""";fjs.parentNode.insertBefore(js, fjs);"
                              & "}(document, 'script', 'facebook-jssdk'));");
         Writer.Start_Element ("div");
         Writer.Write_Attribute ("id", "fb-root");
         Writer.End_Element ("div");
      end if;
      Writer.Start_Element ("div");
      Writer.Write_Attribute ("class", "fb-like");
      Writer.Write_Attribute ("data-href", Href);
      Writer.Write_Attribute ("data-send", "true");
      UI.Render_Attributes (Context, FACEBOOK_ATTRIBUTE_NAMES, Writer);
      Writer.End_Element ("div");
   end Render_Like;

   --  ------------------------------
   --  Google like generator
   --  ------------------------------
   overriding
   procedure Render_Like (Generator : in Google_Like_Generator;
                          UI        : in UILike'Class;
                          Href      : in String;
                          Context   : in out ASF.Contexts.Faces.Faces_Context'Class) is
      pragma Unreferenced (Generator);

      Writer  : constant Contexts.Writer.Response_Writer_Access := Context.Get_Response_Writer;
      Request : constant ASF.Requests.Request_Access := Context.Get_Request;
   begin
      if not Context.Is_Ajax_Request and then
        Util.Beans.Objects.Is_Null (Request.Get_Attribute (GOOGLE_SCRIPT_ATTRIBUTE)) then

         Request.Set_Attribute (GOOGLE_SCRIPT_ATTRIBUTE, Util.Beans.Objects.To_Object (True));
         Writer.Queue_Include_Script ("https://apis.google.com/js/plusone.js");
      end if;
      Writer.Start_Element ("div");
      Writer.Write_Attribute ("class", "g-plusone");
      Writer.Write_Attribute ("data-href", Href);
      Writer.Write_Attribute ("data-send", "true");
      UI.Render_Attributes (Context, GOOGLE_ATTRIBUTE_NAMES, Writer);
      Writer.End_Element ("div");
   end Render_Like;

   --  ------------------------------
   --  Get the link to submit in the like action.
   --  ------------------------------
   function Get_Link (UI      : in UILike;
                      Context : in ASF.Contexts.Faces.Faces_Context'Class) return String is
      Href : constant String := UI.Get_Attribute ("href", Context, "");
   begin
      if Href'Length > 0 then
         return Href;
      else
         return Context.Get_Request.Get_Request_URI;
      end if;
   end Get_Link;

   --  ------------------------------
   --  Render an image with the source link created from an email address to the Gravatars service.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UILike;
                           Context : in out ASF.Contexts.Faces.Faces_Context'Class) is

   begin
      if UI.Is_Rendered (Context) then
         declare
            Kind : constant String := UI.Get_Attribute ("type", Context, "");
            Href : constant String := UILike'Class (UI).Get_Link (Context);

            procedure Render (Name : in String; Done : out Boolean);

            procedure Render (Name : in String;
                              Done : out Boolean) is
               use type Util.Strings.Name_Access;
            begin
               Done := False;
               for I in Generators'Range loop
                  exit when Generators (I).Name = null;
                  if Generators (I).Name.all = Name then
                     Generators (I).Generator.Render_Like (UI, Href, Context);
                     return;
                  end if;
               end loop;
               UI.Log_Error ("Like type {0} is not recognized", Name);
            end Render;

         begin
            if Kind'Length = 0 then
               UI.Log_Error ("The like type is empty.");
            else
               Util.Strings.Tokenizers.Iterate_Tokens (Content => Kind, Pattern => ",",
                                                       Process => Render'Access);
            end if;
         end;
      end if;
   end Encode_Begin;

   --  ------------------------------
   --  Register the like generator under the given name.
   --  ------------------------------
   procedure Register_Like (Name      : in Util.Strings.Name_Access;
                            Generator : in Like_Generator_Access) is
      use type Util.Strings.Name_Access;
   begin
      for I in Generators'Range loop
         if Generators (I).Name = null then
            Generators (I).Name := Name;
            Generators (I).Generator := Generator;
            return;
         end if;
      end loop;
   end Register_Like;

begin
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_LAYOUT_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_SHOW_FACES_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_WIDTH_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_ACTION_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_FONT_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_COlORSCHEME_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_REF_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_KIDS_ATTR'Access);
end ASF.Components.Widgets.Likes;

Implement the Google like generator

Implement the Google like generator


-----------------------------------------------------------------------
--  applications.messages -- Application Messages
--  Copyright (C) 2010 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;
package ASF.Applications.Messages is

   type Severity is (NONE, INFO, WARN, ERROR, FATAL);

   --  ------------------------------
   --  Application message
   --  ------------------------------
   type Message is private;

   --  Return the message severity level.
   function Get_Severity (Msg : in Message) return Severity;

   --  Sets the message severity level.
   procedure Set_Severity (Msg  : in out Message;
                           Kind : in Severity);

   --  Return the localized message summary.
   function Get_Summary (Msg : in Message) return String;

   --  Sets the localized message summary.
   procedure Set_Summary (Msg     : in out Message;
                          Summary : in String);

   --  Return the localized message detail.  If the message detail was
   --  not provided, returns the message summary.
   function Get_Detail (Msg : in Message) return String;

   --  Sets the localized message detail.
   procedure Set_Detail (Msg    : in out Message;
                         Detail : in String);

   --  Returns true if both messages are identical (same severity, same messages)
   function "=" (Left, Right : in Message) return Boolean;

private

   type Message is record
      Kind      : Severity := ERROR;
      Summary   : Ada.Strings.Unbounded.Unbounded_String;
      Detail    : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end ASF.Applications.Messages;

-----------------------------------------------------------------------
--  applications.messages -- Application Messages
--  Copyright (C) 2010, 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;
with ASF.Utils;
package ASF.Applications.Messages is

   type Severity is (NONE, INFO, WARN, ERROR, FATAL);

   --  ------------------------------
   --  Application message
   --  ------------------------------
   type Message is private;

   --  Return the message severity level.
   function Get_Severity (Msg : in Message) return Severity;

   --  Sets the message severity level.
   procedure Set_Severity (Msg  : in out Message;
                           Kind : in Severity);

   --  Return the localized message summary.
   function Get_Summary (Msg : in Message) return String;

   --  Sets the localized message summary.
   procedure Set_Summary (Msg     : in out Message;
                          Summary : in String);

   --  Format the localized message with the arguments and set the message summary.
   procedure Format_Summary (Msg     : in out Message;
                             Summary : in String;
                             Args    : in ASF.Utils.Object_Array);

   --  Return the localized message detail.  If the message detail was
   --  not provided, returns the message summary.
   function Get_Detail (Msg : in Message) return String;

   --  Sets the localized message detail.
   procedure Set_Detail (Msg    : in out Message;
                         Detail : in String);

   --  Returns true if both messages are identical (same severity, same messages)
   function "=" (Left, Right : in Message) return Boolean;

private

   type Message is record
      Kind      : Severity := ERROR;
      Summary   : Ada.Strings.Unbounded.Unbounded_String;
      Detail    : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end ASF.Applications.Messages;

Declare the Format_Summary procedure to format and set the message summary


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

   use MAT.Types;
   use Interfaces;

   Depth : Natural := F.Depth - F.Local_Depth + 1;
   Child : Frame_Ptr;

   procedure Print_Address (File : in File_Type;
                            Addr : in Target_Addr);

   function Hex_Image (Val : Target_Addr; Len : Positive) return String;

   function Hex_Image (Val : Target_Addr; Len : Positive) return String is
      Conversion : constant String (1 .. 16) := "0123456789ABCDEF";
      S : String (1 .. Len) := (others => '0');
      P : Target_Addr := Val;
      N : Target_Addr;
      I : Positive := Len;
   begin
      while P /= 0 loop
         N := P mod 16;
         P := P / 16;
         S (I) := Conversion (Natural (N + 1));
         exit when I = 1;
         I := I - 1;
      end loop;
      return S;
   end Hex_Image;

   procedure Print_Address (File : in File_Type;
                            Addr : in Target_Addr) is
   begin
      Put (File, Hex_Image (Addr, 20));
   end Print_Address;

begin
   for I in 1 .. F.Local_Depth loop
      Set_Col (File, Positive_Count (Depth));
      Print_Address (File, F.Calls (I));
      Put_Line (" D " & Natural'Image (Depth));
      Depth := Depth + 1;
   end loop;
   Child := F.Children;
   while Child /= null loop
      Print (File, Child);
      Child := Child.Next;
   end loop;
end MAT.Frames.Print;

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

   use MAT.Types;
   use Interfaces;

   Depth : Natural := F.Depth - F.Local_Depth + 1;
   Child : Frame_Type;

   procedure Print_Address (File : in File_Type;
                            Addr : in Target_Addr);

   function Hex_Image (Val : Target_Addr; Len : Positive) return String;

   function Hex_Image (Val : Target_Addr; Len : Positive) return String is
      Conversion : constant String (1 .. 16) := "0123456789ABCDEF";
      S : String (1 .. Len) := (others => '0');
      P : Target_Addr := Val;
      N : Target_Addr;
      I : Positive := Len;
   begin
      while P /= 0 loop
         N := P mod 16;
         P := P / 16;
         S (I) := Conversion (Natural (N + 1));
         exit when I = 1;
         I := I - 1;
      end loop;
      return S;
   end Hex_Image;

   procedure Print_Address (File : in File_Type;
                            Addr : in Target_Addr) is
   begin
      Put (File, Hex_Image (Addr, 20));
   end Print_Address;

begin
   for I in 1 .. F.Local_Depth loop
      Set_Col (File, Positive_Count (Depth));
      Print_Address (File, F.Calls (I));
      Put_Line (" D " & Natural'Image (Depth));
      Depth := Depth + 1;
   end loop;
   Child := F.Children;
   while Child /= null loop
      Print (File, Child);
      Child := Child.Next;
   end loop;
end MAT.Frames.Print;

Fix compilation

Fix compilation


-----------------------------------------------------------------------
--  util-streams-raw -- Raw streams (OS specific)
--  Copyright (C) 2011, 2016, 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.IO_Exceptions;

package body Util.Streams.Raw is

   use Util.Systems.Os;
   use type Util.Systems.Types.File_Type;

   --  -----------------------
   --  Initialize the raw stream to read and write on the given file descriptor.
   --  -----------------------
   procedure Initialize (Stream  : in out Raw_Stream;
                         File    : in File_Type) is
   begin
      if Stream.File /= NO_FILE then
         raise Ada.IO_Exceptions.Status_Error;
      end if;
      Stream.File := File;
   end Initialize;

   --  -----------------------
   --  Close the stream.
   --  -----------------------
   overriding
   procedure Close (Stream : in out Raw_Stream) is
   begin
      if Stream.File /= NO_FILE then
         if Close (Stream.File) /= 0 then
            raise Ada.IO_Exceptions.Device_Error;
         end if;
         Stream.File := NO_FILE;
      end if;
   end Close;

   --  -----------------------
   --  Write the buffer array to the output stream.
   --  -----------------------
   procedure Write (Stream : in out Raw_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
   begin
      if Write (Stream.File, Buffer'Address, Buffer'Length) < 0 then
         raise Ada.IO_Exceptions.Device_Error;
      end if;
   end Write;

   --  -----------------------
   --  Read into the buffer as many bytes as possible and return in
   --  <b>last</b> the position of the last byte read.
   --  -----------------------
   procedure Read (Stream : in out Raw_Stream;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset) is
      Res : Ssize_T;
   begin
      Res := Read (Stream.File, Into'Address, Into'Length);
      if Res < 0 then
         raise Ada.IO_Exceptions.Device_Error;
      end if;
      Last := Into'First + Ada.Streams.Stream_Element_Offset (Res) - 1;
   end Read;

   --  -----------------------
   --  Reposition the read/write file offset.
   --  -----------------------
   procedure Seek (Stream : in out Raw_Stream;
                   Pos    : in Util.Systems.Types.off_t;
                   Mode   : in Util.Systems.Types.Seek_Mode) is
      --  use type Util.Systems.Types.off_t;

      Res : Util.Systems.Types.off_t;
   begin
      Res := Sys_Lseek (Stream.File, Pos, Mode);
      if Res < 0 then
         raise Ada.IO_Exceptions.Device_Error;
      end if;
   end Seek;

   --  -----------------------
   --  Flush the stream and release the buffer.
   --  -----------------------
   procedure Finalize (Object : in out Raw_Stream) is
   begin
      Close (Object);
   end Finalize;

end Util.Streams.Raw;

-----------------------------------------------------------------------
--  util-streams-raw -- Raw streams (OS specific)
--  Copyright (C) 2011, 2016, 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.IO_Exceptions;
with Interfaces.C;
package body Util.Streams.Raw is

   use Util.Systems.Os;
   use type Util.Systems.Types.File_Type;

   --  GNAT 2018 issues a warning due to the use type Interfaces.C.int clause.
   --  But gcc 7.3 and older fails to compile and requires this use clause.
   pragma Warnings (Off);
   use type Interfaces.C.int;
   pragma Warnings (On);

   --  -----------------------
   --  Initialize the raw stream to read and write on the given file descriptor.
   --  -----------------------
   procedure Initialize (Stream  : in out Raw_Stream;
                         File    : in File_Type) is
   begin
      if Stream.File /= NO_FILE then
         raise Ada.IO_Exceptions.Status_Error;
      end if;
      Stream.File := File;
   end Initialize;

   --  -----------------------
   --  Close the stream.
   --  -----------------------
   overriding
   procedure Close (Stream : in out Raw_Stream) is
   begin
      if Stream.File /= NO_FILE then
         if Close (Stream.File) /= 0 then
            raise Ada.IO_Exceptions.Device_Error;
         end if;
         Stream.File := NO_FILE;
      end if;
   end Close;

   --  -----------------------
   --  Write the buffer array to the output stream.
   --  -----------------------
   procedure Write (Stream : in out Raw_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
   begin
      if Write (Stream.File, Buffer'Address, Buffer'Length) < 0 then
         raise Ada.IO_Exceptions.Device_Error;
      end if;
   end Write;

   --  -----------------------
   --  Read into the buffer as many bytes as possible and return in
   --  <b>last</b> the position of the last byte read.
   --  -----------------------
   procedure Read (Stream : in out Raw_Stream;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset) is
      Res : Ssize_T;
   begin
      Res := Read (Stream.File, Into'Address, Into'Length);
      if Res < 0 then
         raise Ada.IO_Exceptions.Device_Error;
      end if;
      Last := Into'First + Ada.Streams.Stream_Element_Offset (Res) - 1;
   end Read;

   --  -----------------------
   --  Reposition the read/write file offset.
   --  -----------------------
   procedure Seek (Stream : in out Raw_Stream;
                   Pos    : in Util.Systems.Types.off_t;
                   Mode   : in Util.Systems.Types.Seek_Mode) is
      --  use type Util.Systems.Types.off_t;

      Res : Util.Systems.Types.off_t;
   begin
      Res := Sys_Lseek (Stream.File, Pos, Mode);
      if Res < 0 then
         raise Ada.IO_Exceptions.Device_Error;
      end if;
   end Seek;

   --  -----------------------
   --  Flush the stream and release the buffer.
   --  -----------------------
   procedure Finalize (Object : in out Raw_Stream) is
   begin
      Close (Object);
   end Finalize;

end Util.Streams.Raw;

Fix compilation with FSF gcc 7.3: a use type Interfaces.C.int clause is required but it generates a warning with GNAT 2018


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

with Util.Beans.Objects;
with Util.Beans.Objects.Time;
with Util.Serialize.Mappers.Record_Mapper;
with Util.Http.Rest;
package body Security.Auth.OAuth.Facebook is

   --
   TIME_SHIFT : constant Duration := 12 * 3600.0;

   type Token_Info_Field_Type is (FIELD_APP_ID, FIELD_IS_VALID,
                                  FIELD_EXPIRES, FIELD_ISSUED_AT,
                                  FIELD_USER_ID, FIELD_EMAIL, FIELD_FIRST_NAME,
                                  FIELD_LAST_NAME, FIELD_NAME, FIELD_LOCALE, FIELD_GENDER);

   type Token_Info is record
      App_Id     : Ada.Strings.Unbounded.Unbounded_String;
      Is_Valid   : Boolean := False;
      Expires    : Ada.Calendar.Time;
      Issued     : Ada.Calendar.Time;
      User_Id    : Ada.Strings.Unbounded.Unbounded_String;
      Email      : Ada.Strings.Unbounded.Unbounded_String;
      Name       : Ada.Strings.Unbounded.Unbounded_String;
      First_Name : Ada.Strings.Unbounded.Unbounded_String;
      Last_Name  : Ada.Strings.Unbounded.Unbounded_String;
      Locale     : Ada.Strings.Unbounded.Unbounded_String;
      Gender     : Ada.Strings.Unbounded.Unbounded_String;
   end record;
   type Token_Info_Access is access all Token_Info;

   procedure Set_Member (Into  : in out Token_Info;
                         Field : in Token_Info_Field_Type;
                         Value : in Util.Beans.Objects.Object);

   procedure Set_Member (Into  : in out Token_Info;
                         Field : in Token_Info_Field_Type;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_APP_ID =>
            Into.App_Id := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_IS_VALID =>
            Into.Is_Valid := Util.Beans.Objects.To_Boolean (Value);

         when FIELD_EXPIRES =>
            Into.Expires := Util.Beans.Objects.Time.To_Time (Value);

         when FIELD_ISSUED_AT =>
            Into.Issued := Util.Beans.Objects.Time.To_Time (Value);

         when FIELD_USER_ID =>
            Into.User_Id := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_EMAIL =>
            Into.Email := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_NAME =>
            Into.Name := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_FIRST_NAME =>
            Into.First_Name := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_LAST_NAME =>
            Into.Last_Name := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_LOCALE =>
            Into.Locale := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_GENDER =>
            Into.Gender := Util.Beans.Objects.To_Unbounded_String (Value);

      end case;
   end Set_Member;

   package Token_Info_Mapper is
      new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Token_Info,
                                                Element_Type_Access => Token_Info_Access,
                                                Fields              => Token_Info_Field_Type,
                                                Set_Member          => Set_Member);

   procedure Get_Token_Info is
     new Util.Http.Rest.Rest_Get (Element_Mapper => Token_Info_Mapper);

   Token_Info_Map : aliased Token_Info_Mapper.Mapper;

   --  ------------------------------
   --  Verify the OAuth access token and retrieve information about the user.
   --  ------------------------------
   overriding
   procedure Verify_Access_Token (Realm   : in Manager;
                                  Assoc   : in Association;
                                  Request : in Parameters'Class;
                                  Token   : in Security.OAuth.Clients.Access_Token_Access;
                                  Result  : in out Authentication) is
      use type Ada.Calendar.Time;

      T    : constant String := Token.Get_Name;
      Info : aliased Token_Info;
      Now  : constant Ada.Calendar.Time := Ada.Calendar.Clock;
   begin
      Get_Token_Info ("https://graph.facebook.com/debug_token?access_token=" & T
                      & "&input_token=" & T,
                      Token_Info_Map'Access,
                      "/data",
                      Info'Unchecked_Access);
      if not Info.Is_Valid then
         Set_Result (Result, INVALID_SIGNATURE, "invalid access token returned");

      elsif Info.Issued + TIME_SHIFT < Now then
         Set_Result (Result, INVALID_SIGNATURE, "the access token issued more than 1 hour ago");

      elsif Info.Expires + TIME_SHIFT < Now then
         Set_Result (Result, INVALID_SIGNATURE, "the access token has expored");

      elsif Length (Info.User_Id) = 0 then
         Set_Result (Result, INVALID_SIGNATURE, "the access token refers to an empty user_id");

      elsif Info.App_Id /= Realm.App.Get_Application_Identifier then
         Set_Result (Result, INVALID_SIGNATURE,
                     "the access token was granted for another application");

      else
         Result.Identity := To_Unbounded_String ("https://graph.facebook.com/");
         Append (Result.Identity, Info.User_Id);
         Result.Claimed_Id := Result.Identity;

         Get_Token_Info ("https://graph.facebook.com/" & To_String (Info.User_Id)
                           & "?access_token=" & T,
                         Token_Info_Map'Access,
                         "",
                         Info'Unchecked_Access);

         Result.Email      := Info.Email;
         Result.Full_Name  := Info.Name;
         Result.First_Name := Info.First_Name;
         Result.Last_Name  := Info.Last_Name;
         Result.Language   := Info.Locale;
         Result.Gender     := Info.Gender;
         Set_Result (Result, AUTHENTICATED, "authenticated");
      end if;
   end Verify_Access_Token;

begin
   Token_Info_Map.Add_Mapping ("app_id", FIELD_APP_ID);
   Token_Info_Map.Add_Mapping ("expires_at", FIELD_EXPIRES);
   Token_Info_Map.Add_Mapping ("issued_at", FIELD_ISSUED_AT);
   Token_Info_Map.Add_Mapping ("is_valid", FIELD_IS_VALID);
   Token_Info_Map.Add_Mapping ("user_id", FIELD_USER_ID);
   Token_Info_Map.Add_Mapping ("email", FIELD_EMAIL);
   Token_Info_Map.Add_Mapping ("name", FIELD_NAME);
   Token_Info_Map.Add_Mapping ("first_name", FIELD_FIRST_NAME);
   Token_Info_Map.Add_Mapping ("last_name", FIELD_LAST_NAME);
   Token_Info_Map.Add_Mapping ("locale", FIELD_LOCALE);
   Token_Info_Map.Add_Mapping ("gender", FIELD_GENDER);
end Security.Auth.OAuth.Facebook;

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

with Util.Beans.Objects;
with Util.Beans.Objects.Time;
with Util.Serialize.Mappers.Record_Mapper;
with Util.Http.Rest;
package body Security.Auth.OAuth.Facebook is

   --
   TIME_SHIFT : constant Duration := 12 * 3600.0;

   type Token_Info_Field_Type is (FIELD_APP_ID, FIELD_IS_VALID,
                                  FIELD_EXPIRES, FIELD_ISSUED_AT,
                                  FIELD_USER_ID, FIELD_EMAIL, FIELD_FIRST_NAME,
                                  FIELD_LAST_NAME, FIELD_NAME, FIELD_LOCALE, FIELD_GENDER);

   type Token_Info is record
      App_Id     : Ada.Strings.Unbounded.Unbounded_String;
      Is_Valid   : Boolean := False;
      Expires    : Ada.Calendar.Time;
      Issued     : Ada.Calendar.Time;
      User_Id    : Ada.Strings.Unbounded.Unbounded_String;
      Email      : Ada.Strings.Unbounded.Unbounded_String;
      Name       : Ada.Strings.Unbounded.Unbounded_String;
      First_Name : Ada.Strings.Unbounded.Unbounded_String;
      Last_Name  : Ada.Strings.Unbounded.Unbounded_String;
      Locale     : Ada.Strings.Unbounded.Unbounded_String;
      Gender     : Ada.Strings.Unbounded.Unbounded_String;
   end record;
   type Token_Info_Access is access all Token_Info;

   procedure Set_Member (Into  : in out Token_Info;
                         Field : in Token_Info_Field_Type;
                         Value : in Util.Beans.Objects.Object);

   procedure Set_Member (Into  : in out Token_Info;
                         Field : in Token_Info_Field_Type;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_APP_ID =>
            Into.App_Id := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_IS_VALID =>
            Into.Is_Valid := Util.Beans.Objects.To_Boolean (Value);

         when FIELD_EXPIRES =>
            Into.Expires := Util.Beans.Objects.Time.To_Time (Value);

         when FIELD_ISSUED_AT =>
            Into.Issued := Util.Beans.Objects.Time.To_Time (Value);

         when FIELD_USER_ID =>
            Into.User_Id := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_EMAIL =>
            Into.Email := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_NAME =>
            Into.Name := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_FIRST_NAME =>
            Into.First_Name := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_LAST_NAME =>
            Into.Last_Name := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_LOCALE =>
            Into.Locale := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_GENDER =>
            Into.Gender := Util.Beans.Objects.To_Unbounded_String (Value);

      end case;
   end Set_Member;

   package Token_Info_Mapper is
      new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Token_Info,
                                                Element_Type_Access => Token_Info_Access,
                                                Fields              => Token_Info_Field_Type,
                                                Set_Member          => Set_Member);

   procedure Get_Token_Info is
     new Util.Http.Rest.Rest_Get (Element_Mapper => Token_Info_Mapper);

   Token_Info_Map : aliased Token_Info_Mapper.Mapper;

   --  ------------------------------
   --  Verify the OAuth access token and retrieve information about the user.
   --  ------------------------------
   overriding
   procedure Verify_Access_Token (Realm   : in Manager;
                                  Assoc   : in Association;
                                  Request : in Parameters'Class;
                                  Token   : in Security.OAuth.Clients.Access_Token_Access;
                                  Result  : in out Authentication) is
      pragma Unreferenced (Assoc, Request);
      use type Ada.Calendar.Time;

      T    : constant String := Token.Get_Name;
      Info : aliased Token_Info;
      Now  : constant Ada.Calendar.Time := Ada.Calendar.Clock;
   begin
      Get_Token_Info ("https://graph.facebook.com/debug_token?access_token=" & T
                      & "&input_token=" & T,
                      Token_Info_Map'Access,
                      "/data",
                      Info'Unchecked_Access);
      if not Info.Is_Valid then
         Set_Result (Result, INVALID_SIGNATURE, "invalid access token returned");

      elsif Info.Issued + TIME_SHIFT < Now then
         Set_Result (Result, INVALID_SIGNATURE, "the access token issued more than 1 hour ago");

      elsif Info.Expires + TIME_SHIFT < Now then
         Set_Result (Result, INVALID_SIGNATURE, "the access token has expored");

      elsif Length (Info.User_Id) = 0 then
         Set_Result (Result, INVALID_SIGNATURE, "the access token refers to an empty user_id");

      elsif Info.App_Id /= Realm.App.Get_Application_Identifier then
         Set_Result (Result, INVALID_SIGNATURE,
                     "the access token was granted for another application");

      else
         Result.Identity := To_Unbounded_String ("https://graph.facebook.com/");
         Append (Result.Identity, Info.User_Id);
         Result.Claimed_Id := Result.Identity;

         Get_Token_Info ("https://graph.facebook.com/" & To_String (Info.User_Id)
                           & "?access_token=" & T,
                         Token_Info_Map'Access,
                         "",
                         Info'Unchecked_Access);

         Result.Email      := Info.Email;
         Result.Full_Name  := Info.Name;
         Result.First_Name := Info.First_Name;
         Result.Last_Name  := Info.Last_Name;
         Result.Language   := Info.Locale;
         Result.Gender     := Info.Gender;
         Set_Result (Result, AUTHENTICATED, "authenticated");
      end if;
   end Verify_Access_Token;

begin
   Token_Info_Map.Add_Mapping ("app_id", FIELD_APP_ID);
   Token_Info_Map.Add_Mapping ("expires_at", FIELD_EXPIRES);
   Token_Info_Map.Add_Mapping ("issued_at", FIELD_ISSUED_AT);
   Token_Info_Map.Add_Mapping ("is_valid", FIELD_IS_VALID);
   Token_Info_Map.Add_Mapping ("user_id", FIELD_USER_ID);
   Token_Info_Map.Add_Mapping ("email", FIELD_EMAIL);
   Token_Info_Map.Add_Mapping ("name", FIELD_NAME);
   Token_Info_Map.Add_Mapping ("first_name", FIELD_FIRST_NAME);
   Token_Info_Map.Add_Mapping ("last_name", FIELD_LAST_NAME);
   Token_Info_Map.Add_Mapping ("locale", FIELD_LOCALE);
   Token_Info_Map.Add_Mapping ("gender", FIELD_GENDER);
end Security.Auth.OAuth.Facebook;

Fix compilation warning

Fix compilation warning


-----------------------------------------------------------------------
--  wiki-streams-html-builders -- Wiki writer to a string builder
--  Copyright (C) 2011, 2012, 2013, 2015, 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.
-----------------------------------------------------------------------
with Wiki.Streams.Builders;

--  == Writer interfaces ==
--  The <tt>Wiki.Writers</tt> package defines the interfaces used by the renderer to write
--  their outputs.
--
package Wiki.Streams.Html.Builders is

   type Html_Output_Builder_Stream is limited new Wiki.Streams.Builders.Output_Builder_Stream
     and Wiki.Streams.Html.Html_Output_Stream with private;
   type Html_Output_Builder_Stream_Access is access all Html_Output_Builder_Stream'Class;

   overriding
   procedure Write_Wide_Element (Stream  : in out Html_Output_Builder_Stream;
                                 Name    : in String;
                                 Content : in Wiki.Strings.WString);

   overriding
   procedure Write_Wide_Attribute (Stream  : in out Html_Output_Builder_Stream;
                                   Name    : in String;
                                   Content : in Unbounded_Wide_Wide_String);

   --  Write an XML attribute within an XML element.
   --  The attribute value is escaped according to the XML escape rules.
   overriding
   procedure Write_Wide_Attribute (Stream  : in out Html_Output_Builder_Stream;
                                   Name    : in String;
                                   Content : in Wiki.Strings.WString);

   overriding
   procedure Start_Element (Stream : in out Html_Output_Builder_Stream;
                            Name   : in String);

   overriding
   procedure End_Element (Stream : in out Html_Output_Builder_Stream;
                          Name   : in String);

   overriding
   procedure Write_Wide_Text (Stream  : in out Html_Output_Builder_Stream;
                              Content : in Wiki.Strings.WString);

private

   type Html_Output_Builder_Stream is limited new Wiki.Streams.Builders.Output_Builder_Stream
     and Wiki.Streams.Html.Html_Output_Stream with record
      --  Whether an XML element must be closed (that is a '>' is necessary)
      Close_Start : Boolean := False;
   end record;

end Wiki.Streams.Html.Builders;

-----------------------------------------------------------------------
--  wiki-streams-html-builders -- Wiki writer to a string builder
--  Copyright (C) 2011, 2012, 2013, 2015, 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.
-----------------------------------------------------------------------
with Wiki.Streams.Builders;

--  == Writer interfaces ==
--  The <tt>Wiki.Writers</tt> package defines the interfaces used by the renderer to write
--  their outputs.
--
package Wiki.Streams.Html.Builders is

   type Html_Output_Builder_Stream is limited new Wiki.Streams.Builders.Output_Builder_Stream
     and Wiki.Streams.Html.Html_Output_Stream with private;
   type Html_Output_Builder_Stream_Access is access all Html_Output_Builder_Stream'Class;

   overriding
   procedure Write_Wide_Element (Stream  : in out Html_Output_Builder_Stream;
                                 Name    : in String;
                                 Content : in Wiki.Strings.WString);

   overriding
   procedure Write_Wide_Attribute (Stream  : in out Html_Output_Builder_Stream;
                                   Name    : in String;
                                   Content : in Wiki.Strings.UString);

   --  Write an XML attribute within an XML element.
   --  The attribute value is escaped according to the XML escape rules.
   overriding
   procedure Write_Wide_Attribute (Stream  : in out Html_Output_Builder_Stream;
                                   Name    : in String;
                                   Content : in Wiki.Strings.WString);

   overriding
   procedure Start_Element (Stream : in out Html_Output_Builder_Stream;
                            Name   : in String);

   overriding
   procedure End_Element (Stream : in out Html_Output_Builder_Stream;
                          Name   : in String);

   overriding
   procedure Write_Wide_Text (Stream  : in out Html_Output_Builder_Stream;
                              Content : in Wiki.Strings.WString);

private

   type Html_Output_Builder_Stream is limited new Wiki.Streams.Builders.Output_Builder_Stream
     and Wiki.Streams.Html.Html_Output_Stream with record
      --  Whether an XML element must be closed (that is a '>' is necessary)
      Close_Start : Boolean := False;
   end record;

end Wiki.Streams.Html.Builders;

Use the Wiki.Strings.UString type

Use the Wiki.Strings.UString type


-----------------------------------------------------------------------
--  awa_command - Tests for AWA command
--  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 Util.Commands;
with Util.Tests;
with AWA.Tests;
with AWA.Commands.Drivers;
with AWA.Commands.List;
with AWA.Commands.Start;
with AWA.Commands.Stop;
with Servlet.Server;
with AWA.Tests;
with ADO.Drivers;
with AWA.Testsuite;
procedure AWA_Command is

   package Server_Commands is
     new AWA.Commands.Drivers (Driver_Name => "awa",
                               Container_Type => Servlet.Server.Container);

   package List_Command is
      new AWA.Commands.List (Server_Commands);

   package Start_Command is
      new AWA.Commands.Start (Server_Commands);

   package Stop_Command is
      new AWA.Commands.Stop (Server_Commands);

   App       : aliased AWA.Tests.Test_Application;
   Context   : AWA.Commands.Context_Type;
   Arguments : Util.Commands.Dynamic_Argument_List;
   Suite     : Util.Tests.Access_Test_Suite := AWA.Testsuite.Suite;
begin
   ADO.Drivers.Initialize;
   Server_Commands.WS.Register_Application ("/test", App'Unchecked_Access);
   Server_Commands.Run (Context, Arguments);
end AWA_Command;

-----------------------------------------------------------------------
--  awa_command - Tests for AWA command
--  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 Util.Commands;
with Util.Tests;
with AWA.Tests;
with AWA.Commands.Drivers;
with AWA.Commands.List;
with AWA.Commands.Start;
with AWA.Commands.Stop;
with Servlet.Server;
with ADO.Drivers;
with AWA.Testsuite;
procedure AWA_Command is

   package Server_Commands is
     new AWA.Commands.Drivers (Driver_Name => "awa",
                               Container_Type => Servlet.Server.Container);

   package List_Command is
      new AWA.Commands.List (Server_Commands);

   package Start_Command is
      new AWA.Commands.Start (Server_Commands);

   package Stop_Command is
      new AWA.Commands.Stop (Server_Commands);

   App       : aliased AWA.Tests.Test_Application;
   Context   : AWA.Commands.Context_Type;
   Arguments : Util.Commands.Dynamic_Argument_List;
   Suite     : Util.Tests.Access_Test_Suite := AWA.Testsuite.Suite;
   pragma Unreferenced (Suite);
begin
   ADO.Drivers.Initialize;
   Server_Commands.WS.Register_Application ("/test", App'Unchecked_Access);
   Server_Commands.Run (Context, Arguments);

exception
   when E : others =>
      AWA.Commands.Print (Context, E);

end AWA_Command;

Handle exceptions and report them by using the Print procedure


-----------------------------------------------------------------------
--  util-listeners-lifecycles -- Listeners
--  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.
-----------------------------------------------------------------------

--  The `Lifecycles` package provides a listener interface dedicated to
--  track lifecycle managements on objects.  It defines a set of procedures to be
--  notified when an object is created, updated or deleted.
generic
   type Element_Type (<>) is limited private;
package Util.Listeners.Lifecycles is

   --  ------------------------------
   --  Lifecycle listener
   --  ------------------------------
   type Listener is limited interface and Util.Listeners.Listener;

   --  The `On_Create` procedure is called by `Notify_Create` to notify the creation of the item.
   procedure On_Create (Instance : in Listener;
                        Item     : in Element_Type) is abstract;

   --  The `On_Update` procedure is called by `Notify_Update` to notify the update of the item.
   procedure On_Update (Instance : in Listener;
                        Item     : in Element_Type) is abstract;

   --  The `On_Delete` procedure is called by `Notify_Delete` to notify the deletion of the item.
   procedure On_Delete (Instance : in Listener;
                        Item     : in Element_Type) is abstract;

   --  Inform the the lifecycle listeners registered in `List` that the item passed in `Item`
   --  has been created (calls `On_Create`).
   procedure Notify_Create (List : in Util.Listeners.List;
                            Item : in Element_Type);

   --  Inform the the lifecycle listeners registered in `List` that the item passed in `Item`
   --  has been updated (calls `On_Update`).
   procedure Notify_Update (List : in Util.Listeners.List;
                            Item : in Element_Type);

   --  Inform the the lifecycle listeners registered in `List` that the item passed in `Item`
   --  has been deleted (calls `On_Delete`).
   procedure Notify_Delete (List : in Util.Listeners.List;
                            Item : in Element_Type);

end Util.Listeners.Lifecycles;

-----------------------------------------------------------------------
--  util-listeners-lifecycles -- Listeners
--  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.
-----------------------------------------------------------------------

--  The `Lifecycles` package provides a listener interface dedicated to
--  track lifecycle managements on objects.  It defines a set of procedures to be
--  notified when an object is created, updated or deleted.
--
--  Notes: another implementation can be made by using three different listener lists
--  that use the simple observer pattern.
generic
   type Element_Type (<>) is limited private;
package Util.Listeners.Lifecycles is

   --  ------------------------------
   --  Lifecycle listener
   --  ------------------------------
   type Listener is limited interface and Util.Listeners.Listener;

   --  The `On_Create` procedure is called by `Notify_Create` to notify the creation of the item.
   procedure On_Create (Instance : in Listener;
                        Item     : in Element_Type) is abstract;

   --  The `On_Update` procedure is called by `Notify_Update` to notify the update of the item.
   procedure On_Update (Instance : in Listener;
                        Item     : in Element_Type) is abstract;

   --  The `On_Delete` procedure is called by `Notify_Delete` to notify the deletion of the item.
   procedure On_Delete (Instance : in Listener;
                        Item     : in Element_Type) is abstract;

   --  Inform the the lifecycle listeners registered in `List` that the item passed in `Item`
   --  has been created (calls `On_Create`).
   procedure Notify_Create (List : in Util.Listeners.List;
                            Item : in Element_Type);

   --  Inform the the lifecycle listeners registered in `List` that the item passed in `Item`
   --  has been updated (calls `On_Update`).
   procedure Notify_Update (List : in Util.Listeners.List;
                            Item : in Element_Type);

   --  Inform the the lifecycle listeners registered in `List` that the item passed in `Item`
   --  has been deleted (calls `On_Delete`).
   procedure Notify_Delete (List : in Util.Listeners.List;
                            Item : in Element_Type);

end Util.Listeners.Lifecycles;

Update the documentation

Update the documentation


-----------------------------------------------------------------------
--  util-serialize-io-xml -- XML Serialization Driver
--  Copyright (C) 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 Sax.Exceptions;
with Sax.Locators;
with Sax.Readers;
with Sax.Attributes;
with Unicode.CES;
with Input_Sources;

with Ada.Streams;
with Ada.Strings.Unbounded;
with Util.Streams.Buffered;
with Util.Streams.Texts;
package Util.Serialize.IO.XML is

   Parse_Error : exception;

   type Parser is new Serialize.IO.Parser with private;

   --  Parse the stream using the JSON parser.
   procedure Parse (Handler : in out Parser;
                    Stream  : in out Util.Streams.Buffered.Buffered_Stream'Class);

   --  Set the XHTML reader to ignore or not the white spaces.
   --  When set to True, the ignorable white spaces will not be kept.
   procedure Set_Ignore_White_Spaces (Reader : in out Parser;
                                      Value  : in Boolean);

   --  Set the XHTML reader to ignore empty lines.
   procedure Set_Ignore_Empty_Lines (Reader : in out Parser;
                                     Value  : in Boolean);

   --  Get the current location (file and line) to report an error message.
   function Get_Location (Handler : in Parser) return String;

   type Xhtml_Reader is new Sax.Readers.Reader with private;

   --  ------------------------------
   --  XML Output Stream
   --  ------------------------------
   --  The <b>Output_Stream</b> provides methods for creating an XML output stream.
   --  The stream object takes care of the XML escape rules.
   type Output_Stream is limited new Util.Serialize.IO.Output_Stream with private;

   --  Set the target output stream.
   procedure Initialize (Stream : in out Output_Stream;
                         Output : in Util.Streams.Texts.Print_Stream_Access);

   --  Flush the buffer (if any) to the sink.
   overriding
   procedure Flush (Stream : in out Output_Stream);

   --  Close the sink.
   overriding
   procedure Close (Stream : in out Output_Stream);

   --  Write the buffer array to the output stream.
   overriding
   procedure Write (Stream : in out Output_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array);

   --  Write a raw character on the stream.
   procedure Write (Stream : in out Output_Stream;
                    Char   : in Character);

   --  Write a wide character on the stream doing some conversion if necessary.
   --  The default implementation translates the wide character to a UTF-8 sequence.
   procedure Write_Wide (Stream : in out Output_Stream;
                         Item   : in Wide_Wide_Character);

   --  Write a raw string on the stream.
   procedure Write (Stream : in out Output_Stream;
                    Item   : in String);

   --  Write a character on the response stream and escape that character as necessary.
   procedure Write_Escape (Stream : in out Output_Stream'Class;
                           Char   : in Wide_Wide_Character);

   --  Write the value as a XML string.  Special characters are escaped using the XML
   --  escape rules.
   procedure Write_String (Stream : in out Output_Stream;
                           Value  : in String);

   --  Write the value as a XML string.  Special characters are escaped using the XML
   --  escape rules.
   procedure Write_Wide_String (Stream : in out Output_Stream;
                                Value  : in Wide_Wide_String);

   --  Write the value as a XML string.  Special characters are escaped using the XML
   --  escape rules.
   procedure Write_String (Stream : in out Output_Stream;
                           Value  : in Util.Beans.Objects.Object);

   --  Start a new XML object.
   procedure Start_Entity (Stream : in out Output_Stream;
                           Name   : in String);

   --  Terminates the current XML object.
   procedure End_Entity (Stream : in out Output_Stream;
                         Name   : in String);

   --  Write the attribute name/value pair.
   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in String);

   overriding
   procedure Write_Wide_Attribute (Stream : in out Output_Stream;
                                   Name   : in String;
                                   Value  : in Wide_Wide_String);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Integer);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Boolean);

   --  Write a XML name/value attribute.
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object);
   --  Write the entity value.
   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in String);

   overriding
   procedure Write_Wide_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Wide_Wide_String);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Boolean);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Integer);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Ada.Calendar.Time);

   overriding
   procedure Write_Long_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Long_Long_Integer);

   overriding
   procedure Write_Enum_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in String);

   --  Write a XML name/value entity (see Write_Attribute).
   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object);

   --  Starts a XML array.
   overriding
   procedure Start_Array (Stream : in out Output_Stream;
                          Name   : in String);

   --  Terminates a XML array.
   overriding
   procedure End_Array (Stream : in out Output_Stream;
                        Name   : in String);

   --  Return the location where the exception was raised.
   function Get_Location (Except : Sax.Exceptions.Sax_Parse_Exception'Class)
                          return String;

private

   overriding
   procedure Warning (Handler : in out Xhtml_Reader;
                      Except  : in Sax.Exceptions.Sax_Parse_Exception'Class);

   overriding
   procedure Error (Handler : in out Xhtml_Reader;
                    Except  : in Sax.Exceptions.Sax_Parse_Exception'Class);

   overriding
   procedure Fatal_Error (Handler : in out Xhtml_Reader;
                          Except  : in Sax.Exceptions.Sax_Parse_Exception'Class);

   overriding
   procedure Set_Document_Locator (Handler : in out Xhtml_Reader;
                                   Loc     : in out Sax.Locators.Locator);

   overriding
   procedure Start_Document (Handler : in out Xhtml_Reader);

   overriding
   procedure End_Document (Handler : in out Xhtml_Reader);

   overriding
   procedure Start_Prefix_Mapping (Handler : in out Xhtml_Reader;
                                   Prefix  : in Unicode.CES.Byte_Sequence;
                                   URI     : in Unicode.CES.Byte_Sequence);

   overriding
   procedure End_Prefix_Mapping (Handler : in out Xhtml_Reader;
                                 Prefix  : in Unicode.CES.Byte_Sequence);

   overriding
   procedure Start_Element (Handler       : in out Xhtml_Reader;
                            Namespace_URI : in Unicode.CES.Byte_Sequence := "";
                            Local_Name    : in Unicode.CES.Byte_Sequence := "";
                            Qname         : in Unicode.CES.Byte_Sequence := "";
                            Atts          : in Sax.Attributes.Attributes'Class);

   overriding
   procedure End_Element (Handler       : in out Xhtml_Reader;
                          Namespace_URI : in Unicode.CES.Byte_Sequence := "";
                          Local_Name    : in Unicode.CES.Byte_Sequence := "";
                          Qname         : in Unicode.CES.Byte_Sequence := "");

   overriding
   procedure Characters (Handler : in out Xhtml_Reader;
                         Ch      : in Unicode.CES.Byte_Sequence);

   overriding
   procedure Ignorable_Whitespace (Handler : in out Xhtml_Reader;
                                   Ch      : in Unicode.CES.Byte_Sequence);

   overriding
   procedure Processing_Instruction (Handler : in out Xhtml_Reader;
                                     Target  : in Unicode.CES.Byte_Sequence;
                                     Data    : in Unicode.CES.Byte_Sequence);

   overriding
   procedure Skipped_Entity (Handler : in out Xhtml_Reader;
                             Name    : in Unicode.CES.Byte_Sequence);

   overriding
   procedure Start_Cdata (Handler : in out Xhtml_Reader);

   overriding
   procedure End_Cdata (Handler : in out Xhtml_Reader);

   overriding
   function Resolve_Entity (Handler   : Xhtml_Reader;
                            Public_Id : Unicode.CES.Byte_Sequence;
                            System_Id : Unicode.CES.Byte_Sequence)
                            return Input_Sources.Input_Source_Access;

   overriding
   procedure Start_DTD (Handler   : in out Xhtml_Reader;
                        Name      : Unicode.CES.Byte_Sequence;
                        Public_Id : Unicode.CES.Byte_Sequence := "";
                        System_Id : Unicode.CES.Byte_Sequence := "");

   procedure Collect_Text (Handler : in out Xhtml_Reader;
                           Content : Unicode.CES.Byte_Sequence);

   type Xhtml_Reader is new Sax.Readers.Reader with record
      Stack_Pos  : Natural := 0;
      Handler    : access Parser'Class;

      Text : Ada.Strings.Unbounded.Unbounded_String;

      --  Whether white spaces can be ignored.
      Ignore_White_Spaces : Boolean := True;

      --  Whether empty lines should be ignored (when white spaces are kept).
      Ignore_Empty_Lines : Boolean := True;
   end record;

   type Parser is new Util.Serialize.IO.Parser with record
      --  The SAX locator to find the current file and line number.
      Locator             : Sax.Locators.Locator;
      Has_Pending_Char   : Boolean := False;
      Pending_Char       : Character;

      --  Whether white spaces can be ignored.
      Ignore_White_Spaces : Boolean := True;

      --  Whether empty lines should be ignored (when white spaces are kept).
      Ignore_Empty_Lines  : Boolean := True;
   end record;

   type Output_Stream is limited new Util.Serialize.IO.Output_Stream with record
      Close_Start : Boolean := False;
      Stream      : Util.Streams.Texts.Print_Stream_Access;
   end record;

end Util.Serialize.IO.XML;

-----------------------------------------------------------------------
--  util-serialize-io-xml -- XML Serialization Driver
--  Copyright (C) 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 Sax.Exceptions;
with Sax.Locators;
with Sax.Readers;
with Sax.Attributes;
with Unicode.CES;
with Input_Sources;

with Ada.Streams;
with Ada.Strings.Unbounded;
with Util.Streams.Buffered;
with Util.Streams.Texts;
package Util.Serialize.IO.XML is

   Parse_Error : exception;

   type Parser is new Serialize.IO.Parser with private;

   --  Parse the stream using the JSON parser.
   procedure Parse (Handler : in out Parser;
                    Stream  : in out Util.Streams.Buffered.Buffered_Stream'Class;
                    Sink    : in out Reader'Class);

   --  Set the XHTML reader to ignore or not the white spaces.
   --  When set to True, the ignorable white spaces will not be kept.
   procedure Set_Ignore_White_Spaces (Reader : in out Parser;
                                      Value  : in Boolean);

   --  Set the XHTML reader to ignore empty lines.
   procedure Set_Ignore_Empty_Lines (Reader : in out Parser;
                                     Value  : in Boolean);

   --  Get the current location (file and line) to report an error message.
   function Get_Location (Handler : in Parser) return String;

   type Xhtml_Reader is new Sax.Readers.Reader with private;

   --  ------------------------------
   --  XML Output Stream
   --  ------------------------------
   --  The <b>Output_Stream</b> provides methods for creating an XML output stream.
   --  The stream object takes care of the XML escape rules.
   type Output_Stream is limited new Util.Serialize.IO.Output_Stream with private;

   --  Set the target output stream.
   procedure Initialize (Stream : in out Output_Stream;
                         Output : in Util.Streams.Texts.Print_Stream_Access);

   --  Flush the buffer (if any) to the sink.
   overriding
   procedure Flush (Stream : in out Output_Stream);

   --  Close the sink.
   overriding
   procedure Close (Stream : in out Output_Stream);

   --  Write the buffer array to the output stream.
   overriding
   procedure Write (Stream : in out Output_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array);

   --  Write a raw character on the stream.
   procedure Write (Stream : in out Output_Stream;
                    Char   : in Character);

   --  Write a wide character on the stream doing some conversion if necessary.
   --  The default implementation translates the wide character to a UTF-8 sequence.
   procedure Write_Wide (Stream : in out Output_Stream;
                         Item   : in Wide_Wide_Character);

   --  Write a raw string on the stream.
   procedure Write (Stream : in out Output_Stream;
                    Item   : in String);

   --  Write a character on the response stream and escape that character as necessary.
   procedure Write_Escape (Stream : in out Output_Stream'Class;
                           Char   : in Wide_Wide_Character);

   --  Write the value as a XML string.  Special characters are escaped using the XML
   --  escape rules.
   procedure Write_String (Stream : in out Output_Stream;
                           Value  : in String);

   --  Write the value as a XML string.  Special characters are escaped using the XML
   --  escape rules.
   procedure Write_Wide_String (Stream : in out Output_Stream;
                                Value  : in Wide_Wide_String);

   --  Write the value as a XML string.  Special characters are escaped using the XML
   --  escape rules.
   procedure Write_String (Stream : in out Output_Stream;
                           Value  : in Util.Beans.Objects.Object);

   --  Start a new XML object.
   procedure Start_Entity (Stream : in out Output_Stream;
                           Name   : in String);

   --  Terminates the current XML object.
   procedure End_Entity (Stream : in out Output_Stream;
                         Name   : in String);

   --  Write the attribute name/value pair.
   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in String);

   overriding
   procedure Write_Wide_Attribute (Stream : in out Output_Stream;
                                   Name   : in String;
                                   Value  : in Wide_Wide_String);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Integer);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Boolean);

   --  Write a XML name/value attribute.
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object);
   --  Write the entity value.
   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in String);

   overriding
   procedure Write_Wide_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Wide_Wide_String);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Boolean);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Integer);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Ada.Calendar.Time);

   overriding
   procedure Write_Long_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Long_Long_Integer);

   overriding
   procedure Write_Enum_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in String);

   --  Write a XML name/value entity (see Write_Attribute).
   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object);

   --  Starts a XML array.
   overriding
   procedure Start_Array (Stream : in out Output_Stream;
                          Name   : in String);

   --  Terminates a XML array.
   overriding
   procedure End_Array (Stream : in out Output_Stream;
                        Name   : in String);

   --  Return the location where the exception was raised.
   function Get_Location (Except : Sax.Exceptions.Sax_Parse_Exception'Class)
                          return String;

private

   overriding
   procedure Warning (Handler : in out Xhtml_Reader;
                      Except  : in Sax.Exceptions.Sax_Parse_Exception'Class);

   overriding
   procedure Error (Handler : in out Xhtml_Reader;
                    Except  : in Sax.Exceptions.Sax_Parse_Exception'Class);

   overriding
   procedure Fatal_Error (Handler : in out Xhtml_Reader;
                          Except  : in Sax.Exceptions.Sax_Parse_Exception'Class);

   overriding
   procedure Set_Document_Locator (Handler : in out Xhtml_Reader;
                                   Loc     : in out Sax.Locators.Locator);

   overriding
   procedure Start_Document (Handler : in out Xhtml_Reader);

   overriding
   procedure End_Document (Handler : in out Xhtml_Reader);

   overriding
   procedure Start_Prefix_Mapping (Handler : in out Xhtml_Reader;
                                   Prefix  : in Unicode.CES.Byte_Sequence;
                                   URI     : in Unicode.CES.Byte_Sequence);

   overriding
   procedure End_Prefix_Mapping (Handler : in out Xhtml_Reader;
                                 Prefix  : in Unicode.CES.Byte_Sequence);

   overriding
   procedure Start_Element (Handler       : in out Xhtml_Reader;
                            Namespace_URI : in Unicode.CES.Byte_Sequence := "";
                            Local_Name    : in Unicode.CES.Byte_Sequence := "";
                            Qname         : in Unicode.CES.Byte_Sequence := "";
                            Atts          : in Sax.Attributes.Attributes'Class);

   overriding
   procedure End_Element (Handler       : in out Xhtml_Reader;
                          Namespace_URI : in Unicode.CES.Byte_Sequence := "";
                          Local_Name    : in Unicode.CES.Byte_Sequence := "";
                          Qname         : in Unicode.CES.Byte_Sequence := "");

   overriding
   procedure Characters (Handler : in out Xhtml_Reader;
                         Ch      : in Unicode.CES.Byte_Sequence);

   overriding
   procedure Ignorable_Whitespace (Handler : in out Xhtml_Reader;
                                   Ch      : in Unicode.CES.Byte_Sequence);

   overriding
   procedure Processing_Instruction (Handler : in out Xhtml_Reader;
                                     Target  : in Unicode.CES.Byte_Sequence;
                                     Data    : in Unicode.CES.Byte_Sequence);

   overriding
   procedure Skipped_Entity (Handler : in out Xhtml_Reader;
                             Name    : in Unicode.CES.Byte_Sequence);

   overriding
   procedure Start_Cdata (Handler : in out Xhtml_Reader);

   overriding
   procedure End_Cdata (Handler : in out Xhtml_Reader);

   overriding
   function Resolve_Entity (Handler   : Xhtml_Reader;
                            Public_Id : Unicode.CES.Byte_Sequence;
                            System_Id : Unicode.CES.Byte_Sequence)
                            return Input_Sources.Input_Source_Access;

   overriding
   procedure Start_DTD (Handler   : in out Xhtml_Reader;
                        Name      : Unicode.CES.Byte_Sequence;
                        Public_Id : Unicode.CES.Byte_Sequence := "";
                        System_Id : Unicode.CES.Byte_Sequence := "");

   procedure Collect_Text (Handler : in out Xhtml_Reader;
                           Content : Unicode.CES.Byte_Sequence);

   type Xhtml_Reader is new Sax.Readers.Reader with record
      Stack_Pos  : Natural := 0;
      Handler    : access Parser'Class;

      Text : Ada.Strings.Unbounded.Unbounded_String;

      --  Whether white spaces can be ignored.
      Ignore_White_Spaces : Boolean := True;

      --  Whether empty lines should be ignored (when white spaces are kept).
      Ignore_Empty_Lines : Boolean := True;

      Sink               : access Reader'Class;
   end record;

   type Parser is new Util.Serialize.IO.Parser with record
      --  The SAX locator to find the current file and line number.
      Locator             : Sax.Locators.Locator;
      Has_Pending_Char   : Boolean := False;
      Pending_Char       : Character;

      --  Whether white spaces can be ignored.
      Ignore_White_Spaces : Boolean := True;

      --  Whether empty lines should be ignored (when white spaces are kept).
      Ignore_Empty_Lines  : Boolean := True;
   end record;

   type Output_Stream is limited new Util.Serialize.IO.Output_Stream with record
      Close_Start : Boolean := False;
      Stream      : Util.Streams.Texts.Print_Stream_Access;
   end record;

end Util.Serialize.IO.XML;

Add a Sink parameter to the Parse procedure