--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

--  pragma Suppress (All_Checks);
--  too new: Container_Checks, Tampering_Check

with Ada.Text_IO;
with Ada.Calendar;
with Ada.Containers.Hashed_Maps;
with Ada.Containers.Ordered_Sets;
with Ada.Containers.Vectors;
with Ada.Characters.Latin_1;
with Ada.Directories;

with JohnnyText;
with Parameters;
with Definitions;  use Definitions;

package PortScan is

   package JT  renames JohnnyText;
   package AC  renames Ada.Containers;
   package CAL renames Ada.Calendar;
   package AD  renames Ada.Directories;
   package TIO renames Ada.Text_IO;
   package LAT renames Ada.Characters.Latin_1;
   package PM  renames Parameters;

   type count_type is (total, success, failure, ignored, skipped);
   type dim_handlers is array (count_type) of TIO.File_Type;

   type port_id   is private;
   port_match_failed : constant port_id;

   --  Scan the entire ports tree in order with a single, non-recursive pass
   --  Return True on success
   function scan_entire_ports_tree (portsdir : String) return Boolean;

   --  Starting with a single port, recurse to determine a limited but complete
   --  dependency tree.  Repeated calls will augment already existing data.
   --  Return True on success
   function scan_single_port (repository, portsdir, catport : String)
                              return Boolean;

   --  This procedure causes the reverse dependencies to be calculated, and
   --  then the extended (recursive) reverse dependencies.  The former is
   --  used progressively to determine when a port is free to build and the
   --  latter sets the build priority.
   procedure set_build_priority;

   --  Wipe out all scan data so new scan can be performed
   procedure reset_ports_tree;

   --  Returns the number of cores.  The set_cores procedure must be run first.
   --  set_cores was private previously, but we need the information to set
   --  intelligent defaults for the configuration file.
   procedure set_cores;
   function cores_available return cpu_range;

private

   max_ports        : constant := 28000;

   type port_id   is range -1 .. max_ports - 1;
   subtype port_index is port_id range 0 .. port_id'Last;

   port_match_failed : constant port_id := port_id'First;

   --  skip "package" because every port has same dependency on ports-mgmt/pkg
   --  except for pkg itself.  Skip "test" because these dependencies are
   --  not required to build packages.
   type dependency_type is (fetch, extract, patch, build, library, runtime);
   subtype LR_set is dependency_type range library .. runtime;

   bmake_execution  : exception;
   pkgng_execution  : exception;
   make_garbage     : exception;
   nonexistent_port : exception;
   circular_logic   : exception;
   seek_failure     : exception;
   unknown_format   : exception;

   package subqueue is new AC.Vectors
     (Element_Type => port_index,
      Index_Type   => port_index);

   package string_crate is new AC.Vectors
     (Element_Type => JT.Text,
      Index_Type   => port_index,
      "="          => JT.SU."=");

   type queue_record is
      record
         ap_index      : port_index;
         reverse_score : port_index;
      end record;

   --  Functions for ranking_crate definitions
   function "<" (L, R : queue_record) return Boolean;

   package ranking_crate is new AC.Ordered_Sets  (Element_Type => queue_record);

   --  Functions for portkey_crate and package_crate definitions
   function port_hash (key : JT.Text) return AC.Hash_Type;

   package portkey_crate is new AC.Hashed_Maps
     (Key_Type        => JT.Text,
      Element_Type    => port_index,
      Hash            => port_hash,
      Equivalent_Keys => JT.equivalent);

   package package_crate is new AC.Hashed_Maps
     (Key_Type        => JT.Text,
      Element_Type    => Boolean,
      Hash            => port_hash,
      Equivalent_Keys => JT.equivalent);

   --  Functions for block_crate definitions
   function block_hash (key : port_index) return AC.Hash_Type;
   function block_ekey (left, right : port_index) return Boolean;

   package block_crate is new AC.Hashed_Maps
     (Key_Type        => port_index,
      Element_Type    => port_index,
      Hash            => block_hash,
      Equivalent_Keys => block_ekey);

   type port_record is
      record
         sequence_id   : port_index           := 0;
         key_cursor    : portkey_crate.Cursor := portkey_crate.No_Element;
         jobs          : builders             := 1;
         ignore_reason : JT.Text              := JT.blank;
         port_version  : JT.Text              := JT.blank;
         package_name  : JT.Text              := JT.blank;
         ignored       : Boolean              := False;
         scanned       : Boolean              := False;
         rev_scanned   : Boolean              := False;
         unlist_failed : Boolean              := False;
         work_locked   : Boolean              := False;
         reverse_score : port_index           := 0;
         librun        : block_crate.Map;
         blocked_by    : block_crate.Map;
         blocks        : block_crate.Map;
         all_reverse   : block_crate.Map;
         options       : package_crate.Map;
      end record;
   type port_record_access is access all port_record;

   type dim_make_queue is array (scanners) of subqueue.Vector;
   type dim_progress   is array (scanners) of port_index;
   type dim_all_ports  is array (port_index) of aliased port_record;

   all_ports    : dim_all_ports;
   ports_keys   : portkey_crate.Map;
   make_queue   : dim_make_queue;
   mq_progress  : dim_progress := (others => 0);
   rank_queue   : ranking_crate.Set;
   number_cores : cpu_range  := cpu_range'First;
   lot_number   : scanners   := 1;
   lot_counter  : port_index := 0;
   last_port    : port_index := 0;
   prescanned   : Boolean    := False;

   procedure iterate_reverse_deps;
   procedure iterate_drill_down;
   procedure populate_port_data (portsdir : String;
                                 target   : port_index);
   procedure drill_down (next_target     : port_index;
                         original_target : port_index);

   --  subroutines for populate_port_data
   procedure prescan_ports_tree (portsdir : String);
   procedure grep_Makefile (portsdir, category : String);
   procedure walk_all_subdirectories (portsdir, category : String);
   procedure parallel_deep_scan (portsdir : String; success : out Boolean);
   procedure wipe_make_queue;

   --  some helper routines
   function find_colon (Source : String) return Natural;
   function scrub_phase (Source : String) return JT.Text;
   function get_catport (PR : port_record) return String;
   function scan_progress return String;
   function get_ccache return String;
   function get_max_lots return scanners;

   type dim_counters is array (count_type) of Natural;

   --  bulk run variables
   Flog        : dim_handlers;
   start_time  : CAL.Time;
   stop_time   : CAL.Time;
   bld_counter : dim_counters := (0, 0, 0, 0, 0);

end PortScan;

--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

--  GCC 6.0 only (skip Container_Checks until identified need arises)
pragma Suppress (Tampering_Check);

with Ada.Text_IO;
with Ada.Calendar;
with Ada.Containers.Hashed_Maps;
with Ada.Containers.Ordered_Sets;
with Ada.Containers.Vectors;
with Ada.Characters.Latin_1;
with Ada.Directories;

with JohnnyText;
with Parameters;
with Definitions;  use Definitions;

package PortScan is

   package JT  renames JohnnyText;
   package AC  renames Ada.Containers;
   package CAL renames Ada.Calendar;
   package AD  renames Ada.Directories;
   package TIO renames Ada.Text_IO;
   package LAT renames Ada.Characters.Latin_1;
   package PM  renames Parameters;

   type count_type is (total, success, failure, ignored, skipped);
   type dim_handlers is array (count_type) of TIO.File_Type;

   type port_id   is private;
   port_match_failed : constant port_id;

   --  Scan the entire ports tree in order with a single, non-recursive pass
   --  Return True on success
   function scan_entire_ports_tree (portsdir : String) return Boolean;

   --  Starting with a single port, recurse to determine a limited but complete
   --  dependency tree.  Repeated calls will augment already existing data.
   --  Return True on success
   function scan_single_port (repository, portsdir, catport : String)
                              return Boolean;

   --  This procedure causes the reverse dependencies to be calculated, and
   --  then the extended (recursive) reverse dependencies.  The former is
   --  used progressively to determine when a port is free to build and the
   --  latter sets the build priority.
   procedure set_build_priority;

   --  Wipe out all scan data so new scan can be performed
   procedure reset_ports_tree;

   --  Returns the number of cores.  The set_cores procedure must be run first.
   --  set_cores was private previously, but we need the information to set
   --  intelligent defaults for the configuration file.
   procedure set_cores;
   function cores_available return cpu_range;

