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

with Ada.Strings.Unbounded;

--  == Role Based Security Policy ==
--  The <tt>Security.Policies.Roles</tt> package implements a role based security policy.
--
--  A role is represented by a name in security configuration files.  A role based permission
--  is associated with a list of roles.  The permission is granted if the user has one of these
--  roles.
--
--    <security-role>
--      <role-name>admin</role-name>
--    </security-role>
--    <security-role>
--      <role-name>manager</role-name>
--    </security-role>
--    <role-permission>
--      <name>create-workspace</name>
--      <role>admin</role>
--      <role>manager</role>
--    </role-permission>
--
--  This definition declares two roles: <tt>admin</tt> and <tt>manager</tt>
--  It defines a permission create-workspace that will be granted if the
--  user has either the admin or the manager role.
--
--  A <tt>Security_Context</tt> must be associated with a set of roles before checking the
--  permission.  This is done by using the <tt>Set_Role_Context</tt> operation:
--
--     Security.Policies.Roles.Set_Role_Context (Security.Contexts.Current, "admin");
--
package Security.Policies.Roles is

   NAME : constant String := "Role-Policy";

   --  Each role is represented by a Role_Type number to provide a fast
   --  and efficient role check.
   type Role_Type is new Natural range 0 .. 63;
   for Role_Type'Size use 8;

   type Role_Type_Array is array (Positive range <>) of Role_Type;

   --  The Role_Map represents a set of roles which are assigned to a user.
   --  Each role is represented by a boolean in the map.  The implementation is limited
   --  to 64 roles (the number of different permissions can be higher).
   type Role_Map is array (Role_Type'Range) of Boolean;
   pragma Pack (Role_Map);

   --  ------------------------------
   --  Policy context
   --  ------------------------------
   --  The Role_Policy_Context gives security context information that the role
   --  based policy can use to verify the permission.
   type Role_Policy_Context is new Policy_Context with record
      Roles : Role_Map;
   end record;
   type Role_Policy_Context_Access is access all Role_Policy_Context'Class;

   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in Role_Map);

   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in String);

   --  ------------------------------
   --  Role based policy
   --  ------------------------------
   type Role_Policy is new Policy with private;
   type Role_Policy_Access is access all Role_Policy'Class;

   Invalid_Name : exception;

   --  Get the policy name.
   overriding
   function Get_Name (From : in Role_Policy) return String;

   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type;

   --  Get the role name.
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String;

   --  Create a role
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type);

   --  Get or add a role type for the given name.
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type);

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

   --  Setup the XML parser to read the role-permission description.
   overriding
   procedure Prepare_Config (Policy : in out Role_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser);

   --  Finalize the policy manager.
   overriding
   procedure Finalize (Policy : in out Role_Policy);

