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

--  == HTML Renderer ==
--  The <tt>Text_Renderer</tt> allows to render a wiki document into a text content.
--  The formatting rules are ignored except for the paragraphs and sections.
package Wiki.Render.Html is

   --  ------------------------------
   --  Wiki to HTML renderer
   --  ------------------------------
   type Html_Renderer is new Renderer with private;

   --  Set the output stream.
   procedure Set_Output_Stream (Engine : in out Html_Renderer;
                                Stream : in Wiki.Streams.Html.Html_Output_Stream_Access);

   --  Set the link renderer.
   procedure Set_Link_Renderer (Document : in out Html_Renderer;
                                Links    : in Link_Renderer_Access);

   --  Render the node instance from the document.
   overriding
   procedure Render (Engine : in out Html_Renderer;
                     Doc    : in Wiki.Nodes.Document;
                     Node   : in Wiki.Nodes.Node_Type);

   --  Add a section header in the document.
   procedure Add_Header (Engine : in out Html_Renderer;
                         Header : in Wiki.Strings.WString;
                         Level  : in Positive);

   --  Add a blockquote (<blockquote>).  The level indicates the blockquote nested level.
   --  The blockquote must be closed at the next header.
   procedure Add_Blockquote (Document : in out Html_Renderer;
                             Level    : in Natural);

   --  Add a list item (<li>).  Close the previous paragraph and list item if any.
   --  The list item will be closed at the next list item, next paragraph or next header.
   procedure Add_List_Item (Document : in out Html_Renderer;
                            Level    : in Positive;
                            Ordered  : in Boolean);

   --  Add a link.
   procedure Add_Link (Document : in out Html_Renderer;
                       Name     : in Unbounded_Wide_Wide_String;
                       Link     : in Unbounded_Wide_Wide_String;
                       Language : in Unbounded_Wide_Wide_String;
                       Title    : in Unbounded_Wide_Wide_String);

   --  Add an image.
   procedure Add_Image (Document    : in out Html_Renderer;
                        Link        : in Unbounded_Wide_Wide_String;
                        Alt         : in Unbounded_Wide_Wide_String;
                        Position    : in Unbounded_Wide_Wide_String;
                        Description : in Unbounded_Wide_Wide_String);

   --  Add a quote.
   procedure Add_Quote (Document : in out Html_Renderer;
                        Quote    : in Unbounded_Wide_Wide_String;
                        Link     : in Unbounded_Wide_Wide_String;
                        Language : in Unbounded_Wide_Wide_String);

   --  Add a text block with the given format.
   procedure Add_Text (Engine   : in out Html_Renderer;
                       Text     : in Wiki.Strings.WString;
                       Format   : in Wiki.Documents.Format_Map);

   --  Add a text block that is pre-formatted.
   procedure Add_Preformatted (Document : in out Html_Renderer;
                               Text     : in Unbounded_Wide_Wide_String;
                               Format   : in Unbounded_Wide_Wide_String);

   --  Finish the document after complete wiki text has been parsed.
   overriding
   procedure Finish (Document : in out Html_Renderer);

private

   procedure Close_Paragraph (Document : in out Html_Renderer);
   procedure Open_Paragraph (Document : in out Html_Renderer);

   type List_Style_Array is array (1 .. 32) of Boolean;

   Default_Links : aliased Default_Link_Renderer;

   type Html_Renderer is new Renderer with record
      Output         : Wiki.Streams.Html.Html_Output_Stream_Access := null;
      Format         : Wiki.Documents.Format_Map := (others => False);
      Links          : Link_Renderer_Access := Default_Links'Access;
      Has_Paragraph  : Boolean := False;
      Need_Paragraph : Boolean := False;
      Has_Item       : Boolean := False;
      Current_Level  : Natural := 0;
      List_Styles    : List_Style_Array := (others => False);
      Quote_Level    : Natural := 0;
      Html_Level     : Natural := 0;
   end record;

   procedure Render_Tag (Engine : in out Html_Renderer;
                         Doc    : in Wiki.Nodes.Document;
                         Node   : in Wiki.Nodes.Node_Type);

end Wiki.Render.Html;

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

--  == HTML Renderer ==
--  The <tt>Text_Renderer</tt> allows to render a wiki document into a text content.
--  The formatting rules are ignored except for the paragraphs and sections.
package Wiki.Render.Html is

   --  ------------------------------
   --  Wiki to HTML renderer
   --  ------------------------------
   type Html_Renderer is new Renderer with private;

   --  Set the output stream.
   procedure Set_Output_Stream (Engine : in out Html_Renderer;
                                Stream : in Wiki.Streams.Html.Html_Output_Stream_Access);

   --  Set the link renderer.
   procedure Set_Link_Renderer (Document : in out Html_Renderer;
                                Links    : in Link_Renderer_Access);

   --  Render the node instance from the document.
   overriding
   procedure Render (Engine : in out Html_Renderer;
                     Doc    : in Wiki.Nodes.Document;
                     Node   : in Wiki.Nodes.Node_Type);

   --  Add a section header in the document.
   procedure Add_Header (Engine : in out Html_Renderer;
                         Header : in Wiki.Strings.WString;
                         Level  : in Positive);

   --  Add a blockquote (<blockquote>).  The level indicates the blockquote nested level.
   --  The blockquote must be closed at the next header.
   procedure Add_Blockquote (Document : in out Html_Renderer;
                             Level    : in Natural);

   --  Add a list item (<li>).  Close the previous paragraph and list item if any.
   --  The list item will be closed at the next list item, next paragraph or next header.
   procedure Add_List_Item (Document : in out Html_Renderer;
                            Level    : in Positive;
                            Ordered  : in Boolean);

   --  Add an image.
   procedure Add_Image (Document    : in out Html_Renderer;
                        Link        : in Unbounded_Wide_Wide_String;
                        Alt         : in Unbounded_Wide_Wide_String;
                        Position    : in Unbounded_Wide_Wide_String;
                        Description : in Unbounded_Wide_Wide_String);

   --  Add a quote.
   procedure Add_Quote (Document : in out Html_Renderer;
                        Quote    : in Unbounded_Wide_Wide_String;
                        Link     : in Unbounded_Wide_Wide_String;
                        Language : in Unbounded_Wide_Wide_String);

   --  Add a text block with the given format.
   procedure Add_Text (Engine   : in out Html_Renderer;
                       Text     : in Wiki.Strings.WString;
                       Format   : in Wiki.Documents.Format_Map);

   --  Add a text block that is pre-formatted.
   procedure Add_Preformatted (Document : in out Html_Renderer;
                               Text     : in Unbounded_Wide_Wide_String;
                               Format   : in Unbounded_Wide_Wide_String);

   --  Finish the document after complete wiki text has been parsed.
   overriding
   procedure Finish (Document : in out Html_Renderer);

private

   procedure Close_Paragraph (Document : in out Html_Renderer);
   procedure Open_Paragraph (Document : in out Html_Renderer);

   type List_Style_Array is array (1 .. 32) of Boolean;

   Default_Links : aliased Default_Link_Renderer;

   type Html_Renderer is new Renderer with record
      Output         : Wiki.Streams.Html.Html_Output_Stream_Access := null;
      Format         : Wiki.Documents.Format_Map := (others => False);
      Links          : Link_Renderer_Access := Default_Links'Access;
      Has_Paragraph  : Boolean := False;
      Need_Paragraph : Boolean := False;
      Has_Item       : Boolean := False;
      Current_Level  : Natural := 0;
      List_Styles    : List_Style_Array := (others => False);
      Quote_Level    : Natural := 0;
      Html_Level     : Natural := 0;
   end record;

   procedure Render_Tag (Engine : in out Html_Renderer;
                         Doc    : in Wiki.Nodes.Document;
                         Node   : in Wiki.Nodes.Node_Type);

   --  Render a link.
   procedure Render_Link (Engine : in out Html_Renderer;
                          Doc    : in Wiki.Nodes.Document;
                          Title  : in Wiki.Strings.WString;
                          Attr   : in Wiki.Attributes.Attribute_List_Type);

end Wiki.Render.Html;

Declare Render_Link procedure

Declare Render_Link procedure


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