private

   max_ports        : constant := 28000;

   type port_id   is range -1 .. max_ports - 1;
   subtype port_index is port_id range 0 .. port_id'Last;

   port_match_failed : constant port_id := port_id'First;

   --  skip "package" because every port has same dependency on ports-mgmt/pkg
   --  except for pkg itself.  Skip "test" because these dependencies are
   --  not required to build packages.
   type dependency_type is (fetch, extract, patch, build, library, runtime);
   subtype LR_set is dependency_type range library .. runtime;

   bmake_execution  : exception;
   pkgng_execution  : exception;
   make_garbage     : exception;
   nonexistent_port : exception;
   circular_logic   : exception;
   seek_failure     : exception;
   unknown_format   : exception;

   package subqueue is new AC.Vectors
     (Element_Type => port_index,
      Index_Type   => port_index);

   package string_crate is new AC.Vectors
     (Element_Type => JT.Text,
      Index_Type   => port_index,
      "="          => JT.SU."=");

   type queue_record is
      record
         ap_index      : port_index;
         reverse_score : port_index;
      end record;

   --  Functions for ranking_crate definitions
   function "<" (L, R : queue_record) return Boolean;

   package ranking_crate is new AC.Ordered_Sets  (Element_Type => queue_record);

   --  Functions for portkey_crate and package_crate definitions
   function port_hash (key : JT.Text) return AC.Hash_Type;

   package portkey_crate is new AC.Hashed_Maps
     (Key_Type        => JT.Text,
      Element_Type    => port_index,
      Hash            => port_hash,
      Equivalent_Keys => JT.equivalent);

   package package_crate is new AC.Hashed_Maps
     (Key_Type        => JT.Text,
      Element_Type    => Boolean,
      Hash            => port_hash,
      Equivalent_Keys => JT.equivalent);

   --  Functions for block_crate definitions
   function block_hash (key : port_index) return AC.Hash_Type;
   function block_ekey (left, right : port_index) return Boolean;

   package block_crate is new AC.Hashed_Maps
     (Key_Type        => port_index,
      Element_Type    => port_index,
      Hash            => block_hash,
      Equivalent_Keys => block_ekey);

   type port_record is
      record
         sequence_id   : port_index           := 0;
         key_cursor    : portkey_crate.Cursor := portkey_crate.No_Element;
         jobs          : builders             := 1;
         ignore_reason : JT.Text              := JT.blank;
         port_version  : JT.Text              := JT.blank;
         package_name  : JT.Text              := JT.blank;
         ignored       : Boolean              := False;
         scanned       : Boolean              := False;
         rev_scanned   : Boolean              := False;
         unlist_failed : Boolean              := False;
         work_locked   : Boolean              := False;
         reverse_score : port_index           := 0;
         librun        : block_crate.Map;
         blocked_by    : block_crate.Map;
         blocks        : block_crate.Map;
         all_reverse   : block_crate.Map;
         options       : package_crate.Map;
      end record;
   type port_record_access is access all port_record;

   type dim_make_queue is array (scanners) of subqueue.Vector;
   type dim_progress   is array (scanners) of port_index;
   type dim_all_ports  is array (port_index) of aliased port_record;

   all_ports    : dim_all_ports;
   ports_keys   : portkey_crate.Map;
   make_queue   : dim_make_queue;
   mq_progress  : dim_progress := (others => 0);
   rank_queue   : ranking_crate.Set;
   number_cores : cpu_range  := cpu_range'First;
   lot_number   : scanners   := 1;
   lot_counter  : port_index := 0;
   last_port    : port_index := 0;
   prescanned   : Boolean    := False;

   procedure iterate_reverse_deps;
   procedure iterate_drill_down;
   procedure populate_port_data (portsdir : String;
                                 target   : port_index);
   procedure drill_down (next_target     : port_index;
                         original_target : port_index);

   --  subroutines for populate_port_data
   procedure prescan_ports_tree (portsdir : String);
   procedure grep_Makefile (portsdir, category : String);
   procedure walk_all_subdirectories (portsdir, category : String);
   procedure parallel_deep_scan (portsdir : String; success : out Boolean);
   procedure wipe_make_queue;

   --  some helper routines
   function find_colon (Source : String) return Natural;
   function scrub_phase (Source : String) return JT.Text;
   function get_catport (PR : port_record) return String;
   function scan_progress return String;
   function get_ccache return String;
   function get_max_lots return scanners;

   type dim_counters is array (count_type) of Natural;

   --  bulk run variables
   Flog        : dim_handlers;
   start_time  : CAL.Time;
   stop_time   : CAL.Time;
   bld_counter : dim_counters := (0, 0, 0, 0, 0);

end PortScan;

Enable Tampering_Check pragma (gcc6-aux only)


-----------------------------------------------------------------------
--  wiki-parsers -- Wiki parser
--  Copyright (C) 2011, 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 Wiki.Attributes;
with Wiki.Plugins;
with Wiki.Filters;
with Wiki.Strings;
with Wiki.Nodes;
with Wiki.Streams;
with Wiki.Render;

--  == Wiki Parsers ==
--  The Wikis.Parsers package implements a parser for several well known wiki formats.
--  The parser works with the Document_Reader interface type which defines several
--  procedures that are called by the parser when the wiki text is scanned.
package Wiki.Parsers is

   pragma Preelaborate;

   --  Defines the possible wiki syntax supported by the parser.
   type Wiki_Syntax_Type
     is (
         --  Google wiki syntax http://code.google.com/p/support/wiki/WikiSyntax
         SYNTAX_GOOGLE,

         --  Creole wiki syntax http://www.wikicreole.org/wiki/Creole1.0
         SYNTAX_CREOLE,

         --  Dotclear syntax http://dotclear.org/documentation/2.0/usage/syntaxes
         SYNTAX_DOTCLEAR,

         --  PhpBB syntax http://wiki.phpbb.com/Help:Formatting
         SYNTAX_PHPBB,

         --  MediaWiki syntax http://www.mediawiki.org/wiki/Help:Formatting
         SYNTAX_MEDIA_WIKI,

         --  Markdown
         SYNTAX_MARKDOWN,

         --  A mix of the above
         SYNTAX_MIX,

         --  The input is plain possibly incorrect HTML.
         SYNTAX_HTML);

   type Parser is tagged limited private;

   --  Add the plugin to the wiki engine.
   procedure Add_Plugin (Engine : in out Parser;
                         Name   : in String;
                         Plugin : in Wiki.Plugins.Wiki_Plugin_Access);

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

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

   --  Parse the wiki text contained in Text according to the wiki syntax configured
   --  on the wiki engine.  The document reader operations are invoked while parsing the wiki
   --  text.
   procedure Parse (Engine : in out Parser;
                    Text   : in Wide_Wide_String;
                    Render : in Wiki.Render.Renderer_Access);

   --  Parse the wiki stream managed by <tt>Stream</tt> according to the wiki syntax configured
   --  on the wiki engine.  The wiki is then rendered by using the renderer.
   procedure Parse (Engine : in out Parser;
                    Stream : in Wiki.Streams.Input_Stream_Access;
                    Render : in Wiki.Render.Renderer_Access);

private

   HT : constant Wide_Wide_Character := Wide_Wide_Character'Val (16#09#);
   LF : constant Wide_Wide_Character := Wide_Wide_Character'Val (16#0A#);
   CR : constant Wide_Wide_Character := Wide_Wide_Character'Val (16#0D#);

   type Parser is tagged limited record
      Pending             : Wide_Wide_Character;
      Has_Pending         : Boolean;
      Syntax              : Wiki_Syntax_Type;
      Document            : Wiki.Nodes.Document;
      Filters             : Wiki.Filters.Filter_Type_Access;
      Format              : Wiki.Format_Map;
      Text                : Wiki.Strings.BString (512);
      Token               : Wiki.Strings.BString (512);
      Empty_Line          : Boolean := True;
      Is_Eof              : Boolean := False;
      In_Paragraph        : Boolean := False;
      In_List             : Boolean := False;
      Need_Paragraph      : Boolean := True;
      Link_Double_Bracket : Boolean := False;
      Is_Dotclear         : Boolean := False;
      Link_Title_First    : Boolean := False;
      Check_Image_Link    : Boolean := False;
      Header_Offset       : Integer := 0;
      Quote_Level         : Natural := 0;
      Escape_Char         : Wide_Wide_Character;
      List_Level          : Natural := 0;
      Reader              : Wiki.Streams.Input_Stream_Access := null;
      Attributes          : Wiki.Attributes.Attribute_List_Type;
   end record;

   type Parser_Handler is access procedure (P     : in out Parser;
                                            Token : in Wide_Wide_Character);

   type Parser_Table is array (0 .. 127) of Parser_Handler;
   type Parser_Table_Access is access Parser_Table;

   --  Peek the next character from the wiki text buffer.
   procedure Peek (P     : in out Parser;
                   Token : out Wide_Wide_Character);

   --  Put back the character so that it will be returned by the next call to Peek.
   procedure Put_Back (P     : in out Parser;
                       Token : in Wide_Wide_Character);

   --  Skip all the spaces and tabs as well as end of the current line (CR+LF).
   procedure Skip_End_Of_Line (P : in out Parser);

   --  Skip white spaces and tabs.
   procedure Skip_Spaces (P : in out Parser);

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

   --  Flush the wiki dl/dt/dd definition list.
   procedure Flush_List (P : in out Parser);

   --  Append a character to the wiki text buffer.
   procedure Parse_Text (P     : in out Parser;
                         Token : in Wide_Wide_Character);

   --  Check if the link refers to an image and must be rendered as an image.
   function Is_Image (P    : in Parser;
                      Link : in Wide_Wide_String) return Boolean;

   procedure Start_Element (P          : in out Parser;
                            Tag        : in Wiki.Nodes.Html_Tag_Type;
                            Attributes : in out Wiki.Attributes.Attribute_List_Type);

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

end Wiki.Parsers;

-----------------------------------------------------------------------
--  wiki-parsers -- Wiki parser
--  Copyright (C) 2011, 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 Wiki.Attributes;
with Wiki.Plugins;
with Wiki.Filters;
with Wiki.Strings;
with Wiki.Nodes;
with Wiki.Streams;
with Wiki.Render;