private

   type Role_Name_Array is
     array (Role_Type'Range) of Ada.Strings.Unbounded.String_Access;

   type Role_Policy is new Policy with record
      Names        : Role_Name_Array;
      Next_Role    : Role_Type := Role_Type'First;
   end record;

   type Controller_Config is record
      Name    : Util.Beans.Objects.Object;
      Roles   : Role_Type_Array (1 .. Integer (Role_Type'Last));
      Count   : Natural := 0;
      Manager : Role_Policy_Access;
   end record;

end Security.Policies.Roles;

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

with Ada.Strings.Unbounded;

--  == Role Based Security Policy ==
--  The <tt>Security.Policies.Roles</tt> package implements a role based security policy.
--
--  === Policy creation ===
--  An instance of the <tt>Role_Policy</tt> must be created and registered in the policy manager.
--  Get or declare the following variables:
--
--    Manager : Security.Policies.Policy_Manager;
--    Policy  : Security.Policies.Roles.Role_Policy_Access;
--
--  Create the role policy and register it in the policy manager as follows:
--
--    Policy := new Role_Policy;
--    Manager.Add_Policy (Policy.all'Access);
--
--  === Policy Configuration ===
--  A role is represented by a name in security configuration files.  A role based permission
--  is associated with a list of roles.  The permission is granted if the user has one of these
--  roles.  When the role based policy is registered in the policy manager, the following
--  XML configuration is used:
--
--    <security-role>
--      <role-name>admin</role-name>
--    </security-role>
--    <security-role>
--      <role-name>manager</role-name>
--    </security-role>
--    <role-permission>
--      <name>create-workspace</name>
--      <role>admin</role>
--      <role>manager</role>
--    </role-permission>
--
--  This definition declares two roles: <tt>admin</tt> and <tt>manager</tt>
--  It defines a permission create-workspace that will be granted if the
--  user has either the admin or the manager role.
--
--  Each role is identified by a name in the configuration file.  It is represented by
--  a <tt>Role_Type</tt>.  To provide an efficient implementation, the <tt>Role_Type</tt>
--  is represented as an integer with a limit of 64 different roles.
--
--  === Assigning roles to users ===
--  A <tt>Security_Context</tt> must be associated with a set of roles before checking the
--  permission.  This is done by using the <tt>Set_Role_Context</tt> operation:
--
--     Security.Policies.Roles.Set_Role_Context (Security.Contexts.Current, "admin");
--
package Security.Policies.Roles is

   NAME : constant String := "Role-Policy";

   --  Each role is represented by a Role_Type number to provide a fast
   --  and efficient role check.
   type Role_Type is new Natural range 0 .. 63;
   for Role_Type'Size use 8;

   type Role_Type_Array is array (Positive range <>) of Role_Type;

   --  The Role_Map represents a set of roles which are assigned to a user.
   --  Each role is represented by a boolean in the map.  The implementation is limited
   --  to 64 roles (the number of different permissions can be higher).
   type Role_Map is array (Role_Type'Range) of Boolean;
   pragma Pack (Role_Map);

   --  ------------------------------
   --  Policy context
   --  ------------------------------
   --  The Role_Policy_Context gives security context information that the role
   --  based policy can use to verify the permission.
   type Role_Policy_Context is new Policy_Context with record
      Roles : Role_Map;
   end record;
   type Role_Policy_Context_Access is access all Role_Policy_Context'Class;

   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in Role_Map);

   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in String);

   --  ------------------------------
   --  Role based policy
   --  ------------------------------
   type Role_Policy is new Policy with private;
   type Role_Policy_Access is access all Role_Policy'Class;

   Invalid_Name : exception;

   --  Get the policy name.
   overriding
   function Get_Name (From : in Role_Policy) return String;

   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type;

   --  Get the role name.
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String;

   --  Create a role
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type);

   --  Get or add a role type for the given name.
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type);

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

   --  Setup the XML parser to read the role-permission description.
   overriding
   procedure Prepare_Config (Policy : in out Role_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser);

   --  Finalize the policy manager.
   overriding
   procedure Finalize (Policy : in out Role_Policy);

private

   type Role_Name_Array is
     array (Role_Type'Range) of Ada.Strings.Unbounded.String_Access;

   type Role_Policy is new Policy with record
      Names        : Role_Name_Array;
      Next_Role    : Role_Type := Role_Type'First;
   end record;

   type Controller_Config is record
      Name    : Util.Beans.Objects.Object;
      Roles   : Role_Type_Array (1 .. Integer (Role_Type'Last));
      Count   : Natural := 0;
      Manager : Role_Policy_Access;
   end record;

end Security.Policies.Roles;

Document the role based policy

Document the role based policy


-----------------------------------------------------------------------
--  util-http-clients -- HTTP Clients
--  Copyright (C) 2011, 2012, 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 Ada.Finalization;

with Util.Http.Cookies;

--  == Client ==
--  The <tt>Util.Http.Clients</tt> package defines a set of API for an HTTP client to send
--  requests to an HTTP server.
--
--  === GET request ===
--  To retrieve a content using the HTTP GET operation, a client instance must be created.
--  The response is returned in a specific object that must therefore be declared:
--
--    Http     : Util.Http.Clients.Client;
--    Response : Util.Http.Clients.Response;
--
--  Before invoking the GET operation, the client can setup a number of HTTP headers.
--
--    Http.Add_Header ("X-Requested-By", "wget");
--
--  The GET operation is performed when the <tt>Get</tt> procedure is called:
--
--    Http.Get ("http://www.google.com", Response);
--
--  Once the response is received, the <tt>Response</tt> object contains the status of the
--  HTTP response, the HTTP reply headers and the body.  A response header can be obtained
--  by using the <tt>Get_Header</tt> function and the body using <tt>Get_Body</tt>:
--
--    Body : constant String := Response.Get_Body;
--
package Util.Http.Clients is

   Connection_Error : exception;

   --  ------------------------------
   --  Http response
   --  ------------------------------
   --  The Response type represents a response returned by an HTTP request.
   type Response is limited new Abstract_Response with private;

   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   overriding
   function Contains_Header (Reply : in Response;
                             Name  : in String) return Boolean;

   --  Returns the value of the specified response header as a String. If the response
   --  did not include a header of the specified name, this method returns null.
   --  If there are multiple headers with the same name, this method returns the
   --  first head in the request. The header name is case insensitive. You can use
   --  this method with any response header.
   overriding
   function Get_Header (Reply  : in Response;
                        Name   : in String) return String;

   --  Sets a message header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   overriding
   procedure Set_Header (Reply    : in out Response;
                         Name     : in String;
                         Value    : in String);

   --  Adds a request header with the given name and value.
   --  This method allows request headers to have multiple values.
   overriding
   procedure Add_Header (Reply   : in out Response;
                         Name    : in String;
                         Value   : in String);

   --  Iterate over the response headers and executes the Process procedure.
   overriding
   procedure Iterate_Headers (Reply   : in Response;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String));

   --  Get the response body as a string.
   overriding
   function Get_Body (Reply : in Response) return String;

   --  Get the response status code.
   overriding
   function Get_Status (Reply : in Response) return Natural;

   --  ------------------------------
   --  Http client
   --  ------------------------------
   --  The Client type allows to execute HTTP GET/POST requests.
   type Client is limited new Abstract_Request with private;
   type Client_Access is access all Client;

   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   overriding
   function Contains_Header (Request : in Client;
                             Name    : in String) return Boolean;

   --  Returns the value of the specified request header as a String. If the request
   --  did not include a header of the specified name, this method returns null.
   --  If there are multiple headers with the same name, this method returns the
   --  first head in the request. The header name is case insensitive. You can use
   --  this method with any response header.
   overriding
   function Get_Header (Request : in Client;
                        Name    : in String) return String;

   --  Sets a header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   overriding
   procedure Set_Header (Request  : in out Client;
                         Name     : in String;
                         Value    : in String);

   --  Adds a header with the given name and value.
   --  This method allows headers to have multiple values.
   overriding
   procedure Add_Header (Request  : in out Client;
                         Name     : in String;
                         Value    : in String);

   --  Iterate over the request headers and executes the Process procedure.
   overriding
   procedure Iterate_Headers (Request : in Client;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String));

   --  Removes all headers with the given name.
   procedure Remove_Header (Request : in out Client;
                            Name    : in String);

   --  Adds the specified cookie to the request.  This method can be called multiple
   --  times to set more than one cookie.
   procedure Add_Cookie (Http   : in out Client;
                         Cookie : in Util.Http.Cookies.Cookie);

   --  Set the timeout for the connection.
   procedure Set_Timeout (Request : in out Client;
                          Timeout : in Duration);

   --  Execute an http GET request on the given URL.  Additional request parameters,
   --  cookies and headers should have been set on the client object.
   procedure Get (Request  : in out Client;
                  URL      : in String;
                  Reply    : out Response'Class);

   --  Execute an http POST request on the given URL.  The post data is passed in Data.
   --  Additional request cookies and headers should have been set on the client object.
   procedure Post (Request : in out Client;
                   URL     : in String;
                   Data    : in String;
                   Reply   : out Response'Class);

   --  Execute an http PUT request on the given URL.  The post data is passed in Data.
   --  Additional request cookies and headers should have been set on the client object.
   procedure Put (Request : in out Client;
                  URL     : in String;
                  Data    : in String;
                  Reply   : out Response'Class);

   --  Execute a http DELETE request on the given URL.
   procedure Delete (Request : in out Client;
                     URL     : in String;
                     Reply   : out Response'Class);

private

   subtype Http_Request is Abstract_Request;
   subtype Http_Request_Access is Abstract_Request_Access;

   subtype Http_Response is Abstract_Response;
   subtype Http_Response_Access is Abstract_Response_Access;

   type Http_Manager is interface;
   type Http_Manager_Access is access all Http_Manager'Class;

   procedure Create (Manager  : in Http_Manager;
                     Http     : in out Client'Class) is abstract;

   procedure Do_Get (Manager  : in Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Reply    : out Response'Class) is abstract;

   procedure Do_Post (Manager  : in Http_Manager;
                      Http     : in Client'Class;
                      URI      : in String;
                      Data     : in String;
                      Reply    : out Response'Class) is abstract;

   procedure Do_Put (Manager  : in Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Data     : in String;
                     Reply    : out Response'Class) is abstract;

   procedure Do_Delete (Manager  : in Http_Manager;
                        Http     : in Client'Class;
                        URI      : in String;
                        Reply    : out Response'Class) is abstract;

   --  Set the timeout for the connection.
   procedure Set_Timeout (Manager : in Http_Manager;
                          Http    : in Client'Class;
                          Timeout : in Duration) is abstract;

   Default_Http_Manager : Http_Manager_Access;

   type Response is limited new Ada.Finalization.Limited_Controlled
     and Abstract_Response with record
      Delegate : Abstract_Response_Access;
   end record;

   --  Free the resource used by the response.
   overriding
   procedure Finalize (Reply : in out Response);

   type Client is limited new Ada.Finalization.Limited_Controlled
     and Abstract_Request with record
      Manager  : Http_Manager_Access;
      Delegate : Http_Request_Access;
   end record;

   --  Initialize the client
   overriding
   procedure Initialize (Http : in out Client);

   overriding
   procedure Finalize (Http : in out Client);

end Util.Http.Clients;

-----------------------------------------------------------------------
--  util-http-clients -- HTTP Clients
--  Copyright (C) 2011, 2012, 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 Ada.Finalization;

with Util.Streams.Texts;
with Util.Serialize.IO.Form;
with Util.Http.Cookies;

--  == Client ==
--  The <tt>Util.Http.Clients</tt> package defines a set of API for an HTTP client to send
--  requests to an HTTP server.
--
--  === GET request ===
--  To retrieve a content using the HTTP GET operation, a client instance must be created.
--  The response is returned in a specific object that must therefore be declared:
--
--    Http     : Util.Http.Clients.Client;
--    Response : Util.Http.Clients.Response;
--
--  Before invoking the GET operation, the client can setup a number of HTTP headers.
--
--    Http.Add_Header ("X-Requested-By", "wget");
--
--  The GET operation is performed when the <tt>Get</tt> procedure is called:
--
--    Http.Get ("http://www.google.com", Response);
--
--  Once the response is received, the <tt>Response</tt> object contains the status of the
--  HTTP response, the HTTP reply headers and the body.  A response header can be obtained
--  by using the <tt>Get_Header</tt> function and the body using <tt>Get_Body</tt>:
--
--    Body : constant String := Response.Get_Body;
--
package Util.Http.Clients is

   Connection_Error : exception;

   type Form_Data is limited new Util.Serialize.IO.Form.Output_Stream with private;

   procedure Initialize (Form : in out Form_Data;
                         Size : in Positive);

   --  ------------------------------
   --  Http response
   --  ------------------------------
   --  The Response type represents a response returned by an HTTP request.
   type Response is limited new Abstract_Response with private;

   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   overriding
   function Contains_Header (Reply : in Response;
                             Name  : in String) return Boolean;

   --  Returns the value of the specified response header as a String. If the response
   --  did not include a header of the specified name, this method returns null.
   --  If there are multiple headers with the same name, this method returns the
   --  first head in the request. The header name is case insensitive. You can use
   --  this method with any response header.
   overriding
   function Get_Header (Reply  : in Response;
                        Name   : in String) return String;

   --  Sets a message header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   overriding
   procedure Set_Header (Reply    : in out Response;
                         Name     : in String;
                         Value    : in String);

   --  Adds a request header with the given name and value.
   --  This method allows request headers to have multiple values.
   overriding
   procedure Add_Header (Reply   : in out Response;
                         Name    : in String;
                         Value   : in String);

   --  Iterate over the response headers and executes the Process procedure.
   overriding
   procedure Iterate_Headers (Reply   : in Response;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String));

   --  Get the response body as a string.
   overriding
   function Get_Body (Reply : in Response) return String;

   --  Get the response status code.
   overriding
   function Get_Status (Reply : in Response) return Natural;

   --  ------------------------------
   --  Http client
   --  ------------------------------
   --  The Client type allows to execute HTTP GET/POST requests.
   type Client is limited new Abstract_Request with private;
   type Client_Access is access all Client;

   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   overriding
   function Contains_Header (Request : in Client;
                             Name    : in String) return Boolean;

   --  Returns the value of the specified request header as a String. If the request
   --  did not include a header of the specified name, this method returns null.
   --  If there are multiple headers with the same name, this method returns the
   --  first head in the request. The header name is case insensitive. You can use
   --  this method with any response header.
   overriding
   function Get_Header (Request : in Client;
                        Name    : in String) return String;

   --  Sets a header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   overriding
   procedure Set_Header (Request  : in out Client;
                         Name     : in String;
                         Value    : in String);

   --  Adds a header with the given name and value.
   --  This method allows headers to have multiple values.
   overriding
   procedure Add_Header (Request  : in out Client;
                         Name     : in String;
                         Value    : in String);

   --  Iterate over the request headers and executes the Process procedure.
   overriding
   procedure Iterate_Headers (Request : in Client;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String));

   --  Removes all headers with the given name.
   procedure Remove_Header (Request : in out Client;
                            Name    : in String);

   --  Adds the specified cookie to the request.  This method can be called multiple
   --  times to set more than one cookie.
   procedure Add_Cookie (Http   : in out Client;
                         Cookie : in Util.Http.Cookies.Cookie);

   --  Set the timeout for the connection.
   procedure Set_Timeout (Request : in out Client;
                          Timeout : in Duration);

   --  Execute an http GET request on the given URL.  Additional request parameters,
   --  cookies and headers should have been set on the client object.
   procedure Get (Request  : in out Client;
                  URL      : in String;
                  Reply    : out Response'Class);

   --  Execute an http POST request on the given URL.  The post data is passed in Data.
   --  Additional request cookies and headers should have been set on the client object.
   procedure Post (Request : in out Client;
                   URL     : in String;
                   Data    : in String;
                   Reply   : out Response'Class);
   procedure Post (Request : in out Client;
                   URL     : in String;
                   Data    : in Form_Data'Class;
                   Reply   : out Response'Class);

   --  Execute an http PUT request on the given URL.  The post data is passed in Data.
   --  Additional request cookies and headers should have been set on the client object.
   procedure Put (Request : in out Client;
                  URL     : in String;
                  Data    : in String;
                  Reply   : out Response'Class);

   --  Execute a http DELETE request on the given URL.
   procedure Delete (Request : in out Client;
                     URL     : in String;
                     Reply   : out Response'Class);

private

   subtype Http_Request is Abstract_Request;
   subtype Http_Request_Access is Abstract_Request_Access;

   subtype Http_Response is Abstract_Response;
   subtype Http_Response_Access is Abstract_Response_Access;

   type Http_Manager is interface;
   type Http_Manager_Access is access all Http_Manager'Class;

   procedure Create (Manager  : in Http_Manager;
                     Http     : in out Client'Class) is abstract;

   procedure Do_Get (Manager  : in Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Reply    : out Response'Class) is abstract;

   procedure Do_Post (Manager  : in Http_Manager;
                      Http     : in Client'Class;
                      URI      : in String;
                      Data     : in String;
                      Reply    : out Response'Class) is abstract;

   procedure Do_Put (Manager  : in Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Data     : in String;
                     Reply    : out Response'Class) is abstract;

   procedure Do_Delete (Manager  : in Http_Manager;
                        Http     : in Client'Class;
                        URI      : in String;
                        Reply    : out Response'Class) is abstract;

   --  Set the timeout for the connection.
   procedure Set_Timeout (Manager : in Http_Manager;
                          Http    : in Client'Class;
                          Timeout : in Duration) is abstract;

   Default_Http_Manager : Http_Manager_Access;

   type Response is limited new Ada.Finalization.Limited_Controlled
     and Abstract_Response with record
      Delegate : Abstract_Response_Access;
   end record;

   --  Free the resource used by the response.
   overriding
   procedure Finalize (Reply : in out Response);

   type Client is limited new Ada.Finalization.Limited_Controlled
     and Abstract_Request with record
      Manager  : Http_Manager_Access;
      Delegate : Http_Request_Access;
   end record;

   --  Initialize the client
   overriding
   procedure Initialize (Http : in out Client);

   overriding
   procedure Finalize (Http : in out Client);

   type Form_Data is limited new Util.Serialize.IO.Form.Output_Stream with record
      Buffer : aliased Util.Streams.Texts.Print_Stream;
   end record;

end Util.Http.Clients;

Declare the Form_Data type to help in serializing some form parameters Add a Post procedure that accepts a Form_Data object


-----------------------------------------------------------------------
--  upnp-ssdp -- UPnP SSDP operations
--  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;
with Ada.Strings.Unbounded;
with Ada.Calendar;
with Util.Log.Loggers;

package body UPnP.SSDP is
   use type Ada.Streams.Stream_Element_Offset;
   use type Ada.Streams.Stream_Element;

   --  The logger
   Log   : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("UPnP.SSDP");

   Group : constant String := "239.255.255.250";

   procedure Send (Socket  : in GNAT.Sockets.Socket_Type;
                   Content : in String;
                   To      : access GNAT.Sockets.Sock_Addr_Type);

   --  ------------------------------
   --  Initialize the SSDP scanner by opening the UDP socket.
   --  ------------------------------
   procedure Initialize (Scanner : in out Scanner_Type) is
      Address      : aliased GNAT.Sockets.Sock_Addr_Type;
   begin
      Log.Info ("Discovering gateways on the network");

      Address.Addr := GNAT.Sockets.Any_Inet_Addr;
      GNAT.Sockets.Create_Socket (Scanner.Socket, GNAT.Sockets.Family_Inet,
                                  GNAT.Sockets.Socket_Datagram);
      GNAT.Sockets.Bind_Socket (Scanner.Socket, Address);
      GNAT.Sockets.Set_Socket_Option (Scanner.Socket, GNAT.Sockets.IP_Protocol_For_IP_Level,
                                      (GNAT.Sockets.Add_Membership, GNAT.Sockets.Inet_Addr (Group),
                                       GNAT.Sockets.Any_Inet_Addr));
   end Initialize;

   procedure Send (Socket  : in GNAT.Sockets.Socket_Type;
                   Content : in String;
                   To      : access GNAT.Sockets.Sock_Addr_Type) is
      Last : Ada.Streams.Stream_Element_Offset;
      Buf  : Ada.Streams.Stream_Element_Array (1 .. Content'Length);
      for Buf'Address use Content'Address;
      pragma Import (Ada, Buf);
      pragma Unreferenced (Last);
   begin
      GNAT.Sockets.Send_Socket (Socket, Buf, Last, To);
   end Send;

   --  ------------------------------
   --  Send the SSDP discovery UDP packet on the UPnP multicast group 239.255.255.250.
   --  Set the "ST" header to the given target.  The UDP packet is sent on each interface
   --  whose IP address is defined in the set <tt>IPs</tt>.
   --  ------------------------------
   procedure Send_Discovery (Scanner : in out Scanner_Type;
                             Target  : in String;
                             IPs     : in Util.Strings.Sets.Set) is
      Address : aliased GNAT.Sockets.Sock_Addr_Type;
   begin
      Address.Addr := GNAT.Sockets.Inet_Addr (Group);
      Address.Port := 1900;
      for IP of IPs loop
         GNAT.Sockets.Set_Socket_Option (Scanner.Socket, GNAT.Sockets.IP_Protocol_For_IP_Level,
                                         (GNAT.Sockets.Multicast_If,
                                          GNAT.Sockets.Inet_Addr (IP)));

         Log.Debug ("Sending SSDP search for IGD device from {0}", IP);
         Send (Scanner.Socket, "M-SEARCH * HTTP/1.1" & ASCII.CR & ASCII.LF &
                 "HOST: 239.255.255.250:1900" & ASCII.CR & ASCII.LF &
                 "ST: " & Target & ASCII.CR & ASCII.LF &
                 "MAN: ""ssdp:discover""" & ASCII.CR & ASCII.LF &
                 "MX: 2" & ASCII.CR & ASCII.LF, Address'Access);
      end loop;
   end Send_Discovery;

   procedure Receive (Socket : in GNAT.Sockets.Socket_Type;
                      Target : in String;
                      Desc   : out Ada.Strings.Unbounded.Unbounded_String) is
      function Get_Line return String;

      Data         : Ada.Streams.Stream_Element_Array (0 .. 1500);
      Last         : Ada.Streams.Stream_Element_Offset;
      Pos   : Ada.Streams.Stream_Element_Offset := Data'First;

      function Get_Line return String is
         First : constant Ada.Streams.Stream_Element_Offset := Pos;
      begin
         while Pos <= Last loop
            if Data (Pos) = 16#0D# and then Pos + 1 <= Last and then Data (Pos + 1) = 16#0A# then
               declare
                  Result : String (1 .. Natural (Pos - First));
                  P      : Natural := 1;
               begin
                  for I in First .. Pos - 1 loop
                     Result (P) := Character'Val (Data (I));
                     P := P + 1;
                  end loop;
                  Log.Debug ("L: {0}", Result);
                  Pos := Pos + 2;
                  return Result;
               end;
            end if;
            Pos := Pos + 1;
         end loop;
         return "";
      end Get_Line;

   begin
      Desc := Ada.Strings.Unbounded.To_Unbounded_String ("");
      GNAT.Sockets.Receive_Socket (Socket, Data, Last);
      if Get_Line /= "HTTP/1.1 200 OK" then
         Log.Debug ("Receive a non HTTP/1.1 response");
         return;
      end if;
      loop
         declare
            Line : constant String := Get_Line;
            Pos  : constant Natural := Util.Strings.Index (Line, ':');
            Pos2 : Natural := Pos + 1;
         begin
            exit when Pos = 0;
            while Pos2 < Line'Last and then Line (Pos2) = ' ' loop
               Pos2 := Pos2 + 1;
            end loop;
            if Line (1 .. Pos) = "ST:" then
               if Line (Pos2 .. Line'Last) /= Target then
                  return;
               end if;
            elsif Line (1 .. Pos) = "LOCATION:" then
               Desc := Ada.Strings.Unbounded.To_Unbounded_String (Line (Pos2 .. Line'Last));
               Log.Debug ("Found a IGD device: {0}", Ada.Strings.Unbounded.To_String (Desc));
               return;
            end if;
         end;
      end loop;

   exception
      when E : others =>
         Log.Error ("Exception received", E);
   end Receive;

   --  ------------------------------
   --  Receive the UPnP SSDP discovery messages for the given target.
   --  Call the <tt>Process</tt> procedure for each of them.  The <tt>Desc</tt> parameter
   --  represents the UPnP location header which gives the UPnP XML root descriptor.
   --  Wait at most the given time.
   --  ------------------------------
   procedure Discover (Scanner : in out Scanner_Type;
                       Target  : in String;
                       Process : not null access procedure (Desc : in String);
                       Wait    : in Duration) is
      use type Ada.Calendar.Time;
      use type GNAT.Sockets.Selector_Status;

      Sel      : GNAT.Sockets.Selector_Type;
      Rset     : GNAT.Sockets.Socket_Set_Type;
      Wset     : GNAT.Sockets.Socket_Set_Type;
      Status   : GNAT.Sockets.Selector_Status;
      Desc     : Ada.Strings.Unbounded.Unbounded_String;
      Deadline : constant Ada.Calendar.Time := Ada.Calendar.Clock + Wait;
      Remain   : Duration;
   begin
      GNAT.Sockets.Create_Selector (Sel);
      loop
         GNAT.Sockets.Empty (Rset);
         GNAT.Sockets.Empty (Wset);
         GNAT.Sockets.Set (Rset, Scanner.Socket);

         Remain := Deadline - Ada.Calendar.Clock;
         exit when Remain < 0.0;
         GNAT.Sockets.Check_Selector (Selector     => Sel,
                                      R_Socket_Set => Rset,
                                      W_Socket_Set => Wset,
                                      Status       => Status,
                                      Timeout      => Remain);
         exit when Status = GNAT.Sockets.Expired;
         Receive (Scanner.Socket, Target, Desc);
         declare
            URI  : constant String := Ada.Strings.Unbounded.To_String (Desc);
            Pos  : constant Natural := Util.Strings.Index (URI, ':');
         begin
            if Pos > 0 and URI (URI'First .. Pos + 2) = "http://" then
               Process (URI);
            end if;
         end;
      end loop;
   end Discover;

   --  ------------------------------
   --  Release the socket.
   --  ------------------------------
   overriding
   procedure Finalize (Scanner : in out Scanner_Type) is
      use type GNAT.Sockets.Socket_Type;
   begin
      if Scanner.Socket /= GNAT.Sockets.No_Socket then
         GNAT.Sockets.Close_Socket (Scanner.Socket);
      end if;
   end Finalize;

end UPnP.SSDP;

-----------------------------------------------------------------------
--  upnp-ssdp -- UPnP SSDP operations
--  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;
with Ada.Strings.Unbounded;
with Ada.Calendar;
with System;
with Interfaces.C.Strings;
with Util.Log.Loggers;

package body UPnP.SSDP is
   use type Ada.Streams.Stream_Element_Offset;
   use type Ada.Streams.Stream_Element;

   --  The logger
   Log   : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("UPnP.SSDP");

   Group : constant String := "239.255.255.250";

   type Sockaddr is record
      Sa_Family : Interfaces.C.unsigned_short;
      Sa_Port   : Interfaces.C.unsigned_short;
      Sa_Addr   : aliased Interfaces.C.char_array (1 .. 8);
   end record;
   pragma Convention (C, Sockaddr);

   type If_Address;
   type If_Address_Access is access all If_Address;
   type If_Address is record
      Ifa_Next  : If_Address_Access;
      Ifa_Name  : Interfaces.C.Strings.chars_ptr;
      Ifa_Flags : Interfaces.C.unsigned;
      Ifa_Addr  : access Sockaddr;
   end record;
   pragma Convention (C, If_Address);

   function Sys_getifaddrs (ifap : access If_Address_Access) return Interfaces.C.int;
   pragma Import (C, Sys_getifaddrs, "getifaddrs");

   procedure Sys_freeifaddrs (ifap : If_Address_Access);
   pragma Import (C, Sys_freeifaddrs, "freeifaddrs");

   function Sys_Inet_Ntop (Af : in Interfaces.C.unsigned_short;
                           Addr : System.Address;
                           Dst  : in Interfaces.C.Strings.chars_ptr;
                           Size : in Interfaces.C.int) return Interfaces.C.Strings.chars_ptr;
   pragma Import (C, Sys_Inet_Ntop, "inet_ntop");

   procedure Send (Socket  : in GNAT.Sockets.Socket_Type;
                   Content : in String;
                   To      : access GNAT.Sockets.Sock_Addr_Type);
   procedure Receive (Socket : in GNAT.Sockets.Socket_Type;
                      Target : in String;
                      Desc   : out Ada.Strings.Unbounded.Unbounded_String);

   --  ------------------------------
   --  Initialize the SSDP scanner by opening the UDP socket.
   --  ------------------------------
   procedure Initialize (Scanner : in out Scanner_Type) is
      Address      : aliased GNAT.Sockets.Sock_Addr_Type;
   begin
      Log.Info ("Discovering gateways on the network");

      Address.Addr := GNAT.Sockets.Any_Inet_Addr;
      GNAT.Sockets.Create_Socket (Scanner.Socket, GNAT.Sockets.Family_Inet,
                                  GNAT.Sockets.Socket_Datagram);
      GNAT.Sockets.Bind_Socket (Scanner.Socket, Address);
      GNAT.Sockets.Set_Socket_Option (Scanner.Socket, GNAT.Sockets.IP_Protocol_For_IP_Level,
                                      (GNAT.Sockets.Add_Membership, GNAT.Sockets.Inet_Addr (Group),
                                       GNAT.Sockets.Any_Inet_Addr));
   end Initialize;

   --  ------------------------------
   --  Find the IPv4 addresses of the network interfaces.
   --  ------------------------------
   procedure Find_IPv4_Addresses (Scanner : in out Scanner_Type;
                                  IPs     : out Util.Strings.Sets.Set) is
      pragma Unreferenced (Scanner);
      use type Interfaces.C.int;
      use type Interfaces.C.Strings.chars_ptr;

      Iflist   : aliased If_Address_Access;
      Ifp      : If_Address_Access;
      R        : Interfaces.C.Strings.chars_ptr;
   begin
      if Sys_getifaddrs (Iflist'Access) = 0 then
         R := Interfaces.C.Strings.New_String ("xxx.xxx.xxx.xxx.xxx");
         Ifp := Iflist;
         while Ifp /= null loop
            if Sys_Inet_Ntop (Ifp.Ifa_Addr.Sa_Family, Ifp.Ifa_Addr.Sa_Addr'Address, R, 17)
              /= Interfaces.C.Strings.Null_Ptr
            then
               Log.Debug ("Found interface: {0} - IP {1}",
                          Interfaces.C.Strings.Value (Ifp.Ifa_Name),
                          Interfaces.C.Strings.Value (R));
               if Interfaces.C.Strings.Value (R) /= "::" then
                  IPs.Include (Interfaces.C.Strings.Value (R));
               end if;
            end if;
            Ifp := Ifp.Ifa_Next;
         end loop;
         Interfaces.C.Strings.Free (R);
         Sys_freeifaddrs (Iflist);
      end if;
   end Find_IPv4_Addresses;

   procedure Send (Socket  : in GNAT.Sockets.Socket_Type;
                   Content : in String;
                   To      : access GNAT.Sockets.Sock_Addr_Type) is
      Last : Ada.Streams.Stream_Element_Offset;
      Buf  : Ada.Streams.Stream_Element_Array (1 .. Content'Length);
      for Buf'Address use Content'Address;
      pragma Import (Ada, Buf);
      pragma Unreferenced (Last);
   begin
      GNAT.Sockets.Send_Socket (Socket, Buf, Last, To);
   end Send;

   --  ------------------------------
   --  Send the SSDP discovery UDP packet on the UPnP multicast group 239.255.255.250.
   --  Set the "ST" header to the given target.  The UDP packet is sent on each interface
   --  whose IP address is defined in the set <tt>IPs</tt>.
   --  ------------------------------
   procedure Send_Discovery (Scanner : in out Scanner_Type;
                             Target  : in String;
                             IPs     : in Util.Strings.Sets.Set) is
      Address : aliased GNAT.Sockets.Sock_Addr_Type;
   begin
      Address.Addr := GNAT.Sockets.Inet_Addr (Group);
      Address.Port := 1900;
      for IP of IPs loop
         GNAT.Sockets.Set_Socket_Option (Scanner.Socket, GNAT.Sockets.IP_Protocol_For_IP_Level,
                                         (GNAT.Sockets.Multicast_If,
                                          GNAT.Sockets.Inet_Addr (IP)));

         Log.Debug ("Sending SSDP search for IGD device from {0}", IP);
         Send (Scanner.Socket, "M-SEARCH * HTTP/1.1" & ASCII.CR & ASCII.LF &
                 "HOST: 239.255.255.250:1900" & ASCII.CR & ASCII.LF &
                 "ST: " & Target & ASCII.CR & ASCII.LF &
                 "MAN: ""ssdp:discover""" & ASCII.CR & ASCII.LF &
                 "MX: 2" & ASCII.CR & ASCII.LF, Address'Access);
      end loop;
   end Send_Discovery;

   procedure Receive (Socket : in GNAT.Sockets.Socket_Type;
                      Target : in String;
                      Desc   : out Ada.Strings.Unbounded.Unbounded_String) is
      function Get_Line return String;

      Data         : Ada.Streams.Stream_Element_Array (0 .. 1500);
      Last         : Ada.Streams.Stream_Element_Offset;
      Pos   : Ada.Streams.Stream_Element_Offset := Data'First;

      function Get_Line return String is
         First : constant Ada.Streams.Stream_Element_Offset := Pos;
      begin
         while Pos <= Last loop
            if Data (Pos) = 16#0D# and then Pos + 1 <= Last and then Data (Pos + 1) = 16#0A# then
               declare
                  Result : String (1 .. Natural (Pos - First));
                  P      : Natural := 1;
               begin
                  for I in First .. Pos - 1 loop
                     Result (P) := Character'Val (Data (I));
                     P := P + 1;
                  end loop;
                  Log.Debug ("L: {0}", Result);
                  Pos := Pos + 2;
                  return Result;
               end;
            end if;
            Pos := Pos + 1;
         end loop;
         return "";
      end Get_Line;

   begin
      Desc := Ada.Strings.Unbounded.To_Unbounded_String ("");
      GNAT.Sockets.Receive_Socket (Socket, Data, Last);
      if Get_Line /= "HTTP/1.1 200 OK" then
         Log.Debug ("Receive a non HTTP/1.1 response");
         return;
      end if;
      loop
         declare
            Line : constant String := Get_Line;
            Pos  : constant Natural := Util.Strings.Index (Line, ':');
            Pos2 : Natural := Pos + 1;
         begin
            exit when Pos = 0;
            while Pos2 < Line'Last and then Line (Pos2) = ' ' loop
               Pos2 := Pos2 + 1;
            end loop;
            if Line (1 .. Pos) = "ST:" then
               if Line (Pos2 .. Line'Last) /= Target then
                  return;
               end if;
            elsif Line (1 .. Pos) = "LOCATION:" then
               Desc := Ada.Strings.Unbounded.To_Unbounded_String (Line (Pos2 .. Line'Last));
               Log.Debug ("Found a IGD device: {0}", Ada.Strings.Unbounded.To_String (Desc));
               return;
            end if;
         end;
      end loop;

   exception
      when E : others =>
         Log.Error ("Exception received", E);
   end Receive;

   --  ------------------------------
   --  Receive the UPnP SSDP discovery messages for the given target.
   --  Call the <tt>Process</tt> procedure for each of them.  The <tt>Desc</tt> parameter
   --  represents the UPnP location header which gives the UPnP XML root descriptor.
   --  Wait at most the given time.
   --  ------------------------------
   procedure Discover (Scanner : in out Scanner_Type;
                       Target  : in String;
                       Process : not null access procedure (Desc : in String);
                       Wait    : in Duration) is
      use type Ada.Calendar.Time;
      use type GNAT.Sockets.Selector_Status;

      Sel      : GNAT.Sockets.Selector_Type;
      Rset     : GNAT.Sockets.Socket_Set_Type;
      Wset     : GNAT.Sockets.Socket_Set_Type;
      Status   : GNAT.Sockets.Selector_Status;
      Desc     : Ada.Strings.Unbounded.Unbounded_String;
      Deadline : constant Ada.Calendar.Time := Ada.Calendar.Clock + Wait;
      Remain   : Duration;
   begin
      GNAT.Sockets.Create_Selector (Sel);
      loop
         GNAT.Sockets.Empty (Rset);
         GNAT.Sockets.Empty (Wset);
         GNAT.Sockets.Set (Rset, Scanner.Socket);

         Remain := Deadline - Ada.Calendar.Clock;
         exit when Remain < 0.0;
         GNAT.Sockets.Check_Selector (Selector     => Sel,
                                      R_Socket_Set => Rset,
                                      W_Socket_Set => Wset,
                                      Status       => Status,
                                      Timeout      => Remain);
         exit when Status = GNAT.Sockets.Expired;
         Receive (Scanner.Socket, Target, Desc);
         declare
            URI  : constant String := Ada.Strings.Unbounded.To_String (Desc);
            Pos  : constant Natural := Util.Strings.Index (URI, ':');
         begin
            if Pos > 0 and URI (URI'First .. Pos + 2) = "http://" then
               Process (URI);
            end if;
         end;
      end loop;
   end Discover;

   --  ------------------------------
   --  Release the socket.
   --  ------------------------------
   overriding
   procedure Finalize (Scanner : in out Scanner_Type) is
      use type GNAT.Sockets.Socket_Type;
   begin
      if Scanner.Socket /= GNAT.Sockets.No_Socket then
         GNAT.Sockets.Close_Socket (Scanner.Socket);
      end if;
   end Finalize;

end UPnP.SSDP;

Implement the Find_IPv4_Addresses by using the getifaddrs C API


-----------------------------------------------------------------------
--  ado-datasets-tests -- Test executing queries and using datasets
--  Copyright (C) 2013, 2014, 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.Test_Caller;

with Regtests.Simple.Model;
with Regtests.Statements.Model;

with ADO.Queries.Loaders;
package body ADO.Datasets.Tests is

   package Caller is new Util.Test_Caller (Test, "ADO.Datasets");

   package User_List_Query_File is
     new ADO.Queries.Loaders.File (Path => "regtests/files/user-list.xml",
                                   Sha1 => "");

   package User_List_Query is
     new ADO.Queries.Loaders.Query (Name => "user-list",
                                    File => User_List_Query_File.File'Access);

   package User_List_Count_Query is
     new ADO.Queries.Loaders.Query (Name => "user-list-count",
                                    File => User_List_Query_File.File'Access);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Datasets.List (from <sql>)",
                       Test_List'Access);
      Caller.Add_Test (Suite, "Test ADO.Datasets.Get_Count (from <sql>)",
                       Test_Count'Access);
      Caller.Add_Test (Suite, "Test ADO.Datasets.Get_Count (from <sql-count>)",
                       Test_Count_Query'Access);
      Caller.Add_Test (Suite, "Test ADO.Datasets.List (<sql> with null)",
                       Test_List_Nullable'Access);
   end Add_Tests;

   procedure Test_List (T : in out Test) is
      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Query  : ADO.Queries.Context;
      Count  : Natural;
      Data   : ADO.Datasets.Dataset;
   begin
      Query.Set_Count_Query (User_List_Query.Query'Access);
      Query.Bind_Param ("filter", String '("test-list"));
      Count := ADO.Datasets.Get_Count (DB, Query);
      for I in 1 .. 100 loop
         declare
            User : Regtests.Simple.Model.User_Ref;
         begin
            User.Set_Name ("John " & Integer'Image (I));
            User.Set_Select_Name ("test-list");
            User.Set_Value (ADO.Identifier (I));
            User.Save (DB);
         end;
      end loop;
      DB.Commit;

      Query.Set_Query (User_List_Query.Query'Access);
      ADO.Datasets.List (Data, DB, Query);
      Util.Tests.Assert_Equals (T, 100 + Count, Data.Get_Count, "Invalid dataset size");
   end Test_List;

   --  ------------------------------
   --  Test dataset lists with null columns.
   --  ------------------------------
   procedure Test_List_Nullable (T : in out Test) is
      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Query  : ADO.Queries.Context;
      Count  : Natural;
      Data   : ADO.Datasets.Dataset;
   begin
      Query.Set_SQL ("SELECT COUNT(*) FROM test_nullable_table");
      Count := ADO.Datasets.Get_Count (DB, Query);

      for I in 1 .. 100 loop
         declare
            Item : Regtests.Statements.Model.Nullable_Table_Ref;
         begin
            Item.Set_Bool_Value (False);
            if (I mod 2) = 0 then
               Item.Set_Int_Value (ADO.Nullable_Integer '(123, False));
            end if;
            if (I mod 4) = 0 then
               Item.Set_Time_Value (ADO.Nullable_Time '(Value => Ada.Calendar.Clock,
                                                        Is_Null => False));
            end if;
            Item.Save (DB);
         end;
      end loop;
      DB.Commit;

      Query.Set_SQL ("SELECT * FROM test_nullable_table");
      ADO.Datasets.List (Data, DB, Query);
      Util.Tests.Assert_Equals (T, 100 + Count, Data.Get_Count, "Invalid dataset size");
   end Test_List_Nullable;

   procedure Test_Count (T : in out Test) is
      DB     : constant ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Query  : ADO.Queries.Context;
      Count  : Natural;
   begin
      Query.Set_Query (User_List_Count_Query.Query'Access);
      Count := ADO.Datasets.Get_Count (DB, Query);
      T.Assert (Count > 0,
                "The ADO.Datasets.Get_Count query should return a positive count");
   end Test_Count;

   procedure Test_Count_Query (T : in out Test) is
      DB     : constant ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Query  : ADO.Queries.Context;
      Count  : Natural;
   begin
      Query.Set_Count_Query (User_List_Query.Query'Access);
      Query.Bind_Param ("filter", String '("test-list"));
      Count := ADO.Datasets.Get_Count (DB, Query);
      T.Assert (Count > 0,
                "The ADO.Datasets.Get_Count query should return a positive count");
   end Test_Count_Query;

end ADO.Datasets.Tests;

-----------------------------------------------------------------------
--  ado-datasets-tests -- Test executing queries and using datasets
--  Copyright (C) 2013, 2014, 2015, 2017, 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 Regtests.Simple.Model;
with Regtests.Statements.Model;

with ADO.Queries.Loaders;
package body ADO.Datasets.Tests is

   package Caller is new Util.Test_Caller (Test, "ADO.Datasets");

   package User_List_Query_File is
     new ADO.Queries.Loaders.File (Path => "regtests/files/user-list.xml",
                                   Sha1 => "");

   package User_List_Query is
     new ADO.Queries.Loaders.Query (Name => "user-list",
                                    File => User_List_Query_File.File'Access);

   package User_List_Count_Query is
     new ADO.Queries.Loaders.Query (Name => "user-list-count",
                                    File => User_List_Query_File.File'Access);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Datasets.List (from <sql>)",
                       Test_List'Access);
      Caller.Add_Test (Suite, "Test ADO.Datasets.Get_Count (from <sql>)",
                       Test_Count'Access);
      Caller.Add_Test (Suite, "Test ADO.Datasets.Get_Count (from <sql-count>)",
                       Test_Count_Query'Access);
      Caller.Add_Test (Suite, "Test ADO.Datasets.List (<sql> with null)",
                       Test_List_Nullable'Access);
   end Add_Tests;

   procedure Test_List (T : in out Test) is
      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Query  : ADO.Queries.Context;
      Count  : Natural;
      Data   : ADO.Datasets.Dataset;
   begin
      Query.Set_Count_Query (User_List_Query.Query'Access);
      Query.Bind_Param ("filter", String '("test-list"));
      Count := ADO.Datasets.Get_Count (DB, Query);
      for I in 1 .. 100 loop
         declare
            User : Regtests.Simple.Model.User_Ref;
         begin
            User.Set_Name ("John " & Integer'Image (I));
            User.Set_Select_Name ("test-list");
            User.Set_Value (ADO.Identifier (I));
            User.Save (DB);
         end;
      end loop;
      DB.Commit;

      Query.Set_Query (User_List_Query.Query'Access);
      ADO.Datasets.List (Data, DB, Query);
      Util.Tests.Assert_Equals (T, 100 + Count, Data.Get_Count, "Invalid dataset size");
   end Test_List;

   --  ------------------------------
   --  Test dataset lists with null columns.
   --  ------------------------------
   procedure Test_List_Nullable (T : in out Test) is
      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Query  : ADO.Queries.Context;
      Count  : Natural;
      Data   : ADO.Datasets.Dataset;
   begin
      Query.Set_SQL ("SELECT COUNT(*) FROM test_nullable_table");
      Count := ADO.Datasets.Get_Count (DB, Query);

      for I in 1 .. 100 loop
         declare
            Item : Regtests.Statements.Model.Nullable_Table_Ref;
         begin
            Item.Set_Bool_Value ((Value => False, Is_Null => False));
            if (I mod 2) = 0 then
               Item.Set_Int_Value (ADO.Nullable_Integer '(123, False));
            end if;
            if (I mod 4) = 0 then
               Item.Set_Time_Value (ADO.Nullable_Time '(Value => Ada.Calendar.Clock,
                                                        Is_Null => False));
            end if;
            Item.Save (DB);
         end;
      end loop;
      DB.Commit;

      Query.Set_SQL ("SELECT * FROM test_nullable_table");
      ADO.Datasets.List (Data, DB, Query);
      Util.Tests.Assert_Equals (T, 100 + Count, Data.Get_Count, "Invalid dataset size");
   end Test_List_Nullable;

   procedure Test_Count (T : in out Test) is
      DB     : constant ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Query  : ADO.Queries.Context;
      Count  : Natural;
   begin
      Query.Set_Query (User_List_Count_Query.Query'Access);
      Count := ADO.Datasets.Get_Count (DB, Query);
      T.Assert (Count > 0,
                "The ADO.Datasets.Get_Count query should return a positive count");
   end Test_Count;

   procedure Test_Count_Query (T : in out Test) is
      DB     : constant ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Query  : ADO.Queries.Context;
      Count  : Natural;
   begin
      Query.Set_Count_Query (User_List_Query.Query'Access);
      Query.Bind_Param ("filter", String '("test-list"));
      Count := ADO.Datasets.Get_Count (DB, Query);
      T.Assert (Count > 0,
                "The ADO.Datasets.Get_Count query should return a positive count");
   end Test_Count_Query;

end ADO.Datasets.Tests;

Update the test for boolean value

Update the test for boolean value


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

with AUnit.Test_Caller;
with Ada.Text_IO;
with ASF.Sessions.Factory;
with Ada.Calendar;
with Util.Tests;
with Util.Measures;
with EL.Objects;
package body ASF.Sessions.Tests is

   use Util.Tests;

   --  ------------------------------
   --  Test session creation.
   --  ------------------------------
   procedure Test_Create_Session (T : in out Test) is
      F : ASF.Sessions.Factory.Session_Factory;

      S : ASF.Sessions.Session;
      St : Util.Measures.Stamp;
   begin
      for I in 1 .. 10 loop
         F.Create_Session (S);
      end loop;
      Util.Measures.Report (St, "10 Session create");

      for I in 1 .. 100 loop
         F.Create_Session (S);

         T.Assert (S.Is_Valid, "Session should be valid");
         T.Assert (S.Get_Id'Length = 32, "Session id has an invalid length");
         Ada.Text_IO.Put_Line ("ID=" & S.Get_Id);

         declare
            S2 : ASF.Sessions.Session;
         begin
            F.Find_Session (Id => S.Get_Id, Result => S2);
            T.Assert (S2.Is_Valid, "Session was not found");

            Assert_Equals (T, S.Get_Id, S2.Get_Id, "Invalid session id");
         end;
      end loop;
   end Test_Create_Session;

   --  ------------------------------
   --  Tests on an empty session object.
   --  ------------------------------
   procedure Test_Empty_Session (T : in out Test) is
      S : ASF.Sessions.Session;
   begin
      T.Assert (not S.Is_Valid, "Session should be invalid");

      S.Invalidate;
      T.Assert (not S.Is_Valid, "Session should be invalid");
   end Test_Empty_Session;

   procedure Test_Session_Attributes (T : in out Test) is
      F : ASF.Sessions.Factory.Session_Factory;

      S : ASF.Sessions.Session;
   begin
      F.Create_Session (S);

      S.Set_Attribute ("a1", EL.Objects.To_Object (Integer (234)));
      S.Set_Attribute ("a2", EL.Objects.To_Object (String '("name")));

      declare
         Value : EL.Objects.Object := S.Get_Attribute ("a1");
      begin
         Assert_Equals (T, "234", EL.Objects.To_String (Value), "Invalid attribute a1");
      end;
   end Test_Session_Attributes;

   package Caller is new AUnit.Test_Caller (Test);

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite) is

   begin
      --  To document what is tested, register the test methods for each
      --  operation that is tested.
      Suite.Add_Test (Caller.Create ("Test ASF.Sessions.Factory.Create_Session",
                                      Test_Create_Session'Access));
      Suite.Add_Test (Caller.Create ("Test ASF.Sessions.Factory.Find_Session",
                                      Test_Create_Session'Access));
      Suite.Add_Test (Caller.Create ("Test ASF.Sessions.Get_Id",
                                      Test_Create_Session'Access));
      Suite.Add_Test (Caller.Create ("Test ASF.Sessions.Is_Valid",
                                      Test_Empty_Session'Access));
      Suite.Add_Test (Caller.Create ("Test ASF.Sessions.Set_Attribute",
                                      Test_Session_Attributes'Access));
      Suite.Add_Test (Caller.Create ("Test ASF.Sessions.Get_Attribute",
                                      Test_Session_Attributes'Access));
   end Add_Tests;

end ASF.Sessions.Tests;

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

with AUnit.Test_Caller;
with Ada.Text_IO;
with ASF.Sessions.Factory;
with Ada.Calendar;
with Util.Tests;
with Util.Measures;
with EL.Objects;
package body ASF.Sessions.Tests is

   use Util.Tests;

   --  ------------------------------
   --  Test session creation.
   --  ------------------------------
   procedure Test_Create_Session (T : in out Test) is
      F : ASF.Sessions.Factory.Session_Factory;

      S : ASF.Sessions.Session;
      St : Util.Measures.Stamp;
   begin
      for I in 1 .. 10 loop
         F.Create_Session (S);
      end loop;
      Util.Measures.Report (St, "10 Session create");

      for I in 1 .. 100 loop
         F.Create_Session (S);

         T.Assert (S.Is_Valid, "Session should be valid");
         T.Assert (S.Get_Id'Length = 32, "Session id has an invalid length");
         --  Ada.Text_IO.Put_Line ("ID=" & S.Get_Id);

         declare
            S2 : ASF.Sessions.Session;
         begin
            F.Find_Session (Id => S.Get_Id, Result => S2);
            T.Assert (S2.Is_Valid, "Session was not found");

            Assert_Equals (T, S.Get_Id, S2.Get_Id, "Invalid session id");
         end;
      end loop;
   end Test_Create_Session;

   --  ------------------------------
   --  Tests on an empty session object.
   --  ------------------------------
   procedure Test_Empty_Session (T : in out Test) is
      S : ASF.Sessions.Session;
   begin
      T.Assert (not S.Is_Valid, "Session should be invalid");

      S.Invalidate;
      T.Assert (not S.Is_Valid, "Session should be invalid");
   end Test_Empty_Session;

   procedure Test_Session_Attributes (T : in out Test) is
      F : ASF.Sessions.Factory.Session_Factory;

      S : ASF.Sessions.Session;
   begin
      F.Create_Session (S);

      S.Set_Attribute ("a1", EL.Objects.To_Object (Integer (234)));
      S.Set_Attribute ("a2", EL.Objects.To_Object (String '("name")));

      declare
         Value : EL.Objects.Object := S.Get_Attribute ("a1");
      begin
         Assert_Equals (T, "234", EL.Objects.To_String (Value), "Invalid attribute a1");
      end;
   end Test_Session_Attributes;

   package Caller is new AUnit.Test_Caller (Test);

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite) is

   begin
      --  To document what is tested, register the test methods for each
      --  operation that is tested.
      Suite.Add_Test (Caller.Create ("Test ASF.Sessions.Factory.Create_Session",
                                      Test_Create_Session'Access));
      Suite.Add_Test (Caller.Create ("Test ASF.Sessions.Factory.Find_Session",
                                      Test_Create_Session'Access));
      Suite.Add_Test (Caller.Create ("Test ASF.Sessions.Get_Id",
                                      Test_Create_Session'Access));
      Suite.Add_Test (Caller.Create ("Test ASF.Sessions.Is_Valid",
                                      Test_Empty_Session'Access));
      Suite.Add_Test (Caller.Create ("Test ASF.Sessions.Set_Attribute",
                                      Test_Session_Attributes'Access));
      Suite.Add_Test (Caller.Create ("Test ASF.Sessions.Get_Attribute",
                                      Test_Session_Attributes'Access));
   end Add_Tests;

end ASF.Sessions.Tests;

Remove dump of session ID

Remove dump of session ID


-----------------------------------------------------------------------
--  wiki-parsers-tests -- Unit tests for wiki parsing
--  Copyright (C) 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 Util.Tests;

package Wiki.Parsers.Tests is

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

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

   --  Test bold rendering.
   procedure Test_Wiki_Bold (T : in out Test);

   --  Test italic rendering.
   procedure Test_Wiki_Italic (T : in out Test);

   --  Test various format rendering.
   procedure Test_Wiki_Formats (T : in out Test);

   --  Test heading rendering.
   procedure Test_Wiki_Section (T : in out Test);

   --  Test list rendering.
   procedure Test_Wiki_List (T : in out Test);

   --  Test link rendering.
   procedure Test_Wiki_Link (T : in out Test);

   --  Test quote rendering.
   procedure Test_Wiki_Quote (T : in out Test);

   --  Test line break rendering.
   procedure Test_Wiki_Line_Break (T : in out Test);

   --  Test image rendering.
   procedure Test_Wiki_Image (T : in out Test);

   --  Test preformatted rendering.
   procedure Test_Wiki_Preformatted (T : in out Test);

   --  Test the text renderer.
   procedure Test_Wiki_Text_Renderer (T : in out Test);

end Wiki.Parsers.Tests;

-----------------------------------------------------------------------
--  wiki-parsers-tests -- Unit tests for wiki parsing
--  Copyright (C) 2011, 2012, 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 Util.Tests;

package Wiki.Parsers.Tests is

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

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

   --  Test bold rendering.
   procedure Test_Wiki_Bold (T : in out Test);

   --  Test italic rendering.
   procedure Test_Wiki_Italic (T : in out Test);

   --  Test various format rendering.
   procedure Test_Wiki_Formats (T : in out Test);

   --  Test heading rendering.
   procedure Test_Wiki_Section (T : in out Test);

   --  Test list rendering.
   procedure Test_Wiki_List (T : in out Test);

   --  Test link rendering.
   procedure Test_Wiki_Link (T : in out Test);

   --  Test quote rendering.
   procedure Test_Wiki_Quote (T : in out Test);

   --  Test line break rendering.
   procedure Test_Wiki_Line_Break (T : in out Test);

   --  Test image rendering.
   procedure Test_Wiki_Image (T : in out Test);

   --  Test preformatted rendering.
   procedure Test_Wiki_Preformatted (T : in out Test);

   --  Test the text renderer.
   procedure Test_Wiki_Text_Renderer (T : in out Test);

   --  Test the string parser with UTF-8 support.
   procedure Test_Wiki_UTF_8 (T : in out Test);

end Wiki.Parsers.Tests;

Declare Test_Wiki_UTF_8 procedure

Declare Test_Wiki_UTF_8 procedure


-----------------------------------------------------------------------
--  util-serialize-io -- IO Drivers for serialization
--  Copyright (C) 2010, 2011, 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 Util.Beans.Objects;
with Util.Streams;
with Util.Streams.Buffered;
with Util.Log.Loggers;
with Util.Nullables;
package Util.Serialize.IO is

   Parse_Error : exception;

   --  ------------------------------
   --  Output stream for serialization
   --  ------------------------------
   --  The Output_Stream interface defines the abstract operations for
   --  the serialization framework to write objects on the stream according to
   --  a target format such as XML or JSON.
   type Output_Stream is limited interface and Util.Streams.Output_Stream;

   --  Start a document.
   procedure Start_Document (Stream : in out Output_Stream) is null;

   --  Finish a document.
   procedure End_Document (Stream : in out Output_Stream) is null;

   procedure Start_Entity (Stream : in out Output_Stream;
                           Name   : in String) is null;

   procedure End_Entity (Stream : in out Output_Stream;
                         Name   : in String) is null;

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

   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Nullables.Nullable_String) is abstract;

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

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

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

   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream'Class;
                              Name   : in String;
                              Value  : in Ada.Strings.Unbounded.Unbounded_String);

   --  Write the entity value.
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in String) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Nullables.Nullable_String) is abstract;

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

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

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

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

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

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

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream'Class;
                           Name   : in String;
                           Value  : in Ada.Strings.Unbounded.Unbounded_String);

   procedure Start_Array (Stream : in out Output_Stream;
                          Name   : in String) is null;

   procedure End_Array (Stream : in out Output_Stream;
                        Name   : in String) is null;

   type Reader is limited interface;

   --  Start a document.
   procedure Start_Document (Stream : in out Reader) is null;

   --  Finish a document.
   procedure End_Document (Stream : in out Reader) is null;

   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  Set_Member procedure will associate the name/value pair on the
   --  new object.
   procedure Start_Object (Handler : in out Reader;
                           Name    : in String;
                           Logger  : in out Util.Log.Logging'Class) is abstract;

   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   procedure Finish_Object (Handler : in out Reader;
                            Name    : in String;
                            Logger  : in out Util.Log.Logging'Class) is abstract;

   procedure Start_Array (Handler : in out Reader;
                          Name    : in String;
                          Logger  : in out Util.Log.Logging'Class) is abstract;

   procedure Finish_Array (Handler : in out Reader;
                           Name    : in String;
                           Count   : in Natural;
                           Logger  : in out Util.Log.Logging'Class) is abstract;

   --  Set the name/value pair on the current object.  For each active mapping,
   --  find whether a rule matches our name and execute it.
   procedure Set_Member (Handler   : in out Reader;
                         Name      : in String;
                         Value     : in Util.Beans.Objects.Object;
                         Logger    : in out Util.Log.Logging'Class;
                         Attribute : in Boolean := False) is abstract;

   type Parser is abstract new Util.Log.Logging with private;

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

   --  Read the file and parse it using the parser.
   procedure Parse (Handler : in out Parser;
                    File    : in String;
                    Sink    : in out Reader'Class);

   --  Parse the content string.
   procedure Parse_String (Handler : in out Parser;
                           Content : in String;
                           Sink    : in out Reader'Class);

   --  Returns true if the Parse operation detected at least one error.
   function Has_Error (Handler : in Parser) return Boolean;

   --  Set the error logger to report messages while parsing and reading the input file.
   procedure Set_Logger (Handler : in out Parser;
                         Logger  : in Util.Log.Loggers.Logger_Access);

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

   --  Report an error while parsing the input stream.  The error message will be reported
   --  on the logger associated with the parser.  The parser will be set as in error so that
   --  the Has_Error function will return True after parsing the whole file.
   procedure Error (Handler : in out Parser;
                    Message : in String);

private

   type Parser is abstract new Util.Log.Logging with record
      Error_Flag     : Boolean := False;

      --  The file name to use when reporting errors.
      File           : Ada.Strings.Unbounded.Unbounded_String;

      --  The logger which is used to report error messages when parsing an input file.
      Error_Logger   : Util.Log.Loggers.Logger_Access := null;
   end record;

end Util.Serialize.IO;

-----------------------------------------------------------------------
--  util-serialize-io -- IO Drivers for serialization
--  Copyright (C) 2010, 2011, 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 Util.Beans.Objects;
with Util.Streams;
with Util.Streams.Buffered;
with Util.Log.Loggers;
with Util.Nullables;
package Util.Serialize.IO is

   Parse_Error : exception;

   --  ------------------------------
   --  Output stream for serialization
   --  ------------------------------
   --  The Output_Stream interface defines the abstract operations for
   --  the serialization framework to write objects on the stream according to
   --  a target format such as XML or JSON.
   type Output_Stream is limited interface and Util.Streams.Output_Stream;

   --  Start a document.
   procedure Start_Document (Stream : in out Output_Stream) is null;

   --  Finish a document.
   procedure End_Document (Stream : in out Output_Stream) is null;

   procedure Start_Entity (Stream : in out Output_Stream;
                           Name   : in String) is null;

   procedure End_Entity (Stream : in out Output_Stream;
                         Name   : in String) is null;

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

   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Nullables.Nullable_String) is abstract;

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

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

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

   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object) is abstract;

   --  Write the attribute with a null value.
   procedure Write_Null_Attribute (Stream : in out Output_Stream;
                                   Name   : in String) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream'Class;
                              Name   : in String;
                              Value  : in Ada.Strings.Unbounded.Unbounded_String);

   --  Write the entity value.
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in String) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Nullables.Nullable_String) is abstract;

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

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

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

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

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

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

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream'Class;
                           Name   : in String;
                           Value  : in Ada.Strings.Unbounded.Unbounded_String);

   --  Write an entity with a null value.
   procedure Write_Null_Entity (Stream : in out Output_Stream;
                                Name   : in String) is abstract;

   procedure Start_Array (Stream : in out Output_Stream;
                          Name   : in String) is null;

   procedure End_Array (Stream : in out Output_Stream;
                        Name   : in String) is null;

   type Reader is limited interface;

   --  Start a document.
   procedure Start_Document (Stream : in out Reader) is null;

   --  Finish a document.
   procedure End_Document (Stream : in out Reader) is null;

   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  Set_Member procedure will associate the name/value pair on the
   --  new object.
   procedure Start_Object (Handler : in out Reader;
                           Name    : in String;
                           Logger  : in out Util.Log.Logging'Class) is abstract;

   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   procedure Finish_Object (Handler : in out Reader;
                            Name    : in String;
                            Logger  : in out Util.Log.Logging'Class) is abstract;

   procedure Start_Array (Handler : in out Reader;
                          Name    : in String;
                          Logger  : in out Util.Log.Logging'Class) is abstract;

   procedure Finish_Array (Handler : in out Reader;
                           Name    : in String;
                           Count   : in Natural;
                           Logger  : in out Util.Log.Logging'Class) is abstract;

   --  Set the name/value pair on the current object.  For each active mapping,
   --  find whether a rule matches our name and execute it.
   procedure Set_Member (Handler   : in out Reader;
                         Name      : in String;
                         Value     : in Util.Beans.Objects.Object;
                         Logger    : in out Util.Log.Logging'Class;
                         Attribute : in Boolean := False) is abstract;

   type Parser is abstract new Util.Log.Logging with private;

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

   --  Read the file and parse it using the parser.
   procedure Parse (Handler : in out Parser;
                    File    : in String;
                    Sink    : in out Reader'Class);

   --  Parse the content string.
   procedure Parse_String (Handler : in out Parser;
                           Content : in String;
                           Sink    : in out Reader'Class);

   --  Returns true if the Parse operation detected at least one error.
   function Has_Error (Handler : in Parser) return Boolean;

   --  Set the error logger to report messages while parsing and reading the input file.
   procedure Set_Logger (Handler : in out Parser;
                         Logger  : in Util.Log.Loggers.Logger_Access);

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

   --  Report an error while parsing the input stream.  The error message will be reported
   --  on the logger associated with the parser.  The parser will be set as in error so that
   --  the Has_Error function will return True after parsing the whole file.
   procedure Error (Handler : in out Parser;
                    Message : in String);

private

   type Parser is abstract new Util.Log.Logging with record
      Error_Flag     : Boolean := False;

      --  The file name to use when reporting errors.
      File           : Ada.Strings.Unbounded.Unbounded_String;

      --  The logger which is used to report error messages when parsing an input file.
      Error_Logger   : Util.Log.Loggers.Logger_Access := null;
   end record;

end Util.Serialize.IO;

Declare Write_Null_Attribute and Write_Null_Entity to write an attribute or entity with a null value