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

package body Wiki.Plugins.Templates is

   --  ------------------------------
   --  Expand the template configured with the parameters for the document.
   --  The <tt>Get_Template</tt> operation is called and the template content returned
   --  by that operation is parsed in the current document.  Template parameters are passed
   --  in the <tt>Context</tt> instance and they can be evaluated within the template
   --  while parsing the template content.
   --  ------------------------------
   overriding
   procedure Expand (Plugin   : in out Template_Plugin;
                     Document : in out Wiki.Documents.Document;
                     Params   : in out Wiki.Attributes.Attribute_List;
                     Context  : in Plugin_Context) is
      P       : Wiki.Parsers.Parser;
      Content : Wiki.Strings.UString;
   begin
      Template_Plugin'Class (Plugin).Get_Template (Params, Content);
      P.Set_Context (Context);
      P.Parse (Content, Document);
   end Expand;

end Wiki.Plugins.Templates;

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

package body Wiki.Plugins.Templates is

   use Ada.Strings.Unbounded;

   --  ------------------------------
   --  Expand the template configured with the parameters for the document.
   --  The <tt>Get_Template</tt> operation is called and the template content returned
   --  by that operation is parsed in the current document.  Template parameters are passed
   --  in the <tt>Context</tt> instance and they can be evaluated within the template
   --  while parsing the template content.
   --  ------------------------------
   overriding
   procedure Expand (Plugin   : in out Template_Plugin;
                     Document : in out Wiki.Documents.Document;
                     Params   : in out Wiki.Attributes.Attribute_List;
                     Context  : in Plugin_Context) is
      P       : Wiki.Parsers.Parser;
      Content : Wiki.Strings.UString;
   begin
      Template_Plugin'Class (Plugin).Get_Template (Params, Content);
      P.Set_Context (Context);
      P.Parse (Content, Document);
   end Expand;

   --  ------------------------------
   --  Find a plugin knowing its name.
   --  ------------------------------
   overriding
   function Find (Factory : in File_Template_Plugin;
                  Name    : in String) return Wiki_Plugin_Access is
      Path  : constant String := Ada.Directories.Compose (To_String (Factory.Path), Name);
   begin
      if Ada.Directories.Exists (Path) then
         return Factory'Unrestricted_Access;
      else
         return null;
      end if;
   end Find;

   --  ------------------------------
   --  Set the directory path that contains template files.
   --  ------------------------------
   procedure Set_Template_Path (Plugin : in out File_Template_Plugin;
                                Path   : in String) is
   begin
      Plugin.Path := Ada.Strings.Unbounded.To_Unbounded_String (Path);
   end Set_Template_Path;

   --  ------------------------------
   --  Expand the template configured with the parameters for the document.
   --  Read the file whose basename correspond to the first parameter and parse that file
   --  in the current document.  Template parameters are passed
   --  in the <tt>Context</tt> instance and they can be evaluated within the template
   --  while parsing the template content.
   --  ------------------------------
   overriding
   procedure Expand (Plugin   : in out File_Template_Plugin;
                     Document : in out Wiki.Documents.Document;
                     Params   : in out Wiki.Attributes.Attribute_List;
                     Context  : in Plugin_Context) is
      First : constant Wiki.Attributes.Cursor := Wiki.Attributes.First (Params);
      Name  : constant String := Wiki.Attributes.Get_Value (First);
      Input : aliased Wiki.Streams.Text_IO.File_Input_Stream;
      P     : Wiki.Parsers.Parser;
      Path  : constant String := Ada.Directories.Compose (To_String (Plugin.Path), Name);
   begin
      Input.Open (Path, "WCEM=8");
      P.Set_Context (Context);
      P.Parse (Input'Unchecked_Access, Document);
      Input.Close;

   exception
      when Ada.IO_Exceptions.Name_Error =>
         null;
   end Expand;

end Wiki.Plugins.Templates;

Implement the File_Template_Plugin operations


-----------------------------------------------------------------------
--  ADO Mysql Database -- MySQL Database connections
--  Copyright (C) 2009, 2010, 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 Mysql.Mysql; use Mysql.Mysql;

package ADO.Drivers.Connections.Mysql is

   type Mysql_Driver is limited private;

   --  Initialize the Mysql driver.
   procedure Initialize;

private

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

   type Mysql_Driver is new ADO.Drivers.Connections.Driver with record
      Id : Natural := 0;
   end record;

   --  Deletes the Mysql driver.
   overriding
   procedure Finalize (D : in out Mysql_Driver);

   --  Database connection implementation
   type Database_Connection is new ADO.Drivers.Connections.Database_Connection with record
      Name        : Unbounded_String := Null_Unbounded_String;
      Server_Name : Unbounded_String := Null_Unbounded_String;
      Login_Name  : Unbounded_String := Null_Unbounded_String;
      Password    : Unbounded_String := Null_Unbounded_String;

      Server      : Mysql_Access := null;

      Connected   : Boolean      := False;

      --  MySQL autocommit flag
      Autocommit  : Boolean := True;
   end record;

   type Database_Connection_Access is access all Database_Connection'Class;

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

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

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

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

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

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

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

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

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

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

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

   overriding
   procedure Finalize (Database : in out Database_Connection);

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

end ADO.Drivers.Connections.Mysql;

-----------------------------------------------------------------------
--  ADO Mysql Database -- MySQL Database connections
--  Copyright (C) 2009, 2010, 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 Mysql.Mysql; use Mysql.Mysql;

package ADO.Drivers.Connections.Mysql is

   type Mysql_Driver is limited private;

   --  Initialize the Mysql driver.
   procedure Initialize;

private

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

   type Mysql_Driver is new ADO.Drivers.Connections.Driver with record
      Id : Natural := 0;
   end record;

   --  Deletes the Mysql driver.
   overriding
   procedure Finalize (D : in out Mysql_Driver);

   --  Database connection implementation
   type Database_Connection is new ADO.Drivers.Connections.Database_Connection with record
      Name        : Unbounded_String := Null_Unbounded_String;
      Server_Name : Unbounded_String := Null_Unbounded_String;
      Login_Name  : Unbounded_String := Null_Unbounded_String;
      Password    : Unbounded_String := Null_Unbounded_String;

      Server      : Mysql_Access := null;

      Connected   : Boolean      := False;

      --  MySQL autocommit flag
      Autocommit  : Boolean := True;
   end record;

   type Database_Connection_Access is access all Database_Connection'Class;

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

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

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

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

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

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

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

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

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

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

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

   overriding
   procedure Finalize (Database : in out Database_Connection);

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

   --  Create the database and initialize it with the schema SQL file.
   overriding
   procedure Create_Database (Database    : in Database_Connection;
                              Config      : in Configs.Configuration'Class;
                              Schema_Path : in String;
                              Messages    : out Util.Strings.Vectors.Vector);

end ADO.Drivers.Connections.Mysql;

Declare the Create_Database procedure

Declare the Create_Database procedure


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

--  == Text Builders ==
--  The `Util.Texts.Builders` generic package was designed to provide string builders.
--  The interface was designed to reduce memory copies as much as possible.
--
--    * The `Builder` type holds a list of chunks into which texts are appended.
--    * The builder type holds an initial chunk whose capacity is defined when the builder
--      instance is declared.
--    * There is only an `Append` procedure which allows to append text to the builder.
--      This is the only time when a copy is made.
--    * The package defines the `Iterate` operation that allows to get the content
--      collected by the builder.  When using the `Iterate` operation, no copy is
--      performed since chunks data are passed passed by reference.
--    * The type is limited to forbid copies of the builder instance.
--
--  First, instantiate the package for the element type (eg, String):
--
--    package String_Builder is new Util.Texts.Builders (Character, String);
--
--  Declare the string builder instance with its initial capacity:
--
--    Builder : String_Builder.Builder (256);
--
--  And append to it:
--
--    String_Builder.Append (Builder, "Hello");
--
--  To get the content collected in the builder instance, write a procedure that receives
--  the chunk data as parameter:
--
--    procedure Collect (Item : in String) is ...
--
--  And use the `Iterate` operation:
--
--    String_Builder.Iterate (Builder, Collect'Access);
--
generic
   type Element_Type is (<>);
   type Input is array (Positive range <>) of Element_Type;
   Chunk_Size : Positive := 80;
package Util.Texts.Builders is

   pragma Preelaborate;

   type Builder (Len : Positive) is limited private;

   --  Get the length of the item builder.
   function Length (Source : in Builder) return Natural;

   --  Get the capacity of the builder.
   function Capacity (Source : in Builder) return Natural;

   --  Get the builder block size.
   function Block_Size (Source : in Builder) return Positive;

   --  Set the block size for the allocation of next chunks.
   procedure Set_Block_Size (Source : in out Builder;
                             Size   : in Positive);

   --  Append the <tt>New_Item</tt> at the end of the source growing the buffer if necessary.
   procedure Append (Source   : in out Builder;
                     New_Item : in Input);

   --  Append the <tt>New_Item</tt> at the end of the source growing the buffer if necessary.
   procedure Append (Source   : in out Builder;
                     New_Item : in Element_Type);

   --  Append in `Into` builder the `Content` builder starting at `From` position
   --  and the up to and including the `To` position.
   procedure Append (Into     : in out Builder;
                     Content  : in Builder;
                     From     : in Positive;
                     To       : in Positive);

   generic
      with procedure Process (Content : in out Input; Last : out Natural);
   procedure Inline_Append (Source  : in out Builder);

   --  Clear the source freeing any storage allocated for the buffer.
   procedure Clear (Source : in out Builder);

   --  Iterate over the buffer content calling the <tt>Process</tt> procedure with each
   --  chunk.
   procedure Iterate (Source  : in Builder;
                      Process : not null access procedure (Chunk : in Input));

   generic
      with procedure Process (Content : in Input);
   procedure Inline_Iterate (Source  : in Builder);

   --  Get the buffer content as an array.
   function To_Array (Source : in Builder) return Input;

   --  Return the content starting from the tail and up to <tt>Length</tt> items.
   function Tail (Source : in Builder;
                  Length : in Natural) return Input;

   --  Get the element at the given position.
   function Element (Source   : in Builder;
                     Position : in Positive) return Element_Type;

   --  Find the position of some content by running the `Index` function.
   --  The `Index` function is called with chunks starting at the given position and
   --  until it returns a positive value or we reach the last chunk.  It must return
   --  the found position in the chunk.
   generic
      with function Index (Content : in Input) return Natural;
   function Find (Source   : in Builder;
                  Position : in Positive) return Natural;

   --  Call the <tt>Process</tt> procedure with the full buffer content, trying to avoid
   --  secondary stack copies as much as possible.
   generic
      with procedure Process (Content : in Input);
   procedure Get (Source : in Builder);

   --  Format the message and replace occurrences of argument patterns by
   --  their associated value.
   --  Returns the formatted message in the stream
   generic
      type Value is limited private;
      type Value_List is array (Positive range <>) of Value;
      with procedure Append (Input : in out Builder; Item : in Value);
   procedure Format (Into      : in out Builder;
                     Message   : in Input;
                     Arguments : in Value_List);

private

   pragma Inline (Length);
   pragma Inline (Iterate);

   type Block;
   type Block_Access is access all Block;

   type Block (Len : Positive) is limited record
      Next_Block : Block_Access;
      Last       : Natural := 0;
      Content    : Input (1 .. Len);
   end record;

   type Builder (Len : Positive) is new Ada.Finalization.Limited_Controlled with record
      Current    : Block_Access;
      Block_Size : Positive := Chunk_Size;
      Length     : Natural  := 0;
      First      : aliased Block (Len);
   end record;
   pragma Finalize_Storage_Only (Builder);

   --  Setup the builder.
   overriding
   procedure Initialize (Source : in out Builder);

   --  Finalize the builder releasing the storage.
   overriding
   procedure Finalize (Source : in out Builder);

end Util.Texts.Builders;

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

--  == Text Builders ==
--  The `Util.Texts.Builders` generic package was designed to provide string builders.
--  The interface was designed to reduce memory copies as much as possible.
--
--    * The `Builder` type holds a list of chunks into which texts are appended.
--    * The builder type holds an initial chunk whose capacity is defined when the builder
--      instance is declared.
--    * There is only an `Append` procedure which allows to append text to the builder.
--      This is the only time when a copy is made.
--    * The package defines the `Iterate` operation that allows to get the content
--      collected by the builder.  When using the `Iterate` operation, no copy is
--      performed since chunks data are passed passed by reference.
--    * The type is limited to forbid copies of the builder instance.
--
--  First, instantiate the package for the element type (eg, String):
--
--    package String_Builder is new Util.Texts.Builders (Character, String);
--
--  Declare the string builder instance with its initial capacity:
--
--    Builder : String_Builder.Builder (256);
--
--  And append to it:
--
--    String_Builder.Append (Builder, "Hello");
--
--  To get the content collected in the builder instance, write a procedure that receives
--  the chunk data as parameter:
--
--    procedure Collect (Item : in String) is ...
--
--  And use the `Iterate` operation:
--
--    String_Builder.Iterate (Builder, Collect'Access);
--
generic
   type Element_Type is (<>);
   type Input is array (Positive range <>) of Element_Type;
   Chunk_Size : Positive := 80;
package Util.Texts.Builders is

   pragma Preelaborate;

   type Builder (Len : Positive) is limited private;

   --  Get the length of the item builder.
   function Length (Source : in Builder) return Natural;

   --  Get the capacity of the builder.
   function Capacity (Source : in Builder) return Natural;

   --  Get the builder block size.
   function Block_Size (Source : in Builder) return Positive;

   --  Set the block size for the allocation of next chunks.
   procedure Set_Block_Size (Source : in out Builder;
                             Size   : in Positive);

   --  Append the <tt>New_Item</tt> at the end of the source growing the buffer if necessary.
   procedure Append (Source   : in out Builder;
                     New_Item : in Input);

   --  Append the <tt>New_Item</tt> at the end of the source growing the buffer if necessary.
   procedure Append (Source   : in out Builder;
                     New_Item : in Element_Type);

   --  Append in `Into` builder the `Content` builder starting at `From` position
   --  and the up to and including the `To` position.
   procedure Append (Into     : in out Builder;
                     Content  : in Builder;
                     From     : in Positive;
                     To       : in Positive);

   generic
      with procedure Process (Content : in out Input; Last : out Natural);
   procedure Inline_Append (Source  : in out Builder);

   --  Clear the source freeing any storage allocated for the buffer.
   procedure Clear (Source : in out Builder);

   --  Iterate over the buffer content calling the <tt>Process</tt> procedure with each
   --  chunk.
   procedure Iterate (Source  : in Builder;
                      Process : not null access procedure (Chunk : in Input));

   generic
      with procedure Process (Content : in Input);
   procedure Inline_Iterate (Source  : in Builder);

   generic
      with procedure Process (Content : in out Input);
   procedure Inline_Update (Source : in out Builder);

   --  Get the buffer content as an array.
   function To_Array (Source : in Builder) return Input;

   --  Return the content starting from the tail and up to <tt>Length</tt> items.
   function Tail (Source : in Builder;
                  Length : in Natural) return Input;

   --  Get the element at the given position.
   function Element (Source   : in Builder;
                     Position : in Positive) return Element_Type;

   --  Find the position of some content by running the `Index` function.
   --  The `Index` function is called with chunks starting at the given position and
   --  until it returns a positive value or we reach the last chunk.  It must return
   --  the found position in the chunk.
   generic
      with function Index (Content : in Input) return Natural;
   function Find (Source   : in Builder;
                  Position : in Positive) return Natural;

   --  Call the <tt>Process</tt> procedure with the full buffer content, trying to avoid
   --  secondary stack copies as much as possible.
   generic
      with procedure Process (Content : in Input);
   procedure Get (Source : in Builder);

   --  Format the message and replace occurrences of argument patterns by
   --  their associated value.
   --  Returns the formatted message in the stream
   generic
      type Value is limited private;
      type Value_List is array (Positive range <>) of Value;
      with procedure Append (Input : in out Builder; Item : in Value);
   procedure Format (Into      : in out Builder;
                     Message   : in Input;
                     Arguments : in Value_List);

private

   pragma Inline (Length);
   pragma Inline (Iterate);

   type Block;
   type Block_Access is access all Block;

   type Block (Len : Positive) is limited record
      Next_Block : Block_Access;
      Last       : Natural := 0;
      Content    : Input (1 .. Len);
   end record;

   type Builder (Len : Positive) is new Ada.Finalization.Limited_Controlled with record
      Current    : Block_Access;
      Block_Size : Positive := Chunk_Size;
      Length     : Natural  := 0;
      First      : aliased Block (Len);
   end record;
   pragma Finalize_Storage_Only (Builder);

   --  Setup the builder.
   overriding
   procedure Initialize (Source : in out Builder);

   --  Finalize the builder releasing the storage.
   overriding
   procedure Finalize (Source : in out Builder);

end Util.Texts.Builders;

Add Inline_Update generic procedure

Add Inline_Update generic procedure


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

with ADO.Queries;
with ADO.Sessions.Entities;
with ADO.Statements;
with Util.Log.Loggers;
with Util.Serialize.IO.XML;

with Security.Controllers.Roles;

with AWA.Permissions.Models;
with AWA.Services.Contexts;
package body AWA.Permissions.Services is

   use Util.Log;
   use ADO.Sessions;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Permissions.Services");

   --  ------------------------------
   --  Get the permission manager associated with the security context.
   --  Returns null if there is none.
   --  ------------------------------
   function Get_Permission_Manager (Context : in Security.Contexts.Security_Context'Class)
                                    return Permission_Manager_Access is
      use type Security.Permissions.Permission_Manager_Access;

      M : constant Security.Permissions.Permission_Manager_Access
        := Context.Get_Permission_Manager;
   begin
      if M = null then
         Log.Info ("There is no permission manager");
         return null;

      elsif not (M.all in Permission_Manager'Class) then
         Log.Info ("Permission manager is not a AWA permission manager");
         return null;

      else
         return Permission_Manager'Class (M.all)'Access;
      end if;
   end Get_Permission_Manager;

   --  ------------------------------
   --  Get the application instance.
   --  ------------------------------
   function Get_Application (Manager : in Permission_Manager)
                             return AWA.Applications.Application_Access is
   begin
      return Manager.App;
   end Get_Application;

   --  ------------------------------
   --  Set the application instance.
   --  ------------------------------
   procedure Set_Application (Manager : in out Permission_Manager;
                              App : in AWA.Applications.Application_Access) is
   begin
      Manager.App := App;
   end Set_Application;

   --  ------------------------------
   --  Add a permission for the current user to access the entity identified by
   --  Entity and Kind.
   --  ------------------------------
   procedure Add_Permission (Manager    : in Permission_Manager;
                             Entity     : in ADO.Identifier;
                             Kind       : in ADO.Entity_Type;
                             Permission : in Permission_Type) is
      pragma Unreferenced (Manager);

      Ctx  : constant AWA.Services.Contexts.Service_Context_Access
        := AWA.Services.Contexts.Current;
      DB   : Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Perm : AWA.Permissions.Models.ACL_Ref;
   begin
      Log.Info ("Adding permission");

      Ctx.Start;
      Perm.Set_Entity_Type (Kind);
      Perm.Set_User_Id (Ctx.Get_User_Identifier);
      Perm.Set_Entity_Id (Entity);
      Perm.Set_Writeable (Permission = AWA.Permissions.WRITE);
      Perm.Save (DB);
      Ctx.Commit;
   end Add_Permission;

   --  ------------------------------
   --  Check that the current user has the specified permission.
   --  Raise NO_PERMISSION exception if the user does not have the permission.
   --  ------------------------------
   procedure Check_Permission (Manager    : in Permission_Manager;
                               Entity     : in ADO.Identifier;
                               Kind       : in ADO.Entity_Type;
                               Permission : in Permission_Type) is
      pragma Unreferenced (Manager, Permission);
      use AWA.Services;

      Ctx   : constant Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      User  : constant ADO.Identifier := Ctx.Get_User_Identifier;
      DB    : constant Session := AWA.Services.Contexts.Get_Session (Ctx);
      Query : ADO.Queries.Context;
   begin
      Query.Set_Query (AWA.Permissions.Models.Query_Check_Entity_Permission);
      Query.Bind_Param ("user_id", User);
      Query.Bind_Param ("entity_id", Entity);
      Query.Bind_Param ("entity_type", Integer (Kind));
      declare
         Stmt : ADO.Statements.Query_Statement := DB.Create_Statement (Query);
      begin
         Stmt.Execute;
         if not Stmt.Has_Elements then
            Log.Info ("User {0} does not have permission to access entity {1}/{2}",
                      ADO.Identifier'Image (User), ADO.Identifier'Image (Entity),
                      ADO.Entity_Type'Image (Kind));
            raise NO_PERMISSION;
         end if;
      end;
   end Check_Permission;

   --  ------------------------------
   --  Read the policy file
   --  ------------------------------
   overriding
   procedure Read_Policy (Manager : in out Permission_Manager;
                          File    : in String) is

      use Util;

      Reader  : Util.Serialize.IO.XML.Parser;

      package Policy_Config is
        new Security.Permissions.Reader_Config (Reader, Manager'Unchecked_Access);
      package Role_Config is
        new Security.Controllers.Roles.Reader_Config (Reader, Manager'Unchecked_Access);
--        package Entity_Config is
--           new AWA.Permissions.Controllers.Reader_Config (Reader, Manager'Unchecked_Access);
      pragma Warnings (Off, Policy_Config);
      pragma Warnings (Off, Role_Config);
--        pragma Warnings (Off, Entity_Config);
   begin
      Log.Info ("Reading policy file {0}", File);

      Reader.Parse (File);

   end Read_Policy;

   --  ------------------------------
   --  Add a permission for the user User to access the entity identified by
   --  Entity which is of type Kind.
   --  ------------------------------
   procedure Add_Permission (Session    : in out ADO.Sessions.Master_Session;
                             User       : in ADO.Identifier;
                             Entity     : in ADO.Identifier;
                             Kind       : in ADO.Entity_Type;
                             Permission : in Permission_Type := READ) is
      Acl : AWA.Permissions.Models.ACL_Ref;
   begin
      Acl.Set_User_Id (User);
      Acl.Set_Entity_Type (Kind);
      Acl.Set_Entity_Id (Entity);
      Acl.Set_Writeable (Permission = WRITE);
      Acl.Save (Session);

      Log.Info ("Permission created for {0} to access {1}, entity type {2}",
                ADO.Identifier'Image (User),
                ADO.Identifier'Image (Entity),
                ADO.Entity_Type'Image (Kind));
   end Add_Permission;

   --  ------------------------------
   --  Add a permission for the user User to access the entity identified by
   --  Entity.
   --  ------------------------------
   procedure Add_Permission (Session    : in out ADO.Sessions.Master_Session;
                             User       : in ADO.Identifier;
                             Entity     : in ADO.Objects.Object_Ref'Class;
                             Permission : in Permission_Type := READ) is
      Key  : constant ADO.Objects.Object_Key := Entity.Get_Key;
      Kind : constant ADO.Entity_Type
        := ADO.Sessions.Entities.Find_Entity_Type (Session => Session,
                                                   Object  => Key);
   begin
      Add_Permission (Session, User, ADO.Objects.Get_Value (Key), Kind, Permission);
   end Add_Permission;

   --  ------------------------------
   --  Create a permission manager for the given application.
   --  ------------------------------
   function Create_Permission_Manager (App : in AWA.Applications.Application_Access)
                                       return Security.Permissions.Permission_Manager_Access is
      Result : constant AWA.Permissions.Services.Permission_Manager_Access
        := new AWA.Permissions.Services.Permission_Manager;
   begin
      Result.Set_Application (App);
      return Result.all'Access;
   end Create_Permission_Manager;

end AWA.Permissions.Services;

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

with ADO.Queries;
with ADO.Sessions.Entities;
with ADO.Statements;
with Util.Log.Loggers;
with Util.Serialize.IO.XML;

with AWA.Permissions.Models;
with AWA.Services.Contexts;
package body AWA.Permissions.Services is

   use Util.Log;
   use ADO.Sessions;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Permissions.Services");

   --  ------------------------------
   --  Get the permission manager associated with the security context.
   --  Returns null if there is none.
   --  ------------------------------
   function Get_Permission_Manager (Context : in Security.Contexts.Security_Context'Class)
                                    return Permission_Manager_Access is
      use type Security.Policies.Policy_Manager_Access;

      M : constant Security.Policies.Policy_Manager_Access
        := Context.Get_Permission_Manager;
   begin
      if M = null then
         Log.Info ("There is no permission manager");
         return null;

      elsif not (M.all in Permission_Manager'Class) then
         Log.Info ("Permission manager is not a AWA permission manager");
         return null;

      else
         return Permission_Manager'Class (M.all)'Access;
      end if;
   end Get_Permission_Manager;

   --  ------------------------------
   --  Get the application instance.
   --  ------------------------------
   function Get_Application (Manager : in Permission_Manager)
                             return AWA.Applications.Application_Access is
   begin
      return Manager.App;
   end Get_Application;

   --  ------------------------------
   --  Set the application instance.
   --  ------------------------------
   procedure Set_Application (Manager : in out Permission_Manager;
                              App : in AWA.Applications.Application_Access) is
   begin
      Manager.App := App;
   end Set_Application;

   --  ------------------------------
   --  Add a permission for the current user to access the entity identified by
   --  Entity and Kind.
   --  ------------------------------
   procedure Add_Permission (Manager    : in Permission_Manager;
                             Entity     : in ADO.Identifier;
                             Kind       : in ADO.Entity_Type;
                             Permission : in Permission_Type) is
      pragma Unreferenced (Manager);

      Ctx  : constant AWA.Services.Contexts.Service_Context_Access
        := AWA.Services.Contexts.Current;
      DB   : Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Perm : AWA.Permissions.Models.ACL_Ref;
   begin
      Log.Info ("Adding permission");

      Ctx.Start;
      Perm.Set_Entity_Type (Kind);
      Perm.Set_User_Id (Ctx.Get_User_Identifier);
      Perm.Set_Entity_Id (Entity);
      Perm.Set_Writeable (Permission = AWA.Permissions.WRITE);
      Perm.Save (DB);
      Ctx.Commit;
   end Add_Permission;

   --  ------------------------------
   --  Check that the current user has the specified permission.
   --  Raise NO_PERMISSION exception if the user does not have the permission.
   --  ------------------------------
   procedure Check_Permission (Manager    : in Permission_Manager;
                               Entity     : in ADO.Identifier;
                               Kind       : in ADO.Entity_Type;
                               Permission : in Permission_Type) is
      pragma Unreferenced (Manager, Permission);
      use AWA.Services;

      Ctx   : constant Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      User  : constant ADO.Identifier := Ctx.Get_User_Identifier;
      DB    : constant Session := AWA.Services.Contexts.Get_Session (Ctx);
      Query : ADO.Queries.Context;
   begin
      Query.Set_Query (AWA.Permissions.Models.Query_Check_Entity_Permission);
      Query.Bind_Param ("user_id", User);
      Query.Bind_Param ("entity_id", Entity);
      Query.Bind_Param ("entity_type", Integer (Kind));
      declare
         Stmt : ADO.Statements.Query_Statement := DB.Create_Statement (Query);
      begin
         Stmt.Execute;
         if not Stmt.Has_Elements then
            Log.Info ("User {0} does not have permission to access entity {1}/{2}",
                      ADO.Identifier'Image (User), ADO.Identifier'Image (Entity),
                      ADO.Entity_Type'Image (Kind));
            raise NO_PERMISSION;
         end if;
      end;
   end Check_Permission;

   --  ------------------------------
   --  Read the policy file
   --  ------------------------------
   overriding
   procedure Read_Policy (Manager : in out Permission_Manager;
                          File    : in String) is

      use Util;

      Reader  : Util.Serialize.IO.XML.Parser;

--        package Policy_Config is
--          new Security.Permissions.Reader_Config (Reader, Manager'Unchecked_Access);
--        package Role_Config is
--          new Security.Controllers.Roles.Reader_Config (Reader, Manager'Unchecked_Access);
--        pragma Warnings (Off, Policy_Config);
--        pragma Warnings (Off, Role_Config);
--        pragma Warnings (Off, Entity_Config);
   begin
      Log.Info ("Reading policy file {0}", File);

      Reader.Parse (File);

   end Read_Policy;

   --  ------------------------------
   --  Add a permission for the user User to access the entity identified by
   --  Entity which is of type Kind.
   --  ------------------------------
   procedure Add_Permission (Session    : in out ADO.Sessions.Master_Session;
                             User       : in ADO.Identifier;
                             Entity     : in ADO.Identifier;
                             Kind       : in ADO.Entity_Type;
                             Permission : in Permission_Type := READ) is
      Acl : AWA.Permissions.Models.ACL_Ref;
   begin
      Acl.Set_User_Id (User);
      Acl.Set_Entity_Type (Kind);
      Acl.Set_Entity_Id (Entity);
      Acl.Set_Writeable (Permission = WRITE);
      Acl.Save (Session);

      Log.Info ("Permission created for {0} to access {1}, entity type {2}",
                ADO.Identifier'Image (User),
                ADO.Identifier'Image (Entity),
                ADO.Entity_Type'Image (Kind));
   end Add_Permission;

   --  ------------------------------
   --  Add a permission for the user User to access the entity identified by
   --  Entity.
   --  ------------------------------
   procedure Add_Permission (Session    : in out ADO.Sessions.Master_Session;
                             User       : in ADO.Identifier;
                             Entity     : in ADO.Objects.Object_Ref'Class;
                             Permission : in Permission_Type := READ) is
      Key  : constant ADO.Objects.Object_Key := Entity.Get_Key;
      Kind : constant ADO.Entity_Type
        := ADO.Sessions.Entities.Find_Entity_Type (Session => Session,
                                                   Object  => Key);
   begin
      Add_Permission (Session, User, ADO.Objects.Get_Value (Key), Kind, Permission);
   end Add_Permission;

   --  ------------------------------
   --  Create a permission manager for the given application.
   --  ------------------------------
   function Create_Permission_Manager (App : in AWA.Applications.Application_Access)
                                       return Security.Policies.Policy_Manager_Access is
      Result : constant AWA.Permissions.Services.Permission_Manager_Access
        := new AWA.Permissions.Services.Permission_Manager (10);
   begin
      Result.Set_Application (App);
      return Result.all'Access;
   end Create_Permission_Manager;

end AWA.Permissions.Services;

Fix compilation after refactoring Security package


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

with Util.Test_Caller;
with Util.Log.Loggers;
with Util.Measures;
with Util.Concurrent.Counters;

with EL.Beans;
with EL.Expressions;
with EL.Contexts.Default;

with ASF.Applications;
with ASF.Servlets.Faces;

with AWA.Applications;
with AWA.Applications.Configs;
with AWA.Applications.Factory;
with AWA.Events.Action_Method;
with AWA.Services.Contexts;

with AWA.Events.Queues;
with AWA.Events.Services;

package body AWA.Events.Services.Tests is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Events.Tests");

   package Event_Test_4 is new AWA.Events.Definition (Name => "event-test-4");
   package Event_Test_1 is new AWA.Events.Definition (Name => "event-test-1");
   package Event_Test_3 is new AWA.Events.Definition (Name => "event-test-3");
   package Event_Test_2 is new AWA.Events.Definition (Name => "event-test-2");
   package Event_Test_5 is new AWA.Events.Definition (Name => "event-test-5");

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Events.Get_Event_Name",
                       Test_Get_Event_Name'Access);
      Caller.Add_Test (Suite, "Test AWA.Events.Find_Event_Index",
                       Test_Find_Event'Access);
      Caller.Add_Test (Suite, "Test AWA.Events.Initialize",
                       Test_Initialize'Access);
      Caller.Add_Test (Suite, "Test AWA.Events.Add_Action",
                       Test_Add_Action'Access);
      Caller.Add_Test (Suite, "Test AWA.Events.Dispatch_Synchronous",
                       Test_Dispatch_Synchronous'Access);
      Caller.Add_Test (Suite, "Test AWA.Events.Dispatch_Fifo",
                       Test_Dispatch_Fifo'Access);
      Caller.Add_Test (Suite, "Test AWA.Events.Dispatch_Persist",
                       Test_Dispatch_Persist'Access);
      Caller.Add_Test (Suite, "Test AWA.Events.Dispatch_Synchronous_Dyn",
                       Test_Dispatch_Synchronous_Dyn'Access);
      Caller.Add_Test (Suite, "Test AWA.Events.Dispatch_Synchronous_Raise",
                       Test_Dispatch_Synchronous_Raise'Access);
   end Add_Tests;

   package Event_Action_Binding is
     new AWA.Events.Action_Method.Bind (Bean => Action_Bean,
                                        Method => Event_Action,
                                        Name   => "send");

   Binding_Array : aliased constant Util.Beans.Methods.Method_Binding_Array
     := (1 => Event_Action_Binding.Proxy'Access);

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Action_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
      pragma Unreferenced (From, Name);
   begin
      return Util.Beans.Objects.Null_Object;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Action_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "priority" then
         From.Priority := Util.Beans.Objects.To_Integer (Value);
      elsif Name = "raise_exception" then
         From.Raise_Exception := Util.Beans.Objects.To_Boolean (Value);
      end if;
   end Set_Value;

   overriding
   function Get_Method_Bindings (From : in Action_Bean)
                                 return Util.Beans.Methods.Method_Binding_Array_Access is
      pragma Unreferenced (From);
   begin
      return Binding_Array'Access;
   end Get_Method_Bindings;

   Action_Exception : exception;
   Global_Counter   : Util.Concurrent.Counters.Counter;

   procedure Event_Action (From  : in out Action_Bean;
                           Event : in AWA.Events.Module_Event'Class) is
      pragma Unreferenced (Event);
   begin
      if From.Raise_Exception then
         raise Action_Exception with "Raising an exception from the event action bean";
      end if;
      From.Count := From.Count + 1;
      Util.Concurrent.Counters.Increment (Global_Counter);
   end Event_Action;

   function Create_Action_Bean return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Action_Bean_Access := new Action_Bean;
   begin
      return Result.all'Access;
   end Create_Action_Bean;

   --  ------------------------------
   --  Test searching an event name in the definition list.
   --  ------------------------------
   procedure Test_Find_Event (T : in out Test) is
   begin
      Util.Tests.Assert_Equals (T, Integer (Event_Test_4.Kind),
                                Integer (Find_Event_Index ("event-test-4")), "Find_Event");
      Util.Tests.Assert_Equals (T, Integer (Event_Test_5.Kind),
                                Integer (Find_Event_Index ("event-test-5")), "Find_Event");
      Util.Tests.Assert_Equals (T, Integer (Event_Test_1.Kind),
                                Integer (Find_Event_Index ("event-test-1")), "Find_Event");
   end Test_Find_Event;

   --  ------------------------------
   --  Test the Get_Event_Type_Name internal operation.
   --  ------------------------------
   procedure Test_Get_Event_Name (T : in out Test) is
   begin
      Util.Tests.Assert_Equals (T, "event-test-1", Get_Event_Type_Name (Event_Test_1.Kind).all,
                                "Get_Event_Type_Name");
      Util.Tests.Assert_Equals (T, "event-test-2", Get_Event_Type_Name (Event_Test_2.Kind).all,
                                "Get_Event_Type_Name");
      Util.Tests.Assert_Equals (T, "event-test-3", Get_Event_Type_Name (Event_Test_3.Kind).all,
                                "Get_Event_Type_Name");
      Util.Tests.Assert_Equals (T, "event-test-4", Get_Event_Type_Name (Event_Test_4.Kind).all,
                                "Get_Event_Type_Name");
      Util.Tests.Assert_Equals (T, "event-test-5", Get_Event_Type_Name (Event_Test_5.Kind).all,
                                "Get_Event_Type_Name");
   end Test_Get_Event_Name;

   --  ------------------------------
   --  Test creation and initialization of event manager.
   --  ------------------------------
   procedure Test_Initialize (T : in out Test) is
      App     : constant AWA.Applications.Application_Access := AWA.Tests.Get_Application;
      Manager : Event_Manager;
   begin
      Manager.Initialize (App.all'Access);
      T.Assert (Manager.Actions /= null, "Initialization failed");
   end Test_Initialize;

   --  ------------------------------
   --  Test adding an action.
   --  ------------------------------
   procedure Test_Add_Action (T : in out Test) is
      App     : constant AWA.Applications.Application_Access := AWA.Tests.Get_Application;
      Manager : Event_Manager;
      Ctx     : EL.Contexts.Default.Default_Context;
      Action  : constant EL.Expressions.Method_Expression
        := EL.Expressions.Create_Expression ("#{a.send}", Ctx);
      Props   : EL.Beans.Param_Vectors.Vector;
      Queue   : Queue_Ref;
      Index   : constant Event_Index := Find_Event_Index ("event-test-4");
   begin
      Manager.Initialize (App.all'Access);

      Queue := AWA.Events.Queues.Create_Queue ("test", "fifo", Props, Ctx);
      Manager.Add_Queue (Queue);
      for I in 1 .. 10 loop
         Manager.Add_Action (Event  => "event-test-4",
                             Queue  => Queue,
                             Action => Action,
                             Params => Props);
         Util.Tests.Assert_Equals (T, 1, Integer (Manager.Actions (Index).Queues.Length),
                                   "Add_Action failed");
      end loop;

   end Test_Add_Action;

   --  ------------------------------
   --  Test dispatching events
   --  ------------------------------
   procedure Dispatch_Event (T            : in out Test;
                             Kind         : in Event_Index;
                             Expect_Count : in Natural;
                             Expect_Prio  : in Natural) is

      Factory : AWA.Applications.Factory.Application_Factory;
      Conf    : ASF.Applications.Config;
      Ctx     : aliased EL.Contexts.Default.Default_Context;
      Path    : constant String := Util.Tests.Get_Test_Path ("regtests/config/event-test.xml");
      Action  : aliased Action_Bean;
   begin
      Conf.Set ("database", Util.Tests.Get_Parameter ("database"));

      declare
         App   : aliased AWA.Tests.Test_Application;
         S     : Util.Measures.Stamp;
         Faces : aliased ASF.Servlets.Faces.Faces_Servlet;
         SC    : AWA.Services.Contexts.Service_Context;
      begin
         App.Initialize (Conf    => Conf,
                         Factory => Factory);
         App.Set_Global ("event_test",
           Util.Beans.Objects.To_Object (Action'Unchecked_Access,
             Util.Beans.Objects.STATIC));

         SC.Set_Context (App'Unchecked_Access, null);

         App.Add_Servlet (Name => "faces", Server => Faces'Unchecked_Access);
         App.Register_Class ("AWA.Events.Tests.Event_Action",
                             Create_Action_Bean'Access);
         AWA.Applications.Configs.Read_Configuration (App     => App,
                                                      File    => Path,
                                                      Context => Ctx'Unchecked_Access,
                                                      Override_Context => True);
         Util.Measures.Report (S, "Initialize AWA application and read config");
         App.Start;
         Util.Measures.Report (S, "Start event tasks");

         for I in 1 .. 100 loop
            declare
               Event : Module_Event;
            begin
               Event.Set_Event_Kind (Kind);
               Event.Set_Parameter ("prio", "3");
               Event.Set_Parameter ("template", "def");
               App.Send_Event (Event);
            end;
         end loop;
         Util.Measures.Report (S, "Send 100 events");

         --  Wait for the dispatcher to process the events but do not wait more than 10 secs.
         for I in 1 .. 10_000 loop
            exit when Action.Count = Expect_Count;

            delay 0.1;
         end loop;
      end;

      Log.Info ("Action count: {0}", Natural'Image (Action.Count));
      Log.Info ("Priority: {0}", Integer'Image (Action.Priority));
      Util.Tests.Assert_Equals (T, Expect_Count, Action.Count,
                                "invalid number of calls for the action (global bean)");
      Util.Tests.Assert_Equals (T, Expect_Prio, Action.Priority,
                                "prio parameter not transmitted (global bean)");
   end Dispatch_Event;

   --  ------------------------------
   --  Test dispatching synchronous event to a global bean.
   --  ------------------------------
   procedure Test_Dispatch_Synchronous (T : in out Test) is
   begin
      T.Dispatch_Event (Event_Test_1.Kind, 500, 3);
   end Test_Dispatch_Synchronous;

   --  ------------------------------
   --  Test dispatching event through a fifo queue.
   --  ------------------------------
   procedure Test_Dispatch_Fifo (T : in out Test) is
   begin
      T.Dispatch_Event (Event_Test_2.Kind, 200, 3);
   end Test_Dispatch_Fifo;

   --  ------------------------------
   --  Test dispatching event through a database queue.
   --  ------------------------------
   procedure Test_Dispatch_Persist (T : in out Test) is
   begin
      T.Dispatch_Event (Event_Test_5.Kind, 100, 3);
   end Test_Dispatch_Persist;

   --  ------------------------------
   --  Test dispatching synchronous event to a dynamic bean (created on demand).
   --  ------------------------------
   procedure Test_Dispatch_Synchronous_Dyn (T : in out Test) is
   begin
      T.Dispatch_Event (Event_Test_3.Kind, 0, 0);
   end Test_Dispatch_Synchronous_Dyn;

   --  ------------------------------
   --  Test dispatching synchronous event to a dynamic bean and raise an exception in the action.
   --  ------------------------------
   procedure Test_Dispatch_Synchronous_Raise (T : in out Test) is
   begin
      T.Dispatch_Event (Event_Test_4.Kind, 0, 0);
   end Test_Dispatch_Synchronous_Raise;

end AWA.Events.Services.Tests;

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

with Util.Test_Caller;
with Util.Log.Loggers;
with Util.Measures;
with Util.Concurrent.Counters;

with EL.Beans;
with EL.Expressions;
with EL.Contexts.Default;

with ASF.Applications;
with ASF.Servlets.Faces;

with AWA.Applications;
with AWA.Applications.Configs;
with AWA.Applications.Factory;
with AWA.Events.Action_Method;
with AWA.Services.Contexts;

with AWA.Events.Queues;
with AWA.Events.Services;

package body AWA.Events.Services.Tests is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Events.Tests");

   package Event_Test_4 is new AWA.Events.Definition (Name => "event-test-4");
   package Event_Test_1 is new AWA.Events.Definition (Name => "event-test-1");
   package Event_Test_3 is new AWA.Events.Definition (Name => "event-test-3");
   package Event_Test_2 is new AWA.Events.Definition (Name => "event-test-2");
   package Event_Test_5 is new AWA.Events.Definition (Name => "event-test-5");

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Events.Get_Event_Name",
                       Test_Get_Event_Name'Access);
      Caller.Add_Test (Suite, "Test AWA.Events.Find_Event_Index",
                       Test_Find_Event'Access);
      Caller.Add_Test (Suite, "Test AWA.Events.Initialize",
                       Test_Initialize'Access);
      Caller.Add_Test (Suite, "Test AWA.Events.Add_Action",
                       Test_Add_Action'Access);
      Caller.Add_Test (Suite, "Test AWA.Events.Dispatch_Synchronous",
                       Test_Dispatch_Synchronous'Access);
      Caller.Add_Test (Suite, "Test AWA.Events.Dispatch_Fifo",
                       Test_Dispatch_Fifo'Access);
      Caller.Add_Test (Suite, "Test AWA.Events.Dispatch_Persist",
                       Test_Dispatch_Persist'Access);
      Caller.Add_Test (Suite, "Test AWA.Events.Dispatch_Synchronous_Dyn",
                       Test_Dispatch_Synchronous_Dyn'Access);
      Caller.Add_Test (Suite, "Test AWA.Events.Dispatch_Synchronous_Raise",
                       Test_Dispatch_Synchronous_Raise'Access);
   end Add_Tests;

   package Event_Action_Binding is
     new AWA.Events.Action_Method.Bind (Bean => Action_Bean,
                                        Method => Event_Action,
                                        Name   => "send");

   Binding_Array : aliased constant Util.Beans.Methods.Method_Binding_Array
     := (1 => Event_Action_Binding.Proxy'Access);

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Action_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
      pragma Unreferenced (From, Name);
   begin
      return Util.Beans.Objects.Null_Object;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Action_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "priority" then
         From.Priority := Util.Beans.Objects.To_Integer (Value);
      elsif Name = "raise_exception" then
         From.Raise_Exception := Util.Beans.Objects.To_Boolean (Value);
      end if;
   end Set_Value;

   overriding
   function Get_Method_Bindings (From : in Action_Bean)
                                 return Util.Beans.Methods.Method_Binding_Array_Access is
      pragma Unreferenced (From);
   begin
      return Binding_Array'Access;
   end Get_Method_Bindings;

   Action_Exception : exception;
   Global_Counter   : Util.Concurrent.Counters.Counter;

   procedure Event_Action (From  : in out Action_Bean;
                           Event : in AWA.Events.Module_Event'Class) is
      pragma Unreferenced (Event);
   begin
      if From.Raise_Exception then
         raise Action_Exception with "Raising an exception from the event action bean";
      end if;
      From.Count := From.Count + 1;
      Util.Concurrent.Counters.Increment (Global_Counter);
   end Event_Action;

   function Create_Action_Bean return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Action_Bean_Access := new Action_Bean;
   begin
      return Result.all'Access;
   end Create_Action_Bean;

   --  ------------------------------
   --  Test searching an event name in the definition list.
   --  ------------------------------
   procedure Test_Find_Event (T : in out Test) is
   begin
      Util.Tests.Assert_Equals (T, Integer (Event_Test_4.Kind),
                                Integer (Find_Event_Index ("event-test-4")), "Find_Event");
      Util.Tests.Assert_Equals (T, Integer (Event_Test_5.Kind),
                                Integer (Find_Event_Index ("event-test-5")), "Find_Event");
      Util.Tests.Assert_Equals (T, Integer (Event_Test_1.Kind),
                                Integer (Find_Event_Index ("event-test-1")), "Find_Event");
   end Test_Find_Event;

   --  ------------------------------
   --  Test the Get_Event_Type_Name internal operation.
   --  ------------------------------
   procedure Test_Get_Event_Name (T : in out Test) is
   begin
      Util.Tests.Assert_Equals (T, "event-test-1", Get_Event_Type_Name (Event_Test_1.Kind).all,
                                "Get_Event_Type_Name");
      Util.Tests.Assert_Equals (T, "event-test-2", Get_Event_Type_Name (Event_Test_2.Kind).all,
                                "Get_Event_Type_Name");
      Util.Tests.Assert_Equals (T, "event-test-3", Get_Event_Type_Name (Event_Test_3.Kind).all,
                                "Get_Event_Type_Name");
      Util.Tests.Assert_Equals (T, "event-test-4", Get_Event_Type_Name (Event_Test_4.Kind).all,
                                "Get_Event_Type_Name");
      Util.Tests.Assert_Equals (T, "event-test-5", Get_Event_Type_Name (Event_Test_5.Kind).all,
                                "Get_Event_Type_Name");
   end Test_Get_Event_Name;

   --  ------------------------------
   --  Test creation and initialization of event manager.
   --  ------------------------------
   procedure Test_Initialize (T : in out Test) is
      App     : constant AWA.Applications.Application_Access := AWA.Tests.Get_Application;
      Manager : Event_Manager;
   begin
      Manager.Initialize (App.all'Access);
      T.Assert (Manager.Actions /= null, "Initialization failed");
   end Test_Initialize;

   --  ------------------------------
   --  Test adding an action.
   --  ------------------------------
   procedure Test_Add_Action (T : in out Test) is
      App     : constant AWA.Applications.Application_Access := AWA.Tests.Get_Application;
      Manager : Event_Manager;
      Ctx     : EL.Contexts.Default.Default_Context;
      Action  : constant EL.Expressions.Method_Expression
        := EL.Expressions.Create_Expression ("#{a.send}", Ctx);
      Props   : EL.Beans.Param_Vectors.Vector;
      Queue   : Queue_Ref;
      Index   : constant Event_Index := Find_Event_Index ("event-test-4");
   begin
      Manager.Initialize (App.all'Access);

      Queue := AWA.Events.Queues.Create_Queue ("test", "fifo", Props, Ctx);
      Manager.Add_Queue (Queue);
      for I in 1 .. 10 loop
         Manager.Add_Action (Event  => "event-test-4",
                             Queue  => Queue,
                             Action => Action,
                             Params => Props);
         Util.Tests.Assert_Equals (T, 1, Integer (Manager.Actions (Index).Queues.Length),
                                   "Add_Action failed");
      end loop;

   end Test_Add_Action;

   --  ------------------------------
   --  Test dispatching events
   --  ------------------------------
   procedure Dispatch_Event (T            : in out Test;
                             Kind         : in Event_Index;
                             Expect_Count : in Natural;
                             Expect_Prio  : in Natural) is

      Factory : AWA.Applications.Factory.Application_Factory;
      Conf    : ASF.Applications.Config;
      Ctx     : aliased EL.Contexts.Default.Default_Context;
      Path    : constant String := Util.Tests.Get_Path ("regtests/config/event-test.xml");
      Action  : aliased Action_Bean;
   begin
      Conf.Set ("database", Util.Tests.Get_Parameter ("database"));

      declare
         App   : aliased AWA.Tests.Test_Application;
         S     : Util.Measures.Stamp;
         Faces : aliased ASF.Servlets.Faces.Faces_Servlet;
         SC    : AWA.Services.Contexts.Service_Context;
      begin
         App.Initialize (Conf    => Conf,
                         Factory => Factory);
         App.Set_Global ("event_test",
           Util.Beans.Objects.To_Object (Action'Unchecked_Access,
             Util.Beans.Objects.STATIC));

         SC.Set_Context (App'Unchecked_Access, null);

         App.Add_Servlet (Name => "faces", Server => Faces'Unchecked_Access);
         App.Register_Class ("AWA.Events.Tests.Event_Action",
                             Create_Action_Bean'Access);
         AWA.Applications.Configs.Read_Configuration (App     => App,
                                                      File    => Path,
                                                      Context => Ctx'Unchecked_Access,
                                                      Override_Context => True);
         Util.Measures.Report (S, "Initialize AWA application and read config");
         App.Start;
         Util.Measures.Report (S, "Start event tasks");

         for I in 1 .. 100 loop
            declare
               Event : Module_Event;
            begin
               Event.Set_Event_Kind (Kind);
               Event.Set_Parameter ("prio", "3");
               Event.Set_Parameter ("template", "def");
               App.Send_Event (Event);
            end;
         end loop;
         Util.Measures.Report (S, "Send 100 events");

         --  Wait for the dispatcher to process the events but do not wait more than 10 secs.
         for I in 1 .. 10_000 loop
            exit when Action.Count = Expect_Count;

            delay 0.1;
         end loop;
      end;

      Log.Info ("Action count: {0}", Natural'Image (Action.Count));
      Log.Info ("Priority: {0}", Integer'Image (Action.Priority));
      Util.Tests.Assert_Equals (T, Expect_Count, Action.Count,
                                "invalid number of calls for the action (global bean)");
      Util.Tests.Assert_Equals (T, Expect_Prio, Action.Priority,
                                "prio parameter not transmitted (global bean)");
   end Dispatch_Event;

   --  ------------------------------
   --  Test dispatching synchronous event to a global bean.
   --  ------------------------------
   procedure Test_Dispatch_Synchronous (T : in out Test) is
   begin
      T.Dispatch_Event (Event_Test_1.Kind, 500, 3);
   end Test_Dispatch_Synchronous;

   --  ------------------------------
   --  Test dispatching event through a fifo queue.
   --  ------------------------------
   procedure Test_Dispatch_Fifo (T : in out Test) is
   begin
      T.Dispatch_Event (Event_Test_2.Kind, 200, 3);
   end Test_Dispatch_Fifo;

   --  ------------------------------
   --  Test dispatching event through a database queue.
   --  ------------------------------
   procedure Test_Dispatch_Persist (T : in out Test) is
   begin
      T.Dispatch_Event (Event_Test_5.Kind, 100, 3);
   end Test_Dispatch_Persist;

   --  ------------------------------
   --  Test dispatching synchronous event to a dynamic bean (created on demand).
   --  ------------------------------
   procedure Test_Dispatch_Synchronous_Dyn (T : in out Test) is
   begin
      T.Dispatch_Event (Event_Test_3.Kind, 0, 0);
   end Test_Dispatch_Synchronous_Dyn;

   --  ------------------------------
   --  Test dispatching synchronous event to a dynamic bean and raise an exception in the action.
   --  ------------------------------
   procedure Test_Dispatch_Synchronous_Raise (T : in out Test) is
   begin
      T.Dispatch_Event (Event_Test_4.Kind, 0, 0);
   end Test_Dispatch_Synchronous_Raise;

end AWA.Events.Services.Tests;

Replace Util.Tests.Get_Test_Path by Util.Tests.Get_Path


-----------------------------------------------------------------------
--  security-filters-oauth -- OAuth Security filter
--  Copyright (C) 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 ASF.Filters;
with ASF.Requests;
with ASF.Responses;
with ASF.Servlets;
with Security.OAuth.Servers; use Security.OAuth;
with Security.Policies;

--  The ASF.Security.Filters.OAuth package provides a servlet filter that
--  implements the RFC 6749 "Accessing Protected Resources" part: it extracts the OAuth
--  access token, verifies the grant and the permission.  The servlet filter implements
--  the RFC 6750 "OAuth 2.0 Bearer Token Usage".
--
package ASF.Security.Filters.OAuth is

   --  RFC 2617 HTTP header for authorization.
   AUTHORIZATION_HEADER_NAME    : constant String := "Authorization";

   --  RFC 2617 HTTP header for failed authorization.
   WWW_AUTHENTICATE_HEADER_NAME : constant String := "WWW-Authenticate";

   type Auth_Filter is new ASF.Filters.Filter with private;

   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   overriding
   procedure Initialize (Server  : in out Auth_Filter;
                         Config  : in ASF.Servlets.Filter_Config);

   --  Set the permission manager that must be used to verify the permission.
   procedure Set_Permission_Manager (Filter  : in out Auth_Filter;
                                     Manager : in Policies.Policy_Manager_Access);

   --  Filter the request to make sure the user is authenticated.
   --  Invokes the Do_Login procedure if there is no user.
   --  If a permission manager is defined, check that the user has the permission
   --  to view the page.  Invokes the Do_Deny procedure if the permission
   --  is denied.
   procedure Do_Filter (F        : in Auth_Filter;
                        Request  : in out ASF.Requests.Request'Class;
                        Response : in out ASF.Responses.Response'Class;
                        Chain    : in out ASF.Servlets.Filter_Chain);

   --  Display or redirects the user to the login page.  This procedure is called when
   --  the user is not authenticated.
   procedure Do_Login (F        : in Auth_Filter;
                       Request  : in out ASF.Requests.Request'Class;
                       Response : in out ASF.Responses.Response'Class);

   --  Display the forbidden access page.  This procedure is called when the user is not
   --  authorized to see the page.  The default implementation returns the SC_FORBIDDEN error.
   procedure Do_Deny (F        : in Auth_Filter;
                      Request  : in out ASF.Requests.Request'Class;
                      Response : in out ASF.Responses.Response'Class);

private

   type Auth_Filter is new ASF.Filters.Filter with record
      Manager   : Policies.Policy_Manager_Access;
      Realm     : Servers.Auth_Manager_Access;
      Realm_URL : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end ASF.Security.Filters.OAuth;

-----------------------------------------------------------------------
--  security-filters-oauth -- OAuth Security filter
--  Copyright (C) 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 ASF.Filters;
with ASF.Requests;
with ASF.Responses;
with ASF.Servlets;
with Security.OAuth.Servers; use Security.OAuth;
with Security.Policies;
with Servlet.Security.Filters.OAuth;

--  The <b>ASF.Security.Filters.OAuth</b> package provides a servlet filter that
--  implements the RFC 6749 "Accessing Protected Resources" part: it extracts the OAuth
--  access token, verifies the grant and the permission.  The servlet filter implements
--  the RFC 6750 "OAuth 2.0 Bearer Token Usage".
--
package ASF.Security.Filters.OAuth renames Servlet.Security.Filters.OAuth;

Package ASF.Security.Filters moved to Servlet.Security.Filters


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

package body ADO.C is

   use Ada.Strings.Unbounded;
   use type Interfaces.C.Strings.chars_ptr;

   --  ------------------------------
   --  Convert a string to a C string.
   --  ------------------------------
   function To_String_Ptr (S : String) return String_Ptr is
   begin
      return Result : String_Ptr do
         Result.Ptr := Strings.New_String (S);
      end return;
   end To_String_Ptr;

   --  ------------------------------
   --  Get the C string pointer.
   --  ------------------------------
   function To_C (S : String_Ptr) return Interfaces.C.Strings.chars_ptr is
   begin
      return S.Ptr;
   end To_C;

   --  ------------------------------
   --  Set the string
   --  ------------------------------
   procedure Set_String (S     : in out String_Ptr;
                         Value : in String) is
   begin
      if S.Ptr /= Interfaces.C.Strings.Null_Ptr then
         Strings.Free (S.Ptr);
      end if;
      S.Ptr := Strings.New_String (Value);
   end Set_String;

   --  ------------------------------
   --  Reclaim the storage held by the C string.
   --  ------------------------------
   procedure Finalize (S : in out String_Ptr) is
   begin
      Strings.Free (S.Ptr);
   end Finalize;

end ADO.C;

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

package body ADO.C is

   use type Interfaces.C.Strings.chars_ptr;

   --  ------------------------------
   --  Convert a string to a C string.
   --  ------------------------------
   function To_String_Ptr (S : String) return String_Ptr is
   begin
      return Result : String_Ptr do
         Result.Ptr := Strings.New_String (S);
      end return;
   end To_String_Ptr;

   --  ------------------------------
   --  Get the C string pointer.
   --  ------------------------------
   function To_C (S : String_Ptr) return Interfaces.C.Strings.chars_ptr is
   begin
      return S.Ptr;
   end To_C;

   --  ------------------------------
   --  Set the string
   --  ------------------------------
   procedure Set_String (S     : in out String_Ptr;
                         Value : in String) is
   begin
      if S.Ptr /= Interfaces.C.Strings.Null_Ptr then
         Strings.Free (S.Ptr);
      end if;
      S.Ptr := Strings.New_String (Value);
   end Set_String;

   --  ------------------------------
   --  Reclaim the storage held by the C string.
   --  ------------------------------
   procedure Finalize (S : in out String_Ptr) is
   begin
      Strings.Free (S.Ptr);
   end Finalize;

end ADO.C;

Fix compilation warning

Fix compilation warning