--  == Wiki Parsers ==
--  The Wikis.Parsers package implements a parser for several well known wiki formats.
--  The parser works with the Document_Reader interface type which defines several
--  procedures that are called by the parser when the wiki text is scanned.
package Wiki.Parsers is

   pragma Preelaborate;

   --  Defines the possible wiki syntax supported by the parser.
   type Wiki_Syntax_Type
     is (
         --  Google wiki syntax http://code.google.com/p/support/wiki/WikiSyntax
         SYNTAX_GOOGLE,

         --  Creole wiki syntax http://www.wikicreole.org/wiki/Creole1.0
         SYNTAX_CREOLE,

         --  Dotclear syntax http://dotclear.org/documentation/2.0/usage/syntaxes
         SYNTAX_DOTCLEAR,

         --  PhpBB syntax http://wiki.phpbb.com/Help:Formatting
         SYNTAX_PHPBB,

         --  MediaWiki syntax http://www.mediawiki.org/wiki/Help:Formatting
         SYNTAX_MEDIA_WIKI,

         --  Markdown
         SYNTAX_MARKDOWN,

         --  A mix of the above
         SYNTAX_MIX,

         --  The input is plain possibly incorrect HTML.
         SYNTAX_HTML);

   type Parser is tagged limited private;

   --  Add the plugin to the wiki engine.
   procedure Add_Plugin (Engine : in out Parser;
                         Name   : in String;
                         Plugin : in Wiki.Plugins.Wiki_Plugin_Access);

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

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

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  defined on the parser.
   procedure Parse (Engine : in out Parser;
                    Text   : in Wide_Wide_String);

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

private

   HT : constant Wide_Wide_Character := Wide_Wide_Character'Val (16#09#);
   LF : constant Wide_Wide_Character := Wide_Wide_Character'Val (16#0A#);
   CR : constant Wide_Wide_Character := Wide_Wide_Character'Val (16#0D#);

   type Parser is tagged limited record
      Pending             : Wide_Wide_Character;
      Has_Pending         : Boolean;
      Syntax              : Wiki_Syntax_Type;
      Document            : Wiki.Nodes.Document;
      Filters             : Wiki.Filters.Filter_Chain;
      Format              : Wiki.Format_Map;
      Text                : Wiki.Strings.BString (512);
      Token               : Wiki.Strings.BString (512);
      Empty_Line          : Boolean := True;
      Is_Eof              : Boolean := False;
      In_Paragraph        : Boolean := False;
      In_List             : Boolean := False;
      Need_Paragraph      : Boolean := True;
      Link_Double_Bracket : Boolean := False;
      Is_Dotclear         : Boolean := False;
      Link_Title_First    : Boolean := False;
      Check_Image_Link    : Boolean := False;
      Header_Offset       : Integer := 0;
      Quote_Level         : Natural := 0;
      Escape_Char         : Wide_Wide_Character;
      List_Level          : Natural := 0;
      Reader              : Wiki.Streams.Input_Stream_Access := null;
      Attributes          : Wiki.Attributes.Attribute_List_Type;
   end record;

   type Parser_Handler is access procedure (P     : in out Parser;
                                            Token : in Wide_Wide_Character);

   type Parser_Table is array (0 .. 127) of Parser_Handler;
   type Parser_Table_Access is access Parser_Table;

   --  Peek the next character from the wiki text buffer.
   procedure Peek (P     : in out Parser;
                   Token : out Wide_Wide_Character);

   --  Put back the character so that it will be returned by the next call to Peek.
   procedure Put_Back (P     : in out Parser;
                       Token : in Wide_Wide_Character);

   --  Skip all the spaces and tabs as well as end of the current line (CR+LF).
   procedure Skip_End_Of_Line (P : in out Parser);

   --  Skip white spaces and tabs.
   procedure Skip_Spaces (P : in out Parser);

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

   --  Flush the wiki dl/dt/dd definition list.
   procedure Flush_List (P : in out Parser);

   --  Append a character to the wiki text buffer.
   procedure Parse_Text (P     : in out Parser;
                         Token : in Wide_Wide_Character);

   --  Check if the link refers to an image and must be rendered as an image.
   function Is_Image (P    : in Parser;
                      Link : in Wide_Wide_String) return Boolean;

   procedure Start_Element (P          : in out Parser;
                            Tag        : in Wiki.Nodes.Html_Tag_Type;
                            Attributes : in out Wiki.Attributes.Attribute_List_Type);

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

end Wiki.Parsers;

Use the Filter_Chain to maintain the filters


-----------------------------------------------------------------------
--  wiki-parsers -- Wiki parser
--  Copyright (C) 2011, 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.Strings.Wide_Wide_Unbounded;

with Wiki.Documents;
with Wiki.Attributes;

--  == Wiki Parsers ==
--  The Wikis.Parsers package implements a parser for several well known wiki formats.
--  The parser works with the Document_Reader interface type which defines several
--  procedures that are called by the parser when the wiki text is scanned.
package Wiki.Parsers is

   pragma Preelaborate;

   --  Defines the possible wiki syntax supported by the parser.
   type Wiki_Syntax_Type
     is (
         --  Google wiki syntax http://code.google.com/p/support/wiki/WikiSyntax
         SYNTAX_GOOGLE,

         --  Creole wiki syntax http://www.wikicreole.org/wiki/Creole1.0
         SYNTAX_CREOLE,

         --  Dotclear syntax http://dotclear.org/documentation/2.0/usage/syntaxes
         SYNTAX_DOTCLEAR,

         --  PhpBB syntax http://wiki.phpbb.com/Help:Formatting
         SYNTAX_PHPBB,

         --  MediaWiki syntax http://www.mediawiki.org/wiki/Help:Formatting
         SYNTAX_MEDIA_WIKI,

         --  Markdown
         SYNTAX_MARKDOWN,

         --  A mix of the above
         SYNTAX_MIX);

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  specified in Syntax and invoke the document reader procedures defined
   --  by into.
   procedure Parse (Into   : in Wiki.Documents.Document_Reader_Access;
                    Text   : in Wide_Wide_String;
                    Syntax : in Wiki_Syntax_Type := SYNTAX_MIX);

private

   HT : constant Wide_Wide_Character := Wide_Wide_Character'Val (16#09#);
   LF : constant Wide_Wide_Character := Wide_Wide_Character'Val (16#0A#);
   CR : constant Wide_Wide_Character := Wide_Wide_Character'Val (16#0D#);

   type Input is interface;
   type Input_Access is access all Input'Class;
   procedure Read_Char (From : in out Input;
                        Token : out Wide_Wide_Character;
                        Eof   : out Boolean) is abstract;

   type Parser is limited record
      Pending             : Wide_Wide_Character;
      Has_Pending         : Boolean;
      Document            : Wiki.Documents.Document_Reader_Access;
      Format              : Wiki.Documents.Format_Map;
      Text                : Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String;
      Token               : Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String;
      Empty_Line          : Boolean := True;
      Is_Eof              : Boolean := False;
      In_Paragraph        : Boolean := False;
      Need_Paragraph      : Boolean := True;
      Link_Double_Bracket : Boolean := False;
      Is_Dotclear         : Boolean := False;
      Header_Offset       : Integer := 0;
      Quote_Level         : Natural := 0;
      Escape_Char         : Wide_Wide_Character;
      List_Level          : Natural := 0;
      Reader              : Input_Access := null;
      Attributes          : Wiki.Attributes.Attribute_List_Type;
   end record;

   type Parser_Handler is access procedure (P     : in out Parser;
                                            Token : in Wide_Wide_Character);

   type Parser_Table is array (0 .. 127) of Parser_Handler;
   type Parser_Table_Access is access Parser_Table;

   --  Peek the next character from the wiki text buffer.
   procedure Peek (P     : in out Parser;
                   Token : out Wide_Wide_Character);

   --  Put back the character so that it will be returned by the next call to Peek.
   procedure Put_Back (P     : in out Parser;
                       Token : in Wide_Wide_Character);

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

end Wiki.Parsers;

-----------------------------------------------------------------------
--  wiki-parsers -- Wiki parser
--  Copyright (C) 2011, 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.Strings.Wide_Wide_Unbounded;
with Ada.Containers.Vectors;

with Wiki.Documents;
with Wiki.Attributes;

--  == Wiki Parsers ==
--  The Wikis.Parsers package implements a parser for several well known wiki formats.
--  The parser works with the Document_Reader interface type which defines several
--  procedures that are called by the parser when the wiki text is scanned.
package Wiki.Parsers is

   pragma Preelaborate;

   --  Defines the possible wiki syntax supported by the parser.
   type Wiki_Syntax_Type
     is (
         --  Google wiki syntax http://code.google.com/p/support/wiki/WikiSyntax
         SYNTAX_GOOGLE,

         --  Creole wiki syntax http://www.wikicreole.org/wiki/Creole1.0
         SYNTAX_CREOLE,

         --  Dotclear syntax http://dotclear.org/documentation/2.0/usage/syntaxes
         SYNTAX_DOTCLEAR,

         --  PhpBB syntax http://wiki.phpbb.com/Help:Formatting
         SYNTAX_PHPBB,

         --  MediaWiki syntax http://www.mediawiki.org/wiki/Help:Formatting
         SYNTAX_MEDIA_WIKI,

         --  Markdown
         SYNTAX_MARKDOWN,

         --  A mix of the above
         SYNTAX_MIX);

   --  Parse the wiki text contained in Text according to the wiki syntax
   --  specified in Syntax and invoke the document reader procedures defined
   --  by into.
   procedure Parse (Into   : in Wiki.Documents.Document_Reader_Access;
                    Text   : in Wide_Wide_String;
                    Syntax : in Wiki_Syntax_Type := SYNTAX_MIX);

