------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                   A U N I T . R E P O R T E R . X M L                    --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                                                                          --
--                       Copyright (C) 2000-2009, AdaCore                   --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, USA.                                              --
--                                                                          --
-- GNAT is maintained by AdaCore (http://www.adacore.com)                   --
--                                                                          --
------------------------------------------------------------------------------

with AUnit.Time_Measure;
with Util.Strings;

--  Very simple reporter to console
package body Util.Tests.Reporter is

   use AUnit.Test_Results;
   use AUnit.Time_Measure;
   use type AUnit.Message_String;
   use Ada.Text_IO;

   procedure Dump_Result_List (File : in Ada.Text_IO.File_Type;
                               L    : in Result_Lists.List);
   --  List failed assertions

--     procedure Put_Measure is new Gen_Put_Measure;
   --  Output elapsed time

   procedure Report_Test (File : in Ada.Text_IO.File_Type;
                          Test : in Test_Result);
   --  Report a single assertion failure or unexpected exception

   procedure Put (File : in Ada.Text_IO.File_Type;
                  I    : in Integer);

   procedure Put (File : in Ada.Text_IO.File_Type;
                  I    : in Integer) is
   begin
      Ada.Text_IO.Put (File, Util.Strings.Image (I));
   end Put;

   ----------------------
   -- Dump_Result_List --
   ----------------------

   procedure Dump_Result_List (File : in Ada.Text_IO.File_Type;
                               L    : in Result_Lists.List) is

      use Result_Lists;

      C : Cursor := First (L);

   begin

      --  Note: can't use Iterate because it violates restriction
      --  No_Implicit_Dynamic_Code

      while Has_Element (C) loop
         Report_Test (File, Element (C));
         Next (C);
      end loop;
   end Dump_Result_List;

   ------------
   -- Report --
   ------------

   procedure Report (Engine : XML_Reporter;
                     R      : in out Result'Class)
   is
      Output : Ada.Text_IO.File_Type;
   begin
      Ada.Text_IO.Create (File => Output,
                          Mode => Ada.Text_IO.Out_File,
                          Name => To_String (Engine.File));
      Engine.Report (Output, R);
      Ada.Text_IO.Close (Output);
   end Report;

   ------------
   -- Report --
   ------------

   procedure Report (Engine : XML_Reporter;
                     File   : in out Ada.Text_IO.File_Type;
                     R      : in out Result'Class)
   is
      pragma Unreferenced (Engine);

      procedure Put (I : in Integer);
      procedure Put (S : in String);

      T   : AUnit_Duration;

      procedure Put (I : in Integer) is
      begin
         Ada.Text_IO.Put (File, Integer'Image (I));
      end Put;

      procedure Put (S : in String) is
      begin
         Put (File, S);
      end Put;

      procedure Put_Measure is new AUnit.Time_Measure.Gen_Put_Measure;

   begin
      Put_Line (File, "<?xml version='1.0' encoding='utf-8' ?>");
      Put      (File, "<TestRun");

      if Elapsed  (R) /= AUnit.Time_Measure.Null_Time then
         T := Get_Measure (Elapsed (R));

         Put (File, " elapsed='");
         Put_Measure (T);
         Put_Line (File, "'>");
      else
         Put_Line (File, ">");
      end if;

      Put_Line (File, "  <Statistics>");
      Put      (File, "    <Tests>");
      Put (File, Integer (Test_Count (R)));
      Put_Line (File, "</Tests>");
      Put      (File, "    <FailuresTotal>");
      Put (File, Integer (Failure_Count (R)) + Integer (Error_Count (R)));
      Put_Line (File, "</FailuresTotal>");
      Put      (File, "    <Failures>");
      Put (File, Integer (Failure_Count (R)));
      Put_Line (File, "</Failures>");
      Put      (File, "    <Errors>");
      Put (File, Integer (Error_Count (R)));
      Put_Line (File, "</Errors>");
      Put_Line (File, "  </Statistics>");

      declare
         S : Result_Lists.List;
      begin
         Put_Line (File, "  <SuccessfulTests>");
         Successes (R, S);
         Dump_Result_List (File, S);
         Put_Line (File, "  </SuccessfulTests>");
      end;

      Put_Line (File, "  <FailedTests>");
      declare
         F : Result_Lists.List;
      begin
         Failures (R, F);
         Dump_Result_List (File, F);
      end;

      declare
         E : Result_Lists.List;
      begin
         Errors (R, E);
         Dump_Result_List (File, E);
      end;
      Put_Line (File, "  </FailedTests>");

      Put_Line (File, "</TestRun>");
   end Report;

   ------------------
   -- Report_Error --
   ------------------

   procedure Report_Test (File : in Ada.Text_IO.File_Type;
                          Test : in Test_Result) is

      procedure Put (I : in Integer);
      procedure Put (S : in String);

      Is_Assert : Boolean;
      T : AUnit_Duration;

      procedure Put (I : in Integer) is
      begin
         Put (File, I);
      end Put;

      procedure Put (S : in String) is
      begin
         Put (File, S);
      end Put;

      procedure Put_Measure is new AUnit.Time_Measure.Gen_Put_Measure;

   begin
      Put (File, "    <Test");
      if Test.Elapsed /= AUnit.Time_Measure.Null_Time then
         T := Get_Measure (Test.Elapsed);

         Put (File, " elapsed='");
         Put_Measure (T);
         Put_Line (File, "'>");
      else
         Put_Line (File, ">");
      end if;
      Put      (File, "      <Name>");
      Put      (File, Test.Test_Name.all);

      if Test.Routine_Name /= null then
         Put (File, " : ");
         Put (File, Test.Routine_Name.all);
      end if;

      Put_Line (File, "</Name>");

      if Test.Failure /= null or else Test.Error /= null then
         if Test.Failure /= null then
            Is_Assert := True;
         else
            Is_Assert := False;
         end if;

         Put      (File, "      <FailureType>");

         if Is_Assert then
            Put   (File, "Assertion");
         else
            Put   (File, "Error");
         end if;

         Put_Line (File, "</FailureType>");
         Put      (File, "      <Message>");
         if Is_Assert then
            Put   (File, Test.Failure.Message.all);
         else
            Put   (File, Test.Error.Exception_Name.all);
         end if;
         Put_Line (File, "</Message>");

         if Is_Assert then
            Put_Line (File, "      <Location>");
            Put      (File, "        <File>");
            Put      (File, Test.Failure.Source_Name.all);
            Put_Line (File, "</File>");
            Put      (File, "        <Line>");
            Put      (File, Test.Failure.Line);
            Put_Line (File, "</Line>");
            Put_Line (File, "      </Location>");

         else
            Put_Line (File, "      <Exception>");
            Put      (File, "      <Message>");
            Put      (File, Test.Error.Exception_Name.all);
            Put_Line (File, "</Message>");

            if Test.Error.Exception_Message /= null then
               Put      (File, "      <Information>");
               Put      (File, Test.Error.Exception_Message.all);
               Put_Line (File, "</Information>");
            end if;

            if Test.Error.Traceback /= null then
               Put      (File, "      <Traceback>");
               Put      (File, Test.Error.Traceback.all);
               Put_Line (File, "</Traceback>");
            end if;

            Put_Line (File, "      </Exception>");
         end if;
      end if;

      Put_Line (File, "    </Test>");
   end Report_Test;

end Util.Tests.Reporter;

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                   A U N I T . R E P O R T E R . X M L                    --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                                                                          --
--                       Copyright (C) 2000-2009, AdaCore                   --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, USA.                                              --
--                                                                          --
-- GNAT is maintained by AdaCore (http://www.adacore.com)                   --
--                                                                          --
------------------------------------------------------------------------------

with AUnit.Time_Measure;
with Util.Strings;

--  Very simple reporter to console
package body Util.Tests.Reporter is

   use AUnit.Test_Results;
   use AUnit.Time_Measure;
   use type AUnit.Message_String;
   use Ada.Text_IO;

   procedure Print_Summary (R : in out Result'Class);

   procedure Dump_Result_List (File : in Ada.Text_IO.File_Type;
                               L    : in Result_Lists.List);
   --  List failed assertions

--     procedure Put_Measure is new Gen_Put_Measure;
   --  Output elapsed time

   procedure Report_Test (File : in Ada.Text_IO.File_Type;
                          Test : in Test_Result);
   --  Report a single assertion failure or unexpected exception

   procedure Put (File : in Ada.Text_IO.File_Type;
                  I    : in Integer);

   procedure Put (File : in Ada.Text_IO.File_Type;
                  I    : in Integer) is
   begin
      Ada.Text_IO.Put (File, Util.Strings.Image (I));
   end Put;

   ----------------------
   -- Dump_Result_List --
   ----------------------

   procedure Dump_Result_List (File : in Ada.Text_IO.File_Type;
                               L    : in Result_Lists.List) is

      use Result_Lists;

      C : Cursor := First (L);

   begin

      --  Note: can't use Iterate because it violates restriction
      --  No_Implicit_Dynamic_Code

      while Has_Element (C) loop
         Report_Test (File, Element (C));
         Next (C);
      end loop;
   end Dump_Result_List;

   ------------
   -- Report --
   ------------

   procedure Report (Engine : XML_Reporter;
                     R      : in out Result'Class)
   is
      Output : Ada.Text_IO.File_Type;
   begin
      Ada.Text_IO.Create (File => Output,
                          Mode => Ada.Text_IO.Out_File,
                          Name => To_String (Engine.File));
      Engine.Report (Output, R);
      Ada.Text_IO.Close (Output);
   end Report;

   procedure Print_Summary (R : in out Result'Class) is
      S_Count : constant Integer := Integer (Success_Count (R));
      F_Count : constant Integer := Integer (Failure_Count (R));
      E_Count : constant Integer := Integer (Error_Count (R));
   begin
      New_Line;
      Put ("Total Tests Run:   ");
      Put (Util.Strings.Image (Integer (Test_Count (R))));
      New_Line;
      Put ("Successful Tests:  ");
      Put (Util.Strings.Image (S_Count));
      New_Line;
      Put ("Failed Assertions: ");
      Put (Util.Strings.Image (F_Count));
      New_Line;
      Put ("Unexpected Errors: ");
      Put (Util.Strings.Image (E_Count));
      New_Line;
   end Print_Summary;

   ------------
   -- Report --
   ------------
   procedure Report (Engine : XML_Reporter;
                     File   : in out Ada.Text_IO.File_Type;
                     R      : in out Result'Class)
   is
      pragma Unreferenced (Engine);

      procedure Put (I : in Integer);
      procedure Put (S : in String);

      T   : AUnit_Duration;

      procedure Put (I : in Integer) is
      begin
         Ada.Text_IO.Put (File, Integer'Image (I));
      end Put;

      procedure Put (S : in String) is
      begin
         Put (File, S);
      end Put;

      procedure Put_Measure is new AUnit.Time_Measure.Gen_Put_Measure;

   begin
      Put_Line (File, "<?xml version='1.0' encoding='utf-8' ?>");
      Put      (File, "<TestRun");

      if Elapsed  (R) /= AUnit.Time_Measure.Null_Time then
         T := Get_Measure (Elapsed (R));

         Put (File, " elapsed='");
         Put_Measure (T);
         Put_Line (File, "'>");
      else
         Put_Line (File, ">");
      end if;

      Print_Summary (R);

      Put_Line (File, "  <Statistics>");
      Put      (File, "    <Tests>");
      Put (File, Integer (Test_Count (R)));
      Put_Line (File, "</Tests>");
      Put      (File, "    <FailuresTotal>");
      Put (File, Integer (Failure_Count (R)) + Integer (Error_Count (R)));
      Put_Line (File, "</FailuresTotal>");
      Put      (File, "    <Failures>");
      Put (File, Integer (Failure_Count (R)));
      Put_Line (File, "</Failures>");
      Put      (File, "    <Errors>");
      Put (File, Integer (Error_Count (R)));
      Put_Line (File, "</Errors>");
      Put_Line (File, "  </Statistics>");

      declare
         S : Result_Lists.List;
      begin
         Put_Line (File, "  <SuccessfulTests>");
         Successes (R, S);
         Dump_Result_List (File, S);
         Put_Line (File, "  </SuccessfulTests>");
      end;

      Put_Line (File, "  <FailedTests>");
      declare
         F : Result_Lists.List;
      begin
         Failures (R, F);
         Dump_Result_List (File, F);
      end;

      declare
         E : Result_Lists.List;
      begin
         Errors (R, E);
         Dump_Result_List (File, E);
      end;
      Put_Line (File, "  </FailedTests>");

      Put_Line (File, "</TestRun>");
   end Report;

   ------------------
   -- Report_Error --
   ------------------

   procedure Report_Test (File : in Ada.Text_IO.File_Type;
                          Test : in Test_Result) is

      procedure Put (I : in Integer);
      procedure Put (S : in String);

      Is_Assert : Boolean;
      T : AUnit_Duration;

      procedure Put (I : in Integer) is
      begin
         Put (File, I);
      end Put;

      procedure Put (S : in String) is
      begin
         Put (File, S);
      end Put;

      procedure Put_Measure is new AUnit.Time_Measure.Gen_Put_Measure;

   begin
      Put (File, "    <Test");
      if Test.Elapsed /= AUnit.Time_Measure.Null_Time then
         T := Get_Measure (Test.Elapsed);

         Put (File, " elapsed='");
         Put_Measure (T);
         Put_Line (File, "'>");
      else
         Put_Line (File, ">");
      end if;
      Put      (File, "      <Name>");
      Put      (File, Test.Test_Name.all);

      if Test.Routine_Name /= null then
         Put (File, " : ");
         Put (File, Test.Routine_Name.all);
      end if;

      Put_Line (File, "</Name>");

      if Test.Failure /= null or else Test.Error /= null then
         if Test.Failure /= null then
            Is_Assert := True;
         else
            Is_Assert := False;
         end if;

         Put      (File, "      <FailureType>");

         if Is_Assert then
            Put   (File, "Assertion");
         else
            Put   (File, "Error");
         end if;

         Put_Line (File, "</FailureType>");
         Put      (File, "      <Message>");
         if Is_Assert then
            Put   (File, Test.Failure.Message.all);
         else
            Put   (File, Test.Error.Exception_Name.all);
         end if;
         Put_Line (File, "</Message>");

         if Is_Assert then
            Put_Line (File, "      <Location>");
            Put      (File, "        <File>");
            Put      (File, Test.Failure.Source_Name.all);
            Put_Line (File, "</File>");
            Put      (File, "        <Line>");
            Put      (File, Test.Failure.Line);
            Put_Line (File, "</Line>");
            Put_Line (File, "      </Location>");

         else
            Put_Line (File, "      <Exception>");
            Put      (File, "      <Message>");
            Put      (File, Test.Error.Exception_Name.all);
            Put_Line (File, "</Message>");

            if Test.Error.Exception_Message /= null then
               Put      (File, "      <Information>");
               Put      (File, Test.Error.Exception_Message.all);
               Put_Line (File, "</Information>");
            end if;

            if Test.Error.Traceback /= null then
               Put      (File, "      <Traceback>");
               Put      (File, Test.Error.Traceback.all);
               Put_Line (File, "</Traceback>");
            end if;

            Put_Line (File, "      </Exception>");
         end if;
      end if;

      Put_Line (File, "    </Test>");
   end Report_Test;

end Util.Tests.Reporter;

Print a summary of results on stdout

Print a summary of results on stdout


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

with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;
with Util.Beans.Basic;
package Util.Beans.Objects.Maps is

   package Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Object,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=");

   subtype Cursor is Maps.Cursor;
   subtype Map is Maps.Map;

   --  Make all the Maps operations available (a kind of 'use Maps' for anybody).
   function Length (Container : in Map) return Ada.Containers.Count_Type renames Maps.Length;
   function Is_Empty (Container : in Map) return Boolean renames Maps.Is_Empty;
   procedure Clear (Container : in out Map) renames Maps.Clear;
   function Key (Position : Cursor) return String renames Maps.Key;

   procedure Include (Container : in out Map;
                      Key : in String;
                      New_Item : in Object) renames Maps.Include;
   procedure Query_Element (Position : in Cursor;
                            Process  : not null access procedure (Key     : String;
                                                                  Element : Object))
                            renames Maps.Query_Element;

   function Has_Element (Position : Cursor) return Boolean renames Maps.Has_Element;
   function Element (Position : Cursor) return Object renames Maps.Element;
   procedure Next (Position : in out Cursor) renames Maps.Next;
   function Next (Position : Cursor) return Cursor renames Maps.Next;
   function Equivalent_Keys (Left, Right : Cursor) return Boolean renames Maps.Equivalent_Keys;
   function Equivalent_Keys (Left : Cursor; Right : String) return Boolean
                             renames Maps.Equivalent_Keys;
   function Equivalent_Keys (Left : String; Right : Cursor) return Boolean
                             renames Maps.Equivalent_Keys;

   --  ------------------------------
   --  Map Bean
   --  ------------------------------
   --  The Map_Bean is a map of objects that also exposes the Bean interface.
   --  This allows the map to be available and accessed from an Object instance.
   type Map_Bean is new Maps.Map and Util.Beans.Basic.Bean with private;

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

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

private

   type Map_Bean is new Maps.Map and Util.Beans.Basic.Bean with null record;

end Util.Beans.Objects.Maps;

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

with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;
with Util.Beans.Basic;
package Util.Beans.Objects.Maps is

   package Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Object,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=");

   subtype Cursor is Maps.Cursor;
   subtype Map is Maps.Map;

   --  Make all the Maps operations available (a kind of 'use Maps' for anybody).
   function Length (Container : in Map) return Ada.Containers.Count_Type renames Maps.Length;
   function Is_Empty (Container : in Map) return Boolean renames Maps.Is_Empty;
   procedure Clear (Container : in out Map) renames Maps.Clear;
   function Key (Position : Cursor) return String renames Maps.Key;

   procedure Include (Container : in out Map;
                      Key : in String;
                      New_Item : in Object) renames Maps.Include;
   procedure Query_Element (Position : in Cursor;
                            Process  : not null access procedure (Key     : String;
                                                                  Element : Object))
                            renames Maps.Query_Element;

   function Has_Element (Position : Cursor) return Boolean renames Maps.Has_Element;
   function Element (Position : Cursor) return Object renames Maps.Element;
   procedure Next (Position : in out Cursor) renames Maps.Next;
   function Next (Position : Cursor) return Cursor renames Maps.Next;
   function Equivalent_Keys (Left, Right : Cursor) return Boolean renames Maps.Equivalent_Keys;
   function Equivalent_Keys (Left : Cursor; Right : String) return Boolean
                             renames Maps.Equivalent_Keys;
   function Equivalent_Keys (Left : String; Right : Cursor) return Boolean
                             renames Maps.Equivalent_Keys;
   function Copy (Source : Maps.Map; Capacity : in Ada.Containers.Count_Type) return Maps.Map
     renames Maps.Copy;

   --  ------------------------------
   --  Map Bean
   --  ------------------------------
   --  The Map_Bean is a map of objects that also exposes the Bean interface.
   --  This allows the map to be available and accessed from an Object instance.
   type Map_Bean is new Maps.Map and Util.Beans.Basic.Bean with private;

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

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

   --  Create an object that contains a <tt>Map_Bean</tt> instance.
   function Create return Object;

private

   type Map_Bean is new Maps.Map and Util.Beans.Basic.Bean with null record;

end Util.Beans.Objects.Maps;

Declare the Create procedure Declare the Copy procedure as rename of Maps.Copy


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

--  === Collector Filters ===
--  The <tt>Wiki.Filters.Collectors</tt> package defines two filters that can be used to
--  collect words or links contained in a Wiki document.  The collector filters are inserted
--  in the filter chain and they collect the data as the Wiki text is parsed.  After the
--  parsing, the collector filters have collected either the words or the links and they
--  can be queried by using the <tt>Find</tt> or <tt>Iterate</tt> operations.
package Wiki.Filters.Collectors is

   pragma Preelaborate;

   package WString_Maps is
     new Ada.Containers.Indefinite_Ordered_Maps (Key_Type     => Wiki.Strings.WString,
                                                 Element_Type => Natural,
                                                 "<"          => "<",
                                                 "="          => "=");

   subtype Map is WString_Maps.Map;
   subtype Cursor is WString_Maps.Cursor;

   --  ------------------------------
   --  General purpose collector type
   --  ------------------------------
   type Collector_Type is new Filter_Type with private;
   type Collector_Type_Access is access all Collector_Type'Class;

   function Find (Map  : in Collector_Type;
                  Item : in Wiki.Strings.WString) return Cursor;

   function Contains (Map  : in Collector_Type;
                      Item : in Wiki.Strings.WString) return Boolean;

   procedure Iterate (Map : in Collector_Type;
                      Process : not null access procedure (Pos : in Cursor));

   --  ------------------------------
   --  Word Collector type
   --  ------------------------------
   type Word_Collector_Type is new Collector_Type with private;
   type Word_Collector_Type_Access is access all Word_Collector_Type'Class;

   --  Add a text content with the given format to the document.
   procedure Add_Text (Filter    : in out Word_Collector_Type;
                       Document  : in out Wiki.Documents.Document;
                       Text      : in Wiki.Strings.WString;
                       Format    : in Wiki.Format_Map);

   --  Add a section header with the given level in the document.
   procedure Add_Header (Filter    : in out Word_Collector_Type;
                         Document  : in out Wiki.Documents.Document;
                         Header    : in Wiki.Strings.WString;
                         Level     : in Natural);

   --  Add a link.
   procedure Add_Link (Filter     : in out Word_Collector_Type;
                       Document   : in out Wiki.Documents.Document;
                       Name       : in Wiki.Strings.WString;
                       Attributes : in out Wiki.Attributes.Attribute_List);

   --  Add an image.
   procedure Add_Image (Filter     : in out Word_Collector_Type;
                        Document   : in out Wiki.Documents.Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List);

   --  Add a quote.
   procedure Add_Quote (Filter     : in out Word_Collector_Type;
                        Document   : in out Wiki.Documents.Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List);

   --  Add a text block that is pre-formatted.
   procedure Add_Preformatted (Filter   : in out Word_Collector_Type;
                               Document : in out Wiki.Documents.Document;
                               Text     : in Wiki.Strings.WString;
                               Format   : in Wiki.Strings.WString);

   --  ------------------------------
   --  Link Collector type
   --  ------------------------------
   type Link_Collector_Type is new Collector_Type with private;
   type Link_Collector_Type_Access is access all Link_Collector_Type'Class;

   --  Add a link.
   overriding
   procedure Add_Link (Filter     : in out Link_Collector_Type;
                       Document   : in out Wiki.Documents.Document;
                       Name       : in Wiki.Strings.WString;
                       Attributes : in out Wiki.Attributes.Attribute_List);

   --  Push a HTML node with the given tag to the document.
   overriding
   procedure Push_Node (Filter     : in out Link_Collector_Type;
                        Document   : in out Wiki.Documents.Document;
                        Tag        : in Wiki.Html_Tag;
                        Attributes : in out Wiki.Attributes.Attribute_List);

private

   type Collector_Type is new Filter_Type with record
      Items : WString_Maps.Map;
   end record;

   type Word_Collector_Type is new Collector_Type with null record;

   procedure Collect_Words (Filter  : in out Word_Collector_Type;
                            Content : in Wiki.Strings.WString);

   type Link_Collector_Type is new Collector_Type with null record;

   procedure Collect_Link (Filter     : in out Link_Collector_Type;
                           Attributes : in Wiki.Attributes.Attribute_List;
                           Name       : in String);

end Wiki.Filters.Collectors;

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

--  === Collector Filters ===
--  The <tt>Wiki.Filters.Collectors</tt> package defines two filters that can be used to
--  collect words or links contained in a Wiki document.  The collector filters are inserted
--  in the filter chain and they collect the data as the Wiki text is parsed.  After the
--  parsing, the collector filters have collected either the words or the links and they
--  can be queried by using the <tt>Find</tt> or <tt>Iterate</tt> operations.
package Wiki.Filters.Collectors is

   pragma Preelaborate;

   package WString_Maps is
     new Ada.Containers.Indefinite_Ordered_Maps (Key_Type     => Wiki.Strings.WString,
                                                 Element_Type => Natural,
                                                 "<"          => "<",
                                                 "="          => "=");

   subtype Map is WString_Maps.Map;
   subtype Cursor is WString_Maps.Cursor;

   --  ------------------------------
   --  General purpose collector type
   --  ------------------------------
   type Collector_Type is new Filter_Type with private;
   type Collector_Type_Access is access all Collector_Type'Class;

   function Find (Map  : in Collector_Type;
                  Item : in Wiki.Strings.WString) return Cursor;

   function Contains (Map  : in Collector_Type;
                      Item : in Wiki.Strings.WString) return Boolean;

   procedure Iterate (Map : in Collector_Type;
                      Process : not null access procedure (Pos : in Cursor));

   --  ------------------------------
   --  Word Collector type
   --  ------------------------------
   type Word_Collector_Type is new Collector_Type with private;
   type Word_Collector_Type_Access is access all Word_Collector_Type'Class;

   --  Add a text content with the given format to the document.
   procedure Add_Text (Filter    : in out Word_Collector_Type;
                       Document  : in out Wiki.Documents.Document;
                       Text      : in Wiki.Strings.WString;
                       Format    : in Wiki.Format_Map);

   --  Add a section header with the given level in the document.
   procedure Add_Header (Filter    : in out Word_Collector_Type;
                         Document  : in out Wiki.Documents.Document;
                         Header    : in Wiki.Strings.WString;
                         Level     : in Natural);

   --  Add a link.
   procedure Add_Link (Filter     : in out Word_Collector_Type;
                       Document   : in out Wiki.Documents.Document;
                       Name       : in Wiki.Strings.WString;
                       Attributes : in out Wiki.Attributes.Attribute_List);

   --  Add an image.
   procedure Add_Image (Filter     : in out Word_Collector_Type;
                        Document   : in out Wiki.Documents.Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List);

   --  Add a quote.
   procedure Add_Quote (Filter     : in out Word_Collector_Type;
                        Document   : in out Wiki.Documents.Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List);

   --  Add a text block that is pre-formatted.
   procedure Add_Preformatted (Filter   : in out Word_Collector_Type;
                               Document : in out Wiki.Documents.Document;
                               Text     : in Wiki.Strings.WString;
                               Format   : in Wiki.Strings.WString);

   --  ------------------------------
   --  Link Collector type
   --  ------------------------------
   type Link_Collector_Type is new Collector_Type with private;
   type Link_Collector_Type_Access is access all Link_Collector_Type'Class;

   --  Add a link.
   overriding
   procedure Add_Link (Filter     : in out Link_Collector_Type;
                       Document   : in out Wiki.Documents.Document;
                       Name       : in Wiki.Strings.WString;
                       Attributes : in out Wiki.Attributes.Attribute_List);

   --  Push a HTML node with the given tag to the document.
   overriding
   procedure Push_Node (Filter     : in out Link_Collector_Type;
                        Document   : in out Wiki.Documents.Document;
                        Tag        : in Wiki.Html_Tag;
                        Attributes : in out Wiki.Attributes.Attribute_List);

   --  ------------------------------
   --  Image Collector type
   --  ------------------------------
   type Image_Collector_Type is new Collector_Type with private;
   type Image_Collector_Type_Access is access all Image_Collector_Type'Class;

   --  Add an image.
   overriding
   procedure Add_Image (Filter     : in out Image_Collector_Type;
                        Document   : in out Wiki.Documents.Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List);

private

   type Collector_Type is new Filter_Type with record
      Items : WString_Maps.Map;
   end record;

   type Word_Collector_Type is new Collector_Type with null record;

   procedure Collect_Words (Filter  : in out Word_Collector_Type;
                            Content : in Wiki.Strings.WString);

   type Link_Collector_Type is new Collector_Type with null record;

   procedure Collect_Link (Filter     : in out Link_Collector_Type;
                           Attributes : in Wiki.Attributes.Attribute_List;
                           Name       : in String);

   type Image_Collector_Type is new Collector_Type with null record;

end Wiki.Filters.Collectors;

Declare the Image_Collector_Type to collect images used in a wiki page


--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2021 onox <denkpadje@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 Orka.Logging;
with Orka.Terminals;

with EGL.Objects.Configs;
with EGL.Objects.Surfaces;

with Wayland.Protocols.Client.AWT;

package body Orka.Contexts.EGL.Wayland.AWT is

   use all type Orka.Logging.Source;
   use all type Orka.Logging.Severity;
   use Orka.Logging;

   procedure Log is new Orka.Logging.Generic_Log (Window_System);

   procedure Print_Monitor (Monitor : Standard.AWT.Monitors.Monitor'Class) is
      State : constant Standard.AWT.Monitors.Monitor_State := Monitor.State;

      use Standard.AWT.Monitors;
   begin
      Log (Debug, "Window visible on monitor " & (+State.Name));
      Log (Debug, "  offset:     " &
        Trim (State.X'Image) & ", " & Trim (State.Y'Image));
      Log (Debug, "  size:       " &
        Trim (State.Width'Image) & " × " & Trim (State.Height'Image));
      Log (Debug, "  refresh: " & Orka.Terminals.Image (State.Refresh));
   end Print_Monitor;

   ----------------------------------------------------------------------------

   overriding
   function Width (Object : AWT_Window) return Positive is
      State : Standard.AWT.Windows.Framebuffer_State renames Object.State;
   begin
      return State.Width;
   end Width;

   overriding
   function Height (Object : AWT_Window) return Positive is
      State : Standard.AWT.Windows.Framebuffer_State renames Object.State;
   begin
      return State.Height;
   end Height;

   ----------------------------------------------------------------------------

   function Framebuffer_Resized (Object : in out AWT_Window) return Boolean is
      Result : constant Boolean := Object.Resize;
   begin
      Object.Resize := False;
      return Result;
   end Framebuffer_Resized;

   overriding
   procedure On_Configure
     (Object : in out AWT_Window;
      State  : Standard.AWT.Windows.Window_State) is
   begin
      Log (Debug, "Configured window surface");
      Log (Debug, "  size:   " &
        Trim (State.Width'Image) & " × " & Trim (State.Height'Image));
      Log (Debug, "  margin: " & Trim (State.Margin'Image));

      Object.Resize := State.Visible and State.Width > 0 and State.Height > 0;
   end On_Configure;

   overriding
   procedure On_Move
     (Object   : in out AWT_Window;
      Monitor  : Standard.AWT.Monitors.Monitor'Class;
      Presence : Standard.AWT.Windows.Monitor_Presence)
   is
      use all type Standard.AWT.Windows.Monitor_Presence;
      use Standard.AWT.Monitors;
   begin
      case Presence is
         when Entered =>
            Print_Monitor (Monitor);
         when Left =>
            Log (Debug, "Window not visible on monitor " & (+Monitor.State.Name));
      end case;
   end On_Move;

   ----------------------------------------------------------------------------

   overriding
   procedure Make_Current
     (Object : AWT_Context;
      Window : in out Orka.Windows.Window'Class) is
   begin
      if Window not in AWT_Window'Class then
         raise Constraint_Error;
      end if;

      AWT_Window (Window).Make_Current (Object.Context);
   end Make_Current;

   overriding
   function Create_Context
     (Version : Orka.Contexts.Context_Version;
      Flags   : Orka.Contexts.Context_Flags := (others => False)) return AWT_Context is
   begin
      if not Standard.AWT.Is_Initialized then
         Standard.AWT.Initialize;
      end if;

      return Create_Context
        (Standard.Wayland.Protocols.Client.AWT.Get_Display (Standard.AWT.Wayland.Get_Display.all),
         Version, Flags);
   end Create_Context;

   overriding
   function Create_Window
     (Context            : aliased Orka.Contexts.Surface_Context'Class;
      Width, Height      : Positive;
      Title              : String  := "";
      Samples            : Natural := 0;
      Visible, Resizable : Boolean := True;
      Transparent        : Boolean := False) return AWT_Window
   is
      package EGL_Configs renames Standard.EGL.Objects.Configs;

      use all type Standard.EGL.Objects.Contexts.Buffer_Kind;

      package SU renames Standard.AWT.SU;

      function Flags return String is
         Result : SU.Unbounded_String;
      begin
         if Visible then
            SU.Append (Result, " visible");
         end if;

         if Resizable then
            SU.Append (Result, " resizable");
         end if;

         if Transparent then
            SU.Append (Result, " transparent");
         end if;

         return Trim (SU.To_String (Result));
      end Flags;

      Object : AWT_Context renames AWT_Context (Context);
   begin
      return Result : AWT_Window do
         declare
            Configs : constant EGL_Configs.Config_Array :=
              EGL_Configs.Get_Configs
                (Object.Context.Display,
                 8, 8, 8, (if Transparent then 8 else 0),
                 24, 8, EGL_Configs.Sample_Size (Samples));

            Used_Config : EGL_Configs.Config renames Configs (Configs'First);
         begin
            Log (Debug, "Available EGL configs: " &
              Trim (Natural'Image (Configs'Length)));

            Result.Set_EGL_Data (Object.Context, Used_Config, sRGB => False);

            Result.Create_Window ("", Title, Width, Height,
              Visible     => Visible,
              Resizable   => Resizable,
              Decorated   => True,
              Transparent => Transparent);

            Result.Make_Current (Object.Context);

            pragma Assert (Object.Context.Buffer = Back);

            Log (Debug, "Created AWT window");
            Log (Debug, "  size:        " &
              Trim (Width'Image) & " × " & Trim (Height'Image));
            Log (Debug, "  flags:       " & Flags);

            Log (Debug, "  framebuffer:");
            declare
               State : constant EGL_Configs.Config_State := Used_Config.State;
            begin
               Log (Debug, "    colors:  " &
                Trim (State.Red'Image) & " " &
                Trim (State.Green'Image) & " " &
                Trim (State.Blue'Image) & " " &
                Trim (State.Alpha'Image));
               Log (Debug, "    depth:   " & Trim (State.Depth'Image));
               Log (Debug, "    stencil: " & Trim (State.Stencil'Image));
               Log (Debug, "    samples: " & Trim (State.Samples'Image));
            end;
         end;
      end return;
   end Create_Window;

end Orka.Contexts.EGL.Wayland.AWT;

--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2021 onox <denkpadje@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 Orka.Logging;
with Orka.Terminals;

with EGL.Objects.Configs;

with Wayland.Protocols.Client.AWT;

package body Orka.Contexts.EGL.Wayland.AWT is

   use all type Orka.Logging.Source;
   use all type Orka.Logging.Severity;
   use Orka.Logging;

   procedure Log is new Orka.Logging.Generic_Log (Window_System);

   procedure Print_Monitor (Monitor : Standard.AWT.Monitors.Monitor'Class) is
      State : constant Standard.AWT.Monitors.Monitor_State := Monitor.State;

      use Standard.AWT.Monitors;
   begin
      Log (Debug, "Window visible on monitor " & (+State.Name));
      Log (Debug, "  offset:     " &
        Trim (State.X'Image) & ", " & Trim (State.Y'Image));
      Log (Debug, "  size:       " &
        Trim (State.Width'Image) & " × " & Trim (State.Height'Image));
      Log (Debug, "  refresh: " & Orka.Terminals.Image (State.Refresh));
   end Print_Monitor;

   ----------------------------------------------------------------------------

   overriding
   function Width (Object : AWT_Window) return Positive is
      State : Standard.AWT.Windows.Framebuffer_State renames Object.State;
   begin
      return State.Width;
   end Width;

   overriding
   function Height (Object : AWT_Window) return Positive is
      State : Standard.AWT.Windows.Framebuffer_State renames Object.State;
   begin
      return State.Height;
   end Height;

   ----------------------------------------------------------------------------

   function Framebuffer_Resized (Object : in out AWT_Window) return Boolean is
      Result : constant Boolean := Object.Resize;
   begin
      Object.Resize := False;
      return Result;
   end Framebuffer_Resized;

   overriding
   procedure On_Configure
     (Object : in out AWT_Window;
      State  : Standard.AWT.Windows.Window_State) is
   begin
      Log (Debug, "Configured window surface");
      Log (Debug, "  size:   " &
        Trim (State.Width'Image) & " × " & Trim (State.Height'Image));
      Log (Debug, "  margin: " & Trim (State.Margin'Image));

      Object.Resize := State.Visible and State.Width > 0 and State.Height > 0;
   end On_Configure;

   overriding
   procedure On_Move
     (Object   : in out AWT_Window;
      Monitor  : Standard.AWT.Monitors.Monitor'Class;
      Presence : Standard.AWT.Windows.Monitor_Presence)
   is
      use all type Standard.AWT.Windows.Monitor_Presence;
      use Standard.AWT.Monitors;
   begin
      case Presence is
         when Entered =>
            Print_Monitor (Monitor);
         when Left =>
            Log (Debug, "Window not visible on monitor " & (+Monitor.State.Name));
      end case;
   end On_Move;

   ----------------------------------------------------------------------------

   overriding
   procedure Make_Current
     (Object : AWT_Context;
      Window : in out Orka.Windows.Window'Class) is
   begin
      if Window not in AWT_Window'Class then
         raise Constraint_Error;
      end if;

      AWT_Window (Window).Make_Current (Object.Context);
   end Make_Current;

   overriding
   function Create_Context
     (Version : Orka.Contexts.Context_Version;
      Flags   : Orka.Contexts.Context_Flags := (others => False)) return AWT_Context is
   begin
      if not Standard.AWT.Is_Initialized then
         Standard.AWT.Initialize;
      end if;

      return Create_Context
        (Standard.Wayland.Protocols.Client.AWT.Get_Display (Standard.AWT.Wayland.Get_Display.all),
         Version, Flags);
   end Create_Context;

   overriding
   function Create_Window
     (Context            : aliased Orka.Contexts.Surface_Context'Class;
      Width, Height      : Positive;
      Title              : String  := "";
      Samples            : Natural := 0;
      Visible, Resizable : Boolean := True;
      Transparent        : Boolean := False) return AWT_Window
   is
      package EGL_Configs renames Standard.EGL.Objects.Configs;

      use all type Standard.EGL.Objects.Contexts.Buffer_Kind;

      package SU renames Standard.AWT.SU;

      function Flags return String is
         Result : SU.Unbounded_String;
      begin
         if Visible then
            SU.Append (Result, " visible");
         end if;

         if Resizable then
            SU.Append (Result, " resizable");
         end if;

         if Transparent then
            SU.Append (Result, " transparent");
         end if;

         return Trim (SU.To_String (Result));
      end Flags;

      Object : AWT_Context renames AWT_Context (Context);
   begin
      return Result : AWT_Window do
         declare
            Configs : constant EGL_Configs.Config_Array :=
              EGL_Configs.Get_Configs
                (Object.Context.Display,
                 8, 8, 8, (if Transparent then 8 else 0),
                 24, 8, EGL_Configs.Sample_Size (Samples));

            Used_Config : EGL_Configs.Config renames Configs (Configs'First);
         begin
            Log (Debug, "Available EGL configs: " &
              Trim (Natural'Image (Configs'Length)));

            Result.Set_EGL_Data (Object.Context, Used_Config, sRGB => False);

            Result.Create_Window ("", Title, Width, Height,
              Visible     => Visible,
              Resizable   => Resizable,
              Decorated   => True,
              Transparent => Transparent);

            Result.Make_Current (Object.Context);

            pragma Assert (Object.Context.Buffer = Back);

            Log (Debug, "Created AWT window");
            Log (Debug, "  size:        " &
              Trim (Width'Image) & " × " & Trim (Height'Image));
            Log (Debug, "  flags:       " & Flags);

            Log (Debug, "  framebuffer:");
            declare
               State : constant EGL_Configs.Config_State := Used_Config.State;
            begin
               Log (Debug, "    colors:  " &
                Trim (State.Red'Image) & " " &
                Trim (State.Green'Image) & " " &
                Trim (State.Blue'Image) & " " &
                Trim (State.Alpha'Image));
               Log (Debug, "    depth:   " & Trim (State.Depth'Image));
               Log (Debug, "    stencil: " & Trim (State.Stencil'Image));
               Log (Debug, "    samples: " & Trim (State.Samples'Image));
            end;
         end;
      end return;
   end Create_Window;

end Orka.Contexts.EGL.Wayland.AWT;

Remove with'ing unused package

awt: Remove with'ing unused package

Signed-off-by: onox <34c1d3d2d1347bea60a26f46574de21a7a79b6d5@gmail.com>


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

package Gen.Commands.Generate is

   --  ------------------------------
   --  Generator Command
   --  ------------------------------
   type Command is new Gen.Commands.Command with null record;

   --  Execute the command with the arguments.
   overriding
   procedure Execute (Cmd       : in out Command;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Generator : in out Gen.Generator.Handler);

   --  Write the help associated with the command.
   overriding
   procedure Help (Cmd       : in out Command;
                   Generator : in out Gen.Generator.Handler);

end Gen.Commands.Generate;

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

package Gen.Commands.Generate is

   --  ------------------------------
   --  Generator Command
   --  ------------------------------
   type Command is new Gen.Commands.Command with null record;

   --  Execute the command with the arguments.
   overriding
   procedure Execute (Cmd       : in out Command;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Generator : in out Gen.Generator.Handler);

   --  Write the help associated with the command.
   overriding
   procedure Help (Cmd       : in out Command;
                   Name      : in String;
                   Generator : in out Gen.Generator.Handler);

end Gen.Commands.Generate;

Add Name parameter to the Help procedure


-----------------------------------------------------------------------
--  security-oauth-clients -- OAuth Client Security
--  Copyright (C) 2012, 2013, 2017, 2018 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Exceptions;
with Util.Log.Loggers;
with Util.Strings;
with Util.Http.Clients;
with Util.Properties.JSON;
with Util.Encoders.HMAC.SHA1;
with Security.Random;

package body Security.OAuth.Clients is

   use Ada.Strings.Unbounded;

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

   --  ------------------------------
   --  Access Token
   --  ------------------------------

   Random_Generator : Security.Random.Generator;

   --  ------------------------------
   --  Generate a random nonce with at last the number of random bits.
   --  The number of bits is rounded up to a multiple of 32.
   --  The random bits are then converted to base64url in the returned string.
   --  ------------------------------
   function Create_Nonce (Bits : in Positive := 256) return String is
   begin
      --  Generate the random sequence.
      return Random_Generator.Generate (Bits);
   end Create_Nonce;

   --  ------------------------------
   --  Get the principal name.  This is the OAuth access token.
   --  ------------------------------
   function Get_Name (From : in Access_Token) return String is
   begin
      return From.Access_Id;
   end Get_Name;

   --  ------------------------------
   --  Get the id_token that was returned by the authentication process.
   --  ------------------------------
   function Get_Id_Token (From : in OpenID_Token) return String is
   begin
      return From.Id_Token;
   end Get_Id_Token;

   --  ------------------------------
   --  Get the principal name.  This is the OAuth access token.
   --  ------------------------------
   function Get_Name (From : in Grant_Type) return String is
   begin
      return To_String (From.Access_Token);
   end Get_Name;

   --  ------------------------------
   --  Set the OAuth authorization server URI that the application must use
   --  to exchange the OAuth code into an access token.
   --  ------------------------------
   procedure Set_Provider_URI (App : in out Application;
                               URI : in String) is
   begin
      App.Request_URI := Ada.Strings.Unbounded.To_Unbounded_String (URI);
   end Set_Provider_URI;

   --  ------------------------------
   --  Build a unique opaque value used to prevent cross-site request forgery.
   --  The Nonce parameters is an optional but recommended unique value
   --  used only once.  The state value will be returned back by the OAuth provider.
   --  This protects the <tt>client_id</tt> and <tt>redirect_uri</tt> parameters.
   --  ------------------------------
   function Get_State (App   : in Application;
                       Nonce : in String) return String is
      use Ada.Strings.Unbounded;

      Data : constant String := Nonce & To_String (App.Client_Id) & To_String (App.Callback);
      Hmac : String := Util.Encoders.HMAC.SHA1.Sign_Base64 (Key  => To_String (App.Secret),
                                                            Data => Data,
                                                            URL  => True);
   begin
      --  Avoid the '=' at end of HMAC since it could be replaced by %C20 which is annoying...
      Hmac (Hmac'Last) := '.';
      return Hmac;
   end Get_State;

   --  ------------------------------
   --  Get the authenticate parameters to build the URI to redirect the user to
   --  the OAuth authorization form.
   --  ------------------------------
   function Get_Auth_Params (App : in Application;
                             State : in String;
                             Scope : in String := "") return String is
   begin
      return Security.OAuth.CLIENT_ID
        & "=" & Ada.Strings.Unbounded.To_String (App.Client_Id)
        & "&"
        & Security.OAuth.REDIRECT_URI
        & "=" & Ada.Strings.Unbounded.To_String (App.Callback)
        & "&"
        & Security.OAuth.SCOPE
        & "=" & Scope
        & "&"
        & Security.OAuth.STATE
        & "=" & State;
   end Get_Auth_Params;

   --  ------------------------------
   --  Verify that the State opaque value was created by the Get_State
   --  operation with the given client and redirect URL.
   --  ------------------------------
   function Is_Valid_State (App   : in Application;
                            Nonce : in String;
                            State : in String) return Boolean is
      Hmac : constant String := Application'Class (App).Get_State (Nonce);
   begin
      return Hmac = State;
   end Is_Valid_State;

   --  ------------------------------
   --  Exchange the OAuth code into an access token.
   --  ------------------------------
   function Request_Access_Token (App  : in Application;
                                  Code : in String) return Access_Token_Access is
      Client   : Util.Http.Clients.Client;
      Response : Util.Http.Clients.Response;

      Data : constant String
        := Security.OAuth.GRANT_TYPE & "=authorization_code"
          & "&"
        & Security.OAuth.CODE & "=" & Code
        & "&"
        & Security.OAuth.REDIRECT_URI & "=" & Ada.Strings.Unbounded.To_String (App.Callback)
        & "&"
        & Security.OAuth.CLIENT_ID & "=" & Ada.Strings.Unbounded.To_String (App.Client_Id)
        & "&"
        & Security.OAuth.CLIENT_SECRET & "=" & Ada.Strings.Unbounded.To_String (App.Secret);
      URI : constant String := Ada.Strings.Unbounded.To_String (App.Request_URI);
   begin
      Log.Info ("Getting access token from {0}", URI);
      begin
         Client.Post (URL   => URI,
                      Data  => Data,
                      Reply => Response);
         if Response.Get_Status /= Util.Http.SC_OK then
            Log.Warn ("Cannot get access token from {0}: status is {1} Body {2}",
                      URI, Natural'Image (Response.Get_Status), Response.Get_Body);
            return null;
         end if;

      exception
            --  Handle a Program_Error exception that could be raised by AWS when SSL
            --  is not supported.  Emit a log error so that we can trouble this kins of
            --  problem more easily.
         when E : Program_Error =>
            Log.Error ("Cannot get access token from {0}: program error: {1}",
                       URI, Ada.Exceptions.Exception_Message (E));
            raise;
      end;

      --  Decode the response.
      declare
         Content      : constant String := Response.Get_Body;
         Content_Type : constant String := Response.Get_Header ("Content-Type");
         Pos          : Natural := Util.Strings.Index (Content_Type, ';');
         Last         : Natural;
         Expires      : Natural;
      begin
         if Pos = 0 then
            Pos := Content_Type'Last;
         else
            Pos := Pos - 1;
         end if;
         Log.Debug ("Content type: {0}", Content_Type);
         Log.Debug ("Data: {0}", Content);

         --  Facebook sends the access token as a 'text/plain' content.
         if Content_Type (Content_Type'First .. Pos) = "text/plain" then
            Pos := Util.Strings.Index (Content, '=');
            if Pos = 0 then
               Log.Error ("Invalid access token response: '{0}'", Content);
               return null;
            end if;
            if Content (Content'First .. Pos) /= "access_token=" then
               Log.Error ("The 'access_token' parameter is missing in response: '{0}'", Content);
               return null;
            end if;
            Last := Util.Strings.Index (Content, '&', Pos + 1);
            if Last = 0 then
               Log.Error ("Invalid 'access_token' parameter: '{0}'", Content);
               return null;
            end if;
            if Content (Last .. Last + 8) /= "&expires=" then
               Log.Error ("Invalid 'expires' parameter: '{0}'", Content);
               return null;
            end if;
            Expires := Natural'Value (Content (Last + 9 .. Content'Last));
            return Application'Class (App).Create_Access_Token (Content (Pos + 1 .. Last - 1),
                                                                "", "",
                                                                Expires);

         elsif Content_Type (Content_Type'First .. Pos) = "application/json" then
            declare
               P : Util.Properties.Manager;
            begin
               Util.Properties.JSON.Parse_JSON (P, Content);
               Expires := Natural'Value (P.Get ("expires_in"));
               return Application'Class (App).Create_Access_Token (P.Get ("access_token"),
                                                                   P.Get ("refresh_token", ""),
                                                                   P.Get ("id_token", ""),
                                                                   Expires);
            end;
         else
            Log.Error ("Content type {0} not supported for access token response", Content_Type);
            Log.Error ("Response: {0}", Content);
            return null;
         end if;
      end;
   end Request_Access_Token;
   --  ------------------------------
   --  Exchange the OAuth code into an access token.
   --  ------------------------------
   procedure Do_Request_Token (App  : in Application;
                               URI  : in String;
                               Data : in String;
                               Cred : in out Grant_Type'Class) is
      Client   : Util.Http.Clients.Client;
      Response : Util.Http.Clients.Response;
   begin
      Log.Info ("Getting access token from {0}", URI);
      Client.Post (URL   => URI,
                   Data  => Data,
                   Reply => Response);
      if Response.Get_Status /= Util.Http.SC_OK then
         Log.Warn ("Cannot get access token from {0}: status is {1} Body {2}",
                   URI, Natural'Image (Response.Get_Status), Response.Get_Body);
         return;
      end if;

      --  Decode the response.
      declare
         Content      : constant String := Response.Get_Body;
         Content_Type : constant String := Response.Get_Header ("Content-Type");
         Pos          : Natural := Util.Strings.Index (Content_Type, ';');
         Last         : Natural;
         Expires      : Natural;
      begin
         if Pos = 0 then
            Pos := Content_Type'Last;
         else
            Pos := Pos - 1;
         end if;
         Log.Debug ("Content type: {0}", Content_Type);
         Log.Debug ("Data: {0}", Content);

         --  Facebook sends the access token as a 'text/plain' content.
         if Content_Type (Content_Type'First .. Pos) = "text/plain" then
            Pos := Util.Strings.Index (Content, '=');
            if Pos = 0 then
               Log.Error ("Invalid access token response: '{0}'", Content);
               return;
            end if;
            if Content (Content'First .. Pos) /= "access_token=" then
               Log.Error ("The 'access_token' parameter is missing in response: '{0}'", Content);
               return;
            end if;
            Last := Util.Strings.Index (Content, '&', Pos + 1);
            if Last = 0 then
               Log.Error ("Invalid 'access_token' parameter: '{0}'", Content);
               return;
            end if;
            if Content (Last .. Last + 8) /= "&expires=" then
               Log.Error ("Invalid 'expires' parameter: '{0}'", Content);
               return;
            end if;
            Expires := Natural'Value (Content (Last + 9 .. Content'Last));
            Cred.Access_Token := To_Unbounded_String (Content (Pos + 1 .. Last - 1));

         elsif Content_Type (Content_Type'First .. Pos) = "application/json" then
            declare
               P : Util.Properties.Manager;
            begin
               Util.Properties.JSON.Parse_JSON (P, Content);
               Expires := Natural'Value (P.Get ("expires_in"));
               Cred.Access_Token := P.Get ("access_token");
               Cred.Refresh_Token := To_Unbounded_String (P.Get ("refresh_token", ""));
               Cred.Id_Token := To_Unbounded_String (P.Get ("id_token", ""));
            end;
         else
            Log.Error ("Content type {0} not supported for access token response", Content_Type);
            Log.Error ("Response: {0}", Content);
            return;
         end if;
      end;
   exception
         --  Handle a Program_Error exception that could be raised by AWS when SSL
         --  is not supported.  Emit a log error so that we can trouble this kins of
         --  problem more easily.
      when E : Program_Error =>
         Log.Error ("Cannot get access token from {0}: program error: {1}",
                    URI, Ada.Exceptions.Exception_Message (E));
         raise;
   end Do_Request_Token;

   --  ------------------------------
   --  Get a request token with username and password.
   --  RFC 6749: 4.3.  Resource Owner Password Credentials Grant
   --  ------------------------------
   procedure Request_Token (App      : in Application;
                            Username : in String;
                            Password : in String;
                            Scope    : in String;
                            Token    : in out Grant_Type'Class) is
      Client   : Util.Http.Clients.Client;

      Data : constant String
        := Security.OAuth.GRANT_TYPE & "=password"
          & "&"
        & Security.OAuth.USERNAME & "=" & Username
        & "&"
        & Security.OAuth.PASSWORD & "=" & Password
        & "&"
        & Security.OAuth.CLIENT_ID & "=" & Ada.Strings.Unbounded.To_String (App.Client_Id)
        & "&"
        & Security.OAuth.SCOPE & "=" & Scope
        & "&"
        & Security.OAuth.CLIENT_SECRET & "=" & Ada.Strings.Unbounded.To_String (App.Secret);
      URI : constant String := Ada.Strings.Unbounded.To_String (App.Request_URI);
   begin
      Log.Info ("Getting access token from {0} - resource owner password", URI);
      Do_Request_Token (App, URI, Data, Token);
   end Request_Token;

   --  ------------------------------
   --  Create the access token
   --  ------------------------------
   function Create_Access_Token (App      : in Application;
                                 Token    : in String;
                                 Refresh  : in String;
                                 Id_Token : in String;
                                 Expires  : in Natural) return Access_Token_Access is
      pragma Unreferenced (App, Expires);

   begin
      if Id_Token'Length > 0 then
         declare
            Result : constant OpenID_Token_Access
              := new OpenID_Token '(Len         => Token'Length,
                                    Id_Len      => Id_Token'Length,
                                    Refresh_Len => Refresh'Length,
                                    Access_Id   => Token,
                                    Id_Token    => Id_Token,
                                    Refresh_Token => Refresh);
         begin
            return Result.all'Access;
         end;
      else
         return new Access_Token '(Len => Token'Length,
                                   Access_Id => Token);
      end if;
   end Create_Access_Token;

end Security.OAuth.Clients;

-----------------------------------------------------------------------
--  security-oauth-clients -- OAuth Client Security
--  Copyright (C) 2012, 2013, 2017, 2018 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Exceptions;
with Util.Log.Loggers;
with Util.Strings;
with Util.Http.Clients;
with Util.Properties.JSON;
with Util.Encoders.HMAC.SHA1;
with Security.Random;

package body Security.OAuth.Clients is

   use Ada.Strings.Unbounded;

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

   --  ------------------------------
   --  Access Token
   --  ------------------------------

   Random_Generator : Security.Random.Generator;

   --  ------------------------------
   --  Generate a random nonce with at last the number of random bits.
   --  The number of bits is rounded up to a multiple of 32.
   --  The random bits are then converted to base64url in the returned string.
   --  ------------------------------
   function Create_Nonce (Bits : in Positive := 256) return String is
   begin
      --  Generate the random sequence.
      return Random_Generator.Generate (Bits);
   end Create_Nonce;

   --  ------------------------------
   --  Get the principal name.  This is the OAuth access token.
   --  ------------------------------
   function Get_Name (From : in Access_Token) return String is
   begin
      return From.Access_Id;
   end Get_Name;

   --  ------------------------------
   --  Get the id_token that was returned by the authentication process.
   --  ------------------------------
   function Get_Id_Token (From : in OpenID_Token) return String is
   begin
      return From.Id_Token;
   end Get_Id_Token;

   --  ------------------------------
   --  Get the principal name.  This is the OAuth access token.
   --  ------------------------------
   function Get_Name (From : in Grant_Type) return String is
   begin
      return To_String (From.Access_Token);
   end Get_Name;

   --  ------------------------------
   --  Get the Authorization header to be used for accessing a protected resource.
   --  (See RFC 6749 7.  Accessing Protected Resources)
   --  ------------------------------
   function Get_Authorization (From : in Grant_Type) return String is
   begin
      return "Bearer " & To_String (From.Access_Token);
   end Get_Authorization;

   --  ------------------------------
   --  Set the OAuth authorization server URI that the application must use
   --  to exchange the OAuth code into an access token.
   --  ------------------------------
   procedure Set_Provider_URI (App : in out Application;
                               URI : in String) is
   begin
      App.Request_URI := Ada.Strings.Unbounded.To_Unbounded_String (URI);
   end Set_Provider_URI;

   --  ------------------------------
   --  Build a unique opaque value used to prevent cross-site request forgery.
   --  The Nonce parameters is an optional but recommended unique value
   --  used only once.  The state value will be returned back by the OAuth provider.
   --  This protects the <tt>client_id</tt> and <tt>redirect_uri</tt> parameters.
   --  ------------------------------
   function Get_State (App   : in Application;
                       Nonce : in String) return String is
      use Ada.Strings.Unbounded;

      Data : constant String := Nonce & To_String (App.Client_Id) & To_String (App.Callback);
      Hmac : String := Util.Encoders.HMAC.SHA1.Sign_Base64 (Key  => To_String (App.Secret),
                                                            Data => Data,
                                                            URL  => True);
   begin
      --  Avoid the '=' at end of HMAC since it could be replaced by %C20 which is annoying...
      Hmac (Hmac'Last) := '.';
      return Hmac;
   end Get_State;

   --  ------------------------------
   --  Get the authenticate parameters to build the URI to redirect the user to
   --  the OAuth authorization form.
   --  ------------------------------
   function Get_Auth_Params (App : in Application;
                             State : in String;
                             Scope : in String := "") return String is
   begin
      return Security.OAuth.CLIENT_ID
        & "=" & Ada.Strings.Unbounded.To_String (App.Client_Id)
        & "&"
        & Security.OAuth.REDIRECT_URI
        & "=" & Ada.Strings.Unbounded.To_String (App.Callback)
        & "&"
        & Security.OAuth.SCOPE
        & "=" & Scope
        & "&"
        & Security.OAuth.STATE
        & "=" & State;
   end Get_Auth_Params;

   --  ------------------------------
   --  Verify that the State opaque value was created by the Get_State
   --  operation with the given client and redirect URL.
   --  ------------------------------
   function Is_Valid_State (App   : in Application;
                            Nonce : in String;
                            State : in String) return Boolean is
      Hmac : constant String := Application'Class (App).Get_State (Nonce);
   begin
      return Hmac = State;
   end Is_Valid_State;

   --  ------------------------------
   --  Exchange the OAuth code into an access token.
   --  ------------------------------
   function Request_Access_Token (App  : in Application;
                                  Code : in String) return Access_Token_Access is
      Client   : Util.Http.Clients.Client;
      Response : Util.Http.Clients.Response;

      Data : constant String
        := Security.OAuth.GRANT_TYPE & "=authorization_code"
          & "&"
        & Security.OAuth.CODE & "=" & Code
        & "&"
        & Security.OAuth.REDIRECT_URI & "=" & Ada.Strings.Unbounded.To_String (App.Callback)
        & "&"
        & Security.OAuth.CLIENT_ID & "=" & Ada.Strings.Unbounded.To_String (App.Client_Id)
        & "&"
        & Security.OAuth.CLIENT_SECRET & "=" & Ada.Strings.Unbounded.To_String (App.Secret);
      URI : constant String := Ada.Strings.Unbounded.To_String (App.Request_URI);
   begin
      Log.Info ("Getting access token from {0}", URI);
      begin
         Client.Post (URL   => URI,
                      Data  => Data,
                      Reply => Response);
         if Response.Get_Status /= Util.Http.SC_OK then
            Log.Warn ("Cannot get access token from {0}: status is {1} Body {2}",
                      URI, Natural'Image (Response.Get_Status), Response.Get_Body);
            return null;
         end if;

      exception
            --  Handle a Program_Error exception that could be raised by AWS when SSL
            --  is not supported.  Emit a log error so that we can trouble this kins of
            --  problem more easily.
         when E : Program_Error =>
            Log.Error ("Cannot get access token from {0}: program error: {1}",
                       URI, Ada.Exceptions.Exception_Message (E));
            raise;
      end;

      --  Decode the response.
      declare
         Content      : constant String := Response.Get_Body;
         Content_Type : constant String := Response.Get_Header ("Content-Type");
         Pos          : Natural := Util.Strings.Index (Content_Type, ';');
         Last         : Natural;
         Expires      : Natural;
      begin
         if Pos = 0 then
            Pos := Content_Type'Last;
         else
            Pos := Pos - 1;
         end if;
         Log.Debug ("Content type: {0}", Content_Type);
         Log.Debug ("Data: {0}", Content);

         --  Facebook sends the access token as a 'text/plain' content.
         if Content_Type (Content_Type'First .. Pos) = "text/plain" then
            Pos := Util.Strings.Index (Content, '=');
            if Pos = 0 then
               Log.Error ("Invalid access token response: '{0}'", Content);
               return null;
            end if;
            if Content (Content'First .. Pos) /= "access_token=" then
               Log.Error ("The 'access_token' parameter is missing in response: '{0}'", Content);
               return null;
            end if;
            Last := Util.Strings.Index (Content, '&', Pos + 1);
            if Last = 0 then
               Log.Error ("Invalid 'access_token' parameter: '{0}'", Content);
               return null;
            end if;
            if Content (Last .. Last + 8) /= "&expires=" then
               Log.Error ("Invalid 'expires' parameter: '{0}'", Content);
               return null;
            end if;
            Expires := Natural'Value (Content (Last + 9 .. Content'Last));
            return Application'Class (App).Create_Access_Token (Content (Pos + 1 .. Last - 1),
                                                                "", "",
                                                                Expires);

         elsif Content_Type (Content_Type'First .. Pos) = "application/json" then
            declare
               P : Util.Properties.Manager;
            begin
               Util.Properties.JSON.Parse_JSON (P, Content);
               Expires := Natural'Value (P.Get ("expires_in"));
               return Application'Class (App).Create_Access_Token (P.Get ("access_token"),
                                                                   P.Get ("refresh_token", ""),
                                                                   P.Get ("id_token", ""),
                                                                   Expires);
            end;
         else
            Log.Error ("Content type {0} not supported for access token response", Content_Type);
            Log.Error ("Response: {0}", Content);
            return null;
         end if;
      end;
   end Request_Access_Token;
   --  ------------------------------
   --  Exchange the OAuth code into an access token.
   --  ------------------------------
   procedure Do_Request_Token (App  : in Application;
                               URI  : in String;
                               Data : in String;
                               Cred : in out Grant_Type'Class) is
      Client   : Util.Http.Clients.Client;
      Response : Util.Http.Clients.Response;
   begin
      Log.Info ("Getting access token from {0}", URI);
      Client.Post (URL   => URI,
                   Data  => Data,
                   Reply => Response);
      if Response.Get_Status /= Util.Http.SC_OK then
         Log.Warn ("Cannot get access token from {0}: status is {1} Body {2}",
                   URI, Natural'Image (Response.Get_Status), Response.Get_Body);
         return;
      end if;

      --  Decode the response.
      declare
         Content      : constant String := Response.Get_Body;
         Content_Type : constant String := Response.Get_Header ("Content-Type");
         Pos          : Natural := Util.Strings.Index (Content_Type, ';');
         Last         : Natural;
         Expires      : Natural;
      begin
         if Pos = 0 then
            Pos := Content_Type'Last;
         else
            Pos := Pos - 1;
         end if;
         Log.Debug ("Content type: {0}", Content_Type);
         Log.Debug ("Data: {0}", Content);

         --  Facebook sends the access token as a 'text/plain' content.
         if Content_Type (Content_Type'First .. Pos) = "text/plain" then
            Pos := Util.Strings.Index (Content, '=');
            if Pos = 0 then
               Log.Error ("Invalid access token response: '{0}'", Content);
               return;
            end if;
            if Content (Content'First .. Pos) /= "access_token=" then
               Log.Error ("The 'access_token' parameter is missing in response: '{0}'", Content);
               return;
            end if;
            Last := Util.Strings.Index (Content, '&', Pos + 1);
            if Last = 0 then
               Log.Error ("Invalid 'access_token' parameter: '{0}'", Content);
               return;
            end if;
            if Content (Last .. Last + 8) /= "&expires=" then
               Log.Error ("Invalid 'expires' parameter: '{0}'", Content);
               return;
            end if;
            Expires := Natural'Value (Content (Last + 9 .. Content'Last));
            Cred.Access_Token := To_Unbounded_String (Content (Pos + 1 .. Last - 1));

         elsif Content_Type (Content_Type'First .. Pos) = "application/json" then
            declare
               P : Util.Properties.Manager;
            begin
               Util.Properties.JSON.Parse_JSON (P, Content);
               Expires := Natural'Value (P.Get ("expires_in"));
               Cred.Access_Token := P.Get ("access_token");
               Cred.Refresh_Token := To_Unbounded_String (P.Get ("refresh_token", ""));
               Cred.Id_Token := To_Unbounded_String (P.Get ("id_token", ""));
            end;
         else
            Log.Error ("Content type {0} not supported for access token response", Content_Type);
            Log.Error ("Response: {0}", Content);
            return;
         end if;
      end;
   exception
         --  Handle a Program_Error exception that could be raised by AWS when SSL
         --  is not supported.  Emit a log error so that we can trouble this kins of
         --  problem more easily.
      when E : Program_Error =>
         Log.Error ("Cannot get access token from {0}: program error: {1}",
                    URI, Ada.Exceptions.Exception_Message (E));
         raise;
   end Do_Request_Token;

   --  ------------------------------
   --  Get a request token with username and password.
   --  RFC 6749: 4.3.  Resource Owner Password Credentials Grant
   --  ------------------------------
   procedure Request_Token (App      : in Application;
                            Username : in String;
                            Password : in String;
                            Scope    : in String;
                            Token    : in out Grant_Type'Class) is
      Client   : Util.Http.Clients.Client;

      Data : constant String
        := Security.OAuth.GRANT_TYPE & "=password"
          & "&"
        & Security.OAuth.USERNAME & "=" & Username
        & "&"
        & Security.OAuth.PASSWORD & "=" & Password
        & "&"
        & Security.OAuth.CLIENT_ID & "=" & Ada.Strings.Unbounded.To_String (App.Client_Id)
        & "&"
        & Security.OAuth.SCOPE & "=" & Scope
        & "&"
        & Security.OAuth.CLIENT_SECRET & "=" & Ada.Strings.Unbounded.To_String (App.Secret);
      URI : constant String := Ada.Strings.Unbounded.To_String (App.Request_URI);
   begin
      Log.Info ("Getting access token from {0} - resource owner password", URI);
      Do_Request_Token (App, URI, Data, Token);
   end Request_Token;

   --  ------------------------------
   --  Create the access token
   --  ------------------------------
   function Create_Access_Token (App      : in Application;
                                 Token    : in String;
                                 Refresh  : in String;
                                 Id_Token : in String;
                                 Expires  : in Natural) return Access_Token_Access is
      pragma Unreferenced (App, Expires);

   begin
      if Id_Token'Length > 0 then
         declare
            Result : constant OpenID_Token_Access
              := new OpenID_Token '(Len         => Token'Length,
                                    Id_Len      => Id_Token'Length,
                                    Refresh_Len => Refresh'Length,
                                    Access_Id   => Token,
                                    Id_Token    => Id_Token,
                                    Refresh_Token => Refresh);
         begin
            return Result.all'Access;
         end;
      else
         return new Access_Token '(Len => Token'Length,
                                   Access_Id => Token);
      end if;
   end Create_Access_Token;

end Security.OAuth.Clients;

Implement the Get_Authorization function