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

with ASF.Applications;

with ADO;
with ADO.Sessions;
with AWA.Events;
with AWA.Modules;
with AWA.Modules.Lifecycles;
with AWA.Wikis.Models;
with AWA.Tags.Beans;
with AWA.Counters.Definition;
with Security.Permissions;

--  == Events ==
--  The <tt>wikis</tt> exposes a number of events which are posted when some action
--  are performed at the service level.
--
--  === wiki-create-page ===
--  This event is posted when a new wiki page is created.
--
--  === wiki-create-content ===
--  This event is posted when a new wiki page content is created.  Each time a wiki page is
--  modified, a new wiki page content is created and this event is posted.
--
package AWA.Wikis.Modules is

   --  The name under which the module is registered.
   NAME : constant String := "wikis";

   --  The configuration parameter that defines the image link prefix in rendered HTML content.
   PARAM_IMAGE_PREFIX : constant String := "image_prefix";

   package ACL_Create_Wiki_Pages is new Security.Permissions.Definition ("wiki-page-create");
   package ACL_Delete_Wiki_Pages is new Security.Permissions.Definition ("wiki-page-delete");
   package ACL_Update_Wiki_Pages is new Security.Permissions.Definition ("wiki-page-update");
   package ACL_View_Wiki_Page is new Security.Permissions.Definition ("wiki-page-view");

   --  Define the permissions.
   package ACL_Create_Wiki_Space is new Security.Permissions.Definition ("wiki-space-create");
   package ACL_Delete_Wiki_Space is new Security.Permissions.Definition ("wiki-space-delete");
   package ACL_Update_Wiki_Space is new Security.Permissions.Definition ("wiki-space-update");

   --  Event posted when a new wiki page is created.
   package Create_Page_Event is new AWA.Events.Definition (Name => "wiki-create-page");

   --  Event posted when a new wiki content is created.
   package Create_Content_Event is new AWA.Events.Definition (Name => "wiki-create-content");

   --  Define the read wiki page counter.
   package Read_Counter is new AWA.Counters.Definition (Models.WIKI_PAGE_TABLE, "read_count");

   package Wiki_Lifecycle is
     new AWA.Modules.Lifecycles (Element_Type => AWA.Wikis.Models.Wiki_Page_Ref'Class);

   subtype Listener is Wiki_Lifecycle.Listener;

   --  The configuration parameter that defines a list of wiki page ID to copy when a new
   --  wiki space is created.
   PARAM_WIKI_COPY_LIST : constant String := "wiki_copy_list";

   --  Exception raised when a wiki page name is already used for the wiki space.
   Name_Used : exception;

   --  ------------------------------
   --  Module wikis
   --  ------------------------------
   type Wiki_Module is new AWA.Modules.Module with private;
   type Wiki_Module_Access is access all Wiki_Module'Class;

   --  Initialize the wikis module.
   overriding
   procedure Initialize (Plugin : in out Wiki_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config);

   --  Configures the module after its initialization and after having read its XML configuration.
   overriding
   procedure Configure (Plugin : in out Wiki_Module;
                        Props  : in ASF.Applications.Config);

   --  Get the image prefix that was configured for the Wiki module.
   function Get_Image_Prefix (Module : in Wiki_Module)
                              return Ada.Strings.Unbounded.Unbounded_String;

   --  Get the wikis module.
   function Get_Wiki_Module return Wiki_Module_Access;

   --  Create the wiki space.
   procedure Create_Wiki_Space (Module : in Wiki_Module;
                                Wiki   : in out AWA.Wikis.Models.Wiki_Space_Ref'Class);

   --  Save the wiki space.
   procedure Save_Wiki_Space (Module : in Wiki_Module;
                              Wiki   : in out AWA.Wikis.Models.Wiki_Space_Ref'Class);

   --  Load the wiki space.
   procedure Load_Wiki_Space (Module : in Wiki_Module;
                              Wiki   : in out AWA.Wikis.Models.Wiki_Space_Ref'Class;
                              Id     : in ADO.Identifier);

   --  Create the wiki page into the wiki space.
   procedure Create_Wiki_Page (Model   : in Wiki_Module;
                               Into    : in AWA.Wikis.Models.Wiki_Space_Ref'Class;
                               Page    : in out AWA.Wikis.Models.Wiki_Page_Ref'Class;
                               Content : in out AWA.Wikis.Models.Wiki_Content_Ref'Class);

   --  Save the wiki page.
   procedure Save (Model  : in Wiki_Module;
                   Page   : in out AWA.Wikis.Models.Wiki_Page_Ref'Class);

   --  Delete the wiki page as well as all its versions.
   procedure Delete (Model  : in Wiki_Module;
                     Page   : in out AWA.Wikis.Models.Wiki_Page_Ref'Class);

   --  Load the wiki page and its content.
   procedure Load_Page (Model   : in Wiki_Module;
                        Page    : in out AWA.Wikis.Models.Wiki_Page_Ref'Class;
                        Content : in out AWA.Wikis.Models.Wiki_Content_Ref'Class;
                        Tags    : in out AWA.Tags.Beans.Tag_List_Bean;
                        Id      : in ADO.Identifier);

   --  Load the wiki page and its content from the wiki space Id and the page name.
   procedure Load_Page (Model   : in Wiki_Module;
                        Page    : in out AWA.Wikis.Models.Wiki_Page_Ref'Class;
                        Content : in out AWA.Wikis.Models.Wiki_Content_Ref'Class;
                        Tags    : in out AWA.Tags.Beans.Tag_List_Bean;
                        Wiki    : in ADO.Identifier;
                        Name    : in String);

   --  Create a new wiki content for the wiki page.
   procedure Create_Wiki_Content (Model   : in Wiki_Module;
                                  Page    : in out AWA.Wikis.Models.Wiki_Page_Ref'Class;
                                  Content : in out AWA.Wikis.Models.Wiki_Content_Ref'Class);

   --  Save a new wiki content for the wiki page.
   procedure Save_Wiki_Content (Model   : in Wiki_Module;
                                Page    : in out AWA.Wikis.Models.Wiki_Page_Ref'Class;
                                Content : in out AWA.Wikis.Models.Wiki_Content_Ref'Class);

private
   --  Copy the wiki page with its last version to the wiki space.
   procedure Copy_Page (Module  : in Wiki_Module;
                        DB      : in out ADO.Sessions.Master_Session;
                        Wiki    : in AWA.Wikis.Models.Wiki_Space_Ref'Class;
                        Page_Id : in ADO.Identifier);

   --  Copy the wiki page with its last version to the wiki space.
   procedure Copy_Page (Module  : in Wiki_Module;
                        DB      : in out ADO.Sessions.Master_Session;
                        Wiki    : in AWA.Wikis.Models.Wiki_Space_Ref'Class;
                        Page    : in AWA.Wikis.Models.Wiki_Page_Ref'Class);

   --  Save a new wiki content for the wiki page.
   procedure Save_Wiki_Content (Model   : in Wiki_Module;
                                DB      : in out ADO.Sessions.Master_Session;
                                Page    : in out AWA.Wikis.Models.Wiki_Page_Ref'Class;
                                Content : in out AWA.Wikis.Models.Wiki_Content_Ref'Class);

   type Wiki_Module is new AWA.Modules.Module with record
      Image_Prefix : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end AWA.Wikis.Modules;

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

with ADO;
with ADO.Sessions;
with AWA.Events;
with AWA.Modules;
with AWA.Modules.Lifecycles;
with AWA.Wikis.Models;
with AWA.Tags.Beans;
with AWA.Counters.Definition;
with Security.Permissions;
with Wiki.Strings;

--  == Events ==
--  The <tt>wikis</tt> exposes a number of events which are posted when some action
--  are performed at the service level.
--
--  === wiki-create-page ===
--  This event is posted when a new wiki page is created.
--
--  === wiki-create-content ===
--  This event is posted when a new wiki page content is created.  Each time a wiki page is
--  modified, a new wiki page content is created and this event is posted.
--
package AWA.Wikis.Modules is

   --  The name under which the module is registered.
   NAME : constant String := "wikis";

   --  The configuration parameter that defines the image link prefix in rendered HTML content.
   PARAM_IMAGE_PREFIX : constant String := "image_prefix";

   package ACL_Create_Wiki_Pages is new Security.Permissions.Definition ("wiki-page-create");
   package ACL_Delete_Wiki_Pages is new Security.Permissions.Definition ("wiki-page-delete");
   package ACL_Update_Wiki_Pages is new Security.Permissions.Definition ("wiki-page-update");
   package ACL_View_Wiki_Page is new Security.Permissions.Definition ("wiki-page-view");

   --  Define the permissions.
   package ACL_Create_Wiki_Space is new Security.Permissions.Definition ("wiki-space-create");
   package ACL_Delete_Wiki_Space is new Security.Permissions.Definition ("wiki-space-delete");
   package ACL_Update_Wiki_Space is new Security.Permissions.Definition ("wiki-space-update");

   --  Event posted when a new wiki page is created.
   package Create_Page_Event is new AWA.Events.Definition (Name => "wiki-create-page");

   --  Event posted when a new wiki content is created.
   package Create_Content_Event is new AWA.Events.Definition (Name => "wiki-create-content");

   --  Define the read wiki page counter.
   package Read_Counter is new AWA.Counters.Definition (Models.WIKI_PAGE_TABLE, "read_count");

   package Wiki_Lifecycle is
     new AWA.Modules.Lifecycles (Element_Type => AWA.Wikis.Models.Wiki_Page_Ref'Class);

   subtype Listener is Wiki_Lifecycle.Listener;

   --  The configuration parameter that defines a list of wiki page ID to copy when a new
   --  wiki space is created.
   PARAM_WIKI_COPY_LIST : constant String := "wiki_copy_list";

   --  Exception raised when a wiki page name is already used for the wiki space.
   Name_Used : exception;

   --  ------------------------------
   --  Module wikis
   --  ------------------------------
   type Wiki_Module is new AWA.Modules.Module with private;
   type Wiki_Module_Access is access all Wiki_Module'Class;

   --  Initialize the wikis module.
   overriding
   procedure Initialize (Plugin : in out Wiki_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config);

   --  Configures the module after its initialization and after having read its XML configuration.
   overriding
   procedure Configure (Plugin : in out Wiki_Module;
                        Props  : in ASF.Applications.Config);

   --  Get the image prefix that was configured for the Wiki module.
   function Get_Image_Prefix (Module : in Wiki_Module)
                              return Wiki.Strings.UString;

   --  Get the wikis module.
   function Get_Wiki_Module return Wiki_Module_Access;

   --  Create the wiki space.
   procedure Create_Wiki_Space (Module : in Wiki_Module;
                                Wiki   : in out AWA.Wikis.Models.Wiki_Space_Ref'Class);

   --  Save the wiki space.
   procedure Save_Wiki_Space (Module : in Wiki_Module;
                              Wiki   : in out AWA.Wikis.Models.Wiki_Space_Ref'Class);

   --  Load the wiki space.
   procedure Load_Wiki_Space (Module : in Wiki_Module;
                              Wiki   : in out AWA.Wikis.Models.Wiki_Space_Ref'Class;
                              Id     : in ADO.Identifier);

   --  Create the wiki page into the wiki space.
   procedure Create_Wiki_Page (Model   : in Wiki_Module;
                               Into    : in AWA.Wikis.Models.Wiki_Space_Ref'Class;
                               Page    : in out AWA.Wikis.Models.Wiki_Page_Ref'Class;
                               Content : in out AWA.Wikis.Models.Wiki_Content_Ref'Class);

   --  Save the wiki page.
   procedure Save (Model  : in Wiki_Module;
                   Page   : in out AWA.Wikis.Models.Wiki_Page_Ref'Class);

   --  Delete the wiki page as well as all its versions.
   procedure Delete (Model  : in Wiki_Module;
                     Page   : in out AWA.Wikis.Models.Wiki_Page_Ref'Class);

   --  Load the wiki page and its content.
   procedure Load_Page (Model   : in Wiki_Module;
                        Page    : in out AWA.Wikis.Models.Wiki_Page_Ref'Class;
                        Content : in out AWA.Wikis.Models.Wiki_Content_Ref'Class;
                        Tags    : in out AWA.Tags.Beans.Tag_List_Bean;
                        Id      : in ADO.Identifier);

   --  Load the wiki page and its content from the wiki space Id and the page name.
   procedure Load_Page (Model   : in Wiki_Module;
                        Page    : in out AWA.Wikis.Models.Wiki_Page_Ref'Class;
                        Content : in out AWA.Wikis.Models.Wiki_Content_Ref'Class;
                        Tags    : in out AWA.Tags.Beans.Tag_List_Bean;
                        Wiki    : in ADO.Identifier;
                        Name    : in String);

   --  Create a new wiki content for the wiki page.
   procedure Create_Wiki_Content (Model   : in Wiki_Module;
                                  Page    : in out AWA.Wikis.Models.Wiki_Page_Ref'Class;
                                  Content : in out AWA.Wikis.Models.Wiki_Content_Ref'Class);

   --  Save a new wiki content for the wiki page.
   procedure Save_Wiki_Content (Model   : in Wiki_Module;
                                Page    : in out AWA.Wikis.Models.Wiki_Page_Ref'Class;
                                Content : in out AWA.Wikis.Models.Wiki_Content_Ref'Class);

private
   --  Copy the wiki page with its last version to the wiki space.
   procedure Copy_Page (Module  : in Wiki_Module;
                        DB      : in out ADO.Sessions.Master_Session;
                        Wiki    : in AWA.Wikis.Models.Wiki_Space_Ref'Class;
                        Page_Id : in ADO.Identifier);

   --  Copy the wiki page with its last version to the wiki space.
   procedure Copy_Page (Module  : in Wiki_Module;
                        DB      : in out ADO.Sessions.Master_Session;
                        Wiki    : in AWA.Wikis.Models.Wiki_Space_Ref'Class;
                        Page    : in AWA.Wikis.Models.Wiki_Page_Ref'Class);

   --  Save a new wiki content for the wiki page.
   procedure Save_Wiki_Content (Model   : in Wiki_Module;
                                DB      : in out ADO.Sessions.Master_Session;
                                Page    : in out AWA.Wikis.Models.Wiki_Page_Ref'Class;
                                Content : in out AWA.Wikis.Models.Wiki_Content_Ref'Class);

   type Wiki_Module is new AWA.Modules.Module with record
      Image_Prefix : Wiki.Strings.UString;
   end record;

end AWA.Wikis.Modules;

Use the Wiki.Strings.UString type for the image prefix


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

package body Security.OAuth.Clients is

   use Ada.Strings.Unbounded;

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

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

   Random_Generator : Security.Random.Generator;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end Security.OAuth.Clients;

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

package body Security.OAuth.Clients is

   use Ada.Strings.Unbounded;

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

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

   Random_Generator : Security.Random.Generator;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

   --  ------------------------------
   --  Refresh the access token.
   --  RFC 6749: 6.  Refreshing an Access Token
   --  ------------------------------
   procedure Refresh_Token (App      : in Application;
                            Scope    : in String;
                            Token    : in out Grant_Type'Class) is
      Client   : Util.Http.Clients.Client;

      Data : constant String
        := Security.OAuth.GRANT_TYPE & "=refresh_token"
          & "&"
        & Security.OAuth.REFRESH_TOKEN & "=" & To_String (Token.Refresh_Token)
        & "&"
        & Security.OAuth.CLIENT_ID & "=" & Ada.Strings.Unbounded.To_String (App.Client_Id)
        & "&"
        & Security.OAuth.SCOPE & "=" & Scope
        & "&"
        & Security.OAuth.CLIENT_SECRET & "=" & Ada.Strings.Unbounded.To_String (App.Secret);
      URI : constant String := Ada.Strings.Unbounded.To_String (App.Request_URI);
   begin
      Log.Info ("Refresh access token from {0}", URI);
      Do_Request_Token (App, URI, Data, Token);
   end Refresh_Token;

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

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

end Security.OAuth.Clients;

Implement the Refresh_Token procedure

Implement the Refresh_Token procedure


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

with 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);

   --  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);

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;

   Default_Http_Manager : Http_Manager_Access;

   type Response is 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 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 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);

   --  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);

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;

   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;

Fix compilation error with GNAT 2015

Fix compilation error with GNAT 2015


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

with AWA.Tags.Modules;
with AWA.Services.Contexts;
package body AWA.Questions.Beans is

   package ASC renames AWA.Services.Contexts;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Question_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "tags" then
         return Util.Beans.Objects.To_Object (From.Tags_Bean, Util.Beans.Objects.STATIC);
      elsif From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return AWA.Questions.Models.Question_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Question_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "title" then
         From.Set_Title (Util.Beans.Objects.To_String (Value));

      elsif Name = "description" then
         From.Set_Description (Util.Beans.Objects.To_String (Value));

      elsif Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         declare
            Ctx : constant ASC.Service_Context_Access := AWA.Services.Contexts.Current;
            DB  : constant ADO.Sessions.Session := AWA.Services.Contexts.Get_Session (Ctx);
            Id  : constant ADO.Identifier := ADO.Utils.To_Identifier (Value);
         begin
            From.Service.Load_Question (From, Id);
            From.Tags.Load_Tags (DB, Id);
         end;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create or save the question.
   --  ------------------------------
   procedure Save (Bean    : in out Question_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Save_Question (Bean);
      Bean.Tags.Update_Tags (Bean.Get_Id);
   end Save;

   --  ------------------------------
   --  Delete the question.
   --  ------------------------------
   procedure Delete (Bean    : in out Question_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Delete_Question (Bean);
   end Delete;

   --  ------------------------------
   --  Create the Question_Bean bean instance.
   --  ------------------------------
   function Create_Question_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
      return Util.Beans.Basic.Readonly_Bean_Access is
      Object : constant Question_Bean_Access := new Question_Bean;
   begin
      Object.Service   := Module;
      Object.Tags_Bean := Object.Tags'Access;
      Object.Tags.Set_Entity_Type (AWA.Questions.Models.QUESTION_TABLE);
      Object.Tags.Set_Permission ("question-edit");
      return Object.all'Access;
   end Create_Question_Bean;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Answer_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "question_id" then
         return Util.Beans.Objects.To_Object (Long_Long_Integer (From.Question.Get_Id));
      elsif From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return AWA.Questions.Models.Answer_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Answer_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         From.Service.Load_Answer (From, From.Question,
                                   ADO.Utils.To_Identifier (Value));

      elsif Name = "answer" then
         From.Set_Answer (Util.Beans.Objects.To_String (Value));

      elsif Name = "question_id" and not Util.Beans.Objects.Is_Null (Value) then
         From.Service.Load_Question (From.Question,
                                     ADO.Utils.To_Identifier (Value));
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create or save the answer.
   --  ------------------------------
   procedure Save (Bean    : in out Answer_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Save_Answer (Question => Bean.Question,
                                Answer   => Bean);
   end Save;

   --  ------------------------------
   --  Delete the question.
   --  ------------------------------
   procedure Delete (Bean    : in out Answer_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Delete_Answer (Answer => Bean);
   end Delete;

   --  ------------------------------
   --  Create the answer bean instance.
   --  ------------------------------
   function Create_Answer_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
                                return Util.Beans.Basic.Readonly_Bean_Access is
      Object : constant Answer_Bean_Access := new Answer_Bean;
   begin
      Object.Service := Module;
      return Object.all'Access;
   end Create_Answer_Bean;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Question_List_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
      Pos : Natural;
   begin
      if Name = "tags" then
         Pos := From.Questions.Get_Row_Index;
         if Pos = 0 then
            return Util.Beans.Objects.Null_Object;
         end if;
         declare
            Item : constant Models.Question_Info := From.Questions.List.Element (Pos);
         begin
            return From.Tags.Get_Tags (Item.Id);
         end;
      elsif Name = "questions" then
         return Util.Beans.Objects.To_Object (Value   => From.Questions_Bean,
                                              Storage => Util.Beans.Objects.STATIC);
      elsif Name = "tag" then
         return Util.Beans.Objects.To_Object (From.Tag);
      else
         return From.Questions.Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Question_List_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "tag" then
         From.Tag := Util.Beans.Objects.To_Unbounded_String (Value);
         From.Load_List;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Load the list of question.  If a tag was set, filter the list of questions with the tag.
   --  ------------------------------
   procedure Load_List (Into : in out Question_List_Bean) is
      use AWA.Questions.Models;
      use type ADO.Identifier;

      Session : ADO.Sessions.Session := Into.Service.Get_Session;
      Query   : ADO.Queries.Context;
      Tag_Id  : ADO.Identifier;
   begin
      AWA.Tags.Modules.Find_Tag_Id (Session, Ada.Strings.Unbounded.To_String (Into.Tag), Tag_Id);
      if Tag_Id /= ADO.NO_IDENTIFIER then
         Query.Set_Query (AWA.Questions.Models.Query_Question_Tag_List);
         Query.Bind_Param (Name => "tag", Value => Tag_Id);
      else
         Query.Set_Query (AWA.Questions.Models.Query_Question_List);
      end if;
      ADO.Sessions.Entities.Bind_Param (Params  => Query,
                                        Name    => "entity_type",
                                        Table   => AWA.Questions.Models.QUESTION_TABLE,
                                        Session => Session);
      AWA.Questions.Models.List (Into.Questions, Session, Query);
      declare
         List : ADO.Utils.Identifier_Vector;
         Iter : Question_Info_Vectors.Cursor := Into.Questions.List.First;
      begin
         while Question_Info_Vectors.Has_Element (Iter) loop
            List.Append (Question_Info_Vectors.Element (Iter).Id);
            Question_Info_Vectors.Next (Iter);
         end loop;
         Into.Tags.Load_Tags (Session, AWA.Questions.Models.QUESTION_TABLE.Table.all,
                              List);
      end;
   end Load_List;

   --  ------------------------------
   --  Create the Question_Info_List_Bean bean instance.
   --  ------------------------------
   function Create_Question_List_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
                                       return Util.Beans.Basic.Readonly_Bean_Access is
      Object  : constant Question_List_Bean_Access := new Question_List_Bean;
   begin
      Object.Service := Module;
      Object.Questions_Bean := Object.Questions'Unchecked_Access;
      Object.Load_List;
      return Object.all'Access;
   end Create_Question_List_Bean;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Question_Display_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "answers" then
         return Util.Beans.Objects.To_Object (Value   => From.Answer_List_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      elsif Name = "question" then
         return Util.Beans.Objects.To_Object (Value   => From.Question_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      elsif Name = "tags" then
         return Util.Beans.Objects.To_Object (Value   => From.Tags_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Question_Display_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         declare
            package ASC renames AWA.Services.Contexts;
            use AWA.Questions.Models;

            Session : ADO.Sessions.Session := From.Service.Get_Session;
            Query   : ADO.Queries.Context;
            List    : AWA.Questions.Models.Question_Display_Info_List_Bean;
            Ctx     : constant ASC.Service_Context_Access := ASC.Current;
            Id      : constant ADO.Identifier := ADO.Utils.To_Identifier (Value);
         begin
            Query.Set_Query (AWA.Questions.Models.Query_Question_Info);
            Query.Bind_Param ("question_id", Id);
            Query.Bind_Param ("user_id", Ctx.Get_User_Identifier);
            ADO.Sessions.Entities.Bind_Param (Params  => Query,
                                              Name    => "entity_type",
                                              Table   => AWA.Questions.Models.QUESTION_TABLE,
                                              Session => Session);
            AWA.Questions.Models.List (List, Session, Query);
            if not List.List.Is_Empty then
               From.Question := List.List.Element (1);
            end if;
            Query.Clear;
            Query.Bind_Param ("question_id", Id);
            Query.Bind_Param ("user_id", Ctx.Get_User_Identifier);
            ADO.Sessions.Entities.Bind_Param (Params  => Query,
                                              Name    => "entity_type",
                                              Table   => AWA.Questions.Models.ANSWER_TABLE,
                                              Session => Session);

            Query.Set_Query (AWA.Questions.Models.Query_Answer_List);
            AWA.Questions.Models.List (From.Answer_List, Session, Query);

            --  Load the tags if any.
            From.Tags.Load_Tags (Session, Id);
         end;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create the Question_Display_Bean bean instance.
   --  ------------------------------
   function Create_Question_Display_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
                                       return Util.Beans.Basic.Readonly_Bean_Access is
      Object  : constant Question_Display_Bean_Access := new Question_Display_Bean;
   begin
      Object.Service          := Module;
      Object.Question_Bean    := Object.Question'Access;
      Object.Answer_List_Bean := Object.Answer_List'Access;
      Object.Tags_Bean        := Object.Tags'Access;
      Object.Tags.Set_Entity_Type (AWA.Questions.Models.QUESTION_TABLE);
      return Object.all'Access;
   end Create_Question_Display_Bean;

end AWA.Questions.Beans;

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

with AWA.Tags.Modules;
with AWA.Services.Contexts;
package body AWA.Questions.Beans is

   use type ADO.Identifier;

   package ASC renames AWA.Services.Contexts;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Question_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "tags" then
         return Util.Beans.Objects.To_Object (From.Tags_Bean, Util.Beans.Objects.STATIC);
      elsif From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return AWA.Questions.Models.Question_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Question_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "title" then
         From.Set_Title (Util.Beans.Objects.To_String (Value));

      elsif Name = "description" then
         From.Set_Description (Util.Beans.Objects.To_String (Value));

      elsif Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         From.Set_Id (ADO.Utils.To_Identifier (Value));
      end if;

   exception
      when Constraint_Error =>
         From.Set_Id (ADO.NO_IDENTIFIER);

   end Set_Value;

   --  ------------------------------
   --  Load question.
   --  ------------------------------
   overriding
   procedure Load (Bean    : in out Question_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      Ctx   : constant ASC.Service_Context_Access := ASC.Current;
      DB    : constant ADO.Sessions.Session := ASC.Get_Session (Ctx);
      Found : Boolean;
   begin
      Bean.Service.Load_Question (Bean, Bean.Get_Id, Found);
      if not Found then
         Outcome := Ada.Strings.Unbounded.To_Unbounded_String ("not-found");
      else
         Outcome := Ada.Strings.Unbounded.To_Unbounded_String ("loaded");
         Bean.Tags.Load_Tags (DB, Bean.Id);
      end if;
   end Load;

   --  ------------------------------
   --  Create or save the question.
   --  ------------------------------
   overriding
   procedure Save (Bean    : in out Question_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Save_Question (Bean);
      Bean.Tags.Update_Tags (Bean.Get_Id);
   end Save;

   --  ------------------------------
   --  Delete the question.
   --  ------------------------------
   overriding
   procedure Delete (Bean    : in out Question_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Delete_Question (Bean);
   end Delete;

   --  ------------------------------
   --  Create the Question_Bean bean instance.
   --  ------------------------------
   function Create_Question_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
      return Util.Beans.Basic.Readonly_Bean_Access is
      Object : constant Question_Bean_Access := new Question_Bean;
   begin
      Object.Service   := Module;
      Object.Tags_Bean := Object.Tags'Access;
      Object.Tags.Set_Entity_Type (AWA.Questions.Models.QUESTION_TABLE);
      Object.Tags.Set_Permission ("question-edit");
      return Object.all'Access;
   end Create_Question_Bean;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Answer_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "question_id" then
         return Util.Beans.Objects.To_Object (Long_Long_Integer (From.Question.Get_Id));
      elsif From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return AWA.Questions.Models.Answer_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Answer_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         From.Set_Id (ADO.Utils.To_Identifier (Value));

      elsif Name = "answer" then
         From.Set_Answer (Util.Beans.Objects.To_String (Value));

      elsif Name = "question_id" and not Util.Beans.Objects.Is_Null (Value) then
         From.Question.Set_Id (ADO.Utils.To_Identifier (Value));

      end if;

   exception
      when Constraint_Error =>
         null;
   end Set_Value;

   --  ------------------------------
   --  Load the answer.
   --  ------------------------------
   overriding
   procedure Load (Bean    : in out Answer_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      Found : Boolean;
   begin
      if not Bean.is_Null and then Bean.Get_Id /= ADO.NO_IDENTIFIER then
         Bean.Service.Load_Answer (Bean, Bean.Question, Bean.Get_Id, Found);
      elsif not Bean.Question.Is_Null and then Bean.Question.Get_Id /= ADO.NO_IDENTIFIER then
         Bean.Service.Load_Question (Bean.Question, Bean.Question_Id, Found);
      else
         Found := False;
      end if;
      if not Found then
         Outcome := Ada.Strings.Unbounded.To_Unbounded_String ("not-found");
      else
         Outcome := Ada.Strings.Unbounded.To_Unbounded_String ("loaded");
      end if;
   end Load;

   --  ------------------------------
   --  Create or save the answer.
   --  ------------------------------
   overriding
   procedure Save (Bean    : in out Answer_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Save_Answer (Question => Bean.Question,
                                Answer   => Bean);
   end Save;

   --  ------------------------------
   --  Delete the question.
   --  ------------------------------
   overriding
   procedure Delete (Bean    : in out Answer_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Delete_Answer (Answer => Bean);
   end Delete;

   --  ------------------------------
   --  Create the answer bean instance.
   --  ------------------------------
   function Create_Answer_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
                                return Util.Beans.Basic.Readonly_Bean_Access is
      Object : constant Answer_Bean_Access := new Answer_Bean;
   begin
      Object.Service := Module;
      return Object.all'Access;
   end Create_Answer_Bean;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Question_List_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
      Pos : Natural;
   begin
      if Name = "tags" then
         Pos := From.Questions.Get_Row_Index;
         if Pos = 0 then
            return Util.Beans.Objects.Null_Object;
         end if;
         declare
            Item : constant Models.Question_Info := From.Questions.List.Element (Pos);
         begin
            return From.Tags.Get_Tags (Item.Id);
         end;
      elsif Name = "questions" then
         return Util.Beans.Objects.To_Object (Value   => From.Questions_Bean,
                                              Storage => Util.Beans.Objects.STATIC);
      elsif Name = "tag" then
         return Util.Beans.Objects.To_Object (From.Tag);
      else
         return From.Questions.Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Question_List_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "tag" then
         From.Tag := Util.Beans.Objects.To_Unbounded_String (Value);
      end if;
   end Set_Value;

   --  ------------------------------
   --  Load the list of question.  If a tag was set, filter the list of questions with the tag.
   --  ------------------------------
   procedure Load_List (Into : in out Question_List_Bean) is
      use AWA.Questions.Models;

      Session : ADO.Sessions.Session := Into.Service.Get_Session;
      Query   : ADO.Queries.Context;
      Tag_Id  : ADO.Identifier;
   begin
      AWA.Tags.Modules.Find_Tag_Id (Session, Ada.Strings.Unbounded.To_String (Into.Tag), Tag_Id);
      if Tag_Id /= ADO.NO_IDENTIFIER then
         Query.Set_Query (AWA.Questions.Models.Query_Question_Tag_List);
         Query.Bind_Param (Name => "tag", Value => Tag_Id);
      else
         Query.Set_Query (AWA.Questions.Models.Query_Question_List);
      end if;
      AWA.Questions.Models.List (Into.Questions, Session, Query);
      declare
         List : ADO.Utils.Identifier_Vector;
         Iter : Question_Info_Vectors.Cursor := Into.Questions.List.First;
      begin
         while Question_Info_Vectors.Has_Element (Iter) loop
            List.Append (Question_Info_Vectors.Element (Iter).Id);
            Question_Info_Vectors.Next (Iter);
         end loop;
         Into.Tags.Load_Tags (Session, AWA.Questions.Models.QUESTION_TABLE.Table.all,
                              List);
      end;
   end Load_List;

   --  ------------------------------
   --  Load the list of questions.
   --  ------------------------------
   overriding
   procedure Load (Bean    : in out Question_List_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Bean.Load_List;
   end Load;

   --  ------------------------------
   --  Create the Question_Info_List_Bean bean instance.
   --  ------------------------------
   function Create_Question_List_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
                                       return Util.Beans.Basic.Readonly_Bean_Access is
      Object  : constant Question_List_Bean_Access := new Question_List_Bean;
   begin
      Object.Service := Module;
      Object.Questions_Bean := Object.Questions'Unchecked_Access;
      Object.Load_List;
      return Object.all'Access;
   end Create_Question_List_Bean;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Question_Display_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "answers" then
         return Util.Beans.Objects.To_Object (Value   => From.Answer_List_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      elsif Name = "question" then
         return Util.Beans.Objects.To_Object (Value   => From.Question_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      elsif Name = "tags" then
         return Util.Beans.Objects.To_Object (Value   => From.Tags_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Question_Display_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         From.Id := ADO.Utils.To_Identifier (Value);
         From.Answer := Get_Answer_Bean ("answer");
         From.Answer.Set_Value ("question_id", Value);
      end if;

   exception
      when Constraint_Error =>
         null;
   end Set_Value;

   --  ------------------------------
   --  Load the question and its answers.
   --  ------------------------------
   overriding
   procedure Load (Bean    : in out Question_Display_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      package ASC renames AWA.Services.Contexts;
      use AWA.Questions.Models;

      Session : ADO.Sessions.Session := Bean.Service.Get_Session;
      Query   : ADO.Queries.Context;
      List    : AWA.Questions.Models.Question_Display_Info_List_Bean;
      Ctx     : constant ASC.Service_Context_Access := ASC.Current;
   begin
      Query.Set_Query (AWA.Questions.Models.Query_Question_Info);
      Query.Bind_Param ("question_id", Bean.Id);
      Query.Bind_Param ("user_id", Ctx.Get_User_Identifier);
      AWA.Questions.Models.List (List, Session, Query);
      if List.List.Is_Empty then
         Outcome := Ada.Strings.Unbounded.To_Unbounded_String ("not-found");
         return;
      end if;
      Bean.Question := List.List.Element (1);

      Query.Clear;
      Query.Bind_Param ("question_id", Bean.Id);
      Query.Bind_Param ("user_id", Ctx.Get_User_Identifier);
      Query.Set_Query (AWA.Questions.Models.Query_Answer_List);
      AWA.Questions.Models.List (Bean.Answer_List, Session, Query);

      --  Load the tags if any.
      Bean.Tags.Load_Tags (Session, Bean.Id);
   end Load;

   --  ------------------------------
   --  Create the Question_Display_Bean bean instance.
   --  ------------------------------
   function Create_Question_Display_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
                                       return Util.Beans.Basic.Readonly_Bean_Access is
      Object  : constant Question_Display_Bean_Access := new Question_Display_Bean;
   begin
      Object.Service          := Module;
      Object.Question_Bean    := Object.Question'Access;
      Object.Answer_List_Bean := Object.Answer_List'Access;
      Object.Tags_Bean        := Object.Tags'Access;
      Object.Tags.Set_Entity_Type (AWA.Questions.Models.QUESTION_TABLE);
      return Object.all'Access;
   end Create_Question_Display_Bean;

end AWA.Questions.Beans;

Refactor the question beans: - Implement the Load bean operations - Avoid loading a list/question/answer by setting the question/answer id