private

   use Ada.Strings.Wide_Wide_Unbounded;

   HT : constant Wide_Wide_Character := Wide_Wide_Character'Val (16#09#);
   LF : constant Wide_Wide_Character := Wide_Wide_Character'Val (16#0A#);
   CR : constant Wide_Wide_Character := Wide_Wide_Character'Val (16#0D#);

   type Input is interface;
   type Input_Access is access all Input'Class;
   procedure Read_Char (From : in out Input;
                        Token : out Wide_Wide_Character;
                        Eof   : out Boolean) is abstract;

   package Wide_Wide_String_Vectors is
     new Ada.Containers.Vectors (Index_Type   => Positive,
                                 Element_Type => Unbounded_Wide_Wide_String);

   subtype Wide_Wide_String_Vector is Wide_Wide_String_Vectors.Vector;
   subtype Wide_Wide_String_Cursor is Wide_Wide_String_Vectors.Cursor;

   type Parser is limited record
      Pending             : Wide_Wide_Character;
      Has_Pending         : Boolean;
      Document            : Wiki.Documents.Document_Reader_Access;
      Format              : Wiki.Documents.Format_Map;
      Text                : Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String;
      Token               : Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String;
      Empty_Line          : Boolean := True;
      Is_Eof              : Boolean := False;
      In_Paragraph        : Boolean := False;
      Need_Paragraph      : Boolean := True;
      Link_Double_Bracket : Boolean := False;
      Is_Dotclear         : Boolean := False;
      Header_Offset       : Integer := 0;
      Quote_Level         : Natural := 0;
      Escape_Char         : Wide_Wide_Character;
      List_Level          : Natural := 0;
      Reader              : Input_Access := null;
      Attributes          : Wiki.Attributes.Attribute_List_Type;
      Html_Stack          : Wide_Wide_String_Vector;
   end record;

   type Parser_Handler is access procedure (P     : in out Parser;
                                            Token : in Wide_Wide_Character);

   type Parser_Table is array (0 .. 127) of Parser_Handler;
   type Parser_Table_Access is access Parser_Table;

   --  Peek the next character from the wiki text buffer.
   procedure Peek (P     : in out Parser;
                   Token : out Wide_Wide_Character);

   --  Put back the character so that it will be returned by the next call to Peek.
   procedure Put_Back (P     : in out Parser;
                       Token : in Wide_Wide_Character);

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

   procedure Start_Element (P          : in out Parser;
                            Name       : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String;
                            Attributes : in Wiki.Attributes.Attribute_List_Type);

   procedure End_Element (P    : in out Parser;
                          Name : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String);

   --  Flush the pending HTML stack elements.
   procedure Flush_Stack (P : in out Parser);

end Wiki.Parsers;

Declare Wide_Wide_String_Vectors package to maintain a stack of HTML elements that have been created


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

with Ada.Strings.Unbounded;

with Util.Beans.Basic;
with AWA.Votes.Modules;
with AWA.Votes.Models;

--  === Vote Beans ===
--  The Vote_Bean is a bean intended to be used in presentation files (facelet files)
--  to vote for an item.  The managed bean can be easily configured in the application XML
--  configuration file.  The permission and entity_type are the two properties
--  that should be defined in the configuration.  The permission is the name of the
--  permission that must be used to verify that the user is allowed to vote for the item.
--  The entity_type is the name of the entity (table name) used by the item.
--  The example below defines the bean <tt>questionVote</tt> defined by the question module.
--
--    <managed-bean>
--      <description>The vote bean that allows to vote for a question.</description>
--      <managed-bean-name>questionVote</managed-bean-name>
--      <managed-bean-class>AWA.Votes.Beans.Votes_Bean</managed-bean-class>
--      <managed-bean-scope>request</managed-bean-scope>
--      <managed-property>
--        <property-name>permission</property-name>
--        <property-class>String</property-class>
--        <value>answer-create</value>
--      </managed-property>
--      <managed-property>
--        <property-name>entity_type</property-name>
--        <property-class>String</property-class>
--        <value>awa_question</value>
--      </managed-property>
--    </managed-bean>
--
--  The vote concerns entities for the <tt>awa_question</tt> entity table.
--  The permission <tt>answer-create</tt> is used to verify for the vote.
--
--  [http://ada-awa.googlecode.com/svn/wiki/awa_votes_bean.png]
--
package AWA.Votes.Beans is

   type Vote_Bean is new AWA.Votes.Models.Vote_Bean with private;
   type Vote_Bean_Access is access all Vote_Bean'Class;

   --  Action to vote up.
   overriding
   procedure Vote_Up (Bean    : in out Vote_Bean;
                      Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Action to vote down.
   overriding
   procedure Vote_Down (Bean    : in out Vote_Bean;
                        Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Action to vote.
   overriding
   procedure Vote (Bean    : in out Vote_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Votes_Bean bean instance.
   function Create_Vote_Bean (Module : in AWA.Votes.Modules.Vote_Module_Access)
      return Util.Beans.Basic.Readonly_Bean_Access;

private

   type Vote_Bean is new AWA.Votes.Models.Vote_Bean with record
      Module : AWA.Votes.Modules.Vote_Module_Access := null;
   end record;

end AWA.Votes.Beans;

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

with Ada.Strings.Unbounded;

with Util.Beans.Basic;
with AWA.Votes.Modules;
with AWA.Votes.Models;

--  === Vote Beans ===
--  The <tt>Vote_Bean</tt> is a bean intended to be used in presentation files (XHTML facelet
--  files) to vote for an item.  The managed bean can be easily configured in the application XML
--  configuration file.  The permission and entity_type are the two properties
--  that should be defined in the configuration.  The permission is the name of the
--  permission that must be used to verify that the user is allowed to vote for the item.
--  The entity_type is the name of the entity (table name) used by the item.
--  The example below defines the bean <tt>questionVote</tt> defined by the question module.
--
--    <managed-bean>
--      <description>The vote bean that allows to vote for a question.</description>
--      <managed-bean-name>questionVote</managed-bean-name>
--      <managed-bean-class>AWA.Votes.Beans.Votes_Bean</managed-bean-class>
--      <managed-bean-scope>request</managed-bean-scope>
--      <managed-property>
--        <property-name>permission</property-name>
--        <property-class>String</property-class>
--        <value>answer-create</value>
--      </managed-property>
--      <managed-property>
--        <property-name>entity_type</property-name>
--        <property-class>String</property-class>
--        <value>awa_question</value>
--      </managed-property>
--    </managed-bean>
--
--  The vote concerns entities for the <tt>awa_question</tt> entity table.
--  The permission <tt>answer-create</tt> is used to verify that the vote is allowed.
--
--  [http://ada-awa.googlecode.com/svn/wiki/awa_votes_bean.png]
--
--  The managed bean defines three operations that can be called: <tt>vote_up</tt>,
--  <tt>vote_down</tt> and <tt>vote</tt> to setup specific ratings.
package AWA.Votes.Beans is

   type Vote_Bean is new AWA.Votes.Models.Vote_Bean with private;
   type Vote_Bean_Access is access all Vote_Bean'Class;

   --  Action to vote up.
   overriding
   procedure Vote_Up (Bean    : in out Vote_Bean;
                      Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Action to vote down.
   overriding
   procedure Vote_Down (Bean    : in out Vote_Bean;
                        Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Action to vote.
   overriding
   procedure Vote (Bean    : in out Vote_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Votes_Bean bean instance.
   function Create_Vote_Bean (Module : in AWA.Votes.Modules.Vote_Module_Access)
      return Util.Beans.Basic.Readonly_Bean_Access;

private

   type Vote_Bean is new AWA.Votes.Models.Vote_Bean with record
      Module : AWA.Votes.Modules.Vote_Module_Access := null;
   end record;

end AWA.Votes.Beans;

Update the documentation

Update the documentation


-----------------------------------------------------------------------
--  files.tests -- Unit tests for files
--  Copyright (C) 2011, 2012, 2013, 2014, 2017, 2020 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 Util.Tests;
with Util.Log.Loggers;

with ASF.Principals;
with ASF.Tests;
with ASF.Responses.Mockup;
with AWA.Applications;
with AWA.Tests;
with AWA.Users.Modules;
with ADO.Sessions;
with ADO.SQL;
package body AWA.Tests.Helpers.Users is

   use AWA.Users.Services;
   use type AWA.Users.Principals.Principal_Access;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Tests.Helpers.Users");

   MAX_USERS    : constant Positive := 10;
   Logged_Users : array (1 .. MAX_USERS) of AWA.Users.Principals.Principal_Access;

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => AWA.Users.Principals.Principal'Class,
                                     Name   => AWA.Users.Principals.Principal_Access);

   --  ------------------------------
   --  Initialize the service context.
   --  ------------------------------
   procedure Initialize (Principal : in out Test_User) is
   begin
      --  Setup the service context.
      Principal.Context.Set_Context (AWA.Tests.Get_Application, null);

      if Principal.Manager = null then
         Principal.Manager := AWA.Users.Modules.Get_User_Manager;
         if Principal.Manager = null then
            Log.Error ("There is no User_Manager in the application.");
         end if;
      end if;
   end Initialize;

   --  ------------------------------
   --  Create a test user associated with the given email address.
   --  Get an open session for that user.  If the user already exists, no error is reported.
   --  ------------------------------
   procedure Create_User (Principal : in out Test_User;
                          Email     : in String) is
      DB    : ADO.Sessions.Session;
      Query : ADO.SQL.Query;
      Found : Boolean;
      Key   : AWA.Users.Models.Access_Key_Ref;
   begin
      Initialize (Principal);

      DB := Principal.Manager.Get_Session;

      --  Find the user
      Query.Set_Join ("inner join awa_email e on e.user_id = o.id");
      Query.Set_Filter ("e.email = ?");
      Query.Bind_Param (1, Email);
      Principal.User.Find (DB, Query, Found);
      if not Found then
         Principal.User.Set_First_Name ("Joe");
         Principal.User.Set_Last_Name ("Pot");
         Principal.User.Set_Password ("admin");
         Principal.Email.Set_Email (Email);
         Principal.Manager.Create_User (Principal.User, Principal.Email);

         Find_Access_Key (Principal, Email, Key);

         --  Run the verification and get the user and its session
         Principal.Manager.Verify_User (Key.Get_Access_Key, "192.168.1.1",
                                        Principal.Principal);
      else
         Principal.Manager.Authenticate (Email     => Email,
                                         Password  => "admin",
                                         IpAddr    => "192.168.1.1",
                                         Principal => Principal.Principal);
      end if;
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Create_User;

   --  ------------------------------
   --  Create a test user for a new test and get an open session.
   --  ------------------------------
   procedure Create_User (Principal : in out Test_User) is
      Key     : AWA.Users.Models.Access_Key_Ref;
      Email   : constant String := "Joe-" & Util.Tests.Get_Uuid & "@gmail.com";
   begin
      Initialize (Principal);
      Principal.User.Set_First_Name ("Joe");
      Principal.User.Set_Last_Name ("Pot");
      Principal.User.Set_Password ("admin");
      Principal.Email.Set_Email (Email);
      Principal.Manager.Create_User (Principal.User, Principal.Email);

      Find_Access_Key (Principal, Email, Key);

      --  Run the verification and get the user and its session
      Principal.Manager.Verify_User (Key.Get_Access_Key, "192.168.1.1",
                                     Principal.Principal);
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Create_User;

   --  ------------------------------
   --  Find the access key associated with a user (if any).
   --  ------------------------------
   procedure Find_Access_Key (Principal : in out Test_User;
                              Email     : in String;
                              Key       : in out AWA.Users.Models.Access_Key_Ref) is
      DB    : ADO.Sessions.Session;
      Query : ADO.SQL.Query;
      Found : Boolean;
      Signup_Kind  : constant Integer
        := AWA.Users.Models.Key_Type'Pos (AWA.Users.Models.SIGNUP_KEY);
      Password_Kind  : constant Integer
        := AWA.Users.Models.Key_Type'Pos (AWA.Users.Models.RESET_PASSWORD_KEY);
   begin
      Initialize (Principal);

      DB := Principal.Manager.Get_Session;

      --  Find the access key
      Query.Set_Join ("inner join awa_email e on e.user_id = o.user_id");
      Query.Set_Filter ("e.email = ? AND o.kind = ?");
      Query.Bind_Param (1, Email);
      Query.Bind_Param (2, Signup_Kind);
      Key.Find (DB, Query, Found);
      if not Found then
         Query.Bind_Param (2, Password_Kind);
         Key.Find (DB, Query, Found);
         if not Found then
            Log.Error ("Cannot find access key for email {0}", Email);
         end if;
      end if;
   end Find_Access_Key;

   --  ------------------------------
   --  Login a user and create a session
   --  ------------------------------
   procedure Login (Principal : in out Test_User) is
   begin
      Initialize (Principal);
      Principal.Manager.Authenticate (Email     => Principal.Email.Get_Email,
                                      Password  => "admin",
                                      IpAddr    => "192.168.1.1",
                                      Principal => Principal.Principal);
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Login;

   --  ------------------------------
   --  Logout the user and closes the current session.
   --  ------------------------------
   procedure Logout (Principal : in out Test_User) is
   begin
      Initialize (Principal);
      Principal.Manager.Close_Session (Principal.Session.Get_Id, True);
   end Logout;

   --  ------------------------------
   --  Simulate a user login in the given service context.
   --  ------------------------------
   procedure Login (Context     : in out AWA.Services.Contexts.Service_Context'Class;
                    Sec_Context : in out Security.Contexts.Security_Context;
                    Email       : in String) is
      User      : Test_User;
      Principal : AWA.Users.Principals.Principal_Access;
      App       : constant AWA.Applications.Application_Access := AWA.Tests.Get_Application;
   begin
      AWA.Tests.Set_Application_Context;
      Create_User (User, Email);
      Principal := AWA.Users.Principals.Create (User.User, User.Session);
      Context.Set_Context (App, Principal);
      Sec_Context.Set_Context (Manager   => App.Get_Security_Manager,
                               Principal => Principal.all'Access);

      --  Keep track of the Principal instance so that Tear_Down will release it.
      --  Most tests will call Login but don't call Logout because there is no real purpose
      --  for the test in doing that and it allows to keep the unit test simple.  This creates
      --  memory leak because the Principal instance is not freed.
      for I in Logged_Users'Range loop
         if Logged_Users (I) = null then
            Logged_Users (I) := Principal;
            exit;
         end if;
      end loop;
   end Login;

   --  ------------------------------
   --  Simulate a user login on the request.  Upon successful login, a session that is
   --  authentified is associated with the request object.
   --  ------------------------------
   procedure Login (Email   : in String;
                    Request : in out ASF.Requests.Mockup.Request'Class) is
      User  : Test_User;
      Reply : ASF.Responses.Mockup.Response;
   begin
      Create_User (User, Email);
      ASF.Tests.Do_Get (Request, Reply, "/auth/login.html", "login-user-1.html");

      Request.Set_Parameter ("email", Email);
      Request.Set_Parameter ("password", "admin");
      Request.Set_Parameter ("login", "1");
      Request.Set_Parameter ("login-button", "1");
      ASF.Tests.Do_Post (Request, Reply, "/auth/login.html", "login-user-2.html");
   end Login;

   --  ------------------------------
   --  Setup the context and security context to simulate an anonymous user.
   --  ------------------------------
   procedure Anonymous (Context     : in out AWA.Services.Contexts.Service_Context'Class;
                        Sec_Context : in out Security.Contexts.Security_Context) is
      App : constant AWA.Applications.Application_Access := AWA.Tests.Get_Application;
   begin
      AWA.Tests.Set_Application_Context;
      Context.Set_Context (App, null);
      Sec_Context.Set_Context (Manager   => App.Get_Security_Manager,
                               Principal => null);
   end Anonymous;

   --  ------------------------------
   --  Simulate the recovery password process for the given user.
   --  ------------------------------
   procedure Recover_Password (Email : in String) is
      use type ASF.Principals.Principal_Access;

      Request : ASF.Requests.Mockup.Request;
      Reply   : ASF.Responses.Mockup.Response;
   begin
      Request.Set_Parameter ("email", Email);
      Request.Set_Parameter ("lost-password", "1");
      Request.Set_Parameter ("lost-password-button", "1");
      ASF.Tests.Do_Post (Request, Reply, "/auth/lost-password.html", "lost-password-2.html");

      if Reply.Get_Status /= ASF.Responses.SC_MOVED_TEMPORARILY then
         Log.Error ("Invalid redirect after lost password");
      end if;

      --  Now, get the access key and simulate a click on the reset password link.
      declare
         Principal : AWA.Tests.Helpers.Users.Test_User;
         Key       : AWA.Users.Models.Access_Key_Ref;
      begin
         AWA.Tests.Set_Application_Context;
         AWA.Tests.Helpers.Users.Find_Access_Key (Principal, Email, Key);
         if not Key.Is_Null then
            Log.Error ("There is no access key associated with the user");
         end if;

         --  Simulate user clicking on the reset password link.
         --  This verifies the key, login the user and redirect him to the change-password page
         Request.Set_Parameter ("key", Key.Get_Access_Key);
         Request.Set_Parameter ("password", "admin");
         Request.Set_Parameter ("reset-password", "1");
         ASF.Tests.Do_Post (Request, Reply, "/auth/change-password.html", "reset-password-2.html");

         if Reply.Get_Status /= ASF.Responses.SC_MOVED_TEMPORARILY then
            Log.Error ("Invalid response");
         end if;

         --  Check that the user is logged and we have a user principal now.
         if Request.Get_User_Principal = null then
            Log.Error ("A user principal should be defined");
         end if;
      end;
   end Recover_Password;

   overriding
   procedure Finalize (Principal : in out Test_User) is
   begin
      Free (Principal.Principal);
   end Finalize;

   --  ------------------------------
   --  Cleanup and release the Principal that have been allocated from the Login session
   --  but not released because the Logout is not called from the unit test.
   --  ------------------------------
   procedure Tear_Down is
   begin
      for I in Logged_Users'Range loop
         if Logged_Users (I) /= null then
            Free (Logged_Users (I));
         end if;
      end loop;
   end Tear_Down;

end AWA.Tests.Helpers.Users;

-----------------------------------------------------------------------
--  files.tests -- Unit tests for files
--  Copyright (C) 2011, 2012, 2013, 2014, 2017, 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 Ada.Unchecked_Deallocation;

with Util.Tests;
with Util.Log.Loggers;

with ASF.Principals;
with ASF.Tests;
with ASF.Responses.Mockup;
with AWA.Applications;
with AWA.Users.Modules;
with ADO.Sessions;
with ADO.SQL;
package body AWA.Tests.Helpers.Users is

   use AWA.Users.Services;
   use type AWA.Users.Principals.Principal_Access;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Tests.Helpers.Users");

   MAX_USERS    : constant Positive := 10;
   Logged_Users : array (1 .. MAX_USERS) of AWA.Users.Principals.Principal_Access;

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => AWA.Users.Principals.Principal'Class,
                                     Name   => AWA.Users.Principals.Principal_Access);

   --  ------------------------------
   --  Initialize the service context.
   --  ------------------------------
   procedure Initialize (Principal : in out Test_User) is
   begin
      --  Setup the service context.
      Principal.Context.Set_Context (AWA.Tests.Get_Application, null);

      if Principal.Manager = null then
         Principal.Manager := AWA.Users.Modules.Get_User_Manager;
         if Principal.Manager = null then
            Log.Error ("There is no User_Manager in the application.");
         end if;
      end if;
   end Initialize;

   --  ------------------------------
   --  Create a test user associated with the given email address.
   --  Get an open session for that user.  If the user already exists, no error is reported.
   --  ------------------------------
   procedure Create_User (Principal : in out Test_User;
                          Email     : in String) is
      DB    : ADO.Sessions.Session;
      Query : ADO.SQL.Query;
      Found : Boolean;
      Key   : AWA.Users.Models.Access_Key_Ref;
   begin
      Initialize (Principal);

      DB := Principal.Manager.Get_Session;

      --  Find the user
      Query.Set_Join ("inner join awa_email e on e.user_id = o.id");
      Query.Set_Filter ("e.email = ?");
      Query.Bind_Param (1, Email);
      Principal.User.Find (DB, Query, Found);
      if not Found then
         Principal.User.Set_First_Name ("Joe");
         Principal.User.Set_Last_Name ("Pot");
         Principal.User.Set_Password ("admin");
         Principal.Email.Set_Email (Email);
         Principal.Manager.Create_User (Principal.User, Principal.Email);

         Find_Access_Key (Principal, Email, Key);

         --  Run the verification and get the user and its session
         Principal.Manager.Verify_User (Key.Get_Access_Key, "192.168.1.1",
                                        Principal.Principal);
      else
         Principal.Manager.Authenticate (Email     => Email,
                                         Password  => "admin",
                                         IpAddr    => "192.168.1.1",
                                         Principal => Principal.Principal);
      end if;
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Create_User;

   --  ------------------------------
   --  Create a test user for a new test and get an open session.
   --  ------------------------------
   procedure Create_User (Principal : in out Test_User) is
      Key     : AWA.Users.Models.Access_Key_Ref;
      Email   : constant String := "Joe-" & Util.Tests.Get_Uuid & "@gmail.com";
   begin
      Initialize (Principal);
      Principal.User.Set_First_Name ("Joe");
      Principal.User.Set_Last_Name ("Pot");
      Principal.User.Set_Password ("admin");
      Principal.Email.Set_Email (Email);
      Principal.Manager.Create_User (Principal.User, Principal.Email);

      Find_Access_Key (Principal, Email, Key);

      --  Run the verification and get the user and its session
      Principal.Manager.Verify_User (Key.Get_Access_Key, "192.168.1.1",
                                     Principal.Principal);
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Create_User;

   --  ------------------------------
   --  Find the access key associated with a user (if any).
   --  ------------------------------
   procedure Find_Access_Key (Principal : in out Test_User;
                              Email     : in String;
                              Key       : in out AWA.Users.Models.Access_Key_Ref) is
      DB    : ADO.Sessions.Session;
      Query : ADO.SQL.Query;
      Found : Boolean;
      Signup_Kind  : constant Integer
        := AWA.Users.Models.Key_Type'Pos (AWA.Users.Models.SIGNUP_KEY);
      Password_Kind  : constant Integer
        := AWA.Users.Models.Key_Type'Pos (AWA.Users.Models.RESET_PASSWORD_KEY);
   begin
      Initialize (Principal);

      DB := Principal.Manager.Get_Session;

      --  Find the access key
      Query.Set_Join ("inner join awa_email e on e.user_id = o.user_id");
      Query.Set_Filter ("e.email = ? AND o.kind = ?");
      Query.Bind_Param (1, Email);
      Query.Bind_Param (2, Signup_Kind);
      Key.Find (DB, Query, Found);
      if not Found then
         Query.Bind_Param (2, Password_Kind);
         Key.Find (DB, Query, Found);
         if not Found then
            Log.Error ("Cannot find access key for email {0}", Email);
         end if;
      end if;
   end Find_Access_Key;

   --  ------------------------------
   --  Login a user and create a session
   --  ------------------------------
   procedure Login (Principal : in out Test_User) is
   begin
      Initialize (Principal);
      Principal.Manager.Authenticate (Email     => Principal.Email.Get_Email,
                                      Password  => "admin",
                                      IpAddr    => "192.168.1.1",
                                      Principal => Principal.Principal);
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Login;

   --  ------------------------------
   --  Logout the user and closes the current session.
   --  ------------------------------
   procedure Logout (Principal : in out Test_User) is
   begin
      Initialize (Principal);
      Principal.Manager.Close_Session (Principal.Session.Get_Id, True);
   end Logout;

   --  ------------------------------
   --  Simulate a user login in the given service context.
   --  ------------------------------
   procedure Login (Context     : in out AWA.Services.Contexts.Service_Context'Class;
                    Sec_Context : in out Security.Contexts.Security_Context;
                    Email       : in String) is
      User      : Test_User;
      Principal : AWA.Users.Principals.Principal_Access;
      App       : constant AWA.Applications.Application_Access := AWA.Tests.Get_Application;
   begin
      AWA.Tests.Set_Application_Context;
      Create_User (User, Email);
      Principal := AWA.Users.Principals.Create (User.User, User.Session);
      Context.Set_Context (App, Principal);
      Sec_Context.Set_Context (Manager   => App.Get_Security_Manager,
                               Principal => Principal.all'Access);

      --  Keep track of the Principal instance so that Tear_Down will release it.
      --  Most tests will call Login but don't call Logout because there is no real purpose
      --  for the test in doing that and it allows to keep the unit test simple.  This creates
      --  memory leak because the Principal instance is not freed.
      for I in Logged_Users'Range loop
         if Logged_Users (I) = null then
            Logged_Users (I) := Principal;
            exit;
         end if;
      end loop;
   end Login;

   --  ------------------------------
   --  Simulate a user login on the request.  Upon successful login, a session that is
   --  authentified is associated with the request object.
   --  ------------------------------
   procedure Login (Email   : in String;
                    Request : in out ASF.Requests.Mockup.Request'Class) is
      User  : Test_User;
      Reply : ASF.Responses.Mockup.Response;
   begin
      Create_User (User, Email);
      ASF.Tests.Do_Get (Request, Reply, "/auth/login.html", "login-user-1.html");

      Request.Set_Parameter ("email", Email);
      Request.Set_Parameter ("password", "admin");
      Request.Set_Parameter ("login", "1");
      Request.Set_Parameter ("login-button", "1");
      ASF.Tests.Do_Post (Request, Reply, "/auth/login.html", "login-user-2.html");
   end Login;

   --  ------------------------------
   --  Setup the context and security context to simulate an anonymous user.
   --  ------------------------------
   procedure Anonymous (Context     : in out AWA.Services.Contexts.Service_Context'Class;
                        Sec_Context : in out Security.Contexts.Security_Context) is
      App : constant AWA.Applications.Application_Access := AWA.Tests.Get_Application;
   begin
      AWA.Tests.Set_Application_Context;
      Context.Set_Context (App, null);
      Sec_Context.Set_Context (Manager   => App.Get_Security_Manager,
                               Principal => null);
   end Anonymous;

   --  ------------------------------
   --  Simulate the recovery password process for the given user.
   --  ------------------------------
   procedure Recover_Password (Email : in String) is
      use type ASF.Principals.Principal_Access;

      Request : ASF.Requests.Mockup.Request;
      Reply   : ASF.Responses.Mockup.Response;
   begin
      Request.Set_Parameter ("email", Email);
      Request.Set_Parameter ("lost-password", "1");
      Request.Set_Parameter ("lost-password-button", "1");
      ASF.Tests.Do_Post (Request, Reply, "/auth/lost-password.html", "lost-password-2.html");

      if Reply.Get_Status /= ASF.Responses.SC_MOVED_TEMPORARILY then
         Log.Error ("Invalid redirect after lost password");
      end if;

      --  Now, get the access key and simulate a click on the reset password link.
      declare
         Principal : AWA.Tests.Helpers.Users.Test_User;
         Key       : AWA.Users.Models.Access_Key_Ref;
      begin
         AWA.Tests.Set_Application_Context;
         AWA.Tests.Helpers.Users.Find_Access_Key (Principal, Email, Key);
         if not Key.Is_Null then
            Log.Error ("There is no access key associated with the user");
         end if;

         --  Simulate user clicking on the reset password link.
         --  This verifies the key, login the user and redirect him to the change-password page
         Request.Set_Parameter ("key", Key.Get_Access_Key);
         Request.Set_Parameter ("password", "admin");
         Request.Set_Parameter ("reset-password", "1");
         ASF.Tests.Do_Post (Request, Reply, "/auth/change-password.html", "reset-password-2.html");

         if Reply.Get_Status /= ASF.Responses.SC_MOVED_TEMPORARILY then
            Log.Error ("Invalid response");
         end if;

         --  Check that the user is logged and we have a user principal now.
         if Request.Get_User_Principal = null then
            Log.Error ("A user principal should be defined");
         end if;
      end;
   end Recover_Password;

   overriding
   procedure Finalize (Principal : in out Test_User) is
   begin
      Free (Principal.Principal);
   end Finalize;

   --  ------------------------------
   --  Cleanup and release the Principal that have been allocated from the Login session
   --  but not released because the Logout is not called from the unit test.
   --  ------------------------------
   procedure Tear_Down is
   begin
      for I in Logged_Users'Range loop
         if Logged_Users (I) /= null then
            Free (Logged_Users (I));
         end if;
      end loop;
   end Tear_Down;

end AWA.Tests.Helpers.Users;

Fix compilation warning with GCC 12: remove unused with clause for an ancestor


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

with Security.Contexts;
with ASF.Requests.Mockup;
with AWA.Users.Models;
with AWA.Users.Services;
with AWA.Services.Contexts;
with AWA.Users.Principals;
package AWA.Tests.Helpers.Users is

   type Test_User is new Ada.Finalization.Limited_Controlled with record
      Context   : AWA.Services.Contexts.Service_Context;
      Manager   : AWA.Users.Services.User_Service_Access := null;
      User      : AWA.Users.Models.User_Ref;
      Email     : AWA.Users.Models.Email_Ref;
      Session   : AWA.Users.Models.Session_Ref;
      Principal : AWA.Users.Principals.Principal_Access;
   end record;

   --  Initialize the service context.
   procedure Initialize (Principal : in out Test_User);

   --  Create a test user associated with the given email address.
   --  Get an open session for that user.  If the user already exists, no error is reported.
   procedure Create_User (Principal : in out Test_User;
                          Email     : in String);

   --  Create a test user for a new test and get an open session.
   procedure Create_User (Principal : in out Test_User);

   --  Find the access key associated with a user (if any).
   procedure Find_Access_Key (Principal : in out Test_User;
                              Email     : in String;
                              Key       : in out AWA.Users.Models.Access_Key_Ref);

   --  Login a user and create a session
   procedure Login (Principal : in out Test_User);

   --  Logout the user and closes the current session.
   procedure Logout (Principal : in out Test_User);

   --  Simulate a user login in the given service context.
   procedure Login (Context     : in out AWA.Services.Contexts.Service_Context'Class;
                    Sec_Context : in out Security.Contexts.Security_Context;
                    Email       : in String);

   --  Simulate a user login on the request.  Upon successful login, a session that is
   --  authentified is associated with the request object.
   procedure Login (Email   : in String;
                    Request : in out ASF.Requests.Mockup.Request);

   --  Setup the context and security context to simulate an anonymous user.
   procedure Anonymous (Context     : in out AWA.Services.Contexts.Service_Context'Class;
                        Sec_Context : in out Security.Contexts.Security_Context);

   overriding
   procedure Finalize (Principal : in out Test_User);

   --  Cleanup and release the Principal that have been allocated from the Login session
   --  but not released because the Logout is not called from the unit test.
   procedure Tear_Down;

end AWA.Tests.Helpers.Users;

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

with Security.Contexts;
with ASF.Requests.Mockup;
with AWA.Users.Models;
with AWA.Users.Services;
with AWA.Services.Contexts;
with AWA.Users.Principals;
package AWA.Tests.Helpers.Users is

   type Test_User is new Ada.Finalization.Limited_Controlled with record
      Context   : AWA.Services.Contexts.Service_Context;
      Manager   : AWA.Users.Services.User_Service_Access := null;
      User      : AWA.Users.Models.User_Ref;
      Email     : AWA.Users.Models.Email_Ref;
      Session   : AWA.Users.Models.Session_Ref;
      Principal : AWA.Users.Principals.Principal_Access;
   end record;

   --  Initialize the service context.
   procedure Initialize (Principal : in out Test_User);

   --  Create a test user associated with the given email address.
   --  Get an open session for that user.  If the user already exists, no error is reported.
   procedure Create_User (Principal : in out Test_User;
                          Email     : in String);

   --  Create a test user for a new test and get an open session.
   procedure Create_User (Principal : in out Test_User);

   --  Find the access key associated with a user (if any).
   procedure Find_Access_Key (Principal : in out Test_User;
                              Email     : in String;
                              Key       : in out AWA.Users.Models.Access_Key_Ref);

   --  Login a user and create a session
   procedure Login (Principal : in out Test_User);

   --  Logout the user and closes the current session.
   procedure Logout (Principal : in out Test_User);

   --  Simulate a user login in the given service context.
   procedure Login (Context     : in out AWA.Services.Contexts.Service_Context'Class;
                    Sec_Context : in out Security.Contexts.Security_Context;
                    Email       : in String);

   --  Simulate a user login on the request.  Upon successful login, a session that is
   --  authentified is associated with the request object.
   procedure Login (Email   : in String;
                    Request : in out ASF.Requests.Mockup.Request);

   --  Setup the context and security context to simulate an anonymous user.
   procedure Anonymous (Context     : in out AWA.Services.Contexts.Service_Context'Class;
                        Sec_Context : in out Security.Contexts.Security_Context);

   --  Simulate the recovery password process for the given user.
   procedure Recover_Password (Email : in String);

   overriding
   procedure Finalize (Principal : in out Test_User);

   --  Cleanup and release the Principal that have been allocated from the Login session
   --  but not released because the Logout is not called from the unit test.
   procedure Tear_Down;

end AWA.Tests.Helpers.Users;

Declare the Recover_Password procedure

Declare the Recover_Password procedure


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

with Ada.Task_Attributes;
with ADO.Databases;

package body AWA.Services.Contexts is

   use type ADO.Databases.Connection_Status;
   use type AWA.Users.Principals.Principal_Access;

   package Task_Context is new Ada.Task_Attributes
     (Service_Context_Access, null);

   --  ------------------------------
   --  Get the application associated with the current service operation.
   --  ------------------------------
   function Get_Application (Ctx : in Service_Context)
                             return AWA.Applications.Application_Access is
   begin
      return Ctx.Application;
   end Get_Application;

   --  ------------------------------
   --  Get the current database connection for reading.
   --  ------------------------------
   function Get_Session (Ctx : in Service_Context_Access) return ADO.Sessions.Session is
   begin
      --  If a master database session was created, use it.
      if Ctx.Master.Get_Status = ADO.Databases.OPEN then
         return ADO.Sessions.Session (Ctx.Master);

      elsif Ctx.Slave.Get_Status /= ADO.Databases.OPEN then
         Ctx.Slave  := Ctx.Application.Get_Session;
      end if;
      return Ctx.Slave;
   end Get_Session;

   --  ------------------------------
   --  Get the current database connection for reading and writing.
   --  ------------------------------
   function Get_Master_Session (Ctx : in Service_Context_Access)
                                return ADO.Sessions.Master_Session is
   begin
      if Ctx.Master.Get_Status /= ADO.Databases.OPEN then
         Ctx.Master := Ctx.Application.Get_Master_Session;
      end if;
      return Ctx.Master;
   end Get_Master_Session;

   --  ------------------------------
   --  Get the current user invoking the service operation.
   --  Returns a null user if there is none.
   --  ------------------------------
   function Get_User (Ctx : in Service_Context) return AWA.Users.Models.User_Ref is
   begin
      if Ctx.Principal = null then
         return AWA.Users.Models.Null_User;
      else
         return Ctx.Principal.Get_User;
      end if;
   end Get_User;

   --  ------------------------------
   --  Get the current user identifier invoking the service operation.
   --  Returns NO_IDENTIFIER if there is none.
   --  ------------------------------
   function Get_User_Identifier (Ctx : in Service_Context) return ADO.Identifier is
   begin
      if Ctx.Principal = null then
         return ADO.NO_IDENTIFIER;
      else
         return Ctx.Principal.Get_User_Identifier;
      end if;
   end Get_User_Identifier;

   --  ------------------------------
   --  Get the current user session from the user invoking the service operation.
   --  Returns a null session if there is none.
   --  ------------------------------
   function Get_User_Session (Ctx : in Service_Context) return AWA.Users.Models.Session_Ref is
   begin
      if Ctx.Principal = null then
         return AWA.Users.Models.Null_Session;
      else
         return Ctx.Principal.Get_Session;
      end if;
   end Get_User_Session;

   --  ------------------------------
   --  Starts a transaction.
   --  ------------------------------
   procedure Start (Ctx : in out Service_Context) is
   begin
      if Ctx.Transaction = 0 and then not Ctx.Active_Transaction then
         Ctx.Master.Begin_Transaction;
         Ctx.Active_Transaction := True;
      end if;
      Ctx.Transaction := Ctx.Transaction + 1;
   end Start;

   --  ------------------------------
   --  Commits the current transaction.  The database transaction is really committed by the
   --  last Commit called.
   --  ------------------------------
   procedure Commit (Ctx : in out Service_Context) is
   begin
      Ctx.Transaction := Ctx.Transaction - 1;
      if Ctx.Transaction = 0 and then Ctx.Active_Transaction then
         Ctx.Master.Commit;
         Ctx.Active_Transaction := False;
      end if;
   end Commit;

   --  ------------------------------
   --  Rollback the current transaction.  The database transaction is rollback at the first
   --  call to Rollback.
   --  ------------------------------
   procedure Rollback (Ctx : in out Service_Context) is
   begin
      null;
   end Rollback;

   --  ------------------------------
   --  Get the attribute registered under the given name in the HTTP session.
   --  ------------------------------
   function Get_Session_Attribute (Ctx  : in Service_Context;
                                   Name : in String) return Util.Beans.Objects.Object is
      pragma Unreferenced (Ctx, Name);
   begin
      return Util.Beans.Objects.Null_Object;
   end Get_Session_Attribute;

   --  ------------------------------
   --  Set the attribute registered under the given name in the HTTP session.
   --  ------------------------------
   procedure Set_Session_Attribute (Ctx   : in out Service_Context;
                                    Name  : in String;
                                    Value : in Util.Beans.Objects.Object) is
   begin
      null;
   end Set_Session_Attribute;

   --  ------------------------------
   --  Set the current application and user context.
   --  ------------------------------
   procedure Set_Context (Ctx         : in out Service_Context;
                          Application : in AWA.Applications.Application_Access;
                          Principal   : in AWA.Users.Principals.Principal_Access) is
   begin
      Ctx.Application := Application;
      Ctx.Principal   := Principal;
   end Set_Context;

   --  ------------------------------
   --  Initializes the service context.
   --  ------------------------------
   overriding
   procedure Initialize (Ctx : in out Service_Context) is
      use type AWA.Applications.Application_Access;
   begin
      Ctx.Previous := Task_Context.Value;
      Task_Context.Set_Value (Ctx'Unchecked_Access);
      if Ctx.Previous /= null and then Ctx.Application = null then
         Ctx.Application := Ctx.Previous.Application;
      end if;
   end Initialize;

   --  ------------------------------
   --  Finalize the service context, rollback non-committed transaction, releases any object.
   --  ------------------------------
   overriding
   procedure Finalize (Ctx : in out Service_Context) is
   begin
      --  When the service context is released, we must not have any active transaction.
      --  This means we are leaving the service in an abnormal way such as when an
      --  exception is raised.  If this is the case, rollback the transaction.
      if Ctx.Active_Transaction then
         Ctx.Master.Rollback;
      end if;
      Task_Context.Set_Value (Ctx.Previous);
   end Finalize;

   --  ------------------------------
   --  Get the current service context.
   --  Returns null if the current thread is not associated with any service context.
   --  ------------------------------
   function Current return Service_Context_Access is
   begin
      return Task_Context.Value;
   end Current;

end AWA.Services.Contexts;

-----------------------------------------------------------------------
--  awa-services -- Services
--  Copyright (C) 2011, 2012, 2013, 2014 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.Task_Attributes;
with ADO.Databases;

package body AWA.Services.Contexts is

   use type ADO.Databases.Connection_Status;
   use type AWA.Users.Principals.Principal_Access;

   package Task_Context is new Ada.Task_Attributes
     (Service_Context_Access, null);

   --  ------------------------------
   --  Get the application associated with the current service operation.
   --  ------------------------------
   function Get_Application (Ctx : in Service_Context)
                             return AWA.Applications.Application_Access is
   begin
      return Ctx.Application;
   end Get_Application;

   --  ------------------------------
   --  Get the current database connection for reading.
   --  ------------------------------
   function Get_Session (Ctx : in Service_Context_Access) return ADO.Sessions.Session is
   begin
      --  If a master database session was created, use it.
      if Ctx.Master.Get_Status = ADO.Databases.OPEN then
         return ADO.Sessions.Session (Ctx.Master);

      elsif Ctx.Slave.Get_Status /= ADO.Databases.OPEN then
         Ctx.Slave  := Ctx.Application.Get_Session;
      end if;
      return Ctx.Slave;
   end Get_Session;

   --  ------------------------------
   --  Get the current database connection for reading and writing.
   --  ------------------------------
   function Get_Master_Session (Ctx : in Service_Context_Access)
                                return ADO.Sessions.Master_Session is
   begin
      if Ctx.Master.Get_Status /= ADO.Databases.OPEN then
         Ctx.Master := Ctx.Application.Get_Master_Session;
      end if;
      return Ctx.Master;
   end Get_Master_Session;

   --  ------------------------------
   --  Get the current user invoking the service operation.
   --  Returns a null user if there is none.
   --  ------------------------------
   function Get_User (Ctx : in Service_Context) return AWA.Users.Models.User_Ref is
   begin
      if Ctx.Principal = null then
         return AWA.Users.Models.Null_User;
      else
         return Ctx.Principal.Get_User;
      end if;
   end Get_User;

   --  ------------------------------
   --  Get the current user identifier invoking the service operation.
   --  Returns NO_IDENTIFIER if there is none.
   --  ------------------------------
   function Get_User_Identifier (Ctx : in Service_Context) return ADO.Identifier is
   begin
      if Ctx.Principal = null then
         return ADO.NO_IDENTIFIER;
      else
         return Ctx.Principal.Get_User_Identifier;
      end if;
   end Get_User_Identifier;

   --  ------------------------------
   --  Get the current user session from the user invoking the service operation.
   --  Returns a null session if there is none.
   --  ------------------------------
   function Get_User_Session (Ctx : in Service_Context) return AWA.Users.Models.Session_Ref is
   begin
      if Ctx.Principal = null then
         return AWA.Users.Models.Null_Session;
      else
         return Ctx.Principal.Get_Session;
      end if;
   end Get_User_Session;

   --  ------------------------------
   --  Starts a transaction.
   --  ------------------------------
   procedure Start (Ctx : in out Service_Context) is
   begin
      if Ctx.Transaction = 0 and then not Ctx.Active_Transaction then
         Ctx.Master.Begin_Transaction;
         Ctx.Active_Transaction := True;
      end if;
      Ctx.Transaction := Ctx.Transaction + 1;
   end Start;

   --  ------------------------------
   --  Commits the current transaction.  The database transaction is really committed by the
   --  last Commit called.
   --  ------------------------------
   procedure Commit (Ctx : in out Service_Context) is
   begin
      Ctx.Transaction := Ctx.Transaction - 1;
      if Ctx.Transaction = 0 and then Ctx.Active_Transaction then
         Ctx.Master.Commit;
         Ctx.Active_Transaction := False;
      end if;
   end Commit;

   --  ------------------------------
   --  Rollback the current transaction.  The database transaction is rollback at the first
   --  call to Rollback.
   --  ------------------------------
   procedure Rollback (Ctx : in out Service_Context) is
   begin
      null;
   end Rollback;

   --  ------------------------------
   --  Get the attribute registered under the given name in the HTTP session.
   --  ------------------------------
   function Get_Session_Attribute (Ctx  : in Service_Context;
                                   Name : in String) return Util.Beans.Objects.Object is
      pragma Unreferenced (Ctx, Name);
   begin
      return Util.Beans.Objects.Null_Object;
   end Get_Session_Attribute;

   --  ------------------------------
   --  Set the attribute registered under the given name in the HTTP session.
   --  ------------------------------
   procedure Set_Session_Attribute (Ctx   : in out Service_Context;
                                    Name  : in String;
                                    Value : in Util.Beans.Objects.Object) is
   begin
      null;
   end Set_Session_Attribute;

   --  ------------------------------
   --  Set the current application and user context.
   --  ------------------------------
   procedure Set_Context (Ctx         : in out Service_Context;
                          Application : in AWA.Applications.Application_Access;
                          Principal   : in AWA.Users.Principals.Principal_Access) is
   begin
      Ctx.Application := Application;
      Ctx.Principal   := Principal;
   end Set_Context;

   --  ------------------------------
   --  Initializes the service context.
   --  ------------------------------
   overriding
   procedure Initialize (Ctx : in out Service_Context) is
      use type AWA.Applications.Application_Access;
   begin
      Ctx.Previous := Task_Context.Value;
      Task_Context.Set_Value (Ctx'Unchecked_Access);
      if Ctx.Previous /= null and then Ctx.Application = null then
         Ctx.Application := Ctx.Previous.Application;
      end if;
   end Initialize;

   --  ------------------------------
   --  Finalize the service context, rollback non-committed transaction, releases any object.
   --  ------------------------------
   overriding
   procedure Finalize (Ctx : in out Service_Context) is
   begin
      --  When the service context is released, we must not have any active transaction.
      --  This means we are leaving the service in an abnormal way such as when an
      --  exception is raised.  If this is the case, rollback the transaction.
      if Ctx.Active_Transaction then
         Ctx.Master.Rollback;
      end if;
      Task_Context.Set_Value (Ctx.Previous);
   end Finalize;

   --  ------------------------------
   --  Get the current service context.
   --  Returns null if the current thread is not associated with any service context.
   --  ------------------------------
   function Current return Service_Context_Access is
   begin
      return Task_Context.Value;
   end Current;

   --  ------------------------------
   --  Run the process procedure on behalf of the specific user and session.
   --  This operation changes temporarily the identity of the current user principal and
   --  executes the <tt>Process</tt> procedure.
   --  ------------------------------
   procedure Run_As (User    : in AWA.Users.Models.User_Ref;
                     Session : in AWA.Users.Models.Session_Ref) is
      Ctx       : Service_Context;
      Principal : aliased AWA.Users.Principals.Principal
        := AWA.Users.Principals.Create (User, Session);
   begin
      Ctx.Principal := Principal'Unchecked_Access;
      Process;
   end Run_As;

end AWA.Services.Contexts;

Implement the Run_As by creating a local service context with a user principal and calling the process procedure. When we return (normal return or from an exception), the previous service context is restored