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

with GNAT.Command_Line;

with Util.Files;
with Util.Streams.Pipes;
with Util.Streams.Buffered;
with Util.Strings.Transforms;

with Wiki.Strings;
with Wiki.Filters.Html;
with Wiki.Filters.TOC;
with Wiki.Streams.Builders;
with Wiki.Streams.Html.Builders;
with Wiki.Render.Html;
with Wiki.Render.Text;
with Wiki.Render.Wiki;
with Wiki.Documents;
with Wiki.Parsers;

procedure Import is

   use GNAT.Command_Line;
   use Ada.Strings.Unbounded;
   use Ada.Strings.UTF_Encoding;

   procedure Usage;
   function Is_Url (Name : in String) return Boolean;
   procedure Parse_Url (Url : in String);
   procedure Parse (Content : in String);
   procedure Print (Item : in Wiki.Strings.WString);

   Html_Filter : aliased Wiki.Filters.Html.Html_Filter_Type;
   TOC         : aliased Wiki.Filters.TOC.TOC_Filter;
   Count       : Natural := 0;
   Html_Mode   : Boolean := True;
   Wiki_Mode   : Boolean := False;
   Syntax      : Wiki.Wiki_Syntax := Wiki.SYNTAX_MARKDOWN;

   procedure Usage is
   begin
      Ada.Text_IO.Put_Line ("Import HTML into a target Wiki format");
      Ada.Text_IO.Put_Line ("Usage: import [-t] [-m] [-M] [-H] [-d] [-c] {URL | file}");
      Ada.Text_IO.Put_Line ("  -t      Convert to text only");
      Ada.Text_IO.Put_Line ("  -m      Convert to Markdown");
      Ada.Text_IO.Put_Line ("  -M      Convert to Mediawiki");
      Ada.Text_IO.Put_Line ("  -H      Convert to HTML");
      Ada.Text_IO.Put_Line ("  -d      Convert to Dotclear");
      Ada.Text_IO.Put_Line ("  -c      Convert to Creole");
   end Usage;

   procedure Print (Item : in Wiki.Strings.WString) is
   begin
      Ada.Wide_Wide_Text_IO.Put (Item);
   end Print;

   procedure Parse (Content : in String) is
      Doc    : Wiki.Documents.Document;
      Engine : Wiki.Parsers.Parser;
   begin
      Engine.Add_Filter (TOC'Unchecked_Access);
      Engine.Add_Filter (Html_Filter'Unchecked_Access);
      if Wiki_Mode then
         declare
            Stream   : aliased Wiki.Streams.Builders.Output_Builder_Stream;
            Renderer : aliased Wiki.Render.Wiki.Wiki_Renderer;
         begin
            Engine.Set_Syntax (Wiki.SYNTAX_HTML);
            Engine.Parse (Wide_Wide_Strings.Decode (Content), Doc);
            Renderer.Set_Output_Stream (Stream'Unchecked_Access, Syntax);
            Renderer.Render (Doc);
            Stream.Iterate (Print'Access);
         end;
      elsif Html_Mode then
         declare
            Stream   : aliased Wiki.Streams.Html.Builders.Html_Output_Stream;
            Renderer : aliased Wiki.Render.Html.Html_Renderer;
         begin
            Engine.Set_Syntax (Syntax);
            Engine.Parse (Wide_Wide_Strings.Decode (Content), Doc);
            Renderer.Set_Output_Stream (Stream'Unchecked_Access);
            Renderer.Render (Doc);
            Stream.Iterate (Print'Access);
         end;
      else
         declare
            Stream   : aliased Wiki.Streams.Builders.Output_Builder_Stream;
            Renderer : aliased Wiki.Render.Text.Text_Renderer;
         begin
            Engine.Set_Syntax (Syntax);
            Engine.Parse (Wide_Wide_Strings.Decode (Content), Doc);
            Renderer.Set_Output_Stream (Stream'Unchecked_Access);
            Renderer.Render (Doc);
            Stream.Iterate (Print'Access);
         end;
      end if;
      Ada.Wide_Wide_Text_IO.New_Line;
   end Parse;

   procedure Parse_Url (Url : in String) is
      Command : constant String := "wget -q -O - " & Url;
      Pipe    : aliased Util.Streams.Pipes.Pipe_Stream;
      Buffer  : Util.Streams.Buffered.Input_Buffer_Stream;
      Content : Ada.Strings.Unbounded.Unbounded_String;
   begin
      Pipe.Open (Command);
      Buffer.Initialize (Pipe'Unchecked_Access, 1024 * 1024);
      Buffer.Read (Content);
      Pipe.Close;
      if Pipe.Get_Exit_Status /= 0 then
         Ada.Text_IO.Put_Line (Command & " exited with status "
                               & Integer'Image (Pipe.Get_Exit_Status));
      else
         Parse (To_String (Content));
      end if;
   end Parse_Url;

   function Is_Url (Name : in String) return Boolean is
   begin
      if Name'Length <= 9 then
         return False;
      else
         return Name (Name'First .. Name'First + 6) = "http://"
           or Name (Name'First .. Name'First + 7) = "https://";
      end if;
   end Is_Url;

begin
   loop
      case Getopt ("m M H d c t f:") is
         when 'm' =>
            Syntax := Wiki.SYNTAX_MARKDOWN;
            Wiki_Mode := True;

         when 'M' =>
            Syntax := Wiki.SYNTAX_MEDIA_WIKI;
            Wiki_Mode := True;

         when 'H' =>
            Syntax := Wiki.SYNTAX_HTML;

         when 'c' =>
            Syntax := Wiki.SYNTAX_CREOLE;
            Wiki_Mode := True;

         when 'd' =>
            Syntax := Wiki.SYNTAX_DOTCLEAR;
            Wiki_Mode := True;

         when 't' =>
            Html_Mode := False;

         when 'f' =>
            declare
               Value : constant String := Util.Strings.Transforms.To_Upper_Case (Parameter);
            begin
               Html_Filter.Hide (Wiki.Html_Tag'Value (Value & "_TAG"));
            exception
               when Constraint_Error =>
                  Ada.Text_IO.Put_Line ("Invalid tag " & Value);
            end;

         when others =>
            exit;
      end case;
   end loop;

   loop
      declare
         Name : constant String := GNAT.Command_Line.Get_Argument;
         Data : Unbounded_String;
      begin
         if Name = "" then
            if Count = 0 then
               Usage;
            end if;
            return;
         end if;
         Count := Count + 1;
         if Is_Url (Name) then
            Parse_Url (Name);
         else
            Util.Files.Read_File (Name, Data);
            Parse (To_String (Data));
         end if;

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Ada.Text_IO.Put_Line ("Cannot read file '" & Name & "'");

      end;
   end loop;

exception
   when Invalid_Switch =>
      Ada.Text_IO.Put_Line ("Invalid option.");
      Usage;

end Import;

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

with GNAT.Command_Line;

with Util.Files;
with Util.Streams.Pipes;
with Util.Streams.Buffered;
with Util.Strings.Transforms;

with Wiki.Strings;
with Wiki.Filters.Html;
with Wiki.Filters.TOC;
with Wiki.Streams.Builders;
with Wiki.Streams.Html.Builders;
with Wiki.Render.Html;
with Wiki.Render.Text;
with Wiki.Render.Wiki;
with Wiki.Documents;
with Wiki.Parsers;

procedure Import is

   use GNAT.Command_Line;
   use Ada.Strings.Unbounded;
   use Ada.Strings.UTF_Encoding;

   procedure Usage;
   function Is_Url (Name : in String) return Boolean;
   procedure Parse_Url (Url : in String);
   procedure Parse (Content : in String);
   procedure Print (Item : in Wiki.Strings.WString);

   Html_Filter : aliased Wiki.Filters.Html.Html_Filter_Type;
   TOC         : aliased Wiki.Filters.TOC.TOC_Filter;
   Count       : Natural := 0;
   Html_Mode   : Boolean := True;
   Wiki_Mode   : Boolean := False;
   Syntax      : Wiki.Wiki_Syntax := Wiki.SYNTAX_MARKDOWN;

   procedure Usage is
   begin
      Ada.Text_IO.Put_Line ("Import HTML into a target Wiki format");
      Ada.Text_IO.Put_Line ("Usage: import [-t] [-m] [-M] [-H] [-d] [-c] {URL | file}");
      Ada.Text_IO.Put_Line ("  -t      Convert to text only");
      Ada.Text_IO.Put_Line ("  -m      Convert to Markdown");
      Ada.Text_IO.Put_Line ("  -M      Convert to Mediawiki");
      Ada.Text_IO.Put_Line ("  -H      Convert to HTML");
      Ada.Text_IO.Put_Line ("  -d      Convert to Dotclear");
      Ada.Text_IO.Put_Line ("  -c      Convert to Creole");
   end Usage;

   procedure Print (Item : in Wiki.Strings.WString) is
   begin
      Ada.Wide_Wide_Text_IO.Put (Item);
   end Print;

   procedure Parse (Content : in String) is
      Doc    : Wiki.Documents.Document;
      Engine : Wiki.Parsers.Parser;
   begin
      Engine.Add_Filter (TOC'Unchecked_Access);
      Engine.Add_Filter (Html_Filter'Unchecked_Access);
      if Wiki_Mode then
         declare
            Stream   : aliased Wiki.Streams.Builders.Output_Builder_Stream;
            Renderer : aliased Wiki.Render.Wiki.Wiki_Renderer;
         begin
            Engine.Set_Syntax (Wiki.SYNTAX_HTML);
            Engine.Parse (Wide_Wide_Strings.Decode (Content), Doc);
            Renderer.Set_Output_Stream (Stream'Unchecked_Access, Syntax);
            Renderer.Render (Doc);
            Stream.Iterate (Print'Access);
         end;
      elsif Html_Mode then
         declare
            Stream   : aliased Wiki.Streams.Html.Builders.Html_Output_Stream;
            Renderer : aliased Wiki.Render.Html.Html_Renderer;
         begin
            Engine.Set_Syntax (Syntax);
            Engine.Parse (Wide_Wide_Strings.Decode (Content), Doc);
            Renderer.Set_Output_Stream (Stream'Unchecked_Access);
            Renderer.Render (Doc);
            Stream.Iterate (Print'Access);
         end;
      else
         declare
            Stream   : aliased Wiki.Streams.Builders.Output_Builder_Stream;
            Renderer : aliased Wiki.Render.Text.Text_Renderer;
         begin
            Engine.Set_Syntax (Syntax);
            Engine.Parse (Wide_Wide_Strings.Decode (Content), Doc);
            Renderer.Set_Output_Stream (Stream'Unchecked_Access);
            Renderer.Render (Doc);
            Stream.Iterate (Print'Access);
         end;
      end if;
      Ada.Wide_Wide_Text_IO.New_Line;
   end Parse;

   procedure Parse_Url (Url : in String) is
      Command : constant String := "wget -q -O - " & Url;
      Pipe    : aliased Util.Streams.Pipes.Pipe_Stream;
      Buffer  : Util.Streams.Buffered.Input_Buffer_Stream;
      Content : Ada.Strings.Unbounded.Unbounded_String;
   begin
      Pipe.Open (Command);
      Buffer.Initialize (Pipe'Unchecked_Access, 1024 * 1024);
      Buffer.Read (Content);
      Pipe.Close;
      if Pipe.Get_Exit_Status /= 0 then
         Ada.Text_IO.Put_Line (Command & " exited with status "
                               & Integer'Image (Pipe.Get_Exit_Status));
      else
         Parse (To_String (Content));
      end if;
   end Parse_Url;

   function Is_Url (Name : in String) return Boolean is
   begin
      if Name'Length <= 9 then
         return False;
      else
         return Name (Name'First .. Name'First + 6) = "http://"
           or else Name (Name'First .. Name'First + 7) = "https://";
      end if;
   end Is_Url;

begin
   loop
      case Getopt ("m M H d c t f:") is
         when 'm' =>
            Syntax := Wiki.SYNTAX_MARKDOWN;
            Wiki_Mode := True;

         when 'M' =>
            Syntax := Wiki.SYNTAX_MEDIA_WIKI;
            Wiki_Mode := True;

         when 'H' =>
            Syntax := Wiki.SYNTAX_HTML;

         when 'c' =>
            Syntax := Wiki.SYNTAX_CREOLE;
            Wiki_Mode := True;

         when 'd' =>
            Syntax := Wiki.SYNTAX_DOTCLEAR;
            Wiki_Mode := True;

         when 't' =>
            Html_Mode := False;

         when 'f' =>
            declare
               Value : constant String := Util.Strings.Transforms.To_Upper_Case (Parameter);
            begin
               Html_Filter.Hide (Wiki.Html_Tag'Value (Value & "_TAG"));
            exception
               when Constraint_Error =>
                  Ada.Text_IO.Put_Line ("Invalid tag " & Value);
            end;

         when others =>
            exit;
      end case;
   end loop;

   loop
      declare
         Name : constant String := GNAT.Command_Line.Get_Argument;
         Data : Unbounded_String;
      begin
         if Name = "" then
            if Count = 0 then
               Usage;
            end if;
            return;
         end if;
         Count := Count + 1;
         if Is_Url (Name) then
            Parse_Url (Name);
         else
            Util.Files.Read_File (Name, Data);
            Parse (To_String (Data));
         end if;

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Ada.Text_IO.Put_Line ("Cannot read file '" & Name & "'");

      end;
   end loop;

exception
   when Invalid_Switch =>
      Ada.Text_IO.Put_Line ("Invalid option.");
      Usage;

end Import;

Fix style warnings: add missing overriding and update and then/or else conditions


--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2017 onox <denkpadje@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 Orka.Transforms.SIMD_Vectors;

generic
   with package Vectors is new Orka.Transforms.SIMD_Vectors (<>);
package Orka.Transforms.SIMD_Quaternions is
   pragma Pure;

   type Quaternion is new Vectors.Vector_Type;

   subtype Vector4 is Vectors.Vector_Type;

   type Axis_Angle is record
      Axis  : Vectors.Direction;
      Angle : Vectors.Element_Type;
   end record;

   Zero_Rotation : constant Quaternion := (0.0, 0.0, 0.0, 1.0);

   function "+" (Left, Right : Quaternion) return Quaternion;

   function "*" (Left, Right : Quaternion) return Quaternion;

   function "*" (Left : Vectors.Element_Type; Right : Quaternion) return Quaternion;

   function "*" (Left : Quaternion; Right : Vectors.Element_Type) return Quaternion;

   function Conjugate (Elements : Quaternion) return Quaternion;

   function Inverse (Elements : Quaternion) return Quaternion;

   function Norm (Elements : Quaternion) return Vectors.Element_Type;

   function Normalize (Elements : Quaternion) return Quaternion;

   function Normalized (Elements : Quaternion) return Boolean;

   function To_Axis_Angle (Elements : Quaternion) return Axis_Angle;

   function From_Axis_Angle (Value : Axis_Angle) return Quaternion;

   function R
     (Axis  : Vector4;
      Angle : Vectors.Element_Type) return Quaternion
   with Pre  => Vectors.Normalized (Axis),
        Post => Normalized (R'Result);
   --  Return a quaternion that will cause a rotation of Angle radians
   --  about the given Axis

   function R (Left, Right : Vector4) return Quaternion
     with Post => Normalized (R'Result);
   --  Return the rotation from direction Left to Right

   function Difference (Left, Right : Quaternion) return Quaternion
     with Post => Normalized (Difference'Result);
   --  Return a quaternion describing the rotation from quaternion Left
   --  to Right (Right is a composite rotation of Left and the result)

   procedure Rotate_At_Origin
     (Vector   : in out Vector4;
      Elements : Quaternion)
   with Pre => Normalized (Elements);

   function Lerp
     (Left, Right : Quaternion;
      Time        : Vectors.Element_Type) return Quaternion
   with Pre  => Time in 0.0 .. 1.0,
        Post => Normalized (Lerp'Result);
   --  Return the interpolated normalized quaternion on the chord
   --  between the Left and Right quaternions.

   function Slerp
     (Left, Right : Quaternion;
      Time        : Vectors.Element_Type) return Quaternion
   with Pre  => Time in 0.0 .. 1.0,
        Post => Normalized (Slerp'Result);
   --  Return the interpolated unit quaternion on the shortest arc
   --  between the Left and Right quaternions.

end Orka.Transforms.SIMD_Quaternions;

--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2017 onox <denkpadje@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 Orka.Transforms.SIMD_Vectors;

generic
   with package Vectors is new Orka.Transforms.SIMD_Vectors (<>);
package Orka.Transforms.SIMD_Quaternions is
   pragma Pure;

   type Quaternion is new Vectors.Vector_Type;

   subtype Vector4 is Vectors.Vector_Type;

   type Axis_Angle is record
      Axis  : Vectors.Direction;
      Angle : Vectors.Element_Type;
   end record;

   Identity : constant Quaternion := (0.0, 0.0, 0.0, 1.0);

   function "+" (Left, Right : Quaternion) return Quaternion;

   function "*" (Left, Right : Quaternion) return Quaternion;

   function "*" (Left : Vectors.Element_Type; Right : Quaternion) return Quaternion;

   function "*" (Left : Quaternion; Right : Vectors.Element_Type) return Quaternion;

   function Conjugate (Elements : Quaternion) return Quaternion;

   function Inverse (Elements : Quaternion) return Quaternion;

   function Norm (Elements : Quaternion) return Vectors.Element_Type;

   function Normalize (Elements : Quaternion) return Quaternion;

   function Normalized (Elements : Quaternion) return Boolean;

   function To_Axis_Angle (Elements : Quaternion) return Axis_Angle;

   function From_Axis_Angle (Value : Axis_Angle) return Quaternion;

   function R
     (Axis  : Vector4;
      Angle : Vectors.Element_Type) return Quaternion
   with Pre  => Vectors.Normalized (Axis),
        Post => Normalized (R'Result);
   --  Return a quaternion that will cause a rotation of Angle radians
   --  about the given Axis

   function R (Left, Right : Vector4) return Quaternion
     with Post => Normalized (R'Result);
   --  Return the rotation from direction Left to Right

   function Difference (Left, Right : Quaternion) return Quaternion
     with Post => Normalized (Difference'Result);
   --  Return a quaternion describing the rotation from quaternion Left
   --  to Right (Right is a composite rotation of Left and the result)

   procedure Rotate_At_Origin
     (Vector   : in out Vector4;
      Elements : Quaternion)
   with Pre => Normalized (Elements);

   function Lerp
     (Left, Right : Quaternion;
      Time        : Vectors.Element_Type) return Quaternion
   with Pre  => Time in 0.0 .. 1.0,
        Post => Normalized (Lerp'Result);
   --  Return the interpolated normalized quaternion on the chord
   --  between the Left and Right quaternions.

   function Slerp
     (Left, Right : Quaternion;
      Time        : Vectors.Element_Type) return Quaternion
   with Pre  => Time in 0.0 .. 1.0,
        Post => Normalized (Slerp'Result);
   --  Return the interpolated unit quaternion on the shortest arc
   --  between the Left and Right quaternions.

end Orka.Transforms.SIMD_Quaternions;

transforms: Rename constant Zero_Rotation to Identity

Signed-off-by: onox <34c1d3d2d1347bea60a26f46574de21a7a79b6d5@gmail.com>


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

with Ada.Unchecked_Deallocation;

with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.Mappers;
with Util.Serialize.Mappers.Record_Mapper;

with Security.Controllers.URLs;

package body Security.Policies.URLs is

   --  ------------------------------
   --  Get the policy name.
   --  ------------------------------
   overriding
   function Get_Name (From : in URL_Policy) return String is
      pragma Unreferenced (From);
   begin
      return NAME;
   end Get_Name;

   --  ------------------------------
   --  Returns True if the user has the permission to access the given URI permission.
   --  ------------------------------
   function Has_Permission (Manager    : in URL_Policy;
                            Context    : in Contexts.Security_Context'Class;
                            Permission : in URL_Permission'Class) return Boolean is
      Name  : constant String_Ref := To_String_Ref (Permission.URL);
      Ref   : constant Rules_Ref.Ref := Manager.Cache.Get;
      Rules : constant Rules_Access := Ref.Value;
      Pos   : constant Rules_Maps.Cursor := Rules.Map.Find (Name);
      Rule  : Access_Rule_Ref;
   begin
      --  If the rule is not in the cache, search for the access rule that
      --  matches our URI.  Update the cache.  This cache update is thread-safe
      --  as the cache map is never modified: a new cache map is installed.
      if not Rules_Maps.Has_Element (Pos) then
         declare
            New_Ref : constant Rules_Ref.Ref := Rules_Ref.Create;
         begin
            Rule := Manager.Find_Access_Rule (Permission.URL);
            New_Ref.Value.all.Map := Rules.Map;
            New_Ref.Value.all.Map.Insert (Name, Rule);
            Manager.Cache.Set (New_Ref);
         end;
      else
         Rule := Rules_Maps.Element (Pos);
      end if;

      --  Check if the user has one of the required permission.
      declare
         P       : constant Access_Rule_Access := Rule.Value;
      begin
         if P /= null then
            for I in P.Permissions'Range loop
               if Context.Has_Permission (P.Permissions (I)) then
                  return True;
               end if;
            end loop;
         end if;
      end;
      return False;
   end Has_Permission;

   --  Grant the permission to access to the given URI to users having the To
   --  permissions.
   procedure Grant_URI_Permission (Manager : in out URL_Policy;
                                   URI     : in String;
                                   To      : in String) is
   begin
      null;
   end Grant_URI_Permission;

   --  ------------------------------
   --  Policy Configuration
   --  ------------------------------

   --  ------------------------------
   --  Find the access rule of the policy that matches the given URI.
   --  Returns the No_Rule value (disable access) if no rule is found.
   --  ------------------------------
   function Find_Access_Rule (Manager : in URL_Policy;
                              URI     : in String) return Access_Rule_Ref is

      Matched : Boolean := False;
      Result  : Access_Rule_Ref;

      procedure Match (P : in Policy);

      procedure Match (P : in Policy) is
      begin
         if GNAT.Regexp.Match (URI, P.Pattern) then
            Matched := True;
            Result  := P.Rule;
         end if;
      end Match;

      Last : constant Natural := Manager.Policies.Last_Index;
   begin
      for I in 1 .. Last loop
         Manager.Policies.Query_Element (I, Match'Access);
         if Matched then
            return Result;
         end if;
      end loop;
      return Result;
   end Find_Access_Rule;

   --  ------------------------------
   --  Initialize the permission manager.
   --  ------------------------------
   overriding
   procedure Initialize (Manager : in out URL_Policy) is
   begin
      Manager.Cache := new Rules_Ref.Atomic_Ref;
      Manager.Cache.Set (Rules_Ref.Create);
   end Initialize;

   --  ------------------------------
   --  Finalize the permission manager.
   --  ------------------------------
   overriding
   procedure Finalize (Manager : in out URL_Policy) is

      procedure Free is
        new Ada.Unchecked_Deallocation (Rules_Ref.Atomic_Ref,
                                        Rules_Ref_Access);
   begin
      Free (Manager.Cache);
--        for I in Manager.Names'Range loop
--           exit when Manager.Names (I) = null;
--           Ada.Strings.Unbounded.Free (Manager.Names (I));
--        end loop;

   end Finalize;

   type Policy_Fields is (FIELD_ID, FIELD_PERMISSION, FIELD_URL_PATTERN, FIELD_POLICY);

   procedure Set_Member (P     : in out URL_Policy'Class;
                         Field : in Policy_Fields;
                         Value : in Util.Beans.Objects.Object);

   procedure Process (Policy : in out URL_Policy'Class);

   procedure Set_Member (P     : in out URL_Policy'Class;
                         Field : in Policy_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_ID =>
            P.Id := Util.Beans.Objects.To_Integer (Value);

         when FIELD_PERMISSION =>
            P.Permissions.Append (Value);

         when FIELD_URL_PATTERN =>
            P.Patterns.Append (Value);

         when FIELD_POLICY =>
            Process (P);
            P.Id := 0;
            P.Permissions.Clear;
            P.Patterns.Clear;

      end case;
   end Set_Member;

   procedure Process (Policy : in out URL_Policy'Class) is
      Pol    : Security.Policies.URLs.Policy;
      Count  : constant Natural := Natural (Policy.Permissions.Length);
      Rule   : constant Access_Rule_Ref := Access_Rule_Refs.Create (new Access_Rule (Count));
      Iter   : Util.Beans.Objects.Vectors.Cursor := Policy.Permissions.First;
      Pos    : Positive := 1;
   begin
      Pol.Rule := Rule;

      --  Step 1: Initialize the list of permission index in Access_Rule from the permission names.
      while Util.Beans.Objects.Vectors.Has_Element (Iter) loop
         declare
            Perm : constant Util.Beans.Objects.Object := Util.Beans.Objects.Vectors.Element (Iter);
            Name : constant String := Util.Beans.Objects.To_String (Perm);
         begin
            Rule.Value.all.Permissions (Pos) := Permissions.Get_Permission_Index (Name);
            Pos := Pos + 1;

         exception
            when Invalid_Name =>
               raise Util.Serialize.Mappers.Field_Error with "Invalid permission: " & Name;
         end;
         Util.Beans.Objects.Vectors.Next (Iter);
      end loop;

      --  Step 2: Create one policy for each URL pattern
      Iter := Policy.Patterns.First;
      while Util.Beans.Objects.Vectors.Has_Element (Iter) loop
         declare
            Pattern : constant Util.Beans.Objects.Object
              := Util.Beans.Objects.Vectors.Element (Iter);
         begin
            Pol.Id   := Policy.Id;
            Pol.Pattern := GNAT.Regexp.Compile (Util.Beans.Objects.To_String (Pattern));
            Policy.Policies.Append (Pol);
         end;
         Util.Beans.Objects.Vectors.Next (Iter);
      end loop;
   end Process;

   package Policy_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => URL_Policy'Class,
                                               Element_Type_Access => URL_Policy_Access,
                                               Fields              => Policy_Fields,
                                               Set_Member          => Set_Member);

   Policy_Mapping        : aliased Policy_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the policy description.
   --  ------------------------------
   overriding
   procedure Prepare_Config (Policy : in out URL_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser) is
      Perm : constant Security.Controllers.URLs.URL_Controller_Access
        := new Security.Controllers.URLs.URL_Controller;
   begin
      Perm.Manager := Policy'Unchecked_Access;
      Reader.Add_Mapping ("policy-rules", Policy_Mapping'Access);
      Reader.Add_Mapping ("module", Policy_Mapping'Access);
      Policy_Mapper.Set_Context (Reader, Perm.Manager);
      Policy.Manager.Add_Permission (Name       => "url",
                                     Permission => Perm.all'Access);
   end Prepare_Config;

   --  ------------------------------
   --  Get the URL policy associated with the given policy manager.
   --  Returns the URL policy instance or null if it was not registered in the policy manager.
   --  ------------------------------
   function Get_URL_Policy (Manager : in Security.Policies.Policy_Manager'Class)
                            return URL_Policy_Access is
      Policy : constant Security.Policies.Policy_Access := Manager.Get_Policy (NAME);
   begin
      if Policy = null or else not (Policy.all in URL_Policy'Class) then
         return null;
      else
         return URL_Policy'Class (Policy.all)'Access;
      end if;
   end Get_URL_Policy;

begin
   Policy_Mapping.Add_Mapping ("url-policy", FIELD_POLICY);
   Policy_Mapping.Add_Mapping ("url-policy/@id", FIELD_ID);
   Policy_Mapping.Add_Mapping ("url-policy/permission", FIELD_PERMISSION);
   Policy_Mapping.Add_Mapping ("url-policy/url-pattern", FIELD_URL_PATTERN);
end Security.Policies.URLs;

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

with Ada.Unchecked_Deallocation;

with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.Mappers;
with Util.Serialize.Mappers.Record_Mapper;

with Security.Controllers.URLs;

package body Security.Policies.URLs is

   --  ------------------------------
   --  Get the policy name.
   --  ------------------------------
   overriding
   function Get_Name (From : in URL_Policy) return String is
      pragma Unreferenced (From);
   begin
      return NAME;
   end Get_Name;

   --  ------------------------------
   --  Returns True if the user has the permission to access the given URI permission.
   --  ------------------------------
   function Has_Permission (Manager    : in URL_Policy;
                            Context    : in Contexts.Security_Context'Class;
                            Permission : in URL_Permission'Class) return Boolean is
      Name  : constant String_Ref := To_String_Ref (Permission.URL);
      Ref   : constant Rules_Ref.Ref := Manager.Cache.Get;
      Rules : constant Rules_Access := Ref.Value;
      Pos   : constant Rules_Maps.Cursor := Rules.Map.Find (Name);
      Rule  : Access_Rule_Ref;
   begin
      --  If the rule is not in the cache, search for the access rule that
      --  matches our URI.  Update the cache.  This cache update is thread-safe
      --  as the cache map is never modified: a new cache map is installed.
      if not Rules_Maps.Has_Element (Pos) then
         declare
            New_Ref : constant Rules_Ref.Ref := Rules_Ref.Create;
         begin
            Rule := Manager.Find_Access_Rule (Permission.URL);
            New_Ref.Value.all.Map := Rules.Map;
            New_Ref.Value.all.Map.Insert (Name, Rule);
            Manager.Cache.Set (New_Ref);
         end;
      else
         Rule := Rules_Maps.Element (Pos);
      end if;

      --  Check if the user has one of the required permission.
      declare
         P       : constant Access_Rule_Access := Rule.Value;
      begin
         if P /= null then
            for I in P.Permissions'Range loop
               if Context.Has_Permission (P.Permissions (I)) then
                  return True;
               end if;
            end loop;
         end if;
      end;
      return False;
   end Has_Permission;

   --  Grant the permission to access to the given URI to users having the To
   --  permissions.
   procedure Grant_URI_Permission (Manager : in out URL_Policy;
                                   URI     : in String;
                                   To      : in String) is
   begin
      null;
   end Grant_URI_Permission;

   --  ------------------------------
   --  Policy Configuration
   --  ------------------------------

   --  ------------------------------
   --  Find the access rule of the policy that matches the given URI.
   --  Returns the No_Rule value (disable access) if no rule is found.
   --  ------------------------------
   function Find_Access_Rule (Manager : in URL_Policy;
                              URI     : in String) return Access_Rule_Ref is

      Matched : Boolean := False;
      Result  : Access_Rule_Ref;

      procedure Match (P : in Policy);

      procedure Match (P : in Policy) is
      begin
         if GNAT.Regexp.Match (URI, P.Pattern) then
            Matched := True;
            Result  := P.Rule;
         end if;
      end Match;

      Last : constant Natural := Manager.Policies.Last_Index;
   begin
      for I in 1 .. Last loop
         Manager.Policies.Query_Element (I, Match'Access);
         if Matched then
            return Result;
         end if;
      end loop;
      return Result;
   end Find_Access_Rule;

   --  ------------------------------
   --  Initialize the permission manager.
   --  ------------------------------
   overriding
   procedure Initialize (Manager : in out URL_Policy) is
   begin
      Manager.Cache := new Rules_Ref.Atomic_Ref;
      Manager.Cache.Set (Rules_Ref.Create);
   end Initialize;

   --  ------------------------------
   --  Finalize the permission manager.
   --  ------------------------------
   overriding
   procedure Finalize (Manager : in out URL_Policy) is

      procedure Free is
        new Ada.Unchecked_Deallocation (Rules_Ref.Atomic_Ref,
                                        Rules_Ref_Access);
   begin
      Free (Manager.Cache);
--        for I in Manager.Names'Range loop
--           exit when Manager.Names (I) = null;
--           Ada.Strings.Unbounded.Free (Manager.Names (I));
--        end loop;

   end Finalize;

   type Policy_Fields is (FIELD_ID, FIELD_PERMISSION, FIELD_URL_PATTERN, FIELD_POLICY);

   procedure Set_Member (P     : in out URL_Policy'Class;
                         Field : in Policy_Fields;
                         Value : in Util.Beans.Objects.Object);

   procedure Process (Policy : in out URL_Policy'Class);

   procedure Set_Member (P     : in out URL_Policy'Class;
                         Field : in Policy_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_ID =>
            P.Id := Util.Beans.Objects.To_Integer (Value);

         when FIELD_PERMISSION =>
            P.Permissions.Append (Value);

         when FIELD_URL_PATTERN =>
            P.Patterns.Append (Value);

         when FIELD_POLICY =>
            Process (P);
            P.Id := 0;
            P.Permissions.Clear;
            P.Patterns.Clear;

      end case;
   end Set_Member;

   procedure Process (Policy : in out URL_Policy'Class) is
      Pol    : Security.Policies.URLs.Policy;
      Count  : constant Natural := Natural (Policy.Permissions.Length);
      Rule   : constant Access_Rule_Ref := Access_Rule_Refs.Create (new Access_Rule (Count));
      Iter   : Util.Beans.Objects.Vectors.Cursor := Policy.Permissions.First;
      Pos    : Positive := 1;
   begin
      Pol.Rule := Rule;

      --  Step 1: Initialize the list of permission index in Access_Rule from the permission names.
      while Util.Beans.Objects.Vectors.Has_Element (Iter) loop
         declare
            Perm : constant Util.Beans.Objects.Object := Util.Beans.Objects.Vectors.Element (Iter);
            Name : constant String := Util.Beans.Objects.To_String (Perm);
         begin
            Rule.Value.all.Permissions (Pos) := Permissions.Get_Permission_Index (Name);
            Pos := Pos + 1;

         exception
            when Invalid_Name =>
               raise Util.Serialize.Mappers.Field_Error with "Invalid permission: " & Name;
         end;
         Util.Beans.Objects.Vectors.Next (Iter);
      end loop;

      --  Step 2: Create one policy for each URL pattern
      Iter := Policy.Patterns.First;
      while Util.Beans.Objects.Vectors.Has_Element (Iter) loop
         declare
            Pattern : constant Util.Beans.Objects.Object
              := Util.Beans.Objects.Vectors.Element (Iter);
         begin
            Pol.Id   := Policy.Id;
            Pol.Pattern := GNAT.Regexp.Compile (Util.Beans.Objects.To_String (Pattern));
            Policy.Policies.Append (Pol);
         end;
         Util.Beans.Objects.Vectors.Next (Iter);
      end loop;
   end Process;

   package Policy_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => URL_Policy'Class,
                                               Element_Type_Access => URL_Policy_Access,
                                               Fields              => Policy_Fields,
                                               Set_Member          => Set_Member);

   Policy_Mapping        : aliased Policy_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the policy description.
   --  ------------------------------
   overriding
   procedure Prepare_Config (Policy : in out URL_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser) is
      Perm : constant Security.Controllers.URLs.URL_Controller_Access
        := new Security.Controllers.URLs.URL_Controller;
   begin
      Perm.Manager := Policy'Unchecked_Access;
      Reader.Add_Mapping ("policy-rules", Policy_Mapping'Access);
      Reader.Add_Mapping ("module", Policy_Mapping'Access);
      Policy_Mapper.Set_Context (Reader, Perm.Manager);
      if not Policy.Manager.Has_Controller (P_URL.Permission) then
         Policy.Manager.Add_Permission (Name       => "url",
                                        Permission => Perm.all'Access);
      end if;
   end Prepare_Config;

   --  ------------------------------
   --  Get the URL policy associated with the given policy manager.
   --  Returns the URL policy instance or null if it was not registered in the policy manager.
   --  ------------------------------
   function Get_URL_Policy (Manager : in Security.Policies.Policy_Manager'Class)
                            return URL_Policy_Access is
      Policy : constant Security.Policies.Policy_Access := Manager.Get_Policy (NAME);
   begin
      if Policy = null or else not (Policy.all in URL_Policy'Class) then
         return null;
      else
         return URL_Policy'Class (Policy.all)'Access;
      end if;
   end Get_URL_Policy;

begin
   Policy_Mapping.Add_Mapping ("url-policy", FIELD_POLICY);
   Policy_Mapping.Add_Mapping ("url-policy/@id", FIELD_ID);
   Policy_Mapping.Add_Mapping ("url-policy/permission", FIELD_PERMISSION);
   Policy_Mapping.Add_Mapping ("url-policy/url-pattern", FIELD_URL_PATTERN);
end Security.Policies.URLs;

Check that the policy manager has a URL permission controller


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

with Ada.Directories;
with Ada.IO_Exceptions;
with Ada.Text_IO;
with Ada.Calendar;

with Ahven.Listeners.Basic;
with Ahven.XML_Runner;
with Ahven.Text_Runner;
with Ahven.AStrings;

with Util.Tests;
with Util.Strings;
package body Util.XUnit is

   function Image (Time : in Duration) return String;
   procedure Report_XML_Summary (Path    : in String;
                                 Result  : in Ahven.Results.Result_Collection;
                                 Time    : in Duration);

   --  ------------------------------
   --  Build a message from a string (Adaptation for AUnit API).
   --  ------------------------------
   function Format (S : in String) return Message_String is
   begin
      return S;
   end Format;

   --  ------------------------------
   --  Build a message with the source and line number.
   --  ------------------------------
   function Build_Message (Message   : in String;
                           Source    : in String;
                           Line      : in Natural) return String is
      L : constant String := Natural'Image (Line);
   begin
      return Source & ":" & L (2 .. L'Last) & ": " & Message;
   end Build_Message;

   procedure Run_Test_Case (T : in out Ahven.Framework.Test_Case'Class);

   procedure Run_Test_Case (T : in out Ahven.Framework.Test_Case'Class) is
   begin
      Test_Case'Class (T).Run_Test;
   end Run_Test_Case;

   overriding
   procedure Initialize (T : in out Test_Case) is
   begin
      Ahven.Framework.Add_Test_Routine (T, Run_Test_Case'Access, "Test case");
   end Initialize;

   --  ------------------------------
   --  Return the name of the test case.
   --  ------------------------------
   overriding
   function Get_Name (T : Test_Case) return String is
   begin
      return Test_Case'Class (T).Name;
   end Get_Name;

   --  maybe_overriding
   procedure Assert (T         : in Test_Case;
                     Condition : in Boolean;
                     Message   : in String := "Test failed";
                     Source    : in String := GNAT.Source_Info.File;
                     Line      : in Natural := GNAT.Source_Info.Line) is
      pragma Unreferenced (T);
   begin
      Ahven.Assert (Condition => Condition,
                    Message   => Build_Message (Message => Message,
                                                Source  => Source,
                                                Line    => Line));
   end Assert;

   --  ------------------------------
   --  Check that the value matches what we expect.
   --  ------------------------------
   procedure Assert (T         : in Test;
                     Condition : in Boolean;
                     Message   : in String := "Test failed";
                     Source    : String := GNAT.Source_Info.File;
                     Line      : Natural := GNAT.Source_Info.Line) is
      pragma Unreferenced (T);
   begin
      Ahven.Assert (Condition => Condition,
                    Message   => Build_Message (Message => Message,
                                                Source  => Source,
                                                Line    => Line));
   end Assert;

   First_Test : Test_Object_Access := null;

   --  ------------------------------
   --  Register a test object in the test suite.
   --  ------------------------------
   procedure Register (T : in Test_Object_Access) is
   begin
      T.Next := First_Test;
      First_Test := T;
   end Register;

   --  ------------------------------
   --  Report passes, skips, failures, and errors from the result collection.
   --  ------------------------------
   procedure Report_Results (Result  : in Ahven.Results.Result_Collection;
                             Time    : in Duration) is
      T_Count : constant Integer := Ahven.Results.Test_Count (Result);
      F_Count : constant Integer := Ahven.Results.Failure_Count (Result);
      S_Count : constant Integer := Ahven.Results.Skipped_Count (Result);
      E_Count : constant Integer := Ahven.Results.Error_Count (Result);
   begin
      if F_Count > 0 then
         Ahven.Text_Runner.Print_Failures (Result, 0);
      end if;
      if E_Count > 0 then
         Ahven.Text_Runner.Print_Errors (Result, 0);
      end if;
      Ada.Text_IO.Put_Line ("Tests run:" & Integer'Image (T_Count - S_Count)
                            & ", Failures:" & Integer'Image (F_Count)
                            & ", Errors:" & Integer'Image (E_Count)
                            & ", Skipped:" & Integer'Image (S_Count)
                            & ", Time elapsed:" & Duration'Image (Time));

   end Report_Results;

   function Image (Time : in Duration) return String is
      Result : constant String := Duration'Image (Time);
   begin
      if Result (Result'First) = ' ' then
         return Result (Result'First + 1 .. Result'Last);
      else
         return Result;
      end if;
   end Image;

   --  ------------------------------
   --  Write a XML summary report in the JUnit format so that the result file
   --  can be used by Jenkins performance plugin.
   --  ------------------------------
   procedure Report_XML_Summary (Path    : in String;
                                 Result  : in Ahven.Results.Result_Collection;
                                 Time    : in Duration) is
      use Ahven.Results;
      File : Ada.Text_IO.File_Type;
      Group : Result_Collection_Cursor;
      Iter : Result_Collection_Cursor;
      Test : Result_Collection_Access;
   begin
      Ada.Text_IO.Create (File => File,
                          Mode => Ada.Text_IO.Out_File,
                          Name => Path);
      Ada.Text_IO.Put_Line (File, "<?xml version='1.0'?>");
      Ada.Text_IO.Put (File, "<testsuite ");
      Ada.Text_IO.Put (File, "errors='"
                       & Util.Strings.Image (Error_Count (Result)) & "' ");
      Ada.Text_IO.Put (File, "failures='"
                       & Util.Strings.Image (Failure_Count (Result)) & "' ");
      Ada.Text_IO.Put (File, "tests='"
                       & Util.Strings.Image (Test_Count (Result)) & "' ");
      Ada.Text_IO.Put (File, "time='" & Image (Time) & "' ");
      Ada.Text_IO.Put (File, "name='");
      Ada.Text_IO.Put (File, Ahven.AStrings.To_String (Get_Test_Name (Result)));
      Ada.Text_IO.Put_Line (File, "'>");
      Group := First_Child (Result);
      while Is_Valid (Group) loop
         Iter := First_Child (Data (Group).all);
         while Is_Valid (Iter) loop
            Test := Data (Iter);
            Ada.Text_IO.Put (File, "<testcase name='");
            Ada.Text_IO.Put (File, Ahven.AStrings.To_String (Get_Test_Name (Test.all)));
            Ada.Text_IO.Put (File, "' errors='");
            Ada.Text_IO.Put (File, Util.Strings.Image (Error_Count (Test.all)));
            Ada.Text_IO.Put (File, "' failures='");
            Ada.Text_IO.Put (File, Util.Strings.Image (Failure_Count (Test.all)));
            Ada.Text_IO.Put (File, "' tests='");
            Ada.Text_IO.Put (File, Util.Strings.Image (Test_Count (Test.all)));
            Ada.Text_IO.Put (File, "' time='");
            Ada.Text_IO.Put (File, Image (Get_Execution_Time (Test.all)));
            Ada.Text_IO.Put_Line (File, "'/>");
            Iter := Next (Iter);
         end loop;
         Group := Next (Group);
      end loop;
      Ada.Text_IO.Put_Line (File, "</testsuite>");
      Ada.Text_IO.Close (File);
   end Report_XML_Summary;

   --  ------------------------------
   --  The main testsuite program.  This launches the tests, collects the
   --  results, create performance logs and set the program exit status
   --  according to the testsuite execution status.
   --  ------------------------------
   procedure Harness (Output : in Ada.Strings.Unbounded.Unbounded_String;
                      XML    : in Boolean;
                      Result : out Status) is

      use Ahven.Listeners.Basic;
      use Ahven.Framework;
      use Ahven.Results;
      use type Ada.Calendar.Time;

      Tests    : constant Access_Test_Suite := Suite;
      T        : Test_Object_Access := First_Test;
      Listener : Ahven.Listeners.Basic.Basic_Listener;
      Timeout  : constant Test_Duration := Test_Duration (Util.Tests.Get_Test_Timeout ("all"));
      Out_Dir  : constant String := Util.Tests.Get_Test_Path ("regtests/result");
      Start    : Ada.Calendar.Time;
      Dt       : Duration;
   begin
      while T /= null loop
         Ahven.Framework.Add_Static_Test (Tests.all, T.Test.all);
         T := T.Next;
      end loop;
      Set_Output_Capture (Listener, True);
      if not Ada.Directories.Exists (Out_Dir) then
         Ada.Directories.Create_Path (Out_Dir);
      end if;

      Ahven.Framework.Set_Logging (Util.Tests.Verbose);
      Start := Ada.Calendar.Clock;
      Ahven.Framework.Execute (Tests.all, Listener, Timeout);
      Dt := Ada.Calendar.Clock - Start;
      Report_Results (Listener.Main_Result, Dt);

      Ahven.XML_Runner.Report_Results (Listener.Main_Result, Out_Dir);

      if (Error_Count (Listener.Main_Result) > 0) or
        (Failure_Count (Listener.Main_Result) > 0)
      then
         Result := Failure;
      else
         Result := Success;
      end if;

      if XML then
         Report_XML_Summary (Ada.Strings.Unbounded.To_String (Output),
                             Listener.Main_Result, Dt);
      end if;

   exception
      when Ada.IO_Exceptions.Name_Error =>
         Ada.Text_IO.Put_Line ("Cannot create file");
         Result := Failure;

   end Harness;

end Util.XUnit;

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

with Ada.Directories;
with Ada.IO_Exceptions;
with Ada.Text_IO;
with Ada.Calendar;

with Ahven.Listeners.Basic;
with Ahven.XML_Runner;
with Ahven.Text_Runner;
with Ahven.AStrings;

with Util.Tests;
with Util.Strings;
package body Util.XUnit is

   function Image (Time : in Duration) return String;
   procedure Report_XML_Summary (Path    : in String;
                                 Result  : in Ahven.Results.Result_Collection;
                                 Time    : in Duration);

   --  ------------------------------
   --  Build a message from a string (Adaptation for AUnit API).
   --  ------------------------------
   function Format (S : in String) return Message_String is
   begin
      return S;
   end Format;

   --  ------------------------------
   --  Build a message with the source and line number.
   --  ------------------------------
   function Build_Message (Message   : in String;
                           Source    : in String;
                           Line      : in Natural) return String is
      L : constant String := Natural'Image (Line);
   begin
      return Source & ":" & L (2 .. L'Last) & ": " & Message;
   end Build_Message;

   procedure Run_Test_Case (T : in out Ahven.Framework.Test_Case'Class);

   procedure Run_Test_Case (T : in out Ahven.Framework.Test_Case'Class) is
   begin
      Test_Case'Class (T).Run_Test;
   end Run_Test_Case;

   overriding
   procedure Initialize (T : in out Test_Case) is
   begin
      Ahven.Framework.Add_Test_Routine (T, Run_Test_Case'Access, "Test case");
   end Initialize;

   --  ------------------------------
   --  Return the name of the test case.
   --  ------------------------------
   overriding
   function Get_Name (T : Test_Case) return String is
   begin
      return Test_Case'Class (T).Name;
   end Get_Name;

   --  maybe_overriding
   procedure Assert (T         : in Test_Case;
                     Condition : in Boolean;
                     Message   : in String := "Test failed";
                     Source    : in String := GNAT.Source_Info.File;
                     Line      : in Natural := GNAT.Source_Info.Line) is
      pragma Unreferenced (T);
   begin
      Ahven.Assert (Condition => Condition,
                    Message   => Build_Message (Message => Message,
                                                Source  => Source,
                                                Line    => Line));
   end Assert;

   --  ------------------------------
   --  Check that the value matches what we expect.
   --  ------------------------------
   procedure Assert (T         : in Test;
                     Condition : in Boolean;
                     Message   : in String := "Test failed";
                     Source    : String := GNAT.Source_Info.File;
                     Line      : Natural := GNAT.Source_Info.Line) is
      pragma Unreferenced (T);
   begin
      Ahven.Assert (Condition => Condition,
                    Message   => Build_Message (Message => Message,
                                                Source  => Source,
                                                Line    => Line));
   end Assert;

   First_Test : Test_Object_Access := null;

   --  ------------------------------
   --  Register a test object in the test suite.
   --  ------------------------------
   procedure Register (T : in Test_Object_Access) is
   begin
      T.Next := First_Test;
      First_Test := T;
   end Register;

   --  ------------------------------
   --  Report passes, skips, failures, and errors from the result collection.
   --  ------------------------------
   procedure Report_Results (Result  : in Ahven.Results.Result_Collection;
                             Label   : in String;
                             Time    : in Duration) is
      T_Count : constant Integer := Ahven.Results.Test_Count (Result);
      F_Count : constant Integer := Ahven.Results.Failure_Count (Result);
      S_Count : constant Integer := Ahven.Results.Skipped_Count (Result);
      E_Count : constant Integer := Ahven.Results.Error_Count (Result);
   begin
      if F_Count > 0 then
         Ahven.Text_Runner.Print_Failures (Result, 0);
      end if;
      if E_Count > 0 then
         Ahven.Text_Runner.Print_Errors (Result, 0);
      end if;
      Ada.Text_IO.Put_Line (Label
                            & "Tests run:" & Integer'Image (T_Count - S_Count)
                            & ", Failures:" & Integer'Image (F_Count)
                            & ", Errors:" & Integer'Image (E_Count)
                            & ", Skipped:" & Integer'Image (S_Count)
                            & ", Time elapsed:" & Duration'Image (Time));

   end Report_Results;

   function Image (Time : in Duration) return String is
      Result : constant String := Duration'Image (Time);
   begin
      if Result (Result'First) = ' ' then
         return Result (Result'First + 1 .. Result'Last);
      else
         return Result;
      end if;
   end Image;

   --  ------------------------------
   --  Write a XML summary report in the JUnit format so that the result file
   --  can be used by Jenkins performance plugin.
   --  ------------------------------
   procedure Report_XML_Summary (Path    : in String;
                                 Result  : in Ahven.Results.Result_Collection;
                                 Time    : in Duration) is
      use Ahven.Results;
      File : Ada.Text_IO.File_Type;
      Group : Result_Collection_Cursor;
      Iter : Result_Collection_Cursor;
      Test : Result_Collection_Access;
   begin
      Ada.Text_IO.Create (File => File,
                          Mode => Ada.Text_IO.Out_File,
                          Name => Path);
      Ada.Text_IO.Put_Line (File, "<?xml version='1.0'?>");
      Ada.Text_IO.Put (File, "<testsuite ");
      Ada.Text_IO.Put (File, "errors='"
                       & Util.Strings.Image (Error_Count (Result)) & "' ");
      Ada.Text_IO.Put (File, "failures='"
                       & Util.Strings.Image (Failure_Count (Result)) & "' ");
      Ada.Text_IO.Put (File, "tests='"
                       & Util.Strings.Image (Test_Count (Result)) & "' ");
      Ada.Text_IO.Put (File, "time='" & Image (Time) & "' ");
      Ada.Text_IO.Put (File, "name='");
      Ada.Text_IO.Put (File, Ahven.AStrings.To_String (Get_Test_Name (Result)));
      Ada.Text_IO.Put_Line (File, "'>");
      Group := First_Child (Result);
      while Is_Valid (Group) loop
         Iter := First_Child (Data (Group).all);
         while Is_Valid (Iter) loop
            Test := Data (Iter);
            Ada.Text_IO.Put (File, "<testcase name='");
            Ada.Text_IO.Put (File, Ahven.AStrings.To_String (Get_Test_Name (Test.all)));
            Ada.Text_IO.Put (File, "' errors='");
            Ada.Text_IO.Put (File, Util.Strings.Image (Error_Count (Test.all)));
            Ada.Text_IO.Put (File, "' failures='");
            Ada.Text_IO.Put (File, Util.Strings.Image (Failure_Count (Test.all)));
            Ada.Text_IO.Put (File, "' tests='");
            Ada.Text_IO.Put (File, Util.Strings.Image (Test_Count (Test.all)));
            Ada.Text_IO.Put (File, "' time='");
            Ada.Text_IO.Put (File, Image (Get_Execution_Time (Test.all)));
            Ada.Text_IO.Put_Line (File, "'/>");
            Iter := Next (Iter);
         end loop;
         Group := Next (Group);
      end loop;
      Ada.Text_IO.Put_Line (File, "</testsuite>");
      Ada.Text_IO.Close (File);
   end Report_XML_Summary;

   --  ------------------------------
   --  The main testsuite program.  This launches the tests, collects the
   --  results, create performance logs and set the program exit status
   --  according to the testsuite execution status.
   --  ------------------------------
   procedure Harness (Output : in String;
                      XML    : in Boolean;
                      Label  : in String;
                      Result : out Status) is

      use Ahven.Listeners.Basic;
      use Ahven.Framework;
      use Ahven.Results;
      use type Ada.Calendar.Time;

      Tests    : constant Access_Test_Suite := Suite;
      T        : Test_Object_Access := First_Test;
      Listener : Ahven.Listeners.Basic.Basic_Listener;
      Timeout  : constant Test_Duration := Test_Duration (Util.Tests.Get_Test_Timeout ("all"));
      Out_Dir  : constant String := Util.Tests.Get_Test_Path ("regtests/result");
      Start    : Ada.Calendar.Time;
      Dt       : Duration;
   begin
      while T /= null loop
         Ahven.Framework.Add_Static_Test (Tests.all, T.Test.all);
         T := T.Next;
      end loop;
      Set_Output_Capture (Listener, True);
      if not Ada.Directories.Exists (Out_Dir) then
         Ada.Directories.Create_Path (Out_Dir);
      end if;

      Ahven.Framework.Set_Logging (Util.Tests.Verbose);
      Start := Ada.Calendar.Clock;
      Ahven.Framework.Execute (Tests.all, Listener, Timeout);
      Dt := Ada.Calendar.Clock - Start;
      Report_Results (Listener.Main_Result, Label, Dt);

      Ahven.XML_Runner.Report_Results (Listener.Main_Result, Out_Dir);

      if (Error_Count (Listener.Main_Result) > 0) or
        (Failure_Count (Listener.Main_Result) > 0)
      then
         Result := Failure;
      else
         Result := Success;
      end if;

      if XML then
         Report_XML_Summary (Output, Listener.Main_Result, Dt);
      end if;

   exception
      when Ada.IO_Exceptions.Name_Error =>
         Ada.Text_IO.Put_Line ("Cannot create file");
         Result := Failure;

   end Harness;

end Util.XUnit;

Add Label parameter to Harness procedure and print the Label before the test summary report


-----------------------------------------------------------------------
--  util-dates-tests - Test for dates
--  Copyright (C) 2018, 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 Util.Tests;
package Util.Dates.Tests is

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

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

   --  Test converting a date in ISO8601.
   procedure Test_ISO8601_Image (T : in out Test);

   --  Test converting a string in ISO8601 into a date.
   procedure Test_ISO8601_Value (T : in out Test);

   --  Test value convertion errors.
   procedure Test_ISO8601_Error (T : in out Test);

      --  Test Is_Same_Day operation.
   procedure Test_Is_Same_Day (T : in out Test);

end Util.Dates.Tests;

-----------------------------------------------------------------------
--  util-dates-tests - Test for dates
--  Copyright (C) 2018, 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 Util.Tests;
package Util.Dates.Tests is

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

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

   --  Test converting a date in ISO8601.
   procedure Test_ISO8601_Image (T : in out Test);

   --  Test converting a string in ISO8601 into a date.
   procedure Test_ISO8601_Value (T : in out Test);

   --  Test value convertion errors.
   procedure Test_ISO8601_Error (T : in out Test);

   --  Test Is_Same_Day operation.
   procedure Test_Is_Same_Day (T : in out Test);

   --  Test Get_Day_Count operation.
   procedure Test_Get_Day_Count (T : in out Test);

end Util.Dates.Tests;

Declare Test_Get_Day_Count

Declare Test_Get_Day_Count


-----------------------------------------------------------------------
--  mat-targets-probes - Definition and Analysis of process start events
--  Copyright (C) 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 MAT.Events;
with MAT.Events.Targets;
with MAT.Events.Probes;
package MAT.Targets.Probes is

   type Process_Probe_Type is new MAT.Events.Probes.Probe_Type with record
      Target  : Target_Type_Access;
      Manager : MAT.Events.Probes.Probe_Manager_Type_Access;
      Process : Target_Process_Type_Access;
      Events  : MAT.Events.Targets.Target_Events_Access;
   end record;
   type Process_Probe_Type_Access is access all Process_Probe_Type'Class;

   --  Create a new process after the begin event is received from the event stream.
   procedure Create_Process (Probe : in out Process_Probe_Type;
                             Pid   : in MAT.Types.Target_Process_Ref;
                             Path  : in Ada.Strings.Unbounded.Unbounded_String);

   --  Extract the probe information from the message.
   overriding
   procedure Extract (Probe  : in Process_Probe_Type;
                      Params : in MAT.Events.Const_Attribute_Table_Access;
                      Msg    : in out MAT.Readers.Message_Type;
                      Event  : in out MAT.Events.Targets.Probe_Event_Type);

   procedure Execute (Probe : in Process_Probe_Type;
                      Event : in MAT.Events.Targets.Probe_Event_Type);

   --  Register the reader to extract and analyze process events.
   procedure Register (Into  : in out MAT.Events.Probes.Probe_Manager_Type'Class;
                       Probe : in Process_Probe_Type_Access);

   --  Initialize the target object to prepare for reading process events.
   procedure Initialize (Target  : in out Target_Type;
                         Manager : in out MAT.Events.Probes.Probe_Manager_Type'Class);

private

   procedure Probe_Begin (Probe : in out Process_Probe_Type;
                          Id          : in MAT.Events.Internal_Reference;
                          Defs        : in MAT.Events.Attribute_Table;
                          Frame       : in MAT.Events.Frame_Info;
                          Msg         : in out MAT.Readers.Message);

end MAT.Targets.Probes;

-----------------------------------------------------------------------
--  mat-targets-probes - Definition and Analysis of process start events
--  Copyright (C) 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 MAT.Events;
with MAT.Events.Targets;
with MAT.Events.Probes;
package MAT.Targets.Probes is

   type Process_Probe_Type is new MAT.Events.Probes.Probe_Type with record
      Target  : Target_Type_Access;
      Manager : MAT.Events.Probes.Probe_Manager_Type_Access;
      Events  : MAT.Events.Targets.Target_Events_Access;
   end record;
   type Process_Probe_Type_Access is access all Process_Probe_Type'Class;

   --  Create a new process after the begin event is received from the event stream.
   procedure Create_Process (Probe : in Process_Probe_Type;
                             Pid   : in MAT.Types.Target_Process_Ref;
                             Path  : in Ada.Strings.Unbounded.Unbounded_String);

   --  Extract the probe information from the message.
   overriding
   procedure Extract (Probe  : in Process_Probe_Type;
                      Params : in MAT.Events.Const_Attribute_Table_Access;
                      Msg    : in out MAT.Readers.Message_Type;
                      Event  : in out MAT.Events.Targets.Probe_Event_Type);

   procedure Execute (Probe : in Process_Probe_Type;
                      Event : in MAT.Events.Targets.Probe_Event_Type);

   --  Register the reader to extract and analyze process events.
   procedure Register (Into  : in out MAT.Events.Probes.Probe_Manager_Type'Class;
                       Probe : in Process_Probe_Type_Access);

   --  Initialize the target object to prepare for reading process events.
   procedure Initialize (Target  : in out Target_Type;
                         Manager : in out MAT.Events.Probes.Probe_Manager_Type'Class);

private

   procedure Probe_Begin (Probe : in Process_Probe_Type;
                          Id          : in MAT.Events.Targets.Probe_Index_Type;
                          Defs        : in MAT.Events.Attribute_Table;
                          Msg         : in out MAT.Readers.Message);

end MAT.Targets.Probes;

Fix Create_Process and Probe_Begin for the new MAT.Events.Probes implementation


-----------------------------------------------------------------------
--  awa-workspaces-beans -- Beans for module workspaces
--  Copyright (C) 2011, 2012, 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 ASF.Events.Faces.Actions;

with ADO.Utils;
with ADO.Sessions.Entities;
with ADO.Sessions;
with ADO.Queries;
with ADO.Datasets;

with AWA.Services.Contexts;
with AWA.Workspaces.Models;
with AWA.Events.Action_Method;
with AWA.Services.Contexts;
package body AWA.Workspaces.Beans is

   package ASC renames AWA.Services.Contexts;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Member_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      return AWA.Workspaces.Models.Member_Bean (From).Get_Value (Name);
   end Get_Value;

   overriding
   procedure Load (Bean : in out Member_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      null;
   end Load;

   overriding
   procedure Delete (Bean : in out Member_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Bean.Module.Delete_Member (Bean.Get_Id);
   end Delete;

   --  ------------------------------
   --  Create the Member_Bean bean instance.
   --  ------------------------------
   function Create_Member_Bean (Module : in AWA.Workspaces.Modules.Workspace_Module_Access)
                                return Util.Beans.Basic.Readonly_Bean_Access is
      Object  : constant Member_Bean_Access := new Member_Bean;
   begin
      Object.Module := Module;
      return Object.all'Access;
   end Create_Member_Bean;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Invitation_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "inviter" then
         return From.Inviter.Get_Value ("name");
      else
         return AWA.Workspaces.Models.Invitation_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   overriding
   procedure Load (Bean : in out Invitation_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Bean.Module.Load_Invitation (Key        => Ada.Strings.Unbounded.To_String (Bean.Key),
                                   Invitation => Bean,
                                   Inviter    => Bean.Inviter);

   exception
      when others =>
         Outcome := Ada.Strings.Unbounded.To_Unbounded_String ("not-found");
   end Load;

   overriding
   procedure Accept_Invitation (Bean    : in out Invitation_Bean;
                                Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Bean.Module.Accept_Invitation (Key => Ada.Strings.Unbounded.To_String (Bean.Key));
   end Accept_Invitation;

   overriding
   procedure Send (Bean    : in out Invitation_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Bean.Module.Send_Invitation (Bean);
   end Send;

   --  ------------------------------
   --  Create the Invitation_Bean bean instance.
   --  ------------------------------
   function Create_Invitation_Bean (Module : in AWA.Workspaces.Modules.Workspace_Module_Access)
                                    return Util.Beans.Basic.Readonly_Bean_Access is
      Object  : constant Invitation_Bean_Access := new Invitation_Bean;
   begin
      Object.Module := Module;
      return Object.all'Access;
   end Create_Invitation_Bean;

   --  ------------------------------
   --  Example of action method.
   --  ------------------------------
   procedure Action (Bean    : in out Workspaces_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      null;
   end Action;

   --  ------------------------------
   --  Event action called to create the workspace when the given event is posted.
   --  ------------------------------
   procedure Create (Bean  : in out Workspaces_Bean;
                     Event : in AWA.Events.Module_Event'Class) is
      pragma Unreferenced (Bean, Event);

      WS  : AWA.Workspaces.Models.Workspace_Ref;
      Ctx : constant AWA.Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      DB  : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
   begin
      Ctx.Start;
      AWA.Workspaces.Modules.Get_Workspace (Session   => DB,
                                            Context   => Ctx,
                                            Workspace => WS);
      Ctx.Commit;
   end Create;

   package Action_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => Workspaces_Bean,
                                                      Method => Action,
                                                      Name   => "action");

   package Create_Binding is
      new AWA.Events.Action_Method.Bind (Name   => "create",
                                         Bean   => Workspaces_Bean,
                                         Method => Create);

   Workspaces_Bean_Binding : aliased constant Util.Beans.Methods.Method_Binding_Array
     := (Action_Binding.Proxy'Access, Create_Binding.Proxy'Access);

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Workspaces_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "count" then
         return Util.Beans.Objects.To_Object (From.Count);
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

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

   --  ------------------------------
   --  This bean provides some methods that can be used in a Method_Expression
   --  ------------------------------
   overriding
   function Get_Method_Bindings (From : in Workspaces_Bean)
                                 return Util.Beans.Methods.Method_Binding_Array_Access is
      pragma Unreferenced (From);
   begin
      return Workspaces_Bean_Binding'Access;
   end Get_Method_Bindings;

   --  ------------------------------
   --  Create the Workspaces_Bean bean instance.
   --  ------------------------------
   function Create_Workspaces_Bean (Module : in AWA.Workspaces.Modules.Workspace_Module_Access)
      return Util.Beans.Basic.Readonly_Bean_Access is
      Object : constant Workspaces_Bean_Access := new Workspaces_Bean;
   begin
      Object.Module := Module;
      return Object.all'Access;
   end Create_Workspaces_Bean;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Member_List_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "members" then
         return Util.Beans.Objects.To_Object (Value   => From.Members_Bean,
                                              Storage => Util.Beans.Objects.STATIC);
      else
         return AWA.Workspaces.Models.Member_List_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Load the list of members.
   --  ------------------------------
   overriding
   procedure Load (Into    : in out Member_List_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      Ctx         : constant ASC.Service_Context_Access := ASC.Current;
      User        : constant ADO.Identifier := Ctx.Get_User_Identifier;
      Session     : ADO.Sessions.Session := Into.Module.Get_Session;
      Query       : ADO.Queries.Context;
      Count_Query : ADO.Queries.Context;
      First       : constant Natural  := (Into.Page - 1) * Into.Page_Size;
   begin
      Query.Set_Query (AWA.Workspaces.Models.Query_Workspace_Member_List);
      Count_Query.Set_Count_Query (AWA.Workspaces.Models.Query_Workspace_Member_List);
--        ADO.Sessions.Entities.Bind_Param (Params  => Query,
--                                          Name    => "page_table",
--                                          Table   => AWA.Wikis.Models.WIKI_PAGE_TABLE,
--                                          Session => Session);
      Query.Bind_Param (Name => "user_id", Value => User);
      Count_Query.Bind_Param (Name => "user_id", Value => User);
      AWA.Workspaces.Models.List (Into.Members, Session, Query);
      Into.Count := ADO.Datasets.Get_Count (Session, Count_Query);
   end Load;

   --  ------------------------------
   --  Create the Member_List_Bean bean instance.
   --  ------------------------------
   function Create_Member_List_Bean (Module : in AWA.Workspaces.Modules.Workspace_Module_Access)
                                     return Util.Beans.Basic.Readonly_Bean_Access is
      Object  : constant Member_List_Bean_Access := new Member_List_Bean;
   begin
      Object.Module     := Module;
      Object.Members_Bean := Object.Members'Access;
      Object.Page_Size  := 20;
      Object.Page       := 1;
      Object.Count      := 0;
      return Object.all'Access;
   end Create_Member_List_Bean;

end AWA.Workspaces.Beans;

-----------------------------------------------------------------------
--  awa-workspaces-beans -- Beans for module workspaces
--  Copyright (C) 2011, 2012, 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 ASF.Events.Faces.Actions;

with ADO.Utils;
with ADO.Sessions.Entities;
with ADO.Sessions;
with ADO.Queries;
with ADO.Datasets;

with AWA.Services.Contexts;
with AWA.Workspaces.Models;
with AWA.Events.Action_Method;
with AWA.Services.Contexts;
package body AWA.Workspaces.Beans is

   package ASC renames AWA.Services.Contexts;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Member_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      return AWA.Workspaces.Models.Member_Bean (From).Get_Value (Name);
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name
   --  ------------------------------
   overriding
   procedure Set_Value (Item  : in out Member_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         Item.Set_Id (ADO.Utils.To_Identifier (Value));
      else
         AWA.Workspaces.Models.Member_Bean (Item).Set_Value (Name, Value);
      end if;
   end Set_Value;

   overriding
   procedure Load (Bean : in out Member_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      null;
   end Load;

   overriding
   procedure Delete (Bean : in out Member_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Bean.Module.Delete_Member (Bean.Get_Id);
   end Delete;

   --  ------------------------------
   --  Create the Member_Bean bean instance.
   --  ------------------------------
   function Create_Member_Bean (Module : in AWA.Workspaces.Modules.Workspace_Module_Access)
                                return Util.Beans.Basic.Readonly_Bean_Access is
      Object  : constant Member_Bean_Access := new Member_Bean;
   begin
      Object.Module := Module;
      return Object.all'Access;
   end Create_Member_Bean;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Invitation_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "inviter" then
         return From.Inviter.Get_Value ("name");
      else
         return AWA.Workspaces.Models.Invitation_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   overriding
   procedure Load (Bean : in out Invitation_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Bean.Module.Load_Invitation (Key        => Ada.Strings.Unbounded.To_String (Bean.Key),
                                   Invitation => Bean,
                                   Inviter    => Bean.Inviter);

   exception
      when others =>
         Outcome := Ada.Strings.Unbounded.To_Unbounded_String ("not-found");
   end Load;

   overriding
   procedure Accept_Invitation (Bean    : in out Invitation_Bean;
                                Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Bean.Module.Accept_Invitation (Key => Ada.Strings.Unbounded.To_String (Bean.Key));
   end Accept_Invitation;

   overriding
   procedure Send (Bean    : in out Invitation_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Bean.Module.Send_Invitation (Bean);
   end Send;

   --  ------------------------------
   --  Create the Invitation_Bean bean instance.
   --  ------------------------------
   function Create_Invitation_Bean (Module : in AWA.Workspaces.Modules.Workspace_Module_Access)
                                    return Util.Beans.Basic.Readonly_Bean_Access is
      Object  : constant Invitation_Bean_Access := new Invitation_Bean;
   begin
      Object.Module := Module;
      return Object.all'Access;
   end Create_Invitation_Bean;

   --  ------------------------------
   --  Example of action method.
   --  ------------------------------
   procedure Action (Bean    : in out Workspaces_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      null;
   end Action;

   --  ------------------------------
   --  Event action called to create the workspace when the given event is posted.
   --  ------------------------------
   procedure Create (Bean  : in out Workspaces_Bean;
                     Event : in AWA.Events.Module_Event'Class) is
      pragma Unreferenced (Bean, Event);

      WS  : AWA.Workspaces.Models.Workspace_Ref;
      Ctx : constant AWA.Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      DB  : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
   begin
      Ctx.Start;
      AWA.Workspaces.Modules.Get_Workspace (Session   => DB,
                                            Context   => Ctx,
                                            Workspace => WS);
      Ctx.Commit;
   end Create;

   package Action_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => Workspaces_Bean,
                                                      Method => Action,
                                                      Name   => "action");

   package Create_Binding is
      new AWA.Events.Action_Method.Bind (Name   => "create",
                                         Bean   => Workspaces_Bean,
                                         Method => Create);

   Workspaces_Bean_Binding : aliased constant Util.Beans.Methods.Method_Binding_Array
     := (Action_Binding.Proxy'Access, Create_Binding.Proxy'Access);

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Workspaces_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "count" then
         return Util.Beans.Objects.To_Object (From.Count);
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

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

   --  ------------------------------
   --  This bean provides some methods that can be used in a Method_Expression
   --  ------------------------------
   overriding
   function Get_Method_Bindings (From : in Workspaces_Bean)
                                 return Util.Beans.Methods.Method_Binding_Array_Access is
      pragma Unreferenced (From);
   begin
      return Workspaces_Bean_Binding'Access;
   end Get_Method_Bindings;

   --  ------------------------------
   --  Create the Workspaces_Bean bean instance.
   --  ------------------------------
   function Create_Workspaces_Bean (Module : in AWA.Workspaces.Modules.Workspace_Module_Access)
      return Util.Beans.Basic.Readonly_Bean_Access is
      Object : constant Workspaces_Bean_Access := new Workspaces_Bean;
   begin
      Object.Module := Module;
      return Object.all'Access;
   end Create_Workspaces_Bean;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Member_List_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "members" then
         return Util.Beans.Objects.To_Object (Value   => From.Members_Bean,
                                              Storage => Util.Beans.Objects.STATIC);
      else
         return AWA.Workspaces.Models.Member_List_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Load the list of members.
   --  ------------------------------
   overriding
   procedure Load (Into    : in out Member_List_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      Ctx         : constant ASC.Service_Context_Access := ASC.Current;
      User        : constant ADO.Identifier := Ctx.Get_User_Identifier;
      Session     : ADO.Sessions.Session := Into.Module.Get_Session;
      Query       : ADO.Queries.Context;
      Count_Query : ADO.Queries.Context;
      First       : constant Natural  := (Into.Page - 1) * Into.Page_Size;
   begin
      Query.Set_Query (AWA.Workspaces.Models.Query_Workspace_Member_List);
      Count_Query.Set_Count_Query (AWA.Workspaces.Models.Query_Workspace_Member_List);
--        ADO.Sessions.Entities.Bind_Param (Params  => Query,
--                                          Name    => "page_table",
--                                          Table   => AWA.Wikis.Models.WIKI_PAGE_TABLE,
--                                          Session => Session);
      Query.Bind_Param (Name => "user_id", Value => User);
      Count_Query.Bind_Param (Name => "user_id", Value => User);
      AWA.Workspaces.Models.List (Into.Members, Session, Query);
      Into.Count := ADO.Datasets.Get_Count (Session, Count_Query);
   end Load;

   --  ------------------------------
   --  Create the Member_List_Bean bean instance.
   --  ------------------------------
   function Create_Member_List_Bean (Module : in AWA.Workspaces.Modules.Workspace_Module_Access)
                                     return Util.Beans.Basic.Readonly_Bean_Access is
      Object  : constant Member_List_Bean_Access := new Member_List_Bean;
   begin
      Object.Module     := Module;
      Object.Members_Bean := Object.Members'Access;
      Object.Page_Size  := 20;
      Object.Page       := 1;
      Object.Count      := 0;
      return Object.all'Access;
   end Create_Member_List_Bean;

end AWA.Workspaces.Beans;

Implement the Set_Value procedure on the Member_Bean type