with ASF.Contexts.Faces;
with Ada.Strings.Unbounded;
package body ASF.Locales is

   use Util.Properties.Bundles;

   type Locale_Binding (Len : Natural) is new ASF.Beans.Class_Binding with record
      Loader  : Loader_Access;
      Scope   : ASF.Beans.Scope_Type;
      Name    : String (1 .. Len);
   end record;
   type Locale_Binding_Access is access all Locale_Binding;

   procedure Create (Factory : in Locale_Binding;
                     Name    : in Ada.Strings.Unbounded.Unbounded_String;
                     Result  : out Util.Beans.Basic.Readonly_Bean_Access);

   --  ------------------------------
   --  Initialize the locale support by using the configuration properties.
   --  Properties matching the pattern: bundle.var-name=bundle-name
   --  are used to register bindings linking a facelet variable var-name
   --  to the resource bundle bundle-name.
   --  ------------------------------
   procedure Initialize (Fac    : in out Factory;
                         Beans  : in out ASF.Beans.Bean_Factory;
                         Config : in Util.Properties.Manager'Class) is
      Names : constant Util.Properties.Name_Array := Config.Get_Names ("bundle.var.");
      Dir   : constant String := Config.Get ("bundle.dir", "bundles");
   begin
      Util.Properties.Bundles.Initialize (Fac.Factory, Dir);
      for I in Names'Range loop
         declare
            Name   : Util.Properties.Value renames Names (I);
            Value  : constant String := Config.Get (Name);
            Bundle : constant String := Ada.Strings.Unbounded.To_String (Name);
         begin
            Register (Fac, Beans, Bundle (Bundle'First + 11 .. Bundle'Last), Value);
         end;
      end loop;
   end Initialize;

   --  ------------------------------
   --  Compute the locale that must be used according to the Accept-Language request
   --  header and the application supported locales.
   --  ------------------------------
   function Calculate_Locale (Fac : in Factory;
                              Req : in ASF.Requests.Request'Class)
                              return Util.Locales.Locale is
      use Util.Locales;
      use type ASF.Requests.Quality_Type;

      procedure Process_Locales (Locale  : in Util.Locales.Locale;
                                 Quality : in ASF.Requests.Quality_Type);

      Found_Locale  : Util.Locales.Locale := Fac.Default_Locale;
      Found_Quality : ASF.Requests.Quality_Type := 0.0;

      procedure Process_Locales (Locale  : in Util.Locales.Locale;
                                 Quality : in ASF.Requests.Quality_Type) is
      begin
         if Found_Quality >= Quality then
            return;
         end if;
         for I in 1 .. Fac.Nb_Locales loop
            --  We need a match on the language.  The variant/country can be ignored and will
            --  be honored by the resource bundle.
            if Fac.Locales (I) = Locale
              or Get_Language (Fac.Locales (I)) = Get_Language (Locale) then
               Found_Locale := Locale;
               Found_Quality := Quality;
               return;
            end if;
         end loop;
      end Process_Locales;

   begin
      if Fac.Nb_Locales > 0 then
         Req.Accept_Locales (Process_Locales'Access);
      end if;
      return Found_Locale;
   end Calculate_Locale;

   procedure Register (Fac    : in out Factory;
                       Beans  : in out ASF.Beans.Bean_Factory;
                       Name   : in String;
                       Bundle : in String) is
      L : constant Locale_Binding_Access := new Locale_Binding (Len => Bundle'Length);
      P : ASF.Beans.Parameter_Bean_Ref.Ref;
   begin
      L.Loader := Fac.Factory'Unchecked_Access;
      L.Scope  := ASF.Beans.REQUEST_SCOPE;
      L.Name   := Bundle;
      ASF.Beans.Register (Beans, Name, L.all'Access, P);
   end Register;

   --  Load the resource bundle identified by the Name and for the given
   --  Locale.
   procedure Load_Bundle (Fac    : in out Factory;
                          Name   : in String;
                          Locale : in String;
                          Result : out Bundle) is
   begin
      Load_Bundle (Factory => Fac.Factory,
                   Locale  => Locale,
                   Name    => Name,
                   Bundle  => Result);
   end Load_Bundle;

   --  ------------------------------
   --  Get the list of supported locales for this application.
   --  ------------------------------
   function Get_Supported_Locales (From : in Factory)
                                   return Util.Locales.Locale_Array is
   begin
      return From.Locales (1 .. From.Nb_Locales);
   end Get_Supported_Locales;

   --  ------------------------------
   --  Add the locale to the list of supported locales.
   --  ------------------------------
   procedure Add_Supported_Locale (Into   : in out Factory;
                                   Locale : in Util.Locales.Locale) is
   begin
      Into.Nb_Locales := Into.Nb_Locales + 1;
      Into.Locales (Into.Nb_Locales) := Locale;
   end Add_Supported_Locale;

   --  ------------------------------
   --  Get the default locale defined by the application.
   --  ------------------------------
   function Get_Default_Locale (From : in Factory) return Util.Locales.Locale is
   begin
      return From.Default_Locale;
   end Get_Default_Locale;

   --  ------------------------------
   --  Set the default locale defined by the application.
   --  ------------------------------
   procedure Set_Default_Locale (Into   : in out Factory;
                                 Locale : in Util.Locales.Locale) is
   begin
      Into.Default_Locale := Locale;
   end Set_Default_Locale;

   procedure Create (Factory : in Locale_Binding;
                     Name    : in Ada.Strings.Unbounded.Unbounded_String;
                     Result  : out Util.Beans.Basic.Readonly_Bean_Access) is
      pragma Unreferenced (Name);
      use type ASF.Contexts.Faces.Faces_Context_Access;

      Context : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      B       : constant Bundle_Access := new Bundle;
   begin
      if Context = null then
         Load_Bundle (Factory => Factory.Loader.all,
                      Locale  => "en",
                      Name    => Factory.Name,
                      Bundle  => B.all);
      else
         Load_Bundle (Factory => Factory.Loader.all,
                      Locale  => Util.Locales.To_String (Context.Get_Locale),
                      Name    => Factory.Name,
                      Bundle  => B.all);
      end if;
      Result := B.all'Access;
   end Create;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   function Get_Value (From : Bundle;
                       Name : String) return Util.Beans.Objects.Object is
      Value : constant String := From.Get (Name, Name);
   begin
      return Util.Beans.Objects.To_Object (Value);
   end Get_Value;

end ASF.Locales;

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

with ASF.Contexts.Faces;
with Ada.Strings.Unbounded;
package body ASF.Locales is

   use Util.Properties.Bundles;

   type Locale_Binding (Len : Natural) is new ASF.Beans.Class_Binding with record
      Loader  : Loader_Access;
      Scope   : ASF.Beans.Scope_Type;
      Name    : String (1 .. Len);
   end record;
   type Locale_Binding_Access is access all Locale_Binding;

   procedure Create (Factory : in Locale_Binding;
                     Name    : in Ada.Strings.Unbounded.Unbounded_String;
                     Result  : out Util.Beans.Basic.Readonly_Bean_Access);

   --  ------------------------------
   --  Initialize the locale support by using the configuration properties.
   --  Properties matching the pattern: bundle.var-name=bundle-name
   --  are used to register bindings linking a facelet variable var-name
   --  to the resource bundle bundle-name.
   --  ------------------------------
   procedure Initialize (Fac    : in out Factory;
                         Beans  : in out ASF.Beans.Bean_Factory;
                         Config : in Util.Properties.Manager'Class) is
      Names : constant Util.Properties.Name_Array := Config.Get_Names ("bundle.var.");
      Dir   : constant String := Config.Get ("bundle.dir", "bundles");
   begin
      Util.Properties.Bundles.Initialize (Fac.Factory, Dir);
      for I in Names'Range loop
         declare
            Name   : Util.Properties.Value renames Names (I);
            Value  : constant String := Config.Get (Name);
            Bundle : constant String := Ada.Strings.Unbounded.To_String (Name);
         begin
            Register (Fac, Beans, Bundle (Bundle'First + 11 .. Bundle'Last), Value);
         end;
      end loop;
   end Initialize;

   --  ------------------------------
   --  Compute the locale that must be used according to the Accept-Language request
   --  header and the application supported locales.
   --  ------------------------------
   function Calculate_Locale (Fac : in Factory;
                              Req : in ASF.Requests.Request'Class)
                              return Util.Locales.Locale is
      use Util.Locales;
      use type ASF.Requests.Quality_Type;

      procedure Process_Locales (Locale  : in Util.Locales.Locale;
                                 Quality : in ASF.Requests.Quality_Type);

      Found_Locale  : Util.Locales.Locale := Fac.Default_Locale;
      Found_Quality : ASF.Requests.Quality_Type := 0.0;

      procedure Process_Locales (Locale  : in Util.Locales.Locale;
                                 Quality : in ASF.Requests.Quality_Type) is
      begin
         if Found_Quality >= Quality then
            return;
         end if;
         for I in 1 .. Fac.Nb_Locales loop
            --  We need a match on the language.  The variant/country can be ignored and will
            --  be honored by the resource bundle.
            if Fac.Locales (I) = Locale
              or Get_Language (Fac.Locales (I)) = Get_Language (Locale)
            then
               Found_Locale := Locale;
               Found_Quality := Quality;
               return;
            end if;
         end loop;
      end Process_Locales;

   begin
      if Fac.Nb_Locales > 0 then
         Req.Accept_Locales (Process_Locales'Access);
      end if;
      return Found_Locale;
   end Calculate_Locale;

   procedure Register (Fac    : in out Factory;
                       Beans  : in out ASF.Beans.Bean_Factory;
                       Name   : in String;
                       Bundle : in String) is
      L : constant Locale_Binding_Access := new Locale_Binding (Len => Bundle'Length);
      P : ASF.Beans.Parameter_Bean_Ref.Ref;
   begin
      L.Loader := Fac.Factory'Unchecked_Access;
      L.Scope  := ASF.Beans.REQUEST_SCOPE;
      L.Name   := Bundle;
      ASF.Beans.Register (Beans, Name, L.all'Access, P);
   end Register;

   --  Load the resource bundle identified by the Name and for the given
   --  Locale.
   procedure Load_Bundle (Fac    : in out Factory;
                          Name   : in String;
                          Locale : in String;
                          Result : out Bundle) is
   begin
      Load_Bundle (Factory => Fac.Factory,
                   Locale  => Locale,
                   Name    => Name,
                   Bundle  => Result);
   end Load_Bundle;

   --  ------------------------------
   --  Get the list of supported locales for this application.
   --  ------------------------------
   function Get_Supported_Locales (From : in Factory)
                                   return Util.Locales.Locale_Array is
   begin
      return From.Locales (1 .. From.Nb_Locales);
   end Get_Supported_Locales;

   --  ------------------------------
   --  Add the locale to the list of supported locales.
   --  ------------------------------
   procedure Add_Supported_Locale (Into   : in out Factory;
                                   Locale : in Util.Locales.Locale) is
   begin
      Into.Nb_Locales := Into.Nb_Locales + 1;
      Into.Locales (Into.Nb_Locales) := Locale;
   end Add_Supported_Locale;

   --  ------------------------------
   --  Get the default locale defined by the application.
   --  ------------------------------
   function Get_Default_Locale (From : in Factory) return Util.Locales.Locale is
   begin
      return From.Default_Locale;
   end Get_Default_Locale;

   --  ------------------------------
   --  Set the default locale defined by the application.
   --  ------------------------------
   procedure Set_Default_Locale (Into   : in out Factory;
                                 Locale : in Util.Locales.Locale) is
   begin
      Into.Default_Locale := Locale;
   end Set_Default_Locale;

   procedure Create (Factory : in Locale_Binding;
                     Name    : in Ada.Strings.Unbounded.Unbounded_String;
                     Result  : out Util.Beans.Basic.Readonly_Bean_Access) is
      pragma Unreferenced (Name);
      use type ASF.Contexts.Faces.Faces_Context_Access;

      Context : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      B       : constant Bundle_Access := new Bundle;
   begin
      if Context = null then
         Load_Bundle (Factory => Factory.Loader.all,
                      Locale  => "en",
                      Name    => Factory.Name,
                      Bundle  => B.all);
      else
         Load_Bundle (Factory => Factory.Loader.all,
                      Locale  => Util.Locales.To_String (Context.Get_Locale),
                      Name    => Factory.Name,
                      Bundle  => B.all);
      end if;
      Result := B.all'Access;
   end Create;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   function Get_Value (From : Bundle;
                       Name : String) return Util.Beans.Objects.Object is
      Value : constant String := From.Get (Name, Name);
   begin
      return Util.Beans.Objects.To_Object (Value);
   end Get_Value;

end ASF.Locales;

Fix indentation style warning

Fix indentation style warning


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

with ASF.Contexts.Faces;
with Ada.Strings.Unbounded;
package body ASF.Locales is

   use Util.Properties.Bundles;

   type Locale_Binding (Len : Natural) is new ASF.Beans.Class_Binding with record
      Loader  : Loader_Access;
      Scope   : ASF.Beans.Scope_Type;
      Name    : String (1 .. Len);
   end record;
   type Locale_Binding_Access is access all Locale_Binding;

   procedure Create (Factory : in Locale_Binding;
                     Name    : in Ada.Strings.Unbounded.Unbounded_String;
                     Result  : out Util.Beans.Basic.Readonly_Bean_Access);

   --  ------------------------------
   --  Initialize the locale support by using the configuration properties.
   --  Properties matching the pattern: bundle.var-name=bundle-name
   --  are used to register bindings linking a facelet variable var-name
   --  to the resource bundle bundle-name.
   --  ------------------------------
   procedure Initialize (Fac    : in out Factory;
                         Beans  : in out ASF.Beans.Bean_Factory;
                         Config : in Util.Properties.Manager'Class) is
      Names : constant Util.Properties.Name_Array := Config.Get_Names ("bundle.var.");
      Dir   : constant String := Config.Get ("bundle.dir", "bundles");
   begin
      Util.Properties.Bundles.Initialize (Fac.Factory, Dir);
      for I in Names'Range loop
         declare
            Name   : Util.Properties.Value renames Names (I);
            Value  : constant String := Config.Get (Name);
            Bundle : constant String := Ada.Strings.Unbounded.To_String (Name);
         begin
            Register (Fac, Beans, Bundle (Bundle'First + 11 .. Bundle'Last), Value);
         end;
      end loop;
   end Initialize;

   --  ------------------------------
   --  Compute the locale that must be used according to the Accept-Language request
   --  header and the application supported locales.
   --  ------------------------------
   function Calculate_Locale (Fac : in Factory;
                              Req : in ASF.Requests.Request'Class)
                              return Util.Locales.Locale is
      use Util.Locales;
      use type ASF.Requests.Quality_Type;

      procedure Process_Locales (Locale  : in Util.Locales.Locale;
                                 Quality : in ASF.Requests.Quality_Type);

      Found_Locale  : Util.Locales.Locale := Fac.Default_Locale;
      Found_Quality : ASF.Requests.Quality_Type := 0.0;

      procedure Process_Locales (Locale  : in Util.Locales.Locale;
                                 Quality : in ASF.Requests.Quality_Type) is
      begin
         if Found_Quality >= Quality then
            return;
         end if;
         for I in 1 .. Fac.Nb_Locales loop
            --  We need a match on the language.  The variant/country can be ignored and will
            --  be honored by the resource bundle.
            if Fac.Locales (I) = Locale
              or Get_Language (Fac.Locales (I)) = Get_Language (Locale)
            then
               Found_Locale := Locale;
               Found_Quality := Quality;
               return;
            end if;
         end loop;
      end Process_Locales;

   begin
      if Fac.Nb_Locales > 0 then
         Req.Accept_Locales (Process_Locales'Access);
      end if;
      return Found_Locale;
   end Calculate_Locale;

   procedure Register (Fac    : in out Factory;
                       Beans  : in out ASF.Beans.Bean_Factory;
                       Name   : in String;
                       Bundle : in String) is
      L : constant Locale_Binding_Access := new Locale_Binding (Len => Bundle'Length);
      P : ASF.Beans.Parameter_Bean_Ref.Ref;
   begin
      L.Loader := Fac.Factory'Unchecked_Access;
      L.Scope  := ASF.Beans.REQUEST_SCOPE;
      L.Name   := Bundle;
      ASF.Beans.Register (Beans, Name, L.all'Access, P);
   end Register;

   --  Load the resource bundle identified by the Name and for the given
   --  Locale.
   procedure Load_Bundle (Fac    : in out Factory;
                          Name   : in String;
                          Locale : in String;
                          Result : out Bundle) is
   begin
      Load_Bundle (Factory => Fac.Factory,
                   Locale  => Locale,
                   Name    => Name,
                   Bundle  => Result);
   end Load_Bundle;

   --  ------------------------------
   --  Get the list of supported locales for this application.
   --  ------------------------------
   function Get_Supported_Locales (From : in Factory)
                                   return Util.Locales.Locale_Array is
   begin
      return From.Locales (1 .. From.Nb_Locales);
   end Get_Supported_Locales;

   --  ------------------------------
   --  Add the locale to the list of supported locales.
   --  ------------------------------
   procedure Add_Supported_Locale (Into   : in out Factory;
                                   Locale : in Util.Locales.Locale) is
   begin
      Into.Nb_Locales := Into.Nb_Locales + 1;
      Into.Locales (Into.Nb_Locales) := Locale;
   end Add_Supported_Locale;

   --  ------------------------------
   --  Get the default locale defined by the application.
   --  ------------------------------
   function Get_Default_Locale (From : in Factory) return Util.Locales.Locale is
   begin
      return From.Default_Locale;
   end Get_Default_Locale;

   --  ------------------------------
   --  Set the default locale defined by the application.
   --  ------------------------------
   procedure Set_Default_Locale (Into   : in out Factory;
                                 Locale : in Util.Locales.Locale) is
   begin
      Into.Default_Locale := Locale;
   end Set_Default_Locale;

   procedure Create (Factory : in Locale_Binding;
                     Name    : in Ada.Strings.Unbounded.Unbounded_String;
                     Result  : out Util.Beans.Basic.Readonly_Bean_Access) is
      pragma Unreferenced (Name);
      use type ASF.Contexts.Faces.Faces_Context_Access;

      Context : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      B       : constant Bundle_Access := new Bundle;
   begin
      if Context = null then
         Load_Bundle (Factory => Factory.Loader.all,
                      Locale  => "en",
                      Name    => Factory.Name,
                      Bundle  => B.all);
      else
         Load_Bundle (Factory => Factory.Loader.all,
                      Locale  => Util.Locales.To_String (Context.Get_Locale),
                      Name    => Factory.Name,
                      Bundle  => B.all);
      end if;
      Result := B.all'Access;
   end Create;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   function Get_Value (From : Bundle;
                       Name : String) return Util.Beans.Objects.Object is
      Value : constant String := From.Get (Name, Name);
   begin
      return Util.Beans.Objects.To_Object (Value);
   end Get_Value;

end ASF.Locales;

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

with Util.Strings.Vectors;
with ASF.Contexts.Faces;
with Ada.Strings.Unbounded;
package body ASF.Locales is

   use Util.Properties.Bundles;

   type Locale_Binding (Len : Natural) is new ASF.Beans.Class_Binding with record
      Loader  : Loader_Access;
      Scope   : ASF.Beans.Scope_Type;
      Name    : String (1 .. Len);
   end record;
   type Locale_Binding_Access is access all Locale_Binding;

   procedure Create (Factory : in Locale_Binding;
                     Name    : in Ada.Strings.Unbounded.Unbounded_String;
                     Result  : out Util.Beans.Basic.Readonly_Bean_Access);

   --  ------------------------------
   --  Initialize the locale support by using the configuration properties.
   --  Properties matching the pattern: bundle.var-name=bundle-name
   --  are used to register bindings linking a facelet variable var-name
   --  to the resource bundle bundle-name.
   --  ------------------------------
   procedure Initialize (Fac    : in out Factory;
                         Beans  : in out ASF.Beans.Bean_Factory;
                         Config : in Util.Properties.Manager'Class) is
      Names : Util.Strings.Vectors.Vector;
      Dir   : constant String := Config.Get ("bundle.dir", "bundles");
   begin
      Config.Get_Names (Names, "bundle.var.");
      Util.Properties.Bundles.Initialize (Fac.Factory, Dir);
      for Name of Names loop --  I in Names'Range loop
         declare
            Value  : constant String := Config.Get (Name);
         begin
            Register (Fac, Beans, Name (Name'First + 11 .. Name'Last), Value);
         end;
      end loop;
   end Initialize;

   --  ------------------------------
   --  Compute the locale that must be used according to the Accept-Language request
   --  header and the application supported locales.
   --  ------------------------------
   function Calculate_Locale (Fac : in Factory;
                              Req : in ASF.Requests.Request'Class)
                              return Util.Locales.Locale is
      use Util.Locales;
      use type ASF.Requests.Quality_Type;

      procedure Process_Locales (Locale  : in Util.Locales.Locale;
                                 Quality : in ASF.Requests.Quality_Type);

      Found_Locale  : Util.Locales.Locale := Fac.Default_Locale;
      Found_Quality : ASF.Requests.Quality_Type := 0.0;

      procedure Process_Locales (Locale  : in Util.Locales.Locale;
                                 Quality : in ASF.Requests.Quality_Type) is
      begin
         if Found_Quality >= Quality then
            return;
         end if;
         for I in 1 .. Fac.Nb_Locales loop
            --  We need a match on the language.  The variant/country can be ignored and will
            --  be honored by the resource bundle.
            if Fac.Locales (I) = Locale
              or Get_Language (Fac.Locales (I)) = Get_Language (Locale)
            then
               Found_Locale := Locale;
               Found_Quality := Quality;
               return;
            end if;
         end loop;
      end Process_Locales;

   begin
      if Fac.Nb_Locales > 0 then
         Req.Accept_Locales (Process_Locales'Access);
      end if;
      return Found_Locale;
   end Calculate_Locale;

   procedure Register (Fac    : in out Factory;
                       Beans  : in out ASF.Beans.Bean_Factory;
                       Name   : in String;
                       Bundle : in String) is
      L : constant Locale_Binding_Access := new Locale_Binding (Len => Bundle'Length);
      P : ASF.Beans.Parameter_Bean_Ref.Ref;
   begin
      L.Loader := Fac.Factory'Unchecked_Access;
      L.Scope  := ASF.Beans.REQUEST_SCOPE;
      L.Name   := Bundle;
      ASF.Beans.Register (Beans, Name, L.all'Access, P);
   end Register;

   --  Load the resource bundle identified by the Name and for the given
   --  Locale.
   procedure Load_Bundle (Fac    : in out Factory;
                          Name   : in String;
                          Locale : in String;
                          Result : out Bundle) is
   begin
      Load_Bundle (Factory => Fac.Factory,
                   Locale  => Locale,
                   Name    => Name,
                   Bundle  => Result);
   end Load_Bundle;

   --  ------------------------------
   --  Get the list of supported locales for this application.
   --  ------------------------------
   function Get_Supported_Locales (From : in Factory)
                                   return Util.Locales.Locale_Array is
   begin
      return From.Locales (1 .. From.Nb_Locales);
   end Get_Supported_Locales;

   --  ------------------------------
   --  Add the locale to the list of supported locales.
   --  ------------------------------
   procedure Add_Supported_Locale (Into   : in out Factory;
                                   Locale : in Util.Locales.Locale) is
   begin
      Into.Nb_Locales := Into.Nb_Locales + 1;
      Into.Locales (Into.Nb_Locales) := Locale;
   end Add_Supported_Locale;

   --  ------------------------------
   --  Get the default locale defined by the application.
   --  ------------------------------
   function Get_Default_Locale (From : in Factory) return Util.Locales.Locale is
   begin
      return From.Default_Locale;
   end Get_Default_Locale;

   --  ------------------------------
   --  Set the default locale defined by the application.
   --  ------------------------------
   procedure Set_Default_Locale (Into   : in out Factory;
                                 Locale : in Util.Locales.Locale) is
   begin
      Into.Default_Locale := Locale;
   end Set_Default_Locale;

   procedure Create (Factory : in Locale_Binding;
                     Name    : in Ada.Strings.Unbounded.Unbounded_String;
                     Result  : out Util.Beans.Basic.Readonly_Bean_Access) is
      pragma Unreferenced (Name);
      use type ASF.Contexts.Faces.Faces_Context_Access;

      Context : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      B       : constant Bundle_Access := new Bundle;
   begin
      if Context = null then
         Load_Bundle (Factory => Factory.Loader.all,
                      Locale  => "en",
                      Name    => Factory.Name,
                      Bundle  => B.all);
      else
         Load_Bundle (Factory => Factory.Loader.all,
                      Locale  => Util.Locales.To_String (Context.Get_Locale),
                      Name    => Factory.Name,
                      Bundle  => B.all);
      end if;
      Result := B.all'Access;
   end Create;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   function Get_Value (From : Bundle;
                       Name : String) return Util.Beans.Objects.Object is
      Value : constant String := From.Get (Name, Name);
   begin
      return Util.Beans.Objects.To_Object (Value);
   end Get_Value;

end ASF.Locales;

Use the new Get_Names procedure from the Util.Properties package


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

   pragma Preelaborate;

   type String_Ptr is access all String;

   subtype Uint8 is Interfaces.Unsigned_8;

   subtype Uint16 is Interfaces.Unsigned_16;

   subtype Uint32 is Interfaces.Unsigned_32;

   subtype Uint64 is Interfaces.Unsigned_64;

   subtype Target_Addr is Interfaces.Unsigned_64;

   subtype Target_Size is Interfaces.Unsigned_64;

   subtype Target_Offset is Interfaces.Unsigned_64;

   type Target_Tick_Ref is new Uint64;

   type Target_Thread_Ref is new Uint32;

   subtype Target_Process_Ref is Uint32;

   subtype Target_Time is Target_Tick_Ref;

   --  Return an hexadecimal string representation of the value.
   function Hex_Image (Value : in Uint32;
                       Length : in Positive := 8) return String;

   --  Return an hexadecimal string representation of the value.
   function Hex_Image (Value  : in Uint64;
                       Length : in Positive := 16) return String;

   --  Format the target time to a printable representation.
   function Tick_Image (Value : in Target_Tick_Ref) return String;

   function "-" (Left, Right : in Target_Tick_Ref) return Target_Tick_Ref;

end MAT.Types;

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

   pragma Preelaborate;

   type String_Ptr is access all String;

   subtype Uint8 is Interfaces.Unsigned_8;

   subtype Uint16 is Interfaces.Unsigned_16;

   subtype Uint32 is Interfaces.Unsigned_32;

   subtype Uint64 is Interfaces.Unsigned_64;

   subtype Target_Addr is Interfaces.Unsigned_64;

   subtype Target_Size is Interfaces.Unsigned_64;

   subtype Target_Offset is Interfaces.Unsigned_64;

   type Target_Tick_Ref is new Uint64;

   type Target_Thread_Ref is new Uint32;

   subtype Target_Process_Ref is Uint32;

   subtype Target_Time is Target_Tick_Ref;

   --  Return an hexadecimal string representation of the value.
   function Hex_Image (Value : in Uint32;
                       Length : in Positive := 8) return String;

   --  Return an hexadecimal string representation of the value.
   function Hex_Image (Value  : in Uint64;
                       Length : in Positive := 16) return String;

   --  Format the target time to a printable representation.
   function Tick_Image (Value : in Target_Tick_Ref) return String;

   function "-" (Left, Right : in Target_Tick_Ref) return Target_Tick_Ref;

   --  Convert the hexadecimal string into an unsigned integer.
   function Hex_Value (Value : in String) return Uint64;

end MAT.Types;

Declare the Hex_Value function

Declare the Hex_Value function


-----------------------------------------------------------------------
--  security-oauth-servers -- OAuth Server Authentication Support
--  Copyright (C) 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 Ada.Strings.Unbounded;
with Ada.Calendar;
with Ada.Finalization;
with Ada.Strings.Hash;
with Ada.Containers.Indefinite_Hashed_Maps;

with Util.Strings;

with Security.Auth;
with Security.Permissions;

--  == OAuth Server ==
--  OAuth server side is provided by the <tt>Security.OAuth.Servers</tt> package.
--  This package allows to implement the authorization framework described in RFC 6749
--  "The OAuth 2.0 Authorization Framework".
--
--  The authorization method produces a <tt>Grant_Type</tt> object that contains the result
--  of the grant (successful or denied).  It is the responsibility of the caller to format
--  the result in JSON/XML and return it to the client.
--
--  Three important operations are defined for the OAuth 2.0 framework.  They will be used
--  in the following order:
--
--  <tt>Authorize</tt> is used to obtain an authorization request.  This operation is
--  optional in the OAuth 2.0 framework since some authorization method directly return
--  the access token.  This operation is used by the "Authorization Code Grant" and the
--  "Implicit Grant".
--
--  <tt>Token</tt> is used to get the access token and optional refresh token.  Each time it
--  is called, a new token is generated.
--
--  <tt>Authenticate</tt> is used for the API request to verify the access token
--  and authenticate the API call.  This operation can be called several times with the same
--  token until the token is revoked or it has expired.
--
--  Several grant types are supported.
--
--  === Application Manager ===
--  The application manager maintains the repository of applications which are known by
--  the server and which can request authorization.  Each application is identified by
--  a client identifier (represented by the <tt>client_id</tt> request parameter).
--  The application defines the authorization methods which are allowed as well as
--  the parameters to control and drive the authorization.  This includes the redirection
--  URI, the application secret, the expiration delay for the access token.
--
--  The application manager is implemented by the application server and it must
--  implement the <tt>Application_Manager</tt> interface with the <tt>Find_Application</tt>
--  method.  The <tt>Find_Application</tt> is one of the first call made during the
--  authenticate and token generation phases.
--
--  === Resource Owner Password Credentials Grant ===
--  The password grant is one of the easiest grant method to understand but it is also one
--  of the less secure.  In this grant method, the username and user password are passed in
--  the request parameter together with the application client identifier.  The realm verifies
--  the username and password and when they are correct it generates the access token with
--  an optional refresh token.
--
--    Realm : Security.OAuth.Servers.Auth_Manager;
--    Grant : Security.OAuth.Servers.Grant_Type;
--
--      Realm.Token (Params, Grant);
--
--  === Accessing Protected Resources ===
--  When accessing a protected resource, the API implementation will use the
--  <tt>Authenticate</tt> operation to verify the access token and get a security principal.
--  The security principal will identify the resource owner as well as the application
--  that is doing the call.
--
--     Realm : Security.OAuth.Servers.Auth_Manager;
--     Grant : Security.OAuth.Servers.Grant_Type;
--     Token : String := ...;
--
--       Realm.Authenticate (Token, Grant);
--
--  When a security principal is returned, the access token was validated and the
--  request is granted for the application.
--
package Security.OAuth.Servers is

   --  Minimum length for the server private key (160 bits min length).
   --  (See NIST Special Publication 800-107)
   MIN_KEY_LENGTH : constant Positive := 20;

   Invalid_Application : exception;

   type Application is new Security.OAuth.Application with private;

   --  Check if the application has the given permission.
   function Has_Permission (App        : in Application;
                            Permission : in Security.Permissions.Permission_Index) return Boolean;

   --  Define the status of the grant.
   type Grant_Status is (Invalid_Grant, Expired_Grant, Revoked_Grant,
                         Stealed_Grant, Valid_Grant);

   --  Define the grant type.
   type Grant_Kind is (No_Grant, Access_Grant, Code_Grant,
                       Implicit_Grant, Password_Grant, Credential_Grant,
                       Extension_Grant);

   --  The <tt>Grant_Type</tt> holds the results of the authorization.
   --  When the grant is refused, the type holds information about the refusal.
   type Grant_Type is record
      --  The request grant type.
      Request : Grant_Kind := No_Grant;

      --  The response status.
      Status  : Grant_Status := Invalid_Grant;

      --  When success, the token to return.
      Token   : Ada.Strings.Unbounded.Unbounded_String;

      --  When success, the token expiration date.
      Expires : Ada.Calendar.Time;

      --  When success, the authentication principal.
      Auth    : Security.Principal_Access;

      --  When error, the type of error to return.
      Error   : Util.Strings.Name_Access;
   end record;

   type Application_Manager is limited interface;
   type Application_Manager_Access is access all Application_Manager'Class;

   --  Find the application that correspond to the given client id.
   --  The <tt>Invalid_Application</tt> exception should be raised if there is no such application.
   function Find_Application (Realm     : in Application_Manager;
                              Client_Id : in String) return Application'Class is abstract;

   type Realm_Manager is limited interface;
   type Realm_Manager_Access is access all Realm_Manager'Class;

   --  Authenticate the token and find the associated authentication principal.
   --  The access token has been verified and the token represents the identifier
   --  of the Tuple (client_id, user, session) that describes the authentication.
   --  The <tt>Authenticate</tt> procedure should look in its database (internal
   --  or external) to find the authentication principal that was granted for
   --  the token Tuple.  When the token was not found (because it was revoked),
   --  the procedure should return a null principal.  If the authentication
   --  principal can be cached, the <tt>Cacheable</tt> value should be set.
   --  In that case, the access token and authentication  principal are inserted
   --  in a cache.
   procedure Authenticate (Realm     : in out Realm_Manager;
                           Token     : in String;
                           Auth      : out Principal_Access;
                           Cacheable : out Boolean) is abstract;

   --  Create an auth token string that identifies the given principal.  The returned
   --  token will be used by <tt>Authenticate</tt> to retrieve back the principal.  The
   --  returned token does not need to be signed.  It will be inserted in the public part
   --  of the returned access token.
   function Authorize (Realm : in Realm_Manager;
                       App   : in Application'Class;
                       Scope : in String;
                       Auth  : in Principal_Access) return String is abstract;

   procedure Verify (Realm    : in out Realm_Manager;
                     Username : in String;
                     Password : in String;
                     Auth     : out Principal_Access) is abstract;

   procedure Verify (Realm : in out Realm_Manager;
                     Token : in String;
                     Auth  : out Principal_Access) is abstract;

   procedure Revoke (Realm : in out Realm_Manager;
                     Auth  : in Principal_Access) is abstract;

   type Auth_Manager is tagged limited private;
   type Auth_Manager_Access is access all Auth_Manager'Class;

   --  Set the auth private key.
   procedure Set_Private_Key (Manager : in out Auth_Manager;
                              Key     : in String);

   --  Set the application manager to use and and applications.
   procedure Set_Application_Manager (Manager    : in out Auth_Manager;
                                      Repository : in Application_Manager_Access);

   --  Set the realm manager to authentify users.
   procedure Set_Realm_Manager (Manager : in out Auth_Manager;
                                Realm   : in Realm_Manager_Access);

   --  Authorize the access to the protected resource by the application and for the
   --  given principal.  The resource owner has been verified and is represented by the
   --  <tt>Auth</tt> principal.  Extract from the request parameters represented by
   --  <tt>Params</tt> the application client id, the scope and the expected response type.
   --  Handle the "Authorization Code Grant" and "Implicit Grant" defined in RFC 6749.
   procedure Authorize (Realm   : in out Auth_Manager;
                        Params  : in Security.Auth.Parameters'Class;
                        Auth    : in Security.Principal_Access;
                        Grant   : out Grant_Type);

   --  The <tt>Token</tt> procedure is the main entry point to get the access token and
   --  refresh token.  The request parameters are accessed through the <tt>Params</tt> interface.
   --  The operation looks at the "grant_type" parameter to identify the access method.
   --  It also looks at the "client_id" to find the application for which the access token
   --  is created.  Upon successful authentication, the operation returns a grant.
   procedure Token (Realm   : in out Auth_Manager;
                    Params  : in Security.Auth.Parameters'Class;
                    Grant   : out Grant_Type);

   --  Make the access token from the authorization code that was created by the
   --  <tt>Authorize</tt> operation.  Verify the client application, the redirect uri, the
   --  client secret and the validity of the authorization code.  Extract from the
   --  authorization code the auth principal that was used for the grant and make the
   --  access token.
   procedure Token_From_Code (Realm   : in out Auth_Manager;
                              App     : in Application'Class;
                              Params  : in Security.Auth.Parameters'Class;
                              Grant   : out Grant_Type);

   procedure Authorize_Code (Realm   : in out Auth_Manager;
                             App     : in Application'Class;
                             Params  : in Security.Auth.Parameters'Class;
                             Auth    : in Security.Principal_Access;
                             Grant   : out Grant_Type);

   procedure Authorize_Token (Realm   : in out Auth_Manager;
                              App     : in Application'Class;
                              Params  : in Security.Auth.Parameters'Class;
                              Auth    : in Security.Principal_Access;
                              Grant   : out Grant_Type);

   --  Make the access token from the resource owner password credentials.  The username,
   --  password and scope are extracted from the request and they are verified through the
   --  <tt>Verify</tt> procedure to obtain an associated principal.  When successful, the
   --  principal describes the authorization and it is used to forge the access token.
   --  This operation implements the RFC 6749: 4.3.  Resource Owner Password Credentials Grant.
   procedure Token_From_Password (Realm   : in out Auth_Manager;
                                  App     : in Application'Class;
                                  Params  : in Security.Auth.Parameters'Class;
                                  Grant   : out Grant_Type);

   --  Forge an access token.  The access token is signed by an HMAC-SHA1 signature.
   --  The returned token is formed as follows:
   --    <expiration>.<ident>.HMAC-SHA1(<private-key>, <expiration>.<ident>)
   --  See also RFC 6749: 5.  Issuing an Access Token
   procedure Create_Token (Realm  : in Auth_Manager;
                           Ident  : in String;
                           Grant  : in out Grant_Type);

   --  Authenticate the access token and get a security principal that identifies the app/user.
   --  See RFC 6749, 7.  Accessing Protected Resources.
   --  The access token is first searched in the cache.  If it was found, it means the access
   --  token was already verified in the past, it is granted and associated with a principal.
   --  Otherwise, we have to verify the token signature first, then the expiration date and
   --  we extract from the token public part the auth identification.  The <tt>Authenticate</tt>
   --  operation is then called to obtain the principal from the auth identification.
   --  When access token is invalid or authentification cannot be verified, a null principal
   --  is returned.  The <tt>Grant</tt> data will hold the result of the grant with the reason
   --  of failures (if any).
   procedure Authenticate (Realm : in out Auth_Manager;
                           Token : in String;
                           Grant : out Grant_Type);

   procedure Revoke (Realm     : in out Auth_Manager;
                     Token     : in String);

private

   use Ada.Strings.Unbounded;

   function Format_Expire (Expire : in Ada.Calendar.Time) return String;

   --  Decode the expiration date that was extracted from the token.
   function Parse_Expire (Expire : in String) return Ada.Calendar.Time;

   type Application is new Security.OAuth.Application with record
      Expire_Timeout : Duration := 3600.0;
      Permissions    : Security.Permissions.Permission_Index_Set := Security.Permissions.EMPTY_SET;
   end record;

   type Cache_Entry is record
      Expire : Ada.Calendar.Time;
      Auth   : Principal_Access;
   end record;

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

   --  The access token cache is used to speed up the access token verification
   --  when a request to a protected resource is made.
   protected type Token_Cache is

      procedure Authenticate (Token : in String;
                              Grant : in out Grant_Type);

      procedure Insert (Token     : in String;
                        Expire    : in Ada.Calendar.Time;
                        Principal : in Principal_Access);

      procedure Remove (Token : in String);

      procedure Timeout;

   private
      Entries : Cache_Map.Map;
   end Token_Cache;

   type Auth_Manager is new Ada.Finalization.Limited_Controlled with record
      --  The repository of applications.
      Repository  : Application_Manager_Access;

      --  The realm for user authentication.
      Realm       : Realm_Manager_Access;

      --  The server private key used by the HMAC signature.
      Private_Key : Ada.Strings.Unbounded.Unbounded_String;

      --  The access token cache.
      Cache       : Token_Cache;

      --  The expiration time for the generated authorization code.
      Expire_Code : Duration := 300.0;
   end record;

   --  The <tt>Token_Validity</tt> record provides information about a token to find out
   --  the different components it is made of and verify its validity.  The <tt>Validate</tt>
   --  procedure is in charge of checking the components and verifying the HMAC signature.
   --  The token has the following format:
   --  <expiration>.<client_id>.<auth-ident>.hmac(<public>.<private-key>)
   type Token_Validity is record
      Status       : Grant_Status := Invalid_Grant;
      Ident_Start  : Natural := 0;
      Ident_End    : Natural := 0;
      Expire       : Ada.Calendar.Time;
   end record;

   function Validate (Realm     : in Auth_Manager;
                      Client_Id : in String;
                      Token     : in String) return Token_Validity;

end Security.OAuth.Servers;

-----------------------------------------------------------------------
--  security-oauth-servers -- OAuth Server Authentication Support
--  Copyright (C) 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 Ada.Strings.Unbounded;
with Ada.Calendar;
with Ada.Finalization;
with Ada.Strings.Hash;
with Ada.Containers.Indefinite_Hashed_Maps;

with Util.Strings;

with Security.Auth;
with Security.Permissions;

--  == OAuth Server ==
--  OAuth server side is provided by the <tt>Security.OAuth.Servers</tt> package.
--  This package allows to implement the authorization framework described in RFC 6749
--  "The OAuth 2.0 Authorization Framework".
--
--  The authorization method produces a <tt>Grant_Type</tt> object that contains the result
--  of the grant (successful or denied).  It is the responsibility of the caller to format
--  the result in JSON/XML and return it to the client.
--
--  Three important operations are defined for the OAuth 2.0 framework.  They will be used
--  in the following order:
--
--  <tt>Authorize</tt> is used to obtain an authorization request.  This operation is
--  optional in the OAuth 2.0 framework since some authorization method directly return
--  the access token.  This operation is used by the "Authorization Code Grant" and the
--  "Implicit Grant".
--
--  <tt>Token</tt> is used to get the access token and optional refresh token.  Each time it
--  is called, a new token is generated.
--
--  <tt>Authenticate</tt> is used for the API request to verify the access token
--  and authenticate the API call.  This operation can be called several times with the same
--  token until the token is revoked or it has expired.
--
--  Several grant types are supported.
--
--  === Application Manager ===
--  The application manager maintains the repository of applications which are known by
--  the server and which can request authorization.  Each application is identified by
--  a client identifier (represented by the <tt>client_id</tt> request parameter).
--  The application defines the authorization methods which are allowed as well as
--  the parameters to control and drive the authorization.  This includes the redirection
--  URI, the application secret, the expiration delay for the access token.
--
--  The application manager is implemented by the application server and it must
--  implement the <tt>Application_Manager</tt> interface with the <tt>Find_Application</tt>
--  method.  The <tt>Find_Application</tt> is one of the first call made during the
--  authenticate and token generation phases.
--
--  === Resource Owner Password Credentials Grant ===
--  The password grant is one of the easiest grant method to understand but it is also one
--  of the less secure.  In this grant method, the username and user password are passed in
--  the request parameter together with the application client identifier.  The realm verifies
--  the username and password and when they are correct it generates the access token with
--  an optional refresh token.  The realm also returns in the grant the user principal that
--  identifies the user.
--
--    Realm : Security.OAuth.Servers.Auth_Manager;
--    Grant : Security.OAuth.Servers.Grant_Type;
--
--      Realm.Token (Params, Grant);
--
--  === Accessing Protected Resources ===
--  When accessing a protected resource, the API implementation will use the
--  <tt>Authenticate</tt> operation to verify the access token and get a security principal.
--  The security principal will identify the resource owner as well as the application
--  that is doing the call.
--
--     Realm : Security.OAuth.Servers.Auth_Manager;
--     Grant : Security.OAuth.Servers.Grant_Type;
--     Token : String := ...;
--
--       Realm.Authenticate (Token, Grant);
--
--  When a security principal is returned, the access token was validated and the
--  request is granted for the application.
--
package Security.OAuth.Servers is

   --  Minimum length for the server private key (160 bits min length).
   --  (See NIST Special Publication 800-107)
   MIN_KEY_LENGTH : constant Positive := 20;

   Invalid_Application : exception;

   type Application is new Security.OAuth.Application with private;

   --  Check if the application has the given permission.
   function Has_Permission (App        : in Application;
                            Permission : in Security.Permissions.Permission_Index) return Boolean;

   --  Define the status of the grant.
   type Grant_Status is (Invalid_Grant, Expired_Grant, Revoked_Grant,
                         Stealed_Grant, Valid_Grant);

   --  Define the grant type.
   type Grant_Kind is (No_Grant, Access_Grant, Code_Grant,
                       Implicit_Grant, Password_Grant, Credential_Grant,
                       Extension_Grant);

   --  The <tt>Grant_Type</tt> holds the results of the authorization.
   --  When the grant is refused, the type holds information about the refusal.
   type Grant_Type is record
      --  The request grant type.
      Request : Grant_Kind := No_Grant;

      --  The response status.
      Status  : Grant_Status := Invalid_Grant;

      --  When success, the token to return.
      Token   : Ada.Strings.Unbounded.Unbounded_String;

      --  When success, the token expiration date.
      Expires : Ada.Calendar.Time;

      --  When success, the authentication principal.
      Auth    : Security.Principal_Access;

      --  When error, the type of error to return.
      Error   : Util.Strings.Name_Access;
   end record;

   type Application_Manager is limited interface;
   type Application_Manager_Access is access all Application_Manager'Class;

   --  Find the application that correspond to the given client id.
   --  The <tt>Invalid_Application</tt> exception should be raised if there is no such application.
   function Find_Application (Realm     : in Application_Manager;
                              Client_Id : in String) return Application'Class is abstract;

   type Realm_Manager is limited interface;
   type Realm_Manager_Access is access all Realm_Manager'Class;

   --  Authenticate the token and find the associated authentication principal.
   --  The access token has been verified and the token represents the identifier
   --  of the Tuple (client_id, user, session) that describes the authentication.
   --  The <tt>Authenticate</tt> procedure should look in its database (internal
   --  or external) to find the authentication principal that was granted for
   --  the token Tuple.  When the token was not found (because it was revoked),
   --  the procedure should return a null principal.  If the authentication
   --  principal can be cached, the <tt>Cacheable</tt> value should be set.
   --  In that case, the access token and authentication  principal are inserted
   --  in a cache.
   procedure Authenticate (Realm     : in out Realm_Manager;
                           Token     : in String;
                           Auth      : out Principal_Access;
                           Cacheable : out Boolean) is abstract;

   --  Create an auth token string that identifies the given principal.  The returned
   --  token will be used by <tt>Authenticate</tt> to retrieve back the principal.  The
   --  returned token does not need to be signed.  It will be inserted in the public part
   --  of the returned access token.
   function Authorize (Realm : in Realm_Manager;
                       App   : in Application'Class;
                       Scope : in String;
                       Auth  : in Principal_Access) return String is abstract;

   procedure Verify (Realm    : in out Realm_Manager;
                     Username : in String;
                     Password : in String;
                     Auth     : out Principal_Access) is abstract;

   procedure Verify (Realm : in out Realm_Manager;
                     Token : in String;
                     Auth  : out Principal_Access) is abstract;

   procedure Revoke (Realm : in out Realm_Manager;
                     Auth  : in Principal_Access) is abstract;

   type Auth_Manager is tagged limited private;
   type Auth_Manager_Access is access all Auth_Manager'Class;

   --  Set the auth private key.
   procedure Set_Private_Key (Manager : in out Auth_Manager;
                              Key     : in String);

   --  Set the application manager to use and and applications.
   procedure Set_Application_Manager (Manager    : in out Auth_Manager;
                                      Repository : in Application_Manager_Access);

   --  Set the realm manager to authentify users.
   procedure Set_Realm_Manager (Manager : in out Auth_Manager;
                                Realm   : in Realm_Manager_Access);

   --  Authorize the access to the protected resource by the application and for the
   --  given principal.  The resource owner has been verified and is represented by the
   --  <tt>Auth</tt> principal.  Extract from the request parameters represented by
   --  <tt>Params</tt> the application client id, the scope and the expected response type.
   --  Handle the "Authorization Code Grant" and "Implicit Grant" defined in RFC 6749.
   procedure Authorize (Realm   : in out Auth_Manager;
                        Params  : in Security.Auth.Parameters'Class;
                        Auth    : in Security.Principal_Access;
                        Grant   : out Grant_Type);

   --  The <tt>Token</tt> procedure is the main entry point to get the access token and
   --  refresh token.  The request parameters are accessed through the <tt>Params</tt> interface.
   --  The operation looks at the "grant_type" parameter to identify the access method.
   --  It also looks at the "client_id" to find the application for which the access token
   --  is created.  Upon successful authentication, the operation returns a grant.
   procedure Token (Realm   : in out Auth_Manager;
                    Params  : in Security.Auth.Parameters'Class;
                    Grant   : out Grant_Type);

   --  Make the access token from the authorization code that was created by the
   --  <tt>Authorize</tt> operation.  Verify the client application, the redirect uri, the
   --  client secret and the validity of the authorization code.  Extract from the
   --  authorization code the auth principal that was used for the grant and make the
   --  access token.
   procedure Token_From_Code (Realm   : in out Auth_Manager;
                              App     : in Application'Class;
                              Params  : in Security.Auth.Parameters'Class;
                              Grant   : out Grant_Type);

   procedure Authorize_Code (Realm   : in out Auth_Manager;
                             App     : in Application'Class;
                             Params  : in Security.Auth.Parameters'Class;
                             Auth    : in Security.Principal_Access;
                             Grant   : out Grant_Type);

   procedure Authorize_Token (Realm   : in out Auth_Manager;
                              App     : in Application'Class;
                              Params  : in Security.Auth.Parameters'Class;
                              Auth    : in Security.Principal_Access;
                              Grant   : out Grant_Type);

   --  Make the access token from the resource owner password credentials.  The username,
   --  password and scope are extracted from the request and they are verified through the
   --  <tt>Verify</tt> procedure to obtain an associated principal.  When successful, the
   --  principal describes the authorization and it is used to forge the access token.
   --  This operation implements the RFC 6749: 4.3.  Resource Owner Password Credentials Grant.
   procedure Token_From_Password (Realm   : in out Auth_Manager;
                                  App     : in Application'Class;
                                  Params  : in Security.Auth.Parameters'Class;
                                  Grant   : out Grant_Type);

   --  Forge an access token.  The access token is signed by an HMAC-SHA1 signature.
   --  The returned token is formed as follows:
   --    <expiration>.<ident>.HMAC-SHA1(<private-key>, <expiration>.<ident>)
   --  See also RFC 6749: 5.  Issuing an Access Token
   procedure Create_Token (Realm  : in Auth_Manager;
                           Ident  : in String;
                           Grant  : in out Grant_Type);

   --  Authenticate the access token and get a security principal that identifies the app/user.
   --  See RFC 6749, 7.  Accessing Protected Resources.
   --  The access token is first searched in the cache.  If it was found, it means the access
   --  token was already verified in the past, it is granted and associated with a principal.
   --  Otherwise, we have to verify the token signature first, then the expiration date and
   --  we extract from the token public part the auth identification.  The <tt>Authenticate</tt>
   --  operation is then called to obtain the principal from the auth identification.
   --  When access token is invalid or authentification cannot be verified, a null principal
   --  is returned.  The <tt>Grant</tt> data will hold the result of the grant with the reason
   --  of failures (if any).
   procedure Authenticate (Realm : in out Auth_Manager;
                           Token : in String;
                           Grant : out Grant_Type);

   procedure Revoke (Realm     : in out Auth_Manager;
                     Token     : in String);

private

   use Ada.Strings.Unbounded;

   function Format_Expire (Expire : in Ada.Calendar.Time) return String;

   --  Decode the expiration date that was extracted from the token.
   function Parse_Expire (Expire : in String) return Ada.Calendar.Time;

   type Application is new Security.OAuth.Application with record
      Expire_Timeout : Duration := 3600.0;
      Permissions    : Security.Permissions.Permission_Index_Set := Security.Permissions.EMPTY_SET;
   end record;

   type Cache_Entry is record
      Expire : Ada.Calendar.Time;
      Auth   : Principal_Access;
   end record;

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

   --  The access token cache is used to speed up the access token verification
   --  when a request to a protected resource is made.
   protected type Token_Cache is

      procedure Authenticate (Token : in String;
                              Grant : in out Grant_Type);

      procedure Insert (Token     : in String;
                        Expire    : in Ada.Calendar.Time;
                        Principal : in Principal_Access);

      procedure Remove (Token : in String);

      procedure Timeout;

   private
      Entries : Cache_Map.Map;
   end Token_Cache;

   type Auth_Manager is new Ada.Finalization.Limited_Controlled with record
      --  The repository of applications.
      Repository  : Application_Manager_Access;

      --  The realm for user authentication.
      Realm       : Realm_Manager_Access;

      --  The server private key used by the HMAC signature.
      Private_Key : Ada.Strings.Unbounded.Unbounded_String;

      --  The access token cache.
      Cache       : Token_Cache;

      --  The expiration time for the generated authorization code.
      Expire_Code : Duration := 300.0;
   end record;

   --  The <tt>Token_Validity</tt> record provides information about a token to find out
   --  the different components it is made of and verify its validity.  The <tt>Validate</tt>
   --  procedure is in charge of checking the components and verifying the HMAC signature.
   --  The token has the following format:
   --  <expiration>.<client_id>.<auth-ident>.hmac(<public>.<private-key>)
   type Token_Validity is record
      Status       : Grant_Status := Invalid_Grant;
      Ident_Start  : Natural := 0;
      Ident_End    : Natural := 0;
      Expire       : Ada.Calendar.Time;
   end record;

   function Validate (Realm     : in Auth_Manager;
                      Client_Id : in String;
                      Token     : in String) return Token_Validity;

end Security.OAuth.Servers;

Update the documentation

Update the documentation


with AdaBase;
with Connect;
with CommonText;
with Ada.Text_IO;
with Ada.Calendar;
with AdaBase.Results.Sets;
with Interfaces;

procedure Execute_Dynabound is

   package CON renames Connect;
   package TIO renames Ada.Text_IO;
   package AR  renames AdaBase.Results;
   package ARS renames AdaBase.Results.Sets;
   package CT  renames CommonText;
   package CAL renames Ada.Calendar;

   package Byte_Io is new Ada.Text_Io.Modular_Io (Interfaces.Unsigned_8);

   type halfbyte is mod 2 ** 4;

   procedure dump_result;
   function halfbyte_to_hex (value : halfbyte) return Character;
   function convert_chain (chain : AR.chain) return String;
   function convert_set (set : AR.settype) return String;
   function pad (S : String; Slen : Natural) return String;
   function pad (S : String; Slen : Natural) return String
   is
      field : String (1 .. Slen) := (others => ' ');
      len   : Natural := S'Length;
   begin
      field (1 .. len) := S;
      return field;
   end pad;

   function halfbyte_to_hex (value : halfbyte) return Character
   is
      zero     : constant Natural := Character'Pos ('0');
      alpham10 : constant Natural := Character'Pos ('A') - 10;
   begin
      case value is
         when 0 .. 9 => return Character'Val (zero + Natural (value));
         when others => return Character'Val (alpham10 + Natural (value));
      end case;
   end halfbyte_to_hex;

   function convert_chain (chain : AR.chain) return String
   is
      use type AR.nbyte1;
      blocks    : constant Natural := chain'Length;
      mask_ones : constant AR.nbyte1 := 16#0F#;
      work_4bit : halfbyte;
      result    : String (1 .. blocks * 3 - 1) := (others => ' ');
      index     : Natural := 0;
      fullbyte  : Interfaces.Unsigned_8;
   begin
      for x in Positive range 1 .. blocks loop
         index := index + 1;
         fullbyte := Interfaces.Unsigned_8 (chain (x));
         fullbyte := Interfaces.Shift_Right (fullbyte, 4);
         work_4bit := halfbyte (fullbyte);
         result (index) := halfbyte_to_hex (work_4bit);
         index := index + 1;
         work_4bit := halfbyte (chain (x) and mask_ones);
         result (index) := halfbyte_to_hex (work_4bit);
         index := index + 1;
      end loop;
      if blocks = 0 then
         return "(empty)";
      end if;
      return result;
   end convert_chain;

   function convert_set (set : AR.settype) return String
   is
      result : CT.Text;
   begin
      for x in set'Range loop
         if not CT.IsBlank (set (x).enumeration) then
            if x > set'First then
               CT.SU.Append (result, ",");
            end if;
            CT.SU.Append (result, set (x).enumeration);
         end if;
      end loop;
      return CT.USS (result);
   end convert_set;

   procedure dump_result
   is
      row     : ARS.DataRow_Access;
      numcols : constant Natural := CON.STMT.column_count;
   begin
      loop
         exit when not CON.STMT.fetch_next (row);
         TIO.Put_Line ("");
         for c in Natural range 1 .. numcols loop
            TIO.Put (CT.zeropad (c, 2) & ". ");
            TIO.Put (pad (CON.STMT.column_name (c), 16));
            TIO.Put (pad (CON.STMT.column_native_type (c)'Img, 15));
            case CON.STMT.column_native_type (c) is
               when AdaBase.ft_chain =>
                  TIO.Put_Line (convert_chain (row.column (c).as_chain));
               when others =>
                  TIO.Put_Line (row.column (c).as_string);
            end case;
         end loop;
      end loop;
      TIO.Put_Line ("");
   end dump_result;

   cols : constant String := "id_nbyte3, nbyte0, " &
                             "nbyte1, byte2, byte4, nbyte8, real9, real18, " &
                             "exact_decimal, my_date, my_timestamp, " &
                             "my_time, my_year, my_tinytext, enumtype, " &
                             "settype, my_varbinary, my_blob";
   sql3 : constant String := "INSERT INTO all_types (" & cols & ") VALUES " &
                             "(?,?, ?,?,?,?,?,?, ?,?,?, ?,?,?,?, ?,?,?)";
   sql1 : constant String := "SELECT " & cols & " FROM all_types " &
                             "WHERE id_nbyte3 > 8";

begin

   declare
   begin
      CON.connect_database;
   exception
      when others =>
         TIO.Put_Line ("database connect failed.");
         return;
   end;

   declare
      numrows : AdaBase.AffectedRows;
   begin
      numrows := CON.DR.execute ("DELETE FROM all_types WHERE id_nbyte3 > 8");
      if Natural (numrows) > 0 then
         CON.DR.commit;
      end if;
   end;

   declare
      vals1 : constant String := "20|1|150|-10|-90000|3200100|87.2341|" &
        "15555.213792831213|875.44|2014-10-20|2000-03-25 15:15:00|" &
        "20:18:13|1986|AdaBase is so cool!|green|yellow,black|" &
        " 0123|456789ABC.,z[]";
      vals2 : constant String := "25;0;200;25;22222;50;4.84324982;" &
        "9234963.123235987;15.79;1910-11-05;2030-12-25 11:59:59;" &
        "04:00:45;1945;This is what it sounds like when doves cry;" &
        "red;blue,white;Q|ER;01234" & Character'Val (0) &
        Character'Val (10) & "789";
      good : Boolean := True;
   begin
      CON.STMT := CON.DR.prepare (sql3);
      --  This has to be done only once after the prepare command
      --  Set the type for each parameter (required for at least MySQL)
      CON.STMT.assign (1,  AR.PARAM_IS_NBYTE_3);
      CON.STMT.assign (2,  AR.PARAM_IS_BOOLEAN);
      CON.STMT.assign (3,  AR.PARAM_IS_NBYTE_1);
      CON.STMT.assign (4,  AR.PARAM_IS_BYTE_2);
      CON.STMT.assign (5,  AR.PARAM_IS_BYTE_4);
      CON.STMT.assign (6,  AR.PARAM_IS_NBYTE_8);
      CON.STMT.assign (7,  AR.PARAM_IS_REAL_9);
      CON.STMT.assign (8,  AR.PARAM_IS_REAL_18);
      CON.STMT.assign (9,  AR.PARAM_IS_REAL_9);
      CON.STMT.assign (10, AR.PARAM_IS_TIMESTAMP);
      CON.STMT.assign (11, AR.PARAM_IS_TIMESTAMP);
      CON.STMT.assign (12, AR.PARAM_IS_TIMESTAMP);
      CON.STMT.assign (13, AR.PARAM_IS_NBYTE_2);
      CON.STMT.assign (14, AR.PARAM_IS_TEXTUAL);
      CON.STMT.assign (15, AR.PARAM_IS_ENUM);
      CON.STMT.assign (16, AR.PARAM_IS_SET);
      CON.STMT.assign (17, AR.PARAM_IS_CHAIN);
      CON.STMT.assign (18, AR.PARAM_IS_CHAIN);

      good := CON.STMT.execute (vals1);
      if good then
         good := CON.STMT.execute (parameters => vals2, delimiter => ';');
      end if;
      if good then
         CON.DR.commit;
      else
         TIO.Put_Line ("statement execution failed");
         CON.DR.rollback;
      end if;
   end;

   begin
      CON.STMT := CON.DR.query (sql1);
      if CON.STMT.successful then
         TIO.Put_Line ("Dumping Result from direct statement ...");
         dump_result;
      end if;
   end;

   begin
      CON.STMT := CON.DR.prepare (sql1);
      if CON.STMT.execute then
         TIO.Put_Line ("Dumping Result from prepared statement ...");
         dump_result;
      end if;
   end;

   TIO.Put_Line ("Note slight differences in real9 and real18 field values");
   TIO.Put_Line ("due to rounding differences inherent in the different");
   TIO.Put_Line ("retrieval mechanisms of direct and prep stmt results.");

   CON.DR.disconnect;

end Execute_Dynabound;

with AdaBase;
with Connect;
with CommonText;
with Ada.Text_IO;
with Ada.Calendar;
with AdaBase.Results.Sets;
with Interfaces;

procedure Execute_Dynabound is

   package CON renames Connect;
   package TIO renames Ada.Text_IO;
   package AR  renames AdaBase.Results;
   package ARS renames AdaBase.Results.Sets;
   package CT  renames CommonText;
   package CAL renames Ada.Calendar;

   package Byte_Io is new Ada.Text_Io.Modular_Io (Interfaces.Unsigned_8);

   type halfbyte is mod 2 ** 4;

   stmt_acc : CON.Stmt_Type_access;

   procedure dump_result;
   function halfbyte_to_hex (value : halfbyte) return Character;
   function convert_chain (chain : AR.chain) return String;
   function convert_set (set : AR.settype) return String;
   function pad (S : String; Slen : Natural) return String;
   function pad (S : String; Slen : Natural) return String
   is
      field : String (1 .. Slen) := (others => ' ');
      len   : Natural := S'Length;
   begin
      field (1 .. len) := S;
      return field;
   end pad;

   function halfbyte_to_hex (value : halfbyte) return Character
   is
      zero     : constant Natural := Character'Pos ('0');
      alpham10 : constant Natural := Character'Pos ('A') - 10;
   begin
      case value is
         when 0 .. 9 => return Character'Val (zero + Natural (value));
         when others => return Character'Val (alpham10 + Natural (value));
      end case;
   end halfbyte_to_hex;

   function convert_chain (chain : AR.chain) return String
   is
      use type AR.nbyte1;
      blocks    : constant Natural := chain'Length;
      mask_ones : constant AR.nbyte1 := 16#0F#;
      work_4bit : halfbyte;
      result    : String (1 .. blocks * 3 - 1) := (others => ' ');
      index     : Natural := 0;
      fullbyte  : Interfaces.Unsigned_8;
   begin
      for x in Positive range 1 .. blocks loop
         index := index + 1;
         fullbyte := Interfaces.Unsigned_8 (chain (x));
         fullbyte := Interfaces.Shift_Right (fullbyte, 4);
         work_4bit := halfbyte (fullbyte);
         result (index) := halfbyte_to_hex (work_4bit);
         index := index + 1;
         work_4bit := halfbyte (chain (x) and mask_ones);
         result (index) := halfbyte_to_hex (work_4bit);
         index := index + 1;
      end loop;
      if blocks = 0 then
         return "(empty)";
      end if;
      return result;
   end convert_chain;

   function convert_set (set : AR.settype) return String
   is
      result : CT.Text;
   begin
      for x in set'Range loop
         if not CT.IsBlank (set (x).enumeration) then
            if x > set'First then
               CT.SU.Append (result, ",");
            end if;
            CT.SU.Append (result, set (x).enumeration);
         end if;
      end loop;
      return CT.USS (result);
   end convert_set;

   procedure dump_result
   is
      row     : ARS.DataRow;
      numcols : constant Natural := stmt_acc.column_count;
   begin
      loop
         row := stmt_acc.fetch_next;
         exit when row.data_exhausted;
         TIO.Put_Line ("");
         for c in Natural range 1 .. numcols loop
            TIO.Put (CT.zeropad (c, 2) & ". ");
            TIO.Put (pad (stmt_acc.column_name (c), 16));
            TIO.Put (pad (stmt_acc.column_native_type (c)'Img, 15));
            case stmt_acc.column_native_type (c) is
               when AdaBase.ft_chain =>
                  TIO.Put_Line (convert_chain (row.column (c).as_chain));
               when others =>
                  TIO.Put_Line (row.column (c).as_string);
            end case;
         end loop;
      end loop;
      TIO.Put_Line ("");
   end dump_result;

   cols : constant String := "id_nbyte3, nbyte0, " &
                             "nbyte1, byte2, byte4, nbyte8, real9, real18, " &
                             "exact_decimal, my_date, my_timestamp, " &
                             "my_time, my_year, my_tinytext, enumtype, " &
                             "settype, my_varbinary, my_blob";
   sql3 : constant String := "INSERT INTO all_types (" & cols & ") VALUES " &
                             "(?,?, ?,?,?,?,?,?, ?,?,?, ?,?,?,?, ?,?,?)";
   sql1 : constant String := "SELECT " & cols & " FROM all_types " &
                             "WHERE id_nbyte3 > 8";

begin

   begin
      CON.connect_database;
   exception
      when others =>
         TIO.Put_Line ("database connect failed.");
         return;
   end;

   declare
      numrows : AdaBase.AffectedRows;
   begin
      numrows := CON.DR.execute ("DELETE FROM all_types WHERE id_nbyte3 > 8");
      if Natural (numrows) > 0 then
         CON.DR.commit;
      end if;
   end;

   declare
      vals1 : constant String := "20|1|150|-10|-90000|3200100|87.2341|" &
        "15555.213792831213|875.44|2014-10-20|2000-03-25 15:15:00|" &
        "20:18:13|1986|AdaBase is so cool!|green|yellow,black|" &
        " 0123|456789ABC.,z[]";
      vals2 : constant String := "25;0;200;25;22222;50;4.84324982;" &
        "9234963.123235987;15.79;1910-11-05;2030-12-25 11:59:59;" &
        "04:00:45;1945;This is what it sounds like when doves cry;" &
        "red;blue,white;Q|ER;01234" & Character'Val (0) &
        Character'Val (10) & "789";
      good : Boolean := True;
      stmt : CON.Stmt_Type := CON.DR.prepare (sql3);
   begin
      --  This has to be done only once after the prepare command
      --  Set the type for each parameter (required for at least MySQL)
      stmt.assign (1,  AR.PARAM_IS_NBYTE_3);
      stmt.assign (2,  AR.PARAM_IS_BOOLEAN);
      stmt.assign (3,  AR.PARAM_IS_NBYTE_1);
      stmt.assign (4,  AR.PARAM_IS_BYTE_2);
      stmt.assign (5,  AR.PARAM_IS_BYTE_4);
      stmt.assign (6,  AR.PARAM_IS_NBYTE_8);
      stmt.assign (7,  AR.PARAM_IS_REAL_9);
      stmt.assign (8,  AR.PARAM_IS_REAL_18);
      stmt.assign (9,  AR.PARAM_IS_REAL_9);
      stmt.assign (10, AR.PARAM_IS_TIMESTAMP);
      stmt.assign (11, AR.PARAM_IS_TIMESTAMP);
      stmt.assign (12, AR.PARAM_IS_TIMESTAMP);
      stmt.assign (13, AR.PARAM_IS_NBYTE_2);
      stmt.assign (14, AR.PARAM_IS_TEXTUAL);
      stmt.assign (15, AR.PARAM_IS_ENUM);
      stmt.assign (16, AR.PARAM_IS_SET);
      stmt.assign (17, AR.PARAM_IS_CHAIN);
      stmt.assign (18, AR.PARAM_IS_CHAIN);

      good := stmt.execute (vals1);
      if good then
         good := stmt.execute (parameters => vals2, delimiter => ';');
      end if;
      if good then
         CON.DR.commit;
      else
         TIO.Put_Line ("statement execution failed");
         CON.DR.rollback;
      end if;
   end;

   declare
      stmt : aliased CON.Stmt_Type := CON.DR.query (sql1);
   begin
      if stmt.successful then
         stmt_acc := stmt'Unchecked_Access;
         TIO.Put_Line ("Dumping Result from direct statement ...");
         dump_result;
      end if;
   end;

   declare
      stmt : aliased CON.Stmt_Type := CON.DR.prepare (sql1);
   begin
      if stmt.execute then
         stmt_acc := stmt'Unchecked_Access;
         TIO.Put_Line ("Dumping Result from prepared statement ...");
         dump_result;
      end if;
   end;

   TIO.Put_Line ("Note slight differences in real9 and real18 field values");
   TIO.Put_Line ("due to rounding differences inherent in the different");
   TIO.Put_Line ("retrieval mechanisms of direct and prep stmt results.");

   CON.DR.disconnect;

end Execute_Dynabound;

fix execute_dynabound test case

fix execute_dynabound test case


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

with Ada.Calendar;
package Util.Dates.ISO8601 is

   --  Parses an ISO8601 date and return it as a calendar time.
   --  Raises Constraint_Error if the date format is not recognized.
   function Value (Date : in String) return Ada.Calendar.Time;

   --  Return the ISO8601 date.
   function Image (Date : in Ada.Calendar.Time) return String;
   function Image (Date : in Date_Record) return String;

end Util.Dates.ISO8601;

-----------------------------------------------------------------------
--  util-dates-iso8601 -- ISO8601 dates
--  Copyright (C) 2011, 2013, 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.Calendar;
package Util.Dates.ISO8601 is

   type Precision_Type is (YEAR, MONTH, DAY, HOUR, MINUTE, SECOND, SUBSECOND);

                           --  Parses an ISO8601 date and return it as a calendar time.
   --  Raises Constraint_Error if the date format is not recognized.
   function Value (Date : in String) return Ada.Calendar.Time;

   --  Return the ISO8601 date.
   function Image (Date : in Ada.Calendar.Time) return String;
   function Image (Date : in Date_Record) return String;
   function Image (Date      : in Ada.Calendar.Time;
                   Precision : in Precision_Type) return String;
   function Image (Date      : in Date_Record;
                   Precision : in Precision_Type) return String;

end Util.Dates.ISO8601;

Declare Precision_Type enumeration Declare new Image function