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

with Util.Http;
with Security.Permissions;

--  The Security.Openid package implements an authentication framework based
--  on OpenID 2.0.
--
--  See OpenID Authentication 2.0 - Final
--  http://openid.net/specs/openid-authentication-2_0.html
package Security.Openid is

   Invalid_End_Point : exception;

   Service_Error     : exception;

   type Parameters is limited interface;

   function Get_Parameter (Params : in Parameters;
                           Name   : in String) return String is abstract;

   --  ------------------------------
   --  OpenID provider
   --  ------------------------------
   --  The End_Point represents the OpenID provider that will authenticate
   --  the user.
   type End_Point is private;

   function To_String (OP : End_Point) return String;

   --  ------------------------------
   --  Association
   --  ------------------------------
   --  The OpenID association contains the shared secret between the relying party
   --  and the OpenID provider.  The association can be cached and reused to authenticate
   --  different users using the same OpenID provider.  The association also has an
   --  expiration date.
   type Association is private;

   --  Dump the association as a string (for debugging purposes)
   function To_String (Assoc : Association) return String;

   type Auth_Result is (AUTHENTICATED, CANCEL, SETUP_NEEDED, UNKNOWN, INVALID_SIGNATURE);

   --  ------------------------------
   --  OpenID provider
   --  ------------------------------
   --
   type Authentication is private;

   --  Get the email address
   function Get_Email (Auth : in Authentication) return String;

   --  Get the user first name.
   function Get_First_Name (Auth : in Authentication) return String;

   --  Get the user last name.
   function Get_Last_Name (Auth : in Authentication) return String;

   --  Get the user full name.
   function Get_Full_Name (Auth : in Authentication) return String;

   --  Get the user identity.
   function Get_Identity (Auth : in Authentication) return String;

   --  Get the user claimed identity.
   function Get_Claimed_Id (Auth : in Authentication) return String;

   --  Get the user language.
   function Get_Language (Auth : in Authentication) return String;

   --  Get the user country.
   function Get_Country (Auth : in Authentication) return String;

   --  Get the result of the authentication.
   function Get_Status (Auth : in Authentication) return Auth_Result;

   --  ------------------------------
   --  OpenID Default principal
   --  ------------------------------
   type Principal is new Security.Permissions.Principal with private;
   type Principal_Access is access all Principal'Class;

   --  Returns true if the given role is stored in the user principal.
   function Has_Role (User : in Principal;
                      Role : in Permissions.Role_Type) return Boolean;

   --  Get the principal name.
   function Get_Name (From : in Principal) return String;

   --  Get the user email address.
   function Get_Email (From : in Principal) return String;

   --  Get the authentication data.
   function Get_Authentication (From : in Principal) return Authentication;

   --  Create a principal with the given authentication results.
   function Create_Principal (Auth : in Authentication) return Principal_Access;

   --  ------------------------------
   --  OpenID Manager
   --  ------------------------------
   --  The process is the following:
   --
   --  o Initialize is called to configure the OpenID realm and set the
   --    OpenID return callback CB.
   --  o Discover is called to retrieve from the OpenID provider the XRDS
   --    stream and identify the provider.  An End_Point is returned.
   --  o Associate is called to make the association with the End_Point.
   --    The Association record holds session, and authentication.
   --  o Get_Authentication_URL builds the provider OpenID authentication
   --    URL for the association.
   --  o The user should be redirected to the authentication URL.
   --  o The OpenID provider authenticate the user and redirects the user to the callback CB.
   --  o The association is decoded from the callback parameter.
   --  o Verify is called with the association to check the result and
   --    obtain the authentication results.
   type Manager is tagged limited private;

   --  Initialize the OpenID realm.
   procedure Initialize (Realm     : in out Manager;
                         Name      : in String;
                         Return_To : in String);

   --  Discover the OpenID provider that must be used to authenticate the user.
   --  The Name can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.
   --  (See OpenID Section 7.3 Discovery)
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point);

   --  Associate the application (relying party) with the OpenID provider.
   --  The association can be cached.
   --  (See OpenID Section 8 Establishing Associations)
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association);

   function Get_Authentication_URL (Realm : in Manager;
                                    OP    : in End_Point;
                                    Assoc : in Association) return String;

   --  Verify the authentication result
   procedure Verify (Realm   : in out Manager;
                     Assoc   : in Association;
                     Request : in Parameters'Class;
                     Result  : out Authentication);

   --  Verify the authentication result
   procedure Verify_Discovered (Realm   : in out Manager;
                                Assoc   : in Association;
                                Request : in Parameters'Class;
                                Result  : out Authentication);

   --  Verify the signature part of the result
   procedure Verify_Signature (Realm   : in Manager;
                               Assoc   : in Association;
                               Request : in Parameters'Class;
                               Result  : in out Authentication);

   --  Read the XRDS document from the URI and initialize the OpenID provider end point.
   procedure Discover_XRDS (Realm  : in out Manager;
                            URI    : in String;
                            Result : out End_Point);

   --  Extract from the XRDS content the OpenID provider URI.
   --  The default implementation is very basic as it returns the first <URI>
   --  available in the stream without validating the XRDS document.
   --  Raises the Invalid_End_Point exception if the URI cannot be found.
   procedure Extract_XRDS (Realm   : in out Manager;
                           Content : in String;
                           Result  : out End_Point);

private

   use Ada.Strings.Unbounded;

   type Association is record
      Session_Type : Unbounded_String;
      Assoc_Type   : Unbounded_String;
      Assoc_Handle : Unbounded_String;
      Mac_Key      : Unbounded_String;
      Expired      : Ada.Calendar.Time;
   end record;

   type Authentication is record
      Status     : Auth_Result;
      Identity   : Unbounded_String;
      Claimed_Id : Unbounded_String;
      Email      : Unbounded_String;
      Full_Name  : Unbounded_String;
      First_Name : Unbounded_String;
      Last_Name  : Unbounded_String;
      Language   : Unbounded_String;
      Country    : Unbounded_String;
      Gender     : Unbounded_String;
      Timezone   : Unbounded_String;
      Nickname   : Unbounded_String;
   end record;

   type End_Point is record
      URL        : Unbounded_String;
      Alias      : Unbounded_String;
      Expired    : Ada.Calendar.Time;
   end record;

   type Manager is new Ada.Finalization.Limited_Controlled with record
      Realm     : Unbounded_String;
      Return_To : Unbounded_String;
   end record;

   type Principal is new Security.Permissions.Principal with record
      Auth : Authentication;
   end record;

end Security.Openid;

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

with Security.Permissions;

--  == OpenID ==
--  The Security.Openid package implements an authentication framework based
--  on OpenID 2.0.
--
--  See OpenID Authentication 2.0 - Final
--  http://openid.net/specs/openid-authentication-2_0.html
package Security.Openid is

   Invalid_End_Point : exception;

   Service_Error     : exception;

   type Parameters is limited interface;

   function Get_Parameter (Params : in Parameters;
                           Name   : in String) return String is abstract;

   --  ------------------------------
   --  OpenID provider
   --  ------------------------------
   --  The End_Point represents the OpenID provider that will authenticate
   --  the user.
   type End_Point is private;

   function To_String (OP : End_Point) return String;

   --  ------------------------------
   --  Association
   --  ------------------------------
   --  The OpenID association contains the shared secret between the relying party
   --  and the OpenID provider.  The association can be cached and reused to authenticate
   --  different users using the same OpenID provider.  The association also has an
   --  expiration date.
   type Association is private;

   --  Dump the association as a string (for debugging purposes)
   function To_String (Assoc : Association) return String;

   type Auth_Result is (AUTHENTICATED, CANCEL, SETUP_NEEDED, UNKNOWN, INVALID_SIGNATURE);

   --  ------------------------------
   --  OpenID provider
   --  ------------------------------
   --
   type Authentication is private;

   --  Get the email address
   function Get_Email (Auth : in Authentication) return String;

   --  Get the user first name.
   function Get_First_Name (Auth : in Authentication) return String;

   --  Get the user last name.
   function Get_Last_Name (Auth : in Authentication) return String;

   --  Get the user full name.
   function Get_Full_Name (Auth : in Authentication) return String;

   --  Get the user identity.
   function Get_Identity (Auth : in Authentication) return String;

   --  Get the user claimed identity.
   function Get_Claimed_Id (Auth : in Authentication) return String;

   --  Get the user language.
   function Get_Language (Auth : in Authentication) return String;

   --  Get the user country.
   function Get_Country (Auth : in Authentication) return String;

   --  Get the result of the authentication.
   function Get_Status (Auth : in Authentication) return Auth_Result;

   --  ------------------------------
   --  OpenID Default principal
   --  ------------------------------
   type Principal is new Security.Permissions.Principal with private;
   type Principal_Access is access all Principal'Class;

   --  Returns true if the given role is stored in the user principal.
   function Has_Role (User : in Principal;
                      Role : in Permissions.Role_Type) return Boolean;

   --  Get the principal name.
   function Get_Name (From : in Principal) return String;

   --  Get the user email address.
   function Get_Email (From : in Principal) return String;

   --  Get the authentication data.
   function Get_Authentication (From : in Principal) return Authentication;

   --  Create a principal with the given authentication results.
   function Create_Principal (Auth : in Authentication) return Principal_Access;

   --  ------------------------------
   --  OpenID Manager
   --  ------------------------------
   --  The process is the following:
   --
   --  o Initialize is called to configure the OpenID realm and set the
   --    OpenID return callback CB.
   --  o Discover is called to retrieve from the OpenID provider the XRDS
   --    stream and identify the provider.  An End_Point is returned.
   --  o Associate is called to make the association with the End_Point.
   --    The Association record holds session, and authentication.
   --  o Get_Authentication_URL builds the provider OpenID authentication
   --    URL for the association.
   --  o The user should be redirected to the authentication URL.
   --  o The OpenID provider authenticate the user and redirects the user to the callback CB.
   --  o The association is decoded from the callback parameter.
   --  o Verify is called with the association to check the result and
   --    obtain the authentication results.
   type Manager is tagged limited private;

   --  Initialize the OpenID realm.
   procedure Initialize (Realm     : in out Manager;
                         Name      : in String;
                         Return_To : in String);

   --  Discover the OpenID provider that must be used to authenticate the user.
   --  The Name can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.
   --  (See OpenID Section 7.3 Discovery)
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point);

   --  Associate the application (relying party) with the OpenID provider.
   --  The association can be cached.
   --  (See OpenID Section 8 Establishing Associations)
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association);

   function Get_Authentication_URL (Realm : in Manager;
                                    OP    : in End_Point;
                                    Assoc : in Association) return String;

   --  Verify the authentication result
   procedure Verify (Realm   : in out Manager;
                     Assoc   : in Association;
                     Request : in Parameters'Class;
                     Result  : out Authentication);

   --  Verify the authentication result
   procedure Verify_Discovered (Realm   : in out Manager;
                                Assoc   : in Association;
                                Request : in Parameters'Class;
                                Result  : out Authentication);

   --  Verify the signature part of the result
   procedure Verify_Signature (Realm   : in Manager;
                               Assoc   : in Association;
                               Request : in Parameters'Class;
                               Result  : in out Authentication);

   --  Read the XRDS document from the URI and initialize the OpenID provider end point.
   procedure Discover_XRDS (Realm  : in out Manager;
                            URI    : in String;
                            Result : out End_Point);

   --  Extract from the XRDS content the OpenID provider URI.
   --  The default implementation is very basic as it returns the first <URI>
   --  available in the stream without validating the XRDS document.
   --  Raises the Invalid_End_Point exception if the URI cannot be found.
   procedure Extract_XRDS (Realm   : in out Manager;
                           Content : in String;
                           Result  : out End_Point);

private

   use Ada.Strings.Unbounded;

   type Association is record
      Session_Type : Unbounded_String;
      Assoc_Type   : Unbounded_String;
      Assoc_Handle : Unbounded_String;
      Mac_Key      : Unbounded_String;
      Expired      : Ada.Calendar.Time;
   end record;

   type Authentication is record
      Status     : Auth_Result;
      Identity   : Unbounded_String;
      Claimed_Id : Unbounded_String;
      Email      : Unbounded_String;
      Full_Name  : Unbounded_String;
      First_Name : Unbounded_String;
      Last_Name  : Unbounded_String;
      Language   : Unbounded_String;
      Country    : Unbounded_String;
      Gender     : Unbounded_String;
      Timezone   : Unbounded_String;
      Nickname   : Unbounded_String;
   end record;

   type End_Point is record
      URL        : Unbounded_String;
      Alias      : Unbounded_String;
      Expired    : Ada.Calendar.Time;
   end record;

   type Manager is new Ada.Finalization.Limited_Controlled with record
      Realm     : Unbounded_String;
      Return_To : Unbounded_String;
   end record;

   type Principal is new Security.Permissions.Principal with record
      Auth : Authentication;
   end record;

end Security.Openid;

Include in generated dynamo documentation


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

with Util.Strings;
with Util.Log;
with Util.Log.Loggers;
with ADO.Sessions;
with ADO.Model;
with ADO.Objects;
with ADO.SQL;

package body ADO.Sequences.Hilo is

   use Util.Log;
   use ADO.Sessions;
   use Sequence_Maps;
   use ADO.Model;

   Log : constant Loggers.Logger := Loggers.Create ("ADO.Sequences.Hilo");

   type HiLoGenerator_Access is access all HiLoGenerator'Class;

   --  ------------------------------
   --  Create a high low sequence generator
   --  ------------------------------
   function Create_HiLo_Generator
     (Sess_Factory : in Session_Factory_Access)
      return Generator_Access is
      Result : constant HiLoGenerator_Access := new HiLoGenerator;
   begin
      Result.Factory := Sess_Factory;
      return Result.all'Access;
   end Create_HiLo_Generator;

   --  ------------------------------
   --  Allocate an identifier using the generator.
   --  The generator allocates blocks of sequences by using a sequence
   --  table stored in the database.  One database access is necessary
   --  every N allocations.
   --  ------------------------------
   procedure Allocate (Gen : in out HiLoGenerator;
                       Id  : in out Objects.Object_Record'Class) is
   begin
      --  Get a new sequence range
      if Gen.Next_Id >= Gen.Last_Id then
         Allocate_Sequence (Gen);
      end if;

      Id.Set_Key_Value (Gen.Next_Id);
      Gen.Next_Id := Gen.Next_Id + 1;
   end Allocate;

   --  ------------------------------
   --  Allocate a new sequence block.
   --  ------------------------------
   procedure Allocate_Sequence (Gen : in out HiLoGenerator) is
      Name      : constant String := Get_Sequence_Name (Gen);
      Value     : Identifier;
      Seq_Block : Sequence_Ref;
      DB        : Master_Session'Class := Gen.Get_Session;
   begin
      for Retry in 1 .. 10 loop
         --  Allocate a new sequence within a transaction.
         declare
            Query : ADO.SQL.Query;
            Found : Boolean;
         begin
            Log.Info ("Allocate sequence range for {0}", Name);

            DB.Begin_Transaction;
            Query.Set_Filter ("name = ?");
            Query.Bind_Param (Position => 1, Value => Name);
            Seq_Block.Find (Session => DB, Query => Query, Found => Found);

            begin
               if Found then
                  Value := Seq_Block.Get_Value;
                  Seq_Block.Set_Value (Value + Seq_Block.Get_Block_Size);
                  Seq_Block.Save (DB);
               else
                  Value := 1;
                  Seq_Block.Set_Name (Name);
                  Seq_Block.Set_Block_Size (Gen.Block_Size);
                  Seq_Block.Set_Value (Value + Seq_Block.Get_Block_Size);
                  Seq_Block.Create (DB);
               end if;
               DB.Commit;

               Gen.Next_Id := Value;
               Gen.Last_Id := Seq_Block.Get_Value;
               return;

            exception
               when ADO.Objects.LAZY_LOCK =>
                  Log.Info ("Sequence table modified, retrying {0}/100",
                            Util.Strings.Image (Retry));
                  DB.Rollback;
                  delay 0.01 * Retry;
            end;

         exception
            when E : others =>
               Log.Error ("Cannot allocate sequence range", E);
               raise;
         end;
      end loop;
      Log.Error ("Cannot allocate sequence range");
      raise ADO.Objects.ALLOCATE_ID_ERROR with "Cannot allocate unique identifier";
   end Allocate_Sequence;

end ADO.Sequences.Hilo;

-----------------------------------------------------------------------
--  ADO Sequences -- Database sequence generator
--  Copyright (C) 2009, 2010, 2011, 2012, 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 Util.Strings;
with Util.Log;
with Util.Log.Loggers;
with ADO.Sessions;
with ADO.Model;
with ADO.Objects;
with ADO.SQL;

package body ADO.Sequences.Hilo is

   use Util.Log;
   use ADO.Sessions;
   use ADO.Model;

   Log : constant Loggers.Logger := Loggers.Create ("ADO.Sequences.Hilo");

   type HiLoGenerator_Access is access all HiLoGenerator'Class;

   --  ------------------------------
   --  Create a high low sequence generator
   --  ------------------------------
   function Create_HiLo_Generator
     (Sess_Factory : in Session_Factory_Access)
      return Generator_Access is
      Result : constant HiLoGenerator_Access := new HiLoGenerator;
   begin
      Result.Factory := Sess_Factory;
      return Result.all'Access;
   end Create_HiLo_Generator;

   --  ------------------------------
   --  Allocate an identifier using the generator.
   --  The generator allocates blocks of sequences by using a sequence
   --  table stored in the database.  One database access is necessary
   --  every N allocations.
   --  ------------------------------
   procedure Allocate (Gen : in out HiLoGenerator;
                       Id  : in out Objects.Object_Record'Class) is
   begin
      --  Get a new sequence range
      if Gen.Next_Id >= Gen.Last_Id then
         Allocate_Sequence (Gen);
      end if;

      Id.Set_Key_Value (Gen.Next_Id);
      Gen.Next_Id := Gen.Next_Id + 1;
   end Allocate;

   --  ------------------------------
   --  Allocate a new sequence block.
   --  ------------------------------
   procedure Allocate_Sequence (Gen : in out HiLoGenerator) is
      Name      : constant String := Get_Sequence_Name (Gen);
      Value     : Identifier;
      Seq_Block : Sequence_Ref;
      DB        : Master_Session'Class := Gen.Get_Session;
   begin
      for Retry in 1 .. 10 loop
         --  Allocate a new sequence within a transaction.
         declare
            Query : ADO.SQL.Query;
            Found : Boolean;
         begin
            Log.Info ("Allocate sequence range for {0}", Name);

            DB.Begin_Transaction;
            Query.Set_Filter ("name = ?");
            Query.Bind_Param (Position => 1, Value => Name);
            Seq_Block.Find (Session => DB, Query => Query, Found => Found);

            begin
               if Found then
                  Value := Seq_Block.Get_Value;
                  Seq_Block.Set_Value (Value + Seq_Block.Get_Block_Size);
                  Seq_Block.Save (DB);
               else
                  Value := 1;
                  Seq_Block.Set_Name (Name);
                  Seq_Block.Set_Block_Size (Gen.Block_Size);
                  Seq_Block.Set_Value (Value + Seq_Block.Get_Block_Size);
                  Seq_Block.Create (DB);
               end if;
               DB.Commit;

               Gen.Next_Id := Value;
               Gen.Last_Id := Seq_Block.Get_Value;
               return;

            exception
               when ADO.Objects.LAZY_LOCK =>
                  Log.Info ("Sequence table modified, retrying {0}/100",
                            Util.Strings.Image (Retry));
                  DB.Rollback;
                  delay 0.01 * Retry;
            end;

         exception
            when E : others =>
               Log.Error ("Cannot allocate sequence range", E);
               raise;
         end;
      end loop;
      Log.Error ("Cannot allocate sequence range");
      raise ADO.Objects.ALLOCATE_ID_ERROR with "Cannot allocate unique identifier";
   end Allocate_Sequence;

end ADO.Sequences.Hilo;

Remove unecessary use clause

Remove unecessary use clause


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

with Ada.Unchecked_Deallocation;

with ASF.Contexts.Exceptions;
package body ASF.Lifecycles is

   --  ------------------------------
   --  Initialize the the lifecycle handler.
   --  ------------------------------
   procedure Initialize (Controller : in out Lifecycle;
                         App        : access ASF.Applications.Main.Application'Class) is
   begin
      --  Create the phase controllers.
      Lifecycle'Class (Controller).Create_Phase_Controllers;

      --  Initialize the phase controllers.
      for Phase in Controller.Controllers'Range loop
         Controller.Controllers (Phase).Initialize (App);
      end loop;
   end Initialize;

   --  ------------------------------
   --  Finalize the lifecycle handler, freeing the allocated storage.
   --  ------------------------------
   overriding
   procedure Finalize (Controller : in out Lifecycle) is
      procedure Free is new Ada.Unchecked_Deallocation (Phase_Controller'Class,
                                                        Phase_Controller_Access);
   begin
      --  Free the phase controllers.
      for Phase in Controller.Controllers'Range loop
         Free (Controller.Controllers (Phase));
      end loop;
   end Finalize;

   --  ------------------------------
   --  Set the controller to be used for the given phase.
   --  ------------------------------
   procedure Set_Controller (Controller : in out Lifecycle;
                             Phase      : in Phase_Type;
                             Instance   : in Phase_Controller_Access) is
   begin
      Controller.Controllers (Phase) := Instance;
   end Set_Controller;

   --  ------------------------------
   --  Register a bundle and bind it to a facelet variable.
   --  ------------------------------
   procedure Execute (Controller : in Lifecycle;
                      Context    : in out ASF.Contexts.Faces.Faces_Context'Class) is
      use type ASF.Contexts.Exceptions.Exception_Handler_Access;
      use ASF.Events.Phases;

      Listeners : constant Listener_Vectors.Ref := Controller.Listeners.Get;
   begin
      for Phase in RESTORE_VIEW .. INVOKE_APPLICATION loop
         if Context.Get_Render_Response or Context.Get_Response_Completed then
            return;
         end if;
         declare
            procedure Before_Phase (Listener : in ASF.Events.Phases.Phase_Listener_Access);
            procedure After_Phase (Listener : in ASF.Events.Phases.Phase_Listener_Access);

            Event : ASF.Events.Phases.Phase_Event (Phase);

            procedure Before_Phase (Listener : in ASF.Events.Phases.Phase_Listener_Access) is
               P : constant ASF.Events.Phases.Phase_Type := Listener.Get_Phase;
            begin
               if P = Event.Phase or P = ASF.Events.Phases.ANY_PHASE then
                  Listener.Before_Phase (Event);
               end if;

            exception
               when E : others =>
                  Context.Queue_Exception (E);
            end Before_Phase;

            procedure After_Phase (Listener : in ASF.Events.Phases.Phase_Listener_Access) is
               P : constant ASF.Events.Phases.Phase_Type := Listener.Get_Phase;
            begin
               if P = Event.Phase or P = ASF.Events.Phases.ANY_PHASE then
                  Listener.Before_Phase (Event);
               end if;

            exception
               when E : others =>
                  Context.Queue_Exception (E);
            end After_Phase;

         begin
            Context.Set_Current_Phase (Phase);

            --  Call the before phase listeners if there are some.
            if not Listeners.Is_Empty then
               Listeners.Iterate (Before_Phase'Access);
            end if;

            begin
               Controller.Controllers (Phase).Execute (Context);
            exception
               when E : others =>
                  Context.Queue_Exception (E);
            end;

            if not Listeners.Is_Empty then
               Listeners.Iterate (After_Phase'Access);
            end if;

            --  If exceptions have been raised and queued during the current phase, process them.
            --  An exception handler could use them to redirect the current request to another
            --  page or navigate to a specific view.
            declare
               Ex : constant ASF.Contexts.Exceptions.Exception_Handler_Access
                 := Context.Get_Exception_Handler;
            begin
               if Ex /= null then
                  Ex.Handle;
               end if;
            end;
         end;
      end loop;
   end Execute;

   --  ------------------------------
   --  Render the response by executing the response phase.
   --  ------------------------------
   procedure Render (Controller : in Lifecycle;
                     Context    : in out ASF.Contexts.Faces.Faces_Context'Class) is
   begin
      Context.Set_Current_Phase (ASF.Events.Phases.RENDER_RESPONSE);
      Controller.Controllers (ASF.Events.Phases.RENDER_RESPONSE).Execute (Context);
   end Render;

   --  ------------------------------
   --  Add a phase listener in the lifecycle controller.
   --  ------------------------------
   procedure Add_Phase_Listener (Controller : in out Lifecycle;
                                 Listener   : in ASF.Events.Phases.Phase_Listener_Access) is
   begin
      Controller.Listeners.Append (Listener);
   end Add_Phase_Listener;

end ASF.Lifecycles;

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

with Ada.Unchecked_Deallocation;

with ASF.Contexts.Exceptions;
package body ASF.Lifecycles is

   --  ------------------------------
   --  Initialize the the lifecycle handler.
   --  ------------------------------
   procedure Initialize (Controller : in out Lifecycle;
                         App        : access ASF.Applications.Main.Application'Class) is
   begin
      --  Create the phase controllers.
      Lifecycle'Class (Controller).Create_Phase_Controllers;

      --  Initialize the phase controllers.
      for Phase in Controller.Controllers'Range loop
         Controller.Controllers (Phase).Initialize (App);
      end loop;
   end Initialize;

   --  ------------------------------
   --  Finalize the lifecycle handler, freeing the allocated storage.
   --  ------------------------------
   overriding
   procedure Finalize (Controller : in out Lifecycle) is
      procedure Free is new Ada.Unchecked_Deallocation (Phase_Controller'Class,
                                                        Phase_Controller_Access);
   begin
      --  Free the phase controllers.
      for Phase in Controller.Controllers'Range loop
         Free (Controller.Controllers (Phase));
      end loop;
   end Finalize;

   --  ------------------------------
   --  Set the controller to be used for the given phase.
   --  ------------------------------
   procedure Set_Controller (Controller : in out Lifecycle;
                             Phase      : in Phase_Type;
                             Instance   : in Phase_Controller_Access) is
   begin
      Controller.Controllers (Phase) := Instance;
   end Set_Controller;

   --  ------------------------------
   --  Register a bundle and bind it to a facelet variable.
   --  ------------------------------
   procedure Execute (Controller : in Lifecycle;
                      Context    : in out ASF.Contexts.Faces.Faces_Context'Class) is
      use type ASF.Contexts.Exceptions.Exception_Handler_Access;
      use ASF.Events.Phases;

      Listeners : constant Listener_Vectors.Ref := Controller.Listeners.Get;
   begin
      for Phase in RESTORE_VIEW .. INVOKE_APPLICATION loop
         if Context.Get_Render_Response or Context.Get_Response_Completed then
            return;
         end if;
         declare
            procedure Before_Phase (Listener : in ASF.Events.Phases.Phase_Listener_Access);
            procedure After_Phase (Listener : in ASF.Events.Phases.Phase_Listener_Access);

            Event : ASF.Events.Phases.Phase_Event (Phase);

            procedure Before_Phase (Listener : in ASF.Events.Phases.Phase_Listener_Access) is
               P : constant ASF.Events.Phases.Phase_Type := Listener.Get_Phase;
            begin
               if P = Event.Phase or P = ASF.Events.Phases.ANY_PHASE then
                  Listener.Before_Phase (Event);
               end if;

            exception
               when E : others =>
                  Context.Queue_Exception (E);
            end Before_Phase;

            procedure After_Phase (Listener : in ASF.Events.Phases.Phase_Listener_Access) is
               P : constant ASF.Events.Phases.Phase_Type := Listener.Get_Phase;
            begin
               if P = Event.Phase or P = ASF.Events.Phases.ANY_PHASE then
                  Listener.After_Phase (Event);
               end if;

            exception
               when E : others =>
                  Context.Queue_Exception (E);
            end After_Phase;

         begin
            Context.Set_Current_Phase (Phase);

            --  Call the before phase listeners if there are some.
            Listeners.Iterate (Before_Phase'Access);

            begin
               Controller.Controllers (Phase).Execute (Context);
            exception
               when E : others =>
                  Context.Queue_Exception (E);
            end;

            Listeners.Iterate (After_Phase'Access);

            --  If exceptions have been raised and queued during the current phase, process them.
            --  An exception handler could use them to redirect the current request to another
            --  page or navigate to a specific view.
            declare
               Ex : constant ASF.Contexts.Exceptions.Exception_Handler_Access
                 := Context.Get_Exception_Handler;
            begin
               if Ex /= null then
                  Ex.Handle;
               end if;
            end;
         end;
      end loop;
   end Execute;

   --  ------------------------------
   --  Render the response by executing the response phase.
   --  ------------------------------
   procedure Render (Controller : in Lifecycle;
                     Context    : in out ASF.Contexts.Faces.Faces_Context'Class) is
   begin
      Context.Set_Current_Phase (ASF.Events.Phases.RENDER_RESPONSE);
      Controller.Controllers (ASF.Events.Phases.RENDER_RESPONSE).Execute (Context);
   end Render;

   --  ------------------------------
   --  Add a phase listener in the lifecycle controller.
   --  ------------------------------
   procedure Add_Phase_Listener (Controller : in out Lifecycle;
                                 Listener   : in ASF.Events.Phases.Phase_Listener_Access) is
   begin
      Controller.Listeners.Append (Listener);
   end Add_Phase_Listener;

end ASF.Lifecycles;

Fix call to After_Phase listener

Fix call to After_Phase listener


-----------------------------------------------------------------------
--  contexts-facelets-flash -- Flash context
--  Copyright (C) 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 ASF.Sessions;
with ASF.Applications.Messages.Utils;
package body ASF.Contexts.Flash is

   --  ------------------------------
   --  Set the attribute having given name with the value.
   --  ------------------------------
   procedure Set_Attribute (Flash   : in out Flash_Context;
                            Name    : in String;
                            Value   : in Util.Beans.Objects.Object) is
      Instance : Flash_Bean_Access;
   begin
      Flash.Get_Execute_Flash (Instance);
      if Util.Beans.Objects.Is_Null (Value) then
         Instance.Attributes.Delete (Name);
      else
         Instance.Attributes.Include (Name, Value);
      end if;
   end Set_Attribute;

   --  ------------------------------
   --  Set the attribute having given name with the value.
   --  ------------------------------
   procedure Set_Attribute (Flash   : in out Flash_Context;
                            Name    : in Unbounded_String;
                            Value   : in Util.Beans.Objects.Object) is
   begin
      Flash.Set_Attribute (To_String (Name), Value);
   end Set_Attribute;

   --  ------------------------------
   --  Get the attribute with the given name from the 'previous' flash context.
   --  ------------------------------
   function Get_Attribute (Flash : in Flash_Context;
                           Name  : in String) return Util.Beans.Objects.Object is
   begin
      if Flash.Previous = null then
         return Util.Beans.Objects.Null_Object;
      else
         declare
            Pos : constant Util.Beans.Objects.Maps.Cursor := Flash.Previous.Attributes.Find (Name);
         begin
            if Util.Beans.Objects.Maps.Has_Element (Pos) then
               return Util.Beans.Objects.Maps.Element (Pos);
            else
               return Util.Beans.Objects.Null_Object;
            end if;
         end;
      end if;
   end Get_Attribute;

   --  Keep in the flash context the request attribute identified by the name Name.
   procedure Keep (Flash   : in out Flash_Context;
                   Name    : in String) is
   begin
      null;
   end Keep;

   --  Returns True if the Redirect property was set on the previous flash instance.
   function Is_Redirect (Flash : in Flash_Context) return Boolean is
   begin
      return False;
   end Is_Redirect;

   --  Set this property to True to indicate to the next request on this session will be
   --  a redirect.  After this call, the next request will return the Redirect value
   --  when the Is_Redirect function will be called.
   procedure Set_Redirect (Flash    : in out Flash_Context;
                           Redirect : in Boolean) is
   begin
      null;
   end Set_Redirect;

   --  ------------------------------
   --  Returns True if the faces messages that are queued in the faces context must be
   --  preserved so they are accessible through the flash instance at the next request.
   --  ------------------------------
   function Is_Keep_Messages (Flash : in Flash_Context) return Boolean is
   begin
      return Flash.Keep_Messages;
   end Is_Keep_Messages;

   --  ------------------------------
   --  Set the keep messages property which controlls whether the faces messages
   --  that are queued in the faces context must be preserved so they are accessible through
   --  the flash instance at the next request.
   --  ------------------------------
   procedure Set_Keep_Messages (Flash : in out Flash_Context;
                                Value : in Boolean) is
   begin
      Flash.Keep_Messages := Value;
   end Set_Keep_Messages;

   --  ------------------------------
   --  Perform any specific action before processing the phase referenced by Phase.
   --  This operation is used to restore the flash context for a new request.
   --  ------------------------------
   procedure Do_Pre_Phase_Actions (Flash   : in out Flash_Context;
                                   Phase   : in ASF.Events.Phases.Phase_Type;
                                   Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
      use type ASF.Events.Phases.Phase_Type;
      use type Util.Beans.Basic.Readonly_Bean_Access;
   begin
      --  Restore the flash bean instance from the session if there is one.
      if Phase = ASF.Events.Phases.RESTORE_VIEW then
         declare
            S : constant ASF.Sessions.Session := Context.Get_Session;
            B : access Util.Beans.Basic.Readonly_Bean'Class;
         begin
            if S.Is_Valid then
               Flash.Object := S.Get_Attribute ("asf.flash.bean");
               B := Util.Beans.Objects.To_Bean (Flash.Object);
               if B /= null and then B.all in Flash_Bean'Class then
                  Flash.Previous := Flash_Bean'Class (B.all)'Unchecked_Access;

                  Context.Add_Messages ("", Flash.Previous.Messages);
               end if;
            end if;
         end;
      end if;
   end Do_Pre_Phase_Actions;

   --  ------------------------------
   --  Perform any specific action after processing the phase referenced by Phase.
   --  This operation is used to save the flash context
   --  ------------------------------
   procedure Do_Post_Phase_Actions (Flash   : in out Flash_Context;
                                    Phase   : in ASF.Events.Phases.Phase_Type;
                                    Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
      use type ASF.Events.Phases.Phase_Type;
   begin
      if (Phase = ASF.Events.Phases.INVOKE_APPLICATION
          or Phase = ASF.Events.Phases.RENDER_RESPONSE) and then not Flash.Last_Phase_Done then
         Flash.Do_Last_Phase_Actions (Context);
      end if;
   end Do_Post_Phase_Actions;

   --  ------------------------------
   --  Perform the last actions that must be made to save the flash context in the session.
   --  ------------------------------
   procedure Do_Last_Phase_Actions (Flash   : in out Flash_Context;
                                    Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
      S : ASF.Sessions.Session := Context.Get_Session;
   begin
      --  If we have to keep the messages, save them in the flash bean context if there are any.
      if Flash.Keep_Messages then
         declare
            Messages : constant Applications.Messages.Vectors.Cursor := Context.Get_Messages ("");
         begin
            if ASF.Applications.Messages.Vectors.Has_Element (Messages) then
               if Flash.Next = null then
                  Flash.Next := new Flash_Bean;
               end if;
               ASF.Applications.Messages.Utils.Copy (Flash.Next.Messages, Messages);
            end if;
         end;
      end if;

      if S.Is_Valid then
         S.Set_Attribute ("asf.flash.bean", Util.Beans.Objects.Null_Object);
      elsif Flash.Next /= null then
         S := Context.Get_Session (Create => True);
      end if;

      if Flash.Next /= null then
         S.Set_Attribute ("asf.flash.bean", Util.Beans.Objects.To_Object (Flash.Next.all'Access));
      end if;
      Flash.Last_Phase_Done := True;
   end Do_Last_Phase_Actions;

   procedure Get_Active_Flash (Flash   : in out Flash_Context;
                               Result  : out Flash_Bean_Access) is
   begin
      if Flash.Previous = null then
         null;
      end if;
      Result := Flash.Previous;
   end Get_Active_Flash;

   procedure Get_Execute_Flash (Flash   : in out Flash_Context;
                                Result  : out Flash_Bean_Access) is
   begin
      if Flash.Next = null then
         Flash.Next := new Flash_Bean;
      end if;
      Result := Flash.Next;
   end Get_Execute_Flash;

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

end ASF.Contexts.Flash;

-----------------------------------------------------------------------
--  contexts-facelets-flash -- Flash context
--  Copyright (C) 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 ASF.Sessions;
with ASF.Applications.Messages.Utils;
package body ASF.Contexts.Flash is

   --  ------------------------------
   --  Set the attribute having given name with the value.
   --  ------------------------------
   procedure Set_Attribute (Flash   : in out Flash_Context;
                            Name    : in String;
                            Value   : in Util.Beans.Objects.Object) is
      Instance : Flash_Bean_Access;
   begin
      Flash.Get_Execute_Flash (Instance);
      if Util.Beans.Objects.Is_Null (Value) then
         Instance.Attributes.Delete (Name);
      else
         Instance.Attributes.Include (Name, Value);
      end if;
   end Set_Attribute;

   --  ------------------------------
   --  Set the attribute having given name with the value.
   --  ------------------------------
   procedure Set_Attribute (Flash   : in out Flash_Context;
                            Name    : in Unbounded_String;
                            Value   : in Util.Beans.Objects.Object) is
   begin
      Flash.Set_Attribute (To_String (Name), Value);
   end Set_Attribute;

   --  ------------------------------
   --  Get the attribute with the given name from the 'previous' flash context.
   --  ------------------------------
   function Get_Attribute (Flash : in Flash_Context;
                           Name  : in String) return Util.Beans.Objects.Object is
   begin
      if Flash.Previous = null then
         return Util.Beans.Objects.Null_Object;
      else
         declare
            Pos : constant Util.Beans.Objects.Maps.Cursor := Flash.Previous.Attributes.Find (Name);
         begin
            if Util.Beans.Objects.Maps.Has_Element (Pos) then
               return Util.Beans.Objects.Maps.Element (Pos);
            else
               return Util.Beans.Objects.Null_Object;
            end if;
         end;
      end if;
   end Get_Attribute;

   --  Keep in the flash context the request attribute identified by the name Name.
   procedure Keep (Flash   : in out Flash_Context;
                   Name    : in String) is
   begin
      null;
   end Keep;

   --  ------------------------------
   --  Returns True if the Redirect property was set on the previous flash instance.
   --  ------------------------------
   function Is_Redirect (Flash : in Flash_Context) return Boolean is
   begin
      return Flash.Previous /= null and then Flash.Previous.Redirect;
   end Is_Redirect;

   --  Set this property to True to indicate to the next request on this session will be
   --  a redirect.  After this call, the next request will return the Redirect value
   --  when the Is_Redirect function will be called.
   procedure Set_Redirect (Flash    : in out Flash_Context;
                           Redirect : in Boolean) is
   begin
      null;
   end Set_Redirect;

   --  ------------------------------
   --  Returns True if the faces messages that are queued in the faces context must be
   --  preserved so they are accessible through the flash instance at the next request.
   --  ------------------------------
   function Is_Keep_Messages (Flash : in Flash_Context) return Boolean is
   begin
      return Flash.Keep_Messages;
   end Is_Keep_Messages;

   --  ------------------------------
   --  Set the keep messages property which controlls whether the faces messages
   --  that are queued in the faces context must be preserved so they are accessible through
   --  the flash instance at the next request.
   --  ------------------------------
   procedure Set_Keep_Messages (Flash : in out Flash_Context;
                                Value : in Boolean) is
   begin
      Flash.Keep_Messages := Value;
   end Set_Keep_Messages;

   --  ------------------------------
   --  Perform any specific action before processing the phase referenced by Phase.
   --  This operation is used to restore the flash context for a new request.
   --  ------------------------------
   procedure Do_Pre_Phase_Actions (Flash   : in out Flash_Context;
                                   Phase   : in ASF.Events.Phases.Phase_Type;
                                   Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
      use type ASF.Events.Phases.Phase_Type;
      use type Util.Beans.Basic.Readonly_Bean_Access;
   begin
      --  Restore the flash bean instance from the session if there is one.
      if Phase = ASF.Events.Phases.RESTORE_VIEW then
         declare
            S : constant ASF.Sessions.Session := Context.Get_Session;
            B : access Util.Beans.Basic.Readonly_Bean'Class;
         begin
            if S.Is_Valid then
               Flash.Object := S.Get_Attribute ("asf.flash.bean");
               B := Util.Beans.Objects.To_Bean (Flash.Object);
               if B /= null and then B.all in Flash_Bean'Class then
                  Flash.Previous := Flash_Bean'Class (B.all)'Unchecked_Access;

                  Context.Add_Messages ("", Flash.Previous.Messages);
               end if;
            end if;
         end;
      end if;
   end Do_Pre_Phase_Actions;

   --  ------------------------------
   --  Perform any specific action after processing the phase referenced by Phase.
   --  This operation is used to save the flash context
   --  ------------------------------
   procedure Do_Post_Phase_Actions (Flash   : in out Flash_Context;
                                    Phase   : in ASF.Events.Phases.Phase_Type;
                                    Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
      use type ASF.Events.Phases.Phase_Type;
   begin
      if (Phase = ASF.Events.Phases.INVOKE_APPLICATION
          or Phase = ASF.Events.Phases.RENDER_RESPONSE) and then not Flash.Last_Phase_Done then
         Flash.Do_Last_Phase_Actions (Context);
      end if;
   end Do_Post_Phase_Actions;

   --  ------------------------------
   --  Perform the last actions that must be made to save the flash context in the session.
   --  ------------------------------
   procedure Do_Last_Phase_Actions (Flash   : in out Flash_Context;
                                    Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
      S : ASF.Sessions.Session := Context.Get_Session;
   begin
      --  If we have to keep the messages, save them in the flash bean context if there are any.
      if Flash.Keep_Messages then
         declare
            Messages : constant Applications.Messages.Vectors.Cursor := Context.Get_Messages ("");
         begin
            if ASF.Applications.Messages.Vectors.Has_Element (Messages) then
               if Flash.Next = null then
                  Flash.Next := new Flash_Bean;
               end if;
               ASF.Applications.Messages.Utils.Copy (Flash.Next.Messages, Messages);
            end if;
         end;
      end if;

      if S.Is_Valid then
         S.Set_Attribute ("asf.flash.bean", Util.Beans.Objects.Null_Object);
      elsif Flash.Next /= null then
         S := Context.Get_Session (Create => True);
      end if;

      if Flash.Next /= null then
         S.Set_Attribute ("asf.flash.bean", Util.Beans.Objects.To_Object (Flash.Next.all'Access));
      end if;
      Flash.Last_Phase_Done := True;
   end Do_Last_Phase_Actions;

   procedure Get_Active_Flash (Flash   : in out Flash_Context;
                               Result  : out Flash_Bean_Access) is
   begin
      if Flash.Previous = null then
         null;
      end if;
      Result := Flash.Previous;
   end Get_Active_Flash;

   procedure Get_Execute_Flash (Flash   : in out Flash_Context;
                                Result  : out Flash_Bean_Access) is
   begin
      if Flash.Next = null then
         Flash.Next := new Flash_Bean;
      end if;
      Result := Flash.Next;
   end Get_Execute_Flash;

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

end ASF.Contexts.Flash;

Implement the Is_Redirect function

Implement the Is_Redirect function


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

--  == Wiki Parsers {#wiki-parsers} ==
--  The `Wikis.Parsers` package implements a parser for several well known wiki formats
--  but also for HTML.  While reading the input, the parser populates a wiki `Document`
--  instance with headers, paragraphs, links, and other elements.
--
--     Engine : Wiki.Parsers.Parser;
--
--  Before using the parser, it must be configured to choose the syntax by using the
--  `Set_Syntax` procedure:
--
--    Engine.Set_Syntax (Wiki.SYNTAX_HTML);
--
--  The parser can be configured to use filters.  A filter is added by using the
--  `Add_Filter` procedure.  A filter is added at begining of the chain so that
--  the filter added last is called first.  The wiki `Document` is always built through
--  the filter chain so this allows filters to change or alter the content that was parsed.
--
--    Engine.Add_Filter (TOC'Unchecked_Access);
--    Engine.Add_Filter (Filter'Unchecked_Access);
--
--  The `Parse` procedure is then used to parse either a string content or some stream
--  represented by the `Input_Stream` interface.  After the `Parse` procedure
--  completes, the `Document` instance holds the wiki document.
--
--    Engine.Parse (Some_Text, Doc);
--
package Wiki.Parsers is

   pragma Preelaborate;

   type Parser is tagged limited private;
   subtype Parser_Type is Parser;

   --  Set the plugin factory to find and use plugins.
   procedure Set_Plugin_Factory (Engine  : in out Parser;
                                 Factory : in Wiki.Plugins.Plugin_Factory_Access);

   --  Set the wiki syntax that the wiki engine must use.
   procedure Set_Syntax (Engine : in out Parser;
                         Syntax : in Wiki_Syntax := SYNTAX_MARKDOWN);

   --  Add a filter in the wiki engine.
   procedure Add_Filter (Engine : in out Parser;
                         Filter : in Wiki.Filters.Filter_Type_Access);

   --  Set the plugin context.
   procedure Set_Context (Engine  : in out Parser;
                          Context : in Wiki.Plugins.Plugin_Context);

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  defined on the parser.  The string is assumed to be in UTF-8 format.
   procedure Parse (Engine : in out Parser;
                    Text   : in String;
                    Doc    : in out Wiki.Documents.Document);

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  defined on the parser.
   procedure Parse (Engine : in out Parser;
                    Text   : in Wiki.Strings.WString;
                    Doc    : in out Wiki.Documents.Document);

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  defined on the parser.
   procedure Parse (Engine : in out Parser;
                    Text   : in Wiki.Strings.UString;
                    Doc    : in out Wiki.Documents.Document);

   --  Parse the wiki stream managed by <tt>Stream</tt> according to the wiki syntax configured
   --  on the wiki engine.
   procedure Parse (Engine : in out Parser;
                    Stream : in Wiki.Streams.Input_Stream_Access;
                    Doc    : in out Wiki.Documents.Document);

private

   type Trim_End is (None, Left, Right, Both);

   type Block;
   type Content_Access is access all Block;

   type Block (Len : Positive) is limited record
      Next_Block : Content_Access;
      Last       : Natural := 0;
      Content    : Wiki.Strings.WString (1 .. Len);
   end record;

   use Wiki.Strings.Wide_Wide_Builders;

   type Block_Type is record
      Kind   : Wiki.Nodes.Node_Kind := Wiki.Nodes.N_PARAGRAPH;
      Level  : Natural := 0;
      Marker : Wiki.Strings.WChar := ' ';
      Number : Integer := 0;
   end record;

   type Parser_State_Type is (State_Html_Doctype,
                              State_Html_Comment,
                              State_Html_Attribute,
                              State_Html_Element);

   type Block_Access is access all Block_Type;

   package Block_Stack is new Util.Stacks (Element_Type        => Block_Type,
                                           Element_Type_Access => Block_Access);

   type Parser_Handler is access procedure (Parser : in out Parser_Type;
                                            Text   : in Wiki.Buffers.Buffer_Access);

   type Parser is tagged limited record
      Context             : aliased Wiki.Plugins.Plugin_Context;
      Previous_Syntax     : Wiki_Syntax;
      Document            : Wiki.Documents.Document;
      Parse_Block         : Parser_Handler;
      Parse_Inline        : Parser_Handler;
      Format              : Wiki.Format_Map;
      Text                : Wiki.Strings.BString (512);
      Line_Buffer         : Wiki.Buffers.Builder (512);
      Text_Buffer         : Wiki.Buffers.Builder (512);
      Empty_Line          : Boolean := True;
      Is_Last_Line        : Boolean := False;
      Is_Eof              : Boolean := False;
      In_Paragraph        : Boolean := False;
      In_Table            : Boolean := False;
      In_Html             : Boolean := False;
      Link_Double_Bracket : Boolean := False;
      Link_No_Space       : Boolean := False;
      Link_Title_First    : Boolean := False;
      Check_Image_Link    : Boolean := False;
      Header_Offset       : Integer := 0;
      Preformat_Column    : Natural := 1;
      Quote_Level         : Natural := 0;
      Escape_Char         : Wiki.Strings.WChar;
      Param_Char          : Wiki.Strings.WChar;
      List_Level          : Natural := 0;
      Previous_Tag        : Html_Tag := UNKNOWN_TAG;
      Reader              : Wiki.Streams.Input_Stream_Access := null;
      Attributes          : Wiki.Attributes.Attribute_List;
      Current_Node        : Wiki.Nodes.Node_Kind := Wiki.Nodes.N_NONE;
      Blocks              : Block_Stack.Stack;
      Previous_Line_Empty : Boolean := False;
      Header_Level        : Natural := 0;
      Is_Empty_Paragraph  : Boolean := True;
      Pre_Tag_Counter     : Natural := 0;

      --  Pre-format code block
      Preformat_Fence     : Wiki.Strings.WChar;
      Preformat_Indent    : Natural := 0;
      Preformat_Fcount    : Natural := 0;
      Preformat_Format    : Wiki.Strings.BString (32);

      Html                : Wiki.Html_Parser.Parser_Type;
   end record;

   --  Read the next wiki input line in the line buffer.
   procedure Read_Line (Parser : in out Parser_Type'Class;
                        Buffer : out Wiki.Buffers.Buffer_Access);

   function Is_List_Item (P     : in Parser;
                          Level : in Natural) return Boolean;

   function Is_Single_Token (Text : in Wiki.Buffers.Buffer_Access;
                             From : in Positive;
                             Token : in Wiki.Strings.WChar) return Boolean;

   --  Flush the wiki text that was collected in the text buffer.
   procedure Flush_Text (P    : in out Parser;
                         Trim : in Trim_End := None);

   procedure Flush_Block (Parser : in out Parser_Type);

   --  Flush the wiki dl/dt/dd definition list.
   procedure Flush_List (P : in out Parser);
   procedure Pop_List (P      : in out Parser;
                       Level  : in Natural;
                       Marker : in Wiki.Strings.WChar;
                       Number : in Natural);
   procedure Pop_List (P      : in out Parser);

   function Get_Current_Level (Parser : in Parser_Type) return Natural;

   --  Check if the link refers to an image and must be rendered as an image.
   --  Returns a positive index of the start the the image link.
   function Is_Image (P    : in Parser;
                      Link : in Wiki.Strings.WString) return Natural;

   --  Returns true if we are included from another wiki content.
   function Is_Included (P : in Parser) return Boolean;

   --  Find the plugin with the given name.
   --  Returns null if there is no such plugin.
   function Find (P    : in Parser;
                  Name : in Wiki.Strings.WString) return Wiki.Plugins.Wiki_Plugin_Access;

   type String_Array is array (Positive range <>) of Wiki.String_Access;

   procedure Process_Html (P          : in out Parser;
                           Kind       : in Wiki.Html_Parser.State_Type;
                           Name       : in Wiki.Strings.WString;
                           Attributes : in out Wiki.Attributes.Attribute_List);

   procedure Start_Element (P          : in out Parser;
                            Tag        : in Wiki.Html_Tag;
                            Attributes : in out Wiki.Attributes.Attribute_List);

   procedure End_Element (P    : in out Parser;
                          Tag  : in Wiki.Html_Tag);

   procedure Toggle_Format (P      : in out Parser;
                            Format : in Format_Type);

   --  Parse the beginning or the end of a single character sequence.
   --  Example:
   --    _name_    *bold*   `code`
   procedure Parse_Format (P      : in out Parser;
                           Text   : in out Wiki.Buffers.Buffer_Access;
                           From   : in out Positive;
                           Expect : in Wiki.Strings.WChar;
                           Format : in Format_Type);

   --  Parse the beginning or the end of a double character sequence.
   --  Example:
   --    --name--  **bold** ~~strike~~
   procedure Parse_Format_Double (P      : in out Parser;
                                  Text   : in out Wiki.Buffers.Buffer_Access;
                                  From   : in out Positive;
                                  Expect : in Wiki.Strings.WChar;
                                  Format : in Format_Type);

   --  Push a new block kind on the block stack.
   procedure Push_Block (P      : in out Parser;
                         Kind   : in Wiki.Nodes.Node_Kind;
                         Level  : in Integer := 0;
                         Marker : in Wiki.Strings.WChar := ' ';
                         Number : in Integer := 0);

   --  Pop the current block stack.
   procedure Pop_Block (P    : in out Parser);
   procedure Pop_All (P : in out Parser);

   procedure Pop_Block_Until (P     : in out Parser;
                              Kind  : in Wiki.Nodes.Node_Kind;
                              Level : in Integer);

   procedure Append_Text (P    : in out Parser;
                          Text : in Wiki.Strings.BString;
                          From : in Positive;
                          To   : in Positive);

   NAME_ATTR  : aliased constant String := "name";
   HREF_ATTR  : aliased constant String := "href";
   LANG_ATTR  : aliased constant String := "lang";
   TITLE_ATTR : aliased constant String := "title";

end Wiki.Parsers;

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

--  == Wiki Parsers {#wiki-parsers} ==
--  The `Wikis.Parsers` package implements a parser for several well known wiki formats
--  but also for HTML.  While reading the input, the parser populates a wiki `Document`
--  instance with headers, paragraphs, links, and other elements.
--
--     Engine : Wiki.Parsers.Parser;
--
--  Before using the parser, it must be configured to choose the syntax by using the
--  `Set_Syntax` procedure:
--
--    Engine.Set_Syntax (Wiki.SYNTAX_HTML);
--
--  The parser can be configured to use filters.  A filter is added by using the
--  `Add_Filter` procedure.  A filter is added at begining of the chain so that
--  the filter added last is called first.  The wiki `Document` is always built through
--  the filter chain so this allows filters to change or alter the content that was parsed.
--
--    Engine.Add_Filter (TOC'Unchecked_Access);
--    Engine.Add_Filter (Filter'Unchecked_Access);
--
--  The `Parse` procedure is then used to parse either a string content or some stream
--  represented by the `Input_Stream` interface.  After the `Parse` procedure
--  completes, the `Document` instance holds the wiki document.
--
--    Engine.Parse (Some_Text, Doc);
--
package Wiki.Parsers is

   pragma Preelaborate;

   type Parser is tagged limited private;
   subtype Parser_Type is Parser;

   --  Set the plugin factory to find and use plugins.
   procedure Set_Plugin_Factory (Engine  : in out Parser;
                                 Factory : in Wiki.Plugins.Plugin_Factory_Access);

   --  Set the wiki syntax that the wiki engine must use.
   procedure Set_Syntax (Engine : in out Parser;
                         Syntax : in Wiki_Syntax := SYNTAX_MARKDOWN);

   --  Add a filter in the wiki engine.
   procedure Add_Filter (Engine : in out Parser;
                         Filter : in Wiki.Filters.Filter_Type_Access);

   --  Set the plugin context.
   procedure Set_Context (Engine  : in out Parser;
                          Context : in Wiki.Plugins.Plugin_Context);

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  defined on the parser.  The string is assumed to be in UTF-8 format.
   procedure Parse (Engine : in out Parser;
                    Text   : in String;
                    Doc    : in out Wiki.Documents.Document);

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  defined on the parser.
   procedure Parse (Engine : in out Parser;
                    Text   : in Wiki.Strings.WString;
                    Doc    : in out Wiki.Documents.Document);

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  defined on the parser.
   procedure Parse (Engine : in out Parser;
                    Text   : in Wiki.Strings.UString;
                    Doc    : in out Wiki.Documents.Document);

   --  Parse the wiki stream managed by <tt>Stream</tt> according to the wiki syntax configured
   --  on the wiki engine.
   procedure Parse (Engine : in out Parser;
                    Stream : in Wiki.Streams.Input_Stream_Access;
                    Doc    : in out Wiki.Documents.Document);

private

   type Trim_End is (None, Left, Right, Both);

   use Wiki.Strings.Wide_Wide_Builders;

   type Block_Type is record
      Kind   : Wiki.Nodes.Node_Kind := Wiki.Nodes.N_PARAGRAPH;
      Level  : Natural := 0;
      Marker : Wiki.Strings.WChar := ' ';
      Number : Integer := 0;
   end record;

   type Parser_State_Type is (State_Html_Doctype,
                              State_Html_Comment,
                              State_Html_Attribute,
                              State_Html_Element);

   type Block_Access is access all Block_Type;

   package Block_Stack is new Util.Stacks (Element_Type        => Block_Type,
                                           Element_Type_Access => Block_Access);

   type Parser_Handler is access procedure (Parser : in out Parser_Type;
                                            Text   : in Wiki.Buffers.Buffer_Access);

   type Parser is tagged limited record
      Context             : aliased Wiki.Plugins.Plugin_Context;
      Previous_Syntax     : Wiki_Syntax;
      Document            : Wiki.Documents.Document;
      Parse_Block         : Parser_Handler;
      Parse_Inline        : Parser_Handler;
      Format              : Wiki.Format_Map;
      Text                : Wiki.Strings.BString (512);
      Line_Buffer         : Wiki.Buffers.Builder (512);
      Text_Buffer         : Wiki.Buffers.Builder (512);
      Empty_Line          : Boolean := True;
      Is_Last_Line        : Boolean := False;
      Is_Eof              : Boolean := False;
      In_Paragraph        : Boolean := False;
      In_Table            : Boolean := False;
      In_Html             : Boolean := False;
      Link_Double_Bracket : Boolean := False;
      Link_No_Space       : Boolean := False;
      Link_Title_First    : Boolean := False;
      Check_Image_Link    : Boolean := False;
      Header_Offset       : Integer := 0;
      Preformat_Column    : Natural := 1;
      Quote_Level         : Natural := 0;
      Escape_Char         : Wiki.Strings.WChar;
      Param_Char          : Wiki.Strings.WChar;
      List_Level          : Natural := 0;
      Previous_Tag        : Html_Tag := UNKNOWN_TAG;
      Reader              : Wiki.Streams.Input_Stream_Access := null;
      Attributes          : Wiki.Attributes.Attribute_List;
      Current_Node        : Wiki.Nodes.Node_Kind := Wiki.Nodes.N_NONE;
      Blocks              : Block_Stack.Stack;
      Previous_Line_Empty : Boolean := False;
      Header_Level        : Natural := 0;
      Is_Empty_Paragraph  : Boolean := True;
      Pre_Tag_Counter     : Natural := 0;

      --  Pre-format code block
      Preformat_Fence     : Wiki.Strings.WChar;
      Preformat_Indent    : Natural := 0;
      Preformat_Fcount    : Natural := 0;
      Preformat_Format    : Wiki.Strings.BString (32);

      Html                : Wiki.Html_Parser.Parser_Type;
   end record;

   --  Read the next wiki input line in the line buffer.
   procedure Read_Line (Parser : in out Parser_Type'Class;
                        Buffer : out Wiki.Buffers.Buffer_Access);

   function Is_List_Item (P     : in Parser;
                          Level : in Natural) return Boolean;

   function Is_Single_Token (Text : in Wiki.Buffers.Buffer_Access;
                             From : in Positive;
                             Token : in Wiki.Strings.WChar) return Boolean;

   --  Flush the wiki text that was collected in the text buffer.
   procedure Flush_Text (P    : in out Parser;
                         Trim : in Trim_End := None);

   procedure Flush_Block (Parser : in out Parser_Type);

   --  Flush the wiki dl/dt/dd definition list.
   procedure Flush_List (P : in out Parser);
   procedure Pop_List (P      : in out Parser;
                       Level  : in Natural;
                       Marker : in Wiki.Strings.WChar;
                       Number : in Natural);
   procedure Pop_List (P      : in out Parser);

   function Get_Current_Level (Parser : in Parser_Type) return Natural;

   --  Check if the link refers to an image and must be rendered as an image.
   --  Returns a positive index of the start the the image link.
   function Is_Image (P    : in Parser;
                      Link : in Wiki.Strings.WString) return Natural;

   --  Returns true if we are included from another wiki content.
   function Is_Included (P : in Parser) return Boolean;

   --  Find the plugin with the given name.
   --  Returns null if there is no such plugin.
   function Find (P    : in Parser;
                  Name : in Wiki.Strings.WString) return Wiki.Plugins.Wiki_Plugin_Access;

   type String_Array is array (Positive range <>) of Wiki.String_Access;

   procedure Process_Html (P          : in out Parser;
                           Kind       : in Wiki.Html_Parser.State_Type;
                           Name       : in Wiki.Strings.WString;
                           Attributes : in out Wiki.Attributes.Attribute_List);

   procedure Start_Element (P          : in out Parser;
                            Tag        : in Wiki.Html_Tag;
                            Attributes : in out Wiki.Attributes.Attribute_List);

   procedure End_Element (P    : in out Parser;
                          Tag  : in Wiki.Html_Tag);

   procedure Toggle_Format (P      : in out Parser;
                            Format : in Format_Type);

   --  Parse the beginning or the end of a single character sequence.
   --  Example:
   --    _name_    *bold*   `code`
   procedure Parse_Format (P      : in out Parser;
                           Text   : in out Wiki.Buffers.Buffer_Access;
                           From   : in out Positive;
                           Expect : in Wiki.Strings.WChar;
                           Format : in Format_Type);

   --  Parse the beginning or the end of a double character sequence.
   --  Example:
   --    --name--  **bold** ~~strike~~
   procedure Parse_Format_Double (P      : in out Parser;
                                  Text   : in out Wiki.Buffers.Buffer_Access;
                                  From   : in out Positive;
                                  Expect : in Wiki.Strings.WChar;
                                  Format : in Format_Type);

   --  Push a new block kind on the block stack.
   procedure Push_Block (P      : in out Parser;
                         Kind   : in Wiki.Nodes.Node_Kind;
                         Level  : in Integer := 0;
                         Marker : in Wiki.Strings.WChar := ' ';
                         Number : in Integer := 0);

   --  Pop the current block stack.
   procedure Pop_Block (P    : in out Parser);
   procedure Pop_All (P : in out Parser);

   procedure Pop_Block_Until (P     : in out Parser;
                              Kind  : in Wiki.Nodes.Node_Kind;
                              Level : in Integer);

   procedure Append_Text (P    : in out Parser;
                          Text : in Wiki.Strings.BString;
                          From : in Positive;
                          To   : in Positive);

   NAME_ATTR  : aliased constant String := "name";
   HREF_ATTR  : aliased constant String := "href";
   LANG_ATTR  : aliased constant String := "lang";
   TITLE_ATTR : aliased constant String := "title";

end Wiki.Parsers;

Remove unused type Block

Remove unused type Block