-----------------------------------------------------------------------
--  views.nodes.jsf -- JSF Core Tag Library
--  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 ASF.Converters;
with ASF.Validators.Texts;
with ASF.Validators.Numbers;
with ASF.Components.Holders;
with ASF.Components.Core.Views;
package body ASF.Views.Nodes.Jsf is

   use ASF;
   use EL.Objects;

   --  ------------------------------
   --  Converter Tag
   --  ------------------------------

   --  ------------------------------
   --  Create the Converter Tag
   --  ------------------------------
   function Create_Converter_Tag_Node (Name       : Unbounded_String;
                                       Line       : Views.Line_Info;
                                       Parent     : Views.Nodes.Tag_Node_Access;
                                       Attributes : Views.Nodes.Tag_Attribute_Array_Access)
                                       return Views.Nodes.Tag_Node_Access is

      use ASF.Views.Nodes;

      Node : constant Converter_Tag_Node_Access := new Converter_Tag_Node;
      Conv : constant Tag_Attribute_Access := Find_Attribute (Attributes,
                                                              "converterId");
   begin
      Initialize (Node.all'Access, Name, Line, Parent, Attributes);
      if Conv = null then
         Node.Error ("Missing 'converterId' attribute");
      else
         Node.Converter := EL.Objects.To_Object (Conv.Value);
      end if;
      return Node.all'Access;
   end Create_Converter_Tag_Node;

   --  ------------------------------
   --  Build the component tree from the tag node and attach it as
   --  the last child of the given parent.  Calls recursively the
   --  method to create children.  Get the specified converter and
   --  add it to the parent component.  This operation does not create any
   --  new UIComponent.
   --  ------------------------------
   overriding
   procedure Build_Components (Node    : access Converter_Tag_Node;
                               Parent  : in UIComponent_Access;
                               Context : in out Contexts.Facelets.Facelet_Context'Class) is
      use ASF.Components.Holders;
      use type ASF.Converters.Converter_Access;

      Cvt : constant Converters.Converter_Access := Context.Get_Converter (Node.Converter);
   begin
      if not (Parent.all in Value_Holder'Class) then
         Node.Error ("Parent component is not an instance of Value_Holder");
         return;
      end if;

      if Cvt = null then
         Node.Error ("Converter was not found");
         return;
      end if;

      declare
         VH : constant access Value_Holder'Class := Value_Holder'Class (Parent.all)'Access;
      begin
         VH.Set_Converter (Converter => Cvt);
      end;
   end Build_Components;

   --  ------------------------------
   --  Validator Tag
   --  ------------------------------

   --  ------------------------------
   --  Create the Validator Tag
   --  ------------------------------
   function Create_Validator_Tag_Node (Name       : Unbounded_String;
                                       Line       : Views.Line_Info;
                                       Parent     : Views.Nodes.Tag_Node_Access;
                                       Attributes : Views.Nodes.Tag_Attribute_Array_Access)
                                       return Views.Nodes.Tag_Node_Access is

      use ASF.Views.Nodes;

      Node : constant Validator_Tag_Node_Access := new Validator_Tag_Node;
      Vid  : constant Tag_Attribute_Access := Find_Attribute (Attributes,
                                                              "validatorId");
   begin
      Initialize (Node.all'Access, Name, Line, Parent, Attributes);
      if Vid = null then
         Node.Error ("Missing 'validatorId' attribute");
      else
         Node.Validator := EL.Objects.To_Object (Vid.Value);
      end if;
      return Node.all'Access;
   end Create_Validator_Tag_Node;

   --  ------------------------------
   --  Get the specified validator and add it to the parent component.
   --  This operation does not create any new UIComponent.
   --  ------------------------------
   overriding
   procedure Build_Components (Node    : access Validator_Tag_Node;
                               Parent  : in UIComponent_Access;
                               Context : in out Contexts.Facelets.Facelet_Context'Class) is
      use ASF.Components.Holders;
      use type ASF.Validators.Validator_Access;

      V      : Validators.Validator_Access;
      Shared : Boolean;
   begin
      if not (Parent.all in Editable_Value_Holder'Class) then
         Node.Error ("Parent component is not an instance of Editable_Value_Holder");
         return;
      end if;

      Validator_Tag_Node'Class (Node.all).Get_Validator (Context, V, Shared);
      if V = null then
         Node.Error ("Validator was not found");
         return;
      end if;

      declare
         VH : constant access Editable_Value_Holder'Class
           := Editable_Value_Holder'Class (Parent.all)'Access;
      begin
         VH.Add_Validator (Validator => V, Shared => Shared);
      end;
   end Build_Components;

   --  ------------------------------
   --  Get the validator instance that corresponds to the validator tag.
   --  Returns in Validator the instance if it exists and indicate
   --  in Shared whether it must be freed or not when the component is deleted.
   --  ------------------------------
   procedure Get_Validator (Node      : in Validator_Tag_Node;
                            Context   : in out Contexts.Facelets.Facelet_Context'Class;
                            Validator : out Validators.Validator_Access;
                            Shared    : out Boolean) is
   begin
      Validator := Context.Get_Validator (Node.Validator);
      Shared    := True;
   end Get_Validator;

   --  ------------------------------
   --  Range Validator Tag
   --  ------------------------------

   --  Create the Range_Validator Tag
   function Create_Range_Validator_Tag_Node (Name       : Unbounded_String;
                                             Line       : Views.Line_Info;
                                             Parent     : Views.Nodes.Tag_Node_Access;
                                             Attributes : Views.Nodes.Tag_Attribute_Array_Access)
                                             return Views.Nodes.Tag_Node_Access is

      use ASF.Views.Nodes;

      Node : constant Range_Validator_Tag_Node_Access := new Range_Validator_Tag_Node;
   begin
      Initialize (Node.all'Access, Name, Line, Parent, Attributes);
      Node.Minimum := Find_Attribute (Attributes, "minimum");
      Node.Maximum := Find_Attribute (Attributes, "maximum");
      if Node.Minimum = null and Node.Maximum = null then
         Node.Error ("Missing 'minimum' or 'maximum' attribute");
      end if;
      return Node.all'Access;
   end Create_Range_Validator_Tag_Node;

   --  Get the validator instance that corresponds to the range validator.
   --  Returns in Validator the validator instance if it exists and indicate
   --  in Shared whether it must be freed or not when the component is deleted.
   overriding
   procedure Get_Validator (Node      : in Range_Validator_Tag_Node;
                            Context   : in out Contexts.Facelets.Facelet_Context'Class;
                            Validator : out Validators.Validator_Access;
                            Shared    : out Boolean) is
      use type ASF.Validators.Validator_Access;

      Min : Long_Long_Integer := Long_Long_Integer'First;
      Max : Long_Long_Integer := Long_Long_Integer'Last;
   begin
      --  Get the minimum and maximum attributes.
      begin
         if Node.Minimum /= null then
            Min := EL.Objects.To_Long_Long_Integer (Get_Value (Node.Minimum.all, Context));
         end if;
         if Node.Maximum /= null then
            Max := EL.Objects.To_Long_Long_Integer (Get_Value (Node.Maximum.all, Context));
         end if;

      exception
         when Constraint_Error =>
            Node.Error ("Invalid minimum or maximum value");
      end;
      Shared := False;
      if Max < Min then
         Node.Error ("Minimum ({0}) should be less than maximum ({1})",
                     Long_Long_Integer'Image (Min), Long_Long_Integer'Image (Max));
         return;
      end if;

      Validator := Validators.Numbers.Create_Range_Validator (Minimum => Min,
                                                              Maximum => Max);
   end Get_Validator;

   --  ------------------------------
   --  Length Validator Tag
   --  ------------------------------

   --  ------------------------------
   --  Create the Length_Validator Tag.  Verifies that the XML node defines
   --  the minimum or the maximum or both attributes.
   --  ------------------------------
   function Create_Length_Validator_Tag_Node (Name       : Unbounded_String;
                                              Line       : Views.Line_Info;
                                              Parent     : Views.Nodes.Tag_Node_Access;
                                              Attributes : Views.Nodes.Tag_Attribute_Array_Access)
                                              return Views.Nodes.Tag_Node_Access is

      use ASF.Views.Nodes;

      Node : constant Length_Validator_Tag_Node_Access := new Length_Validator_Tag_Node;
   begin
      Initialize (Node.all'Access, Name, Line, Parent, Attributes);
      Node.Minimum := Find_Attribute (Attributes, "minimum");
      Node.Maximum := Find_Attribute (Attributes, "maximum");
      if Node.Minimum = null and Node.Maximum = null then
         Node.Error ("Missing 'minimum' or 'maximum' attribute");
      end if;
      return Node.all'Access;
   end Create_Length_Validator_Tag_Node;

   --  ------------------------------
   --  Get the validator instance that corresponds to the validator tag.
   --  Returns in Validator the instance if it exists and indicate
   --  in Shared whether it must be freed or not when the component is deleted.
   --  ------------------------------
   overriding
   procedure Get_Validator (Node      : in Length_Validator_Tag_Node;
                            Context   : in out Contexts.Facelets.Facelet_Context'Class;
                            Validator : out Validators.Validator_Access;
                            Shared    : out Boolean) is
      use type ASF.Validators.Validator_Access;

      Min : Natural := 0;
      Max : Natural := Natural'Last;
   begin
      --  Get the minimum and maximum attributes.
      begin
         if Node.Minimum /= null then
            Min := Natural (EL.Objects.To_Integer (Get_Value (Node.Minimum.all, Context)));
         end if;
         if Node.Maximum /= null then
            Max := Natural (EL.Objects.To_Integer (Get_Value (Node.Maximum.all, Context)));
         end if;

      exception
         when Constraint_Error =>
            Node.Error ("Invalid minimum or maximum value");
      end;
      Shared := False;
      if Max < Min then
         Node.Error ("Minimum ({0}) should be less than maximum ({1})",
                     Natural'Image (Min), Natural'Image (Max));
         return;
      end if;

      Validator := Validators.Texts.Create_Length_Validator (Minimum => Min,
                                                             Maximum => Max);
   end Get_Validator;

   --  ------------------------------
   --  Attribute Tag
   --  ------------------------------

   --  ------------------------------
   --  Create the Attribute Tag
   --  ------------------------------
   function Create_Attribute_Tag_Node (Name       : Unbounded_String;
                                       Line       : Views.Line_Info;
                                       Parent     : Views.Nodes.Tag_Node_Access;
                                       Attributes : Views.Nodes.Tag_Attribute_Array_Access)
                                       return Views.Nodes.Tag_Node_Access is

      use ASF.Views.Nodes;

      Node : constant Attribute_Tag_Node_Access := new Attribute_Tag_Node;
   begin
      Initialize (Node.all'Access, Name, Line, Parent, Attributes);
      Node.Attr_Name := Find_Attribute (Attributes, "name");
      Node.Value     := Find_Attribute (Attributes, "value");
      if Node.Attr_Name = null then
         Node.Error ("Missing 'name' attribute");
      end if;
      if Node.Value = null then
         Node.Error ("Missing 'value' attribute");
      end if;
      return Node.all'Access;
   end Create_Attribute_Tag_Node;

   --  ------------------------------
   --  Build the component tree from the tag node and attach it as
   --  the last child of the given parent.  Calls recursively the
   --  method to create children.
   --  Adds the attribute to the component node.
   --  This operation does not create any new UIComponent.
   --  ------------------------------
   overriding
   procedure Build_Components (Node    : access Attribute_Tag_Node;
                               Parent  : in UIComponent_Access;
                               Context : in out Contexts.Facelets.Facelet_Context'Class) is
      use EL.Expressions;
   begin
      if Node.Attr_Name /= null and Node.Value /= null then
         declare
            Name  : constant EL.Objects.Object := Get_Value (Node.Attr_Name.all, Context);
         begin
            Node.Attr.Name := EL.Objects.To_Unbounded_String (Name);
            if Node.Value.Binding /= null then
               declare
                  Expr : constant EL.Expressions.Expression
                    := ASF.Views.Nodes.Reduce_Expression (Node.Value.all, Context);
               begin
                  Parent.Set_Attribute (Def => Node.Attr'Access, Value => Expr);
               end;
            else
               Parent.Set_Attribute (Def   => Node.Attr'Access,
                                     Value => Get_Value (Node.Value.all, Context));
            end if;
         end;
      end if;
   end Build_Components;

   --  ------------------------------
   --  Facet Tag
   --  ------------------------------

   --  ------------------------------
   --  Create the Facet Tag
   --  ------------------------------
   function Create_Facet_Tag_Node (Name       : Unbounded_String;
                                   Line       : Views.Line_Info;
                                   Parent     : Views.Nodes.Tag_Node_Access;
                                   Attributes : Views.Nodes.Tag_Attribute_Array_Access)
                                   return Views.Nodes.Tag_Node_Access is
      use ASF.Views.Nodes;

      Node : constant Facet_Tag_Node_Access := new Facet_Tag_Node;
   begin
      Initialize (Node.all'Access, Name, Line, Parent, Attributes);
      Node.Facet_Name := Find_Attribute (Attributes, "name");
      if Node.Facet_Name = null then
         Node.Error ("Missing 'name' attribute");
      end if;
      return Node.all'Access;
   end Create_Facet_Tag_Node;

   --  ------------------------------
   --  Build the component tree from the tag node and attach it as
   --  the facet component of the given parent.  Calls recursively the
   --  method to create children.
   --  ------------------------------
   overriding
   procedure Build_Components (Node    : access Facet_Tag_Node;
                               Parent  : in UIComponent_Access;
                               Context : in out Contexts.Facelets.Facelet_Context'Class) is
   begin
      null;
   end Build_Components;

   --  ------------------------------
   --  Metadata Tag
   --  ------------------------------

   --  ------------------------------
   --  Create the Metadata Tag
   --  ------------------------------
   function Create_Metadata_Tag_Node (Name       : Unbounded_String;
                                      Line       : Views.Line_Info;
                                      Parent     : Views.Nodes.Tag_Node_Access;
                                      Attributes : Views.Nodes.Tag_Attribute_Array_Access)
                                      return Views.Nodes.Tag_Node_Access is
      use ASF.Views.Nodes;

      Node : constant Metadata_Tag_Node_Access := new Metadata_Tag_Node;
   begin
      Initialize (Node.all'Access, Name, Line, Parent, Attributes);
      return Node.all'Access;
   end Create_Metadata_Tag_Node;

   --  ------------------------------
   --  Build the component tree from the tag node and attach it as a metadata information
   --  facet for the UIView parent component.
   --  ------------------------------
   overriding
   procedure Build_Components (Node    : access Metadata_Tag_Node;
                               Parent  : in UIComponent_Access;
                               Context : in out Contexts.Facelets.Facelet_Context'Class) is
      use ASF.Components.Core.Views;
   begin
      if not (Parent.all in UIView'Class) then
         Node.Error ("Parent component of <f:metadata> must be a <f:view>");
         return;
      end if;
      declare
         UI : constant UIViewMetaData_Access := new UIViewMetaData;
      begin
         UIView'Class (Parent.all).Set_Metadata (UI, Node);
         Build_Attributes (UI.all, Node.all, Context);
         UI.Initialize (UI.Get_Context.all);
         Node.Build_Children (UI.all'Access, Context);
      end;
   end Build_Components;

end ASF.Views.Nodes.Jsf;

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

with ASF.Converters;
with ASF.Validators.Texts;
with ASF.Validators.Numbers;
with ASF.Components.Holders;
with ASF.Components.Core.Views;
package body ASF.Views.Nodes.Jsf is

   use ASF;
   use EL.Objects;

   --  ------------------------------
   --  Converter Tag
   --  ------------------------------

   --  ------------------------------
   --  Create the Converter Tag
   --  ------------------------------
   function Create_Converter_Tag_Node (Binding    : in Binding_Access;
                                       Line       : in Views.Line_Info;
                                       Parent     : in Views.Nodes.Tag_Node_Access;
                                       Attributes : in Views.Nodes.Tag_Attribute_Array_Access)
                                       return Views.Nodes.Tag_Node_Access is

      use ASF.Views.Nodes;

      Node : constant Converter_Tag_Node_Access := new Converter_Tag_Node;
      Conv : constant Tag_Attribute_Access := Find_Attribute (Attributes,
                                                              "converterId");
   begin
      Initialize (Node.all'Access, Binding, Line, Parent, Attributes);
      if Conv = null then
         Node.Error ("Missing 'converterId' attribute");
      else
         Node.Converter := EL.Objects.To_Object (Conv.Value);
      end if;
      return Node.all'Access;
   end Create_Converter_Tag_Node;

   --  ------------------------------
   --  Build the component tree from the tag node and attach it as
   --  the last child of the given parent.  Calls recursively the
   --  method to create children.  Get the specified converter and
   --  add it to the parent component.  This operation does not create any
   --  new UIComponent.
   --  ------------------------------
   overriding
   procedure Build_Components (Node    : access Converter_Tag_Node;
                               Parent  : in UIComponent_Access;
                               Context : in out Contexts.Facelets.Facelet_Context'Class) is
      use ASF.Components.Holders;
      use type ASF.Converters.Converter_Access;

      Cvt : constant Converters.Converter_Access := Context.Get_Converter (Node.Converter);
   begin
      if not (Parent.all in Value_Holder'Class) then
         Node.Error ("Parent component is not an instance of Value_Holder");
         return;
      end if;

      if Cvt = null then
         Node.Error ("Converter was not found");
         return;
      end if;

      declare
         VH : constant access Value_Holder'Class := Value_Holder'Class (Parent.all)'Access;
      begin
         VH.Set_Converter (Converter => Cvt);
      end;
   end Build_Components;

   --  ------------------------------
   --  Validator Tag
   --  ------------------------------

   --  ------------------------------
   --  Create the Validator Tag
   --  ------------------------------
   function Create_Validator_Tag_Node (Binding    : in Binding_Access;
                                       Line       : in Views.Line_Info;
                                       Parent     : in Views.Nodes.Tag_Node_Access;
                                       Attributes : in Views.Nodes.Tag_Attribute_Array_Access)
                                       return Views.Nodes.Tag_Node_Access is

      use ASF.Views.Nodes;

      Node : constant Validator_Tag_Node_Access := new Validator_Tag_Node;
      Vid  : constant Tag_Attribute_Access := Find_Attribute (Attributes,
                                                              "validatorId");
   begin
      Initialize (Node.all'Access, Binding, Line, Parent, Attributes);
      if Vid = null then
         Node.Error ("Missing 'validatorId' attribute");
      else
         Node.Validator := EL.Objects.To_Object (Vid.Value);
      end if;
      return Node.all'Access;
   end Create_Validator_Tag_Node;

   --  ------------------------------
   --  Get the specified validator and add it to the parent component.
   --  This operation does not create any new UIComponent.
   --  ------------------------------
   overriding
   procedure Build_Components (Node    : access Validator_Tag_Node;
                               Parent  : in UIComponent_Access;
                               Context : in out Contexts.Facelets.Facelet_Context'Class) is
      use ASF.Components.Holders;
      use type ASF.Validators.Validator_Access;

      V      : Validators.Validator_Access;
      Shared : Boolean;
   begin
      if not (Parent.all in Editable_Value_Holder'Class) then
         Node.Error ("Parent component is not an instance of Editable_Value_Holder");
         return;
      end if;

      Validator_Tag_Node'Class (Node.all).Get_Validator (Context, V, Shared);
      if V = null then
         Node.Error ("Validator was not found");
         return;
      end if;

      declare
         VH : constant access Editable_Value_Holder'Class
           := Editable_Value_Holder'Class (Parent.all)'Access;
      begin
         VH.Add_Validator (Validator => V, Shared => Shared);
      end;
   end Build_Components;

   --  ------------------------------
   --  Get the validator instance that corresponds to the validator tag.
   --  Returns in Validator the instance if it exists and indicate
   --  in Shared whether it must be freed or not when the component is deleted.
   --  ------------------------------
   procedure Get_Validator (Node      : in Validator_Tag_Node;
                            Context   : in out Contexts.Facelets.Facelet_Context'Class;
                            Validator : out Validators.Validator_Access;
                            Shared    : out Boolean) is
   begin
      Validator := Context.Get_Validator (Node.Validator);
      Shared    := True;
   end Get_Validator;

   --  ------------------------------
   --  Range Validator Tag
   --  ------------------------------

   --  Create the Range_Validator Tag
   function Create_Range_Validator_Tag_Node (Binding    : in Binding_Access;
                                             Line       : in Views.Line_Info;
                                             Parent     : in Views.Nodes.Tag_Node_Access;
                                             Attributes : in Views.Nodes.Tag_Attribute_Array_Access)
                                             return Views.Nodes.Tag_Node_Access is

      use ASF.Views.Nodes;

      Node : constant Range_Validator_Tag_Node_Access := new Range_Validator_Tag_Node;
   begin
      Initialize (Node.all'Access, Binding, Line, Parent, Attributes);
      Node.Minimum := Find_Attribute (Attributes, "minimum");
      Node.Maximum := Find_Attribute (Attributes, "maximum");
      if Node.Minimum = null and Node.Maximum = null then
         Node.Error ("Missing 'minimum' or 'maximum' attribute");
      end if;
      return Node.all'Access;
   end Create_Range_Validator_Tag_Node;

   --  Get the validator instance that corresponds to the range validator.
   --  Returns in Validator the validator instance if it exists and indicate
   --  in Shared whether it must be freed or not when the component is deleted.
   overriding
   procedure Get_Validator (Node      : in Range_Validator_Tag_Node;
                            Context   : in out Contexts.Facelets.Facelet_Context'Class;
                            Validator : out Validators.Validator_Access;
                            Shared    : out Boolean) is
      use type ASF.Validators.Validator_Access;

      Min : Long_Long_Integer := Long_Long_Integer'First;
      Max : Long_Long_Integer := Long_Long_Integer'Last;
   begin
      --  Get the minimum and maximum attributes.
      begin
         if Node.Minimum /= null then
            Min := EL.Objects.To_Long_Long_Integer (Get_Value (Node.Minimum.all, Context));
         end if;
         if Node.Maximum /= null then
            Max := EL.Objects.To_Long_Long_Integer (Get_Value (Node.Maximum.all, Context));
         end if;

      exception
         when Constraint_Error =>
            Node.Error ("Invalid minimum or maximum value");
      end;
      Shared := False;
      if Max < Min then
         Node.Error ("Minimum ({0}) should be less than maximum ({1})",
                     Long_Long_Integer'Image (Min), Long_Long_Integer'Image (Max));
         return;
      end if;

      Validator := Validators.Numbers.Create_Range_Validator (Minimum => Min,
                                                              Maximum => Max);
   end Get_Validator;

   --  ------------------------------
   --  Length Validator Tag
   --  ------------------------------

   --  ------------------------------
   --  Create the Length_Validator Tag.  Verifies that the XML node defines
   --  the minimum or the maximum or both attributes.
   --  ------------------------------
   function Create_Length_Validator_Tag_Node (Binding    : in Binding_Access;
                                              Line       : in Views.Line_Info;
                                              Parent     : in Views.Nodes.Tag_Node_Access;
                                              Attributes : in Views.Nodes.Tag_Attribute_Array_Access)
                                              return Views.Nodes.Tag_Node_Access is

      use ASF.Views.Nodes;

      Node : constant Length_Validator_Tag_Node_Access := new Length_Validator_Tag_Node;
   begin
      Initialize (Node.all'Access, Binding, Line, Parent, Attributes);
      Node.Minimum := Find_Attribute (Attributes, "minimum");
      Node.Maximum := Find_Attribute (Attributes, "maximum");
      if Node.Minimum = null and Node.Maximum = null then
         Node.Error ("Missing 'minimum' or 'maximum' attribute");
      end if;
      return Node.all'Access;
   end Create_Length_Validator_Tag_Node;

   --  ------------------------------
   --  Get the validator instance that corresponds to the validator tag.
   --  Returns in Validator the instance if it exists and indicate
   --  in Shared whether it must be freed or not when the component is deleted.
   --  ------------------------------
   overriding
   procedure Get_Validator (Node      : in Length_Validator_Tag_Node;
                            Context   : in out Contexts.Facelets.Facelet_Context'Class;
                            Validator : out Validators.Validator_Access;
                            Shared    : out Boolean) is
      use type ASF.Validators.Validator_Access;

      Min : Natural := 0;
      Max : Natural := Natural'Last;
   begin
      --  Get the minimum and maximum attributes.
      begin
         if Node.Minimum /= null then
            Min := Natural (EL.Objects.To_Integer (Get_Value (Node.Minimum.all, Context)));
         end if;
         if Node.Maximum /= null then
            Max := Natural (EL.Objects.To_Integer (Get_Value (Node.Maximum.all, Context)));
         end if;

      exception
         when Constraint_Error =>
            Node.Error ("Invalid minimum or maximum value");
      end;
      Shared := False;
      if Max < Min then
         Node.Error ("Minimum ({0}) should be less than maximum ({1})",
                     Natural'Image (Min), Natural'Image (Max));
         return;
      end if;

      Validator := Validators.Texts.Create_Length_Validator (Minimum => Min,
                                                             Maximum => Max);
   end Get_Validator;

   --  ------------------------------
   --  Attribute Tag
   --  ------------------------------

   --  ------------------------------
   --  Create the Attribute Tag
   --  ------------------------------
   function Create_Attribute_Tag_Node (Binding    : in Binding_Access;
                                       Line       : in Views.Line_Info;
                                       Parent     : in Views.Nodes.Tag_Node_Access;
                                       Attributes : in Views.Nodes.Tag_Attribute_Array_Access)
                                       return Views.Nodes.Tag_Node_Access is

      use ASF.Views.Nodes;

      Attr : constant Tag_Attribute_Access := Find_Attribute (Attributes, "name");
      Node : Attribute_Tag_Node_Access;
   begin
      Node := new Attribute_Tag_Node;
      Initialize (Node.all'Access, Binding, Line, Parent, Attributes);
      Node.Attr_Name := Attr;
      Node.Value     := Find_Attribute (Attributes, "value");
      if Node.Attr_Name = null then
         Node.Error ("Missing 'name' attribute");
      else
         Node.Attr.Name := Attr.Value;
      end if;
      if Node.Value = null then
         Node.Error ("Missing 'value' attribute");
      end if;
      return Node.all'Access;
   end Create_Attribute_Tag_Node;

   --  ------------------------------
   --  Build the component tree from the tag node and attach it as
   --  the last child of the given parent.  Calls recursively the
   --  method to create children.
   --  Adds the attribute to the component node.
   --  This operation does not create any new UIComponent.
   --  ------------------------------
   overriding
   procedure Build_Components (Node    : access Attribute_Tag_Node;
                               Parent  : in UIComponent_Access;
                               Context : in out Contexts.Facelets.Facelet_Context'Class) is
      use EL.Expressions;
   begin
      if Node.Attr_Name /= null and Node.Value /= null then
         if Node.Value.Binding /= null then
            declare
               Expr : constant EL.Expressions.Expression
                 := ASF.Views.Nodes.Reduce_Expression (Node.Value.all, Context);
            begin
               Parent.Set_Attribute (Def => Node.Attr'Access, Value => Expr);
            end;
         else
            Parent.Set_Attribute (Def   => Node.Attr'Access,
                                  Value => Get_Value (Node.Value.all, Context));
         end if;
      end if;
   end Build_Components;

   --  ------------------------------
   --  Facet Tag
   --  ------------------------------

   --  ------------------------------
   --  Create the Facet Tag
   --  ------------------------------
   function Create_Facet_Tag_Node (Binding    : in Binding_Access;
                                   Line       : in Views.Line_Info;
                                   Parent     : in Views.Nodes.Tag_Node_Access;
                                   Attributes : in Views.Nodes.Tag_Attribute_Array_Access)
                                   return Views.Nodes.Tag_Node_Access is
      use ASF.Views.Nodes;

      Node : constant Facet_Tag_Node_Access := new Facet_Tag_Node;
   begin
      Initialize (Node.all'Access, Binding, Line, Parent, Attributes);
      Node.Facet_Name := Find_Attribute (Attributes, "name");
      if Node.Facet_Name = null then
         Node.Error ("Missing 'name' attribute");
      end if;
      return Node.all'Access;
   end Create_Facet_Tag_Node;

   --  ------------------------------
   --  Build the component tree from the tag node and attach it as
   --  the facet component of the given parent.  Calls recursively the
   --  method to create children.
   --  ------------------------------
   overriding
   procedure Build_Components (Node    : access Facet_Tag_Node;
                               Parent  : in UIComponent_Access;
                               Context : in out Contexts.Facelets.Facelet_Context'Class) is
   begin
      null;
   end Build_Components;

   --  ------------------------------
   --  Metadata Tag
   --  ------------------------------

   --  ------------------------------
   --  Create the Metadata Tag
   --  ------------------------------
   function Create_Metadata_Tag_Node (Binding    : in Binding_Access;
                                      Line       : in Views.Line_Info;
                                      Parent     : in Views.Nodes.Tag_Node_Access;
                                      Attributes : in Views.Nodes.Tag_Attribute_Array_Access)
                                      return Views.Nodes.Tag_Node_Access is
      use ASF.Views.Nodes;

      Node : constant Metadata_Tag_Node_Access := new Metadata_Tag_Node;
   begin
      Initialize (Node.all'Access, Binding, Line, Parent, Attributes);
      return Node.all'Access;
   end Create_Metadata_Tag_Node;

   --  ------------------------------
   --  Build the component tree from the tag node and attach it as a metadata information
   --  facet for the UIView parent component.
   --  ------------------------------
   overriding
   procedure Build_Components (Node    : access Metadata_Tag_Node;
                               Parent  : in UIComponent_Access;
                               Context : in out Contexts.Facelets.Facelet_Context'Class) is
      use ASF.Components.Core.Views;
   begin
      if not (Parent.all in UIView'Class) then
         Node.Error ("Parent component of <f:metadata> must be a <f:view>");
         return;
      end if;
      declare
         UI : constant UIViewMetaData_Access := new UIViewMetaData;
      begin
         UIView'Class (Parent.all).Set_Metadata (UI, Node);
         Build_Attributes (UI.all, Node.all, Context);
         UI.Initialize (UI.Get_Context.all);
         Node.Build_Children (UI.all'Access, Context);
      end;
   end Build_Components;

end ASF.Views.Nodes.Jsf;

Change the Name parameter to a Binding access


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

package body Util.Texts.Builders is

   --  ------------------------------
   --  Get the length of the item builder.
   --  ------------------------------
   function Length (Source : in Builder) return Natural is
   begin
      return Source.Length;
   end Length;

   --  ------------------------------
   --  Get the capacity of the builder.
   --  ------------------------------
   function Capacity (Source : in Builder) return Natural is
      B : constant Block_Access := Source.Current;
   begin
      return Source.Length + B.Len - B.Last;
   end Capacity;

   --  ------------------------------
   --  Get the builder block size.
   --  ------------------------------
   function Block_Size (Source : in Builder) return Positive is
   begin
      return Source.Block_Size;
   end Block_Size;

   --  ------------------------------
   --  Set the block size for the allocation of next chunks.
   --  ------------------------------
   procedure Set_Block_Size (Source : in out Builder;
                             Size   : in Positive) is
   begin
      Source.Block_Size := Size;
   end Set_Block_Size;

   --  ------------------------------
   --  Append the <tt>New_Item</tt> at the end of the source growing the buffer if necessary.
   --  ------------------------------
   procedure Append (Source   : in out Builder;
                     New_Item : in Input) is
      B     : Block_Access := Source.Current;
      Start : Natural := New_Item'First;
      Last  : constant Natural := New_Item'Last;
   begin
      while Start <= Last loop
         declare
            Space : Natural := B.Len - B.Last;
            Size  : constant Natural := Last - Start + 1;
         begin
            if Space > Size then
               Space := Size;
            elsif Space = 0 then
               if Size > Source.Block_Size then
                  B.Next_Block := new Block (Size);
               else
                  B.Next_Block := new Block (Source.Block_Size);
               end if;
               B := B.Next_Block;
               Source.Current := B;
               if B.Len > Size then
                  Space := Size;
               else
                  Space  := B.Len;
               end if;
            end if;
            B.Content (B.Last + 1 .. B.Last + Space) := New_Item (Start .. Start + Space - 1);
            Source.Length := Source.Length + Space;
            B.Last := B.Last + Space;
            Start  := Start + Space;
         end;
      end loop;
   end Append;

   --  ------------------------------
   --  Append the <tt>New_Item</tt> at the end of the source growing the buffer if necessary.
   --  ------------------------------
   procedure Append (Source   : in out Builder;
                     New_Item : in Element_Type) is
      B     : Block_Access := Source.Current;
   begin
      if B.Len = B.Last then
         B.Next_Block := new Block (Source.Block_Size);
         B := B.Next_Block;
         Source.Current := B;
      end if;
      Source.Length := Source.Length + 1;
      B.Last := B.Last + 1;
      B.Content (B.Last) := New_Item;
   end Append;

   --  ------------------------------
   --  Clear the source freeing any storage allocated for the buffer.
   --  ------------------------------
   procedure Clear (Source : in out Builder) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Block, Name => Block_Access);
      Current, Next : Block_Access;
   begin
      Next := Source.First.Next_Block;
      while Next /= null loop
         Current := Next;
         Next    := Current.Next_Block;
         Free (Current);
      end loop;
      Source.First.Next_Block := null;
      Source.First.Last       := 0;
      Source.Current          := Source.First'Unchecked_Access;
      Source.Length           := 0;
   end Clear;

   --  ------------------------------
   --  Iterate over the buffer content calling the <tt>Process</tt> procedure with each
   --  chunk.
   --  ------------------------------
   procedure Iterate (Source  : in Builder;
                      Process : not null access procedure (Chunk : in Input)) is
   begin
      if Source.First.Last > 0 then
         Process (Source.First.Content (1 .. Source.First.Last));
         declare
            B : Block_Access := Source.First.Next_Block;
         begin
            while B /= null loop
               Process (B.Content (1 .. B.Last));
               B := B.Next_Block;
            end loop;
         end;
      end if;
   end Iterate;

   --  ------------------------------
   --  Get the buffer content as an array.
   --  ------------------------------
   function To_Array (Source : in Builder) return Input is
      Result : Input (1 .. Source.Length);
   begin
      if Source.First.Last > 0 then
         declare
            Pos : Positive := Source.First.Last;
            B   : Block_Access := Source.First.Next_Block;
         begin
            Result (1 .. Pos) := Source.First.Content (1 .. Pos);
            while B /= null loop
               Result (Pos + 1 .. Pos + B.Last) := B.Content (1 .. B.Last);
               Pos := Pos + B.Last;
               B   := B.Next_Block;
            end loop;
         end;
      end if;
      return Result;
   end To_Array;

   --  ------------------------------
   --  Setup the builder.
   --  ------------------------------
   overriding
   procedure Initialize (Source : in out Builder) is
   begin
      Source.Current := Source.First'Unchecked_Access;
   end Initialize;

   --  ------------------------------
   --  Finalize the builder releasing the storage.
   --  ------------------------------
   overriding
   procedure Finalize (Source : in out Builder) is
   begin
      Clear (Source);
   end Finalize;

end Util.Texts.Builders;

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

package body Util.Texts.Builders is

   --  ------------------------------
   --  Get the length of the item builder.
   --  ------------------------------
   function Length (Source : in Builder) return Natural is
   begin
      return Source.Length;
   end Length;

   --  ------------------------------
   --  Get the capacity of the builder.
   --  ------------------------------
   function Capacity (Source : in Builder) return Natural is
      B : constant Block_Access := Source.Current;
   begin
      return Source.Length + B.Len - B.Last;
   end Capacity;

   --  ------------------------------
   --  Get the builder block size.
   --  ------------------------------
   function Block_Size (Source : in Builder) return Positive is
   begin
      return Source.Block_Size;
   end Block_Size;

   --  ------------------------------
   --  Set the block size for the allocation of next chunks.
   --  ------------------------------
   procedure Set_Block_Size (Source : in out Builder;
                             Size   : in Positive) is
   begin
      Source.Block_Size := Size;
   end Set_Block_Size;

   --  ------------------------------
   --  Append the <tt>New_Item</tt> at the end of the source growing the buffer if necessary.
   --  ------------------------------
   procedure Append (Source   : in out Builder;
                     New_Item : in Input) is
      B     : Block_Access := Source.Current;
      Start : Natural := New_Item'First;
      Last  : constant Natural := New_Item'Last;
   begin
      while Start <= Last loop
         declare
            Space : Natural := B.Len - B.Last;
            Size  : constant Natural := Last - Start + 1;
         begin
            if Space > Size then
               Space := Size;
            elsif Space = 0 then
               if Size > Source.Block_Size then
                  B.Next_Block := new Block (Size);
               else
                  B.Next_Block := new Block (Source.Block_Size);
               end if;
               B := B.Next_Block;
               Source.Current := B;
               if B.Len > Size then
                  Space := Size;
               else
                  Space  := B.Len;
               end if;
            end if;
            B.Content (B.Last + 1 .. B.Last + Space) := New_Item (Start .. Start + Space - 1);
            Source.Length := Source.Length + Space;
            B.Last := B.Last + Space;
            Start  := Start + Space;
         end;
      end loop;
   end Append;

   --  ------------------------------
   --  Append the <tt>New_Item</tt> at the end of the source growing the buffer if necessary.
   --  ------------------------------
   procedure Append (Source   : in out Builder;
                     New_Item : in Element_Type) is
      B     : Block_Access := Source.Current;
   begin
      if B.Len = B.Last then
         B.Next_Block := new Block (Source.Block_Size);
         B := B.Next_Block;
         Source.Current := B;
      end if;
      Source.Length := Source.Length + 1;
      B.Last := B.Last + 1;
      B.Content (B.Last) := New_Item;
   end Append;

   --  ------------------------------
   --  Clear the source freeing any storage allocated for the buffer.
   --  ------------------------------
   procedure Clear (Source : in out Builder) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Block, Name => Block_Access);
      Current, Next : Block_Access;
   begin
      Next := Source.First.Next_Block;
      while Next /= null loop
         Current := Next;
         Next    := Current.Next_Block;
         Free (Current);
      end loop;
      Source.First.Next_Block := null;
      Source.First.Last       := 0;
      Source.Current          := Source.First'Unchecked_Access;
      Source.Length           := 0;
   end Clear;

   --  ------------------------------
   --  Iterate over the buffer content calling the <tt>Process</tt> procedure with each
   --  chunk.
   --  ------------------------------
   procedure Iterate (Source  : in Builder;
                      Process : not null access procedure (Chunk : in Input)) is
   begin
      if Source.First.Last > 0 then
         Process (Source.First.Content (1 .. Source.First.Last));
         declare
            B : Block_Access := Source.First.Next_Block;
         begin
            while B /= null loop
               Process (B.Content (1 .. B.Last));
               B := B.Next_Block;
            end loop;
         end;
      end if;
   end Iterate;

   --  ------------------------------
   --  Return the content starting from the tail and up to <tt>Length</tt> items.
   --  ------------------------------
   function Tail (Source : in Builder;
                  Length : in Natural) return Input is
      Last : constant Natural := Source.Current.Last;
   begin
      if Last >= Length then
         return Source.Current.Content (Last - Length + 1 .. Last);
      elsif Length >= Source.Length then
         return To_Array (Source);
      else
         declare
            Result  : Input (1 .. Length);
            Offset  : Natural := Source.Length - Length;
            B       : Block_Access := Source.First'Unrestricted_Access;
            Src_Pos : Positive := 1;
            Dst_Pos : Positive := 1;
            Len     : Natural;
         begin
            --  Skip the data moving to next blocks as needed.
            while Offset /= 0 loop
               if Offset < B.Last then
                  Src_Pos := Offset + 1;
                  Offset := 0;
               else
                  Offset := Offset - B.Last + 1;
                  B := B.Next_Block;
               end if;
            end loop;

            --  Copy what remains until we reach the length.
            while Dst_Pos <= Length loop
               Len := B.Last - Src_Pos + 1;
               Result (Dst_Pos .. Dst_Pos + Len - 1) := B.Content (Src_Pos .. B.Last);
               Src_Pos := 1;
               Dst_Pos := Dst_Pos + Len;
               B := B.Next_Block;
            end loop;
            return Result;
         end;
      end if;
   end Tail;

   --  ------------------------------
   --  Get the buffer content as an array.
   --  ------------------------------
   function To_Array (Source : in Builder) return Input is
      Result : Input (1 .. Source.Length);
   begin
      if Source.First.Last > 0 then
         declare
            Pos : Positive := Source.First.Last;
            B   : Block_Access := Source.First.Next_Block;
         begin
            Result (1 .. Pos) := Source.First.Content (1 .. Pos);
            while B /= null loop
               Result (Pos + 1 .. Pos + B.Last) := B.Content (1 .. B.Last);
               Pos := Pos + B.Last;
               B   := B.Next_Block;
            end loop;
         end;
      end if;
      return Result;
   end To_Array;

   --  ------------------------------
   --  Setup the builder.
   --  ------------------------------
   overriding
   procedure Initialize (Source : in out Builder) is
   begin
      Source.Current := Source.First'Unchecked_Access;
   end Initialize;

   --  ------------------------------
   --  Finalize the builder releasing the storage.
   --  ------------------------------
   overriding
   procedure Finalize (Source : in out Builder) is
   begin
      Clear (Source);
   end Finalize;

end Util.Texts.Builders;

Implement the Tail function

Implement the Tail function


-----------------------------------------------------------------------
--  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.Containers.Hashed_Maps;
with Ada.Containers.Vectors;

with Util.Refs;
with Util.Serialize.IO.XML;

with GNAT.Regexp;

package Security.Policies.Urls is

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

   --  ------------------------------
   --  URI Permission
   --  ------------------------------
   --  Represents a permission to access a given URI.
   type URI_Permission (Len : Natural) is new Permissions.Permission with record
      URI : String (1 .. Len);
   end record;

   --  ------------------------------
   --  URL policy
   --  ------------------------------
   type URL_Policy is new Policy with private;
   type URL_Policy_Access is access all URL_Policy'Class;

   Invalid_Name : exception;

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

   --  Returns True if the user has the permission to access the given URI permission.
   function Has_Permission (Manager    : in URL_Policy;
                            Context    : in Security_Context_Access;
                            Permission : in URI_Permission'Class) return Boolean;

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

   --  Initialize the permission manager.
   overriding
   procedure Initialize (Manager : in out URL_Policy);

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

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

   --  Finish reading the XML policy configuration.  The security policy implementation can use
   --  this procedure to perform any configuration setup after the configuration is parsed.
   overriding
   procedure Finish_Config (Into    : in out URL_Policy;
                            Reader  : in out Util.Serialize.IO.XML.Parser);

private

   --  The Access_Rule represents a list of permissions to verify to grant
   --  access to the resource.  To make it simple, the user must have one of the
   --  permission from the list.  Each permission will refer to a specific permission
   --  controller.
   type Access_Rule (Count : Natural) is new Util.Refs.Ref_Entity with record
      Permissions : Permission_Index_Array (1 .. Count);
   end record;
   type Access_Rule_Access is access all Access_Rule;

   package Access_Rule_Refs is
     new Util.Refs.Indefinite_References (Element_Type   => Access_Rule,
                                          Element_Access => Access_Rule_Access);
   subtype Access_Rule_Ref is Access_Rule_Refs.Ref;

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

   --  The Policy defines the access rules that are applied on a given
   --  URL, set of URLs or files.
   type Policy is record
      Id      : Natural;
      Pattern : GNAT.Regexp.Regexp;
      Rule    : Access_Rule_Ref;
   end record;

   --  The Policy_Vector represents the whole permission policy.  The order of
   --  policy in the list is important as policies can override each other.
   package Policy_Vector is new Ada.Containers.Vectors (Index_Type   => Positive,
                                                        Element_Type => Policy);

   package Rules_Maps is new Ada.Containers.Hashed_Maps (Key_Type        => String_Ref,
                                                         Element_Type    => Access_Rule_Ref,
                                                         Hash            => Hash,
                                                         Equivalent_Keys => Equivalent_Keys,
                                                         "="             => Access_Rule_Refs."=");

   type Rules is new Util.Refs.Ref_Entity with record
      Map : Rules_Maps.Map;
   end record;
   type Rules_Access is access all Rules;

   package Rules_Ref is new Util.Refs.References (Rules, Rules_Access);

   type Rules_Ref_Access is access Rules_Ref.Atomic_Ref;

   type Controller_Access_Array_Access is access all Controller_Access_Array;

   type URL_Policy is new Security.Policies.Policy with record
      Cache        : Rules_Ref_Access;
      Policies     : Policy_Vector.Vector;
   end record;

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.Containers.Hashed_Maps;
with Ada.Containers.Vectors;

with Util.Refs;
with Util.Strings;
with Util.Serialize.IO.XML;

with GNAT.Regexp;

package Security.Policies.Urls is

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

   --  ------------------------------
   --  URI Permission
   --  ------------------------------
   --  Represents a permission to access a given URI.
   type URI_Permission (Len : Natural) is new Permissions.Permission with record
      URI : String (1 .. Len);
   end record;

   --  ------------------------------
   --  URL policy
   --  ------------------------------
   type URL_Policy is new Policy with private;
   type URL_Policy_Access is access all URL_Policy'Class;

   Invalid_Name : exception;

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

   --  Returns True if the user has the permission to access the given URI permission.
   function Has_Permission (Manager    : in URL_Policy;
                            Context    : in Security_Context_Access;
                            Permission : in URI_Permission'Class) return Boolean;

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

   --  Initialize the permission manager.
   overriding
   procedure Initialize (Manager : in out URL_Policy);

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

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

   --  Finish reading the XML policy configuration.  The security policy implementation can use
   --  this procedure to perform any configuration setup after the configuration is parsed.
   overriding
   procedure Finish_Config (Into    : in out URL_Policy;
                            Reader  : in out Util.Serialize.IO.XML.Parser);

private

   use Util.Strings;

   --  The Access_Rule represents a list of permissions to verify to grant
   --  access to the resource.  To make it simple, the user must have one of the
   --  permission from the list.  Each permission will refer to a specific permission
   --  controller.
   type Access_Rule (Count : Natural) is new Util.Refs.Ref_Entity with record
      Permissions : Permission_Index_Array (1 .. Count);
   end record;
   type Access_Rule_Access is access all Access_Rule;

   package Access_Rule_Refs is
     new Util.Refs.Indefinite_References (Element_Type   => Access_Rule,
                                          Element_Access => Access_Rule_Access);
   subtype Access_Rule_Ref is Access_Rule_Refs.Ref;

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

   --  The Policy defines the access rules that are applied on a given
   --  URL, set of URLs or files.
   type Policy is record
      Id      : Natural;
      Pattern : GNAT.Regexp.Regexp;
      Rule    : Access_Rule_Ref;
   end record;

   --  The Policy_Vector represents the whole permission policy.  The order of
   --  policy in the list is important as policies can override each other.
   package Policy_Vector is new Ada.Containers.Vectors (Index_Type   => Positive,
                                                        Element_Type => Policy);

   package Rules_Maps is new Ada.Containers.Hashed_Maps (Key_Type        => String_Ref,
                                                         Element_Type    => Access_Rule_Ref,
                                                         Hash            => Hash,
                                                         Equivalent_Keys => Equivalent_Keys,
                                                         "="             => Access_Rule_Refs."=");

   type Rules is new Util.Refs.Ref_Entity with record
      Map : Rules_Maps.Map;
   end record;
   type Rules_Access is access all Rules;

   package Rules_Ref is new Util.Refs.References (Rules, Rules_Access);

   type Rules_Ref_Access is access Rules_Ref.Atomic_Ref;

   type Controller_Access_Array_Access is access all Controller_Access_Array;

   type URL_Policy is new Security.Policies.Policy with record
      Cache        : Rules_Ref_Access;
      Policies     : Policy_Vector.Vector;
   end record;

end Security.Policies.Urls;

Add with clause for Util.Strings

Add with clause for Util.Strings


------------------------------------------------------------------------------
-- Copyright (c) 2015, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Natools.Web.Reload_Pages provides a URL endpoint that unconditionally    --
-- reloads the site upon POST request and redirects to the given path.      --
--                                                                          --
-- WARNING: site reload can be a very expensive operation, and no access    --
-- restriction or rate-limiting is implemented at this time, so care should --
-- be taken to ensure this endpoint is only accessible to trusted clients.  --
------------------------------------------------------------------------------

with Natools.S_Expressions;
with Natools.Web.Sites;

private with Natools.S_Expressions.Atom_Refs;

package Natools.Web.Reload_Pages is

   type Reload_Page is new Sites.Page with private;

   overriding procedure Respond
     (Object : in out Reload_Page;
      Exchange : in out Sites.Exchange;
      Extra_Path : in S_Expressions.Atom);

   type Loader is new Sites.Page_Loader with private;

   overriding procedure Load
     (Object : in out Loader;
      Builder : in out Sites.Site_Builder;
      Path : in S_Expressions.Atom);

   function Create (File : in S_Expressions.Atom)
     return Sites.Page_Loader'Class;

private

   type Reload_Page is new Sites.Page with record
      Target : S_Expressions.Atom_Refs.Immutable_Reference;
   end record;

   type Loader is new Sites.Page_Loader with record
      Target : S_Expressions.Atom_Refs.Immutable_Reference;
   end record;

end Natools.Web.Reload_Pages;

------------------------------------------------------------------------------
-- Copyright (c) 2015-2019, Natacha Porté                                   --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Natools.Web.Reload_Pages provides a URL endpoint that unconditionally    --
-- reloads the site upon POST request and redirects to the given path.      --
--                                                                          --
-- WARNING: site reload can be a very expensive operation, and no access    --
-- restriction or rate-limiting is implemented at this time, so care should --
-- be taken to ensure this endpoint is only accessible to trusted clients.  --
------------------------------------------------------------------------------

with Natools.S_Expressions;
with Natools.Web.Sites;

private with Natools.S_Expressions.Atom_Refs;

package Natools.Web.Reload_Pages is

   type Reload_Page is new Sites.Page with private;

   overriding procedure Respond
     (Object : in out Reload_Page;
      Exchange : in out Sites.Exchange;
      Extra_Path : in S_Expressions.Atom);

   type Loader is new Sites.Transient_Page_Loader with private;

   overriding function Can_Be_Stored (Object : in Loader) return Boolean
     is (False);

   overriding procedure Load
     (Object : in out Loader;
      Builder : in out Sites.Site_Builder;
      Path : in S_Expressions.Atom);

   function Create (File : in S_Expressions.Atom)
     return Sites.Page_Loader'Class;

private

   type Reload_Page is new Sites.Page with record
      Target : S_Expressions.Atom_Refs.Immutable_Reference;
   end record;

   type Loader is new Sites.Transient_Page_Loader with record
      Target : S_Expressions.Atom_Refs.Immutable_Reference;
   end record;

end Natools.Web.Reload_Pages;

reload-pages: use the new transient page loader interface


------------------------------------------------------------------------------
-- Copyright (c) 2014-2017, Natacha Porté                                   --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

with Natools.S_Expressions.Atom_Ref_Constructors;
with Natools.S_Expressions.File_Readers;
with Natools.S_Expressions.Interpreter_Loop;
with Natools.S_Expressions.Templates.Dates;
with Natools.Static_Maps.Web.Simple_Pages;
with Natools.Web.Error_Pages;
with Natools.Web.Exchanges;
with Natools.Web.Fallback_Render;

package body Natools.Web.Simple_Pages is

   Expiration_Date_Key : constant S_Expressions.Atom
     := S_Expressions.To_Atom ("!expire");
   Publication_Date_Key : constant S_Expressions.Atom
     := S_Expressions.To_Atom ("!publish");

   procedure Append
     (Exchange : in out Sites.Exchange;
      Page : in Page_Data;
      Data : in S_Expressions.Atom);

   procedure Execute
     (Data : in out Page_Data;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class);

   procedure Render
     (Exchange : in out Sites.Exchange;
      Page : in Page_Data;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class);

   procedure Read_Page is new S_Expressions.Interpreter_Loop
     (Page_Data, Meaningless_Type, Execute);

   procedure Render_Page is new S_Expressions.Interpreter_Loop
     (Sites.Exchange, Page_Data, Render, Append);

   ---------------------------
   -- Page Data Constructor --
   ---------------------------

   procedure Execute
     (Data : in out Page_Data;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Context);
      package Components renames Natools.Static_Maps.Web.Simple_Pages;
   begin
      case Components.To_Component (S_Expressions.To_String (Name)) is
         when Components.Error =>
            Log (Severities.Error, "Unknown page component """
              & S_Expressions.To_String (Name) & '"');

         when Components.Comment_List =>
            Data.Comment_List.Set (Arguments);

         when Components.Dates =>
            Containers.Set_Dates (Data.Dates, Arguments);

         when Components.Elements =>
            Containers.Set_Expressions (Data.Elements, Arguments);

         when Components.Maps =>
            Data.Maps := String_Tables.Create (Arguments);

         when Components.Tags =>
            Tags.Append (Data.Tags, Arguments);
      end case;
   end Execute;

   -------------------
   -- Page Renderer --
   -------------------

   procedure Append
     (Exchange : in out Sites.Exchange;
      Page : in Page_Data;
      Data : in S_Expressions.Atom)
   is
      pragma Unreferenced (Page);
   begin
      Exchange.Append (Data);
   end Append;

   procedure Render
     (Exchange : in out Sites.Exchange;
      Page : in Page_Data;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class)
   is
      use type S_Expressions.Events.Event;

      procedure Re_Enter
        (Exchange : in out Sites.Exchange;
         Expression : in out S_Expressions.Lockable.Descriptor'Class);

      procedure Render_Date (Log_Error : in Boolean);

      procedure Re_Enter
        (Exchange : in out Sites.Exchange;
         Expression : in out S_Expressions.Lockable.Descriptor'Class) is
      begin
         Render_Page (Expression, Exchange, Page);
      end Re_Enter;

      procedure Render_Date (Log_Error : in Boolean) is
      begin
         if Arguments.Current_Event = S_Expressions.Events.Add_Atom then
            declare
               Cursor : constant Containers.Date_Maps.Cursor
                 := Page.Dates.Find (Arguments.Current_Atom);
            begin
               if not Containers.Date_Maps.Has_Element (Cursor) then
                  if Log_Error then
                     Log (Severities.Error, "Unable to find date """
                       & S_Expressions.To_String (Arguments.Current_Atom)
                       & """ in page date map");
                  end if;

                  return;
               end if;

               Arguments.Next;

               declare
                  Item : constant Containers.Date
                    := Containers.Date_Maps.Element (Cursor);
               begin
                  S_Expressions.Templates.Dates.Render
                    (Exchange, Arguments, Item.Time, Item.Offset);
               end;
            end;
         end if;
      end Render_Date;

      package Commands renames Natools.Static_Maps.Web.Simple_Pages;
   begin
      case Commands.To_Command (S_Expressions.To_String (Name)) is
         when Commands.Unknown_Command =>
            Fallback_Render
              (Exchange, Name, Arguments,
               "simple page",
               Re_Enter'Access, Page.Elements);

         when Commands.Comment_List =>
            Comments.Render (Exchange, Page.Comment_List, Arguments);

         when Commands.Date =>
            Render_Date (True);

         when Commands.My_Tags =>
            if Arguments.Current_Event = S_Expressions.Events.Add_Atom then
               declare
                  Prefix : constant S_Expressions.Atom
                    := Arguments.Current_Atom;
               begin
                  Arguments.Next;
                  Tags.Render
                    (Exchange,
                     Page.Tags,
                     Exchange.Site.Get_Tags,
                     Prefix,
                     Arguments);
               end;
            end if;

         when Commands.If_No_Date =>
            if Arguments.Current_Event = S_Expressions.Events.Add_Atom
              and then not Page.Dates.Contains (Arguments.Current_Atom)
            then
               Arguments.Next;
               Render_Page (Arguments, Exchange, Page);
            end if;

         when Commands.Maps =>
            String_Tables.Render (Exchange, Page.Maps, Arguments);

         when Commands.Optional_Date =>
            Render_Date (False);

         when Commands.Path =>
            Exchange.Append (Page.Web_Path.Query);

         when Commands.Tags =>
            Tags.Render
              (Exchange,
               Exchange.Site.Get_Tags,
               Arguments,
               Page.Tags);
      end case;
   end Render;

   -------------------------
   -- Page_Data Interface --
   -------------------------

   not overriding procedure Get_Element
     (Data : in Page_Data;
      Name : in S_Expressions.Atom;
      Element : out S_Expressions.Caches.Cursor;
      Found : out Boolean)
   is
      Cursor : constant Containers.Expression_Maps.Cursor
        := Data.Elements.Find (Name);
   begin
      Found := Containers.Expression_Maps.Has_Element (Cursor);

      if Found then
         Element := Containers.Expression_Maps.Element (Cursor);
      end if;
   end Get_Element;

   ----------------------
   -- Public Interface --
   ----------------------

   function Create
     (Expression : in out S_Expressions.Lockable.Descriptor'Class)
     return Page_Ref
   is
      Page : constant Data_Refs.Data_Access := new Page_Data;
      Result : constant Page_Ref := (Ref => Data_Refs.Create (Page));
   begin
      Page.Self := Tags.Visible_Access (Page);
      Read_Page (Expression, Page.all, Meaningless_Value);
      return Result;
   end Create;

   function Create
     (File_Path, Web_Path : in S_Expressions.Atom_Refs.Immutable_Reference)
     return Page_Ref
   is
      Page : constant Data_Refs.Data_Access := new Page_Data'
        (File_Path => File_Path,
         Web_Path => Web_Path,
         Tags => <>,
         Self => null,
         Comment_List | Elements | Dates | Maps => <>);
      Result : constant Page_Ref := (Ref => Data_Refs.Create (Page));
   begin
      Page.Self := Tags.Visible_Access (Page);

      Create_Page :
      declare
         Reader : Natools.S_Expressions.File_Readers.S_Reader
           := Natools.S_Expressions.File_Readers.Reader
              (S_Expressions.To_String (File_Path.Query));
      begin
         Read_Page (Reader, Page.all, Meaningless_Value);
      end Create_Page;

      return Result;
   end Create;

   procedure Get_Lifetime
     (Page : in Page_Ref;
      Publication : out Ada.Calendar.Time;
      Has_Publication : out Boolean;
      Expiration : out Ada.Calendar.Time;
      Has_Expiration : out Boolean)
   is
      Accessor : constant Data_Refs.Accessor := Page.Ref.Query;
      Cursor : Containers.Date_Maps.Cursor;
   begin
      Cursor := Accessor.Dates.Find (Expiration_Date_Key);

      if Containers.Date_Maps.Has_Element (Cursor) then
         Has_Expiration := True;
         Expiration := Containers.Date_Maps.Element (Cursor).Time;
      else
         Has_Expiration := False;
      end if;

      Cursor := Accessor.Dates.Find (Publication_Date_Key);

      if Containers.Date_Maps.Has_Element (Cursor) then
         Has_Publication := True;
         Publication := Containers.Date_Maps.Element (Cursor).Time;
      else
         Has_Publication := False;
      end if;
   end Get_Lifetime;

   procedure Register
     (Page : in Page_Ref;
      Builder : in out Sites.Site_Builder;
      Path : in S_Expressions.Atom) is
   begin
      Time_Check :
      declare
         use type Ada.Calendar.Time;
         Now : constant Ada.Calendar.Time := Ada.Calendar.Clock;
         Publication : Ada.Calendar.Time;
         Has_Publication : Boolean;
         Expiration : Ada.Calendar.Time;
         Has_Expiration : Boolean;
      begin
         Get_Lifetime
           (Page, Publication, Has_Publication, Expiration, Has_Expiration);

         if (Has_Publication and then Publication >= Now)
           or else (Has_Expiration and then Expiration < Now)
         then
            return;
         end if;
      end Time_Check;

      if Path'Length > 0 then
         Sites.Insert (Builder, Path, Page);
      end if;

      Sites.Insert (Builder, Page.Get_Tags, Page);

      Load_Comments :
      declare
         Mutator : constant Data_Refs.Mutator := Page.Ref.Update;
      begin
         Mutator.Comment_List.Load (Builder, Mutator.Self, Mutator.Web_Path);
      end Load_Comments;
   end Register;

   overriding procedure Render
     (Exchange : in out Sites.Exchange;
      Object : in Page_Ref;
      Expression : in out S_Expressions.Lockable.Descriptor'Class) is
   begin
      Render_Page
        (Expression,
         Exchange,
         Object.Ref.Query.Data.all);
   end Render;

   overriding procedure Render
     (Exchange : in out Sites.Exchange;
      Object : in Page_Data;
      Expression : in out S_Expressions.Lockable.Descriptor'Class) is
   begin
      Render_Page (Expression, Exchange, Object);
   end Render;

   overriding procedure Respond
     (Object : in out Page_Ref;
      Exchange : in out Sites.Exchange;
      Extra_Path : in S_Expressions.Atom)
   is
      use type S_Expressions.Offset;
   begin
      if Extra_Path'Length = 9
        and then S_Expressions.To_String (Extra_Path) = "/comments"
      then
         Object.Ref.Update.Comment_List.Respond
           (Exchange, Extra_Path (Extra_Path'First + 9 .. Extra_Path'Last));
         return;
      end if;

      if Extra_Path'Length > 0 then
         return;
      end if;

      declare
         Accessor : constant Data_Refs.Accessor := Object.Ref.Query;
         Expression : S_Expressions.Caches.Cursor;
      begin
         Check_Method :
         declare
            use Exchanges;
            Allowed : Boolean;
         begin
            Error_Pages.Check_Method
              (Exchange,
               (GET, HEAD),
               Allowed);

            if not Allowed then
               return;
            end if;
         end Check_Method;

         Expression := Exchange.Site.Get_Template
           (Accessor.Data.Elements,
            Expression,
            Exchange.Site.Default_Template,
            Lookup_Element => True,
            Lookup_Template => True,
            Lookup_Name => True);

         Render_Page (Expression, Exchange, Accessor.Data.all);
      end;
   end Respond;

   -----------------------
   -- Page Constructors --
   -----------------------

   function Create (File : in S_Expressions.Atom)
     return Sites.Page_Loader'Class is
   begin
      return Loader'(File_Path
        => S_Expressions.Atom_Ref_Constructors.Create (File));
   end Create;

   overriding procedure Load
     (Object : in out Loader;
      Builder : in out Sites.Site_Builder;
      Path : in S_Expressions.Atom)
   is
      Page : constant Page_Ref := Create
        (Object.File_Path,
         S_Expressions.Atom_Ref_Constructors.Create (Path));
   begin
      Register (Page, Builder, Path);
   end Load;

   procedure Register_Loader (Site : in out Sites.Site) is
   begin
      Site.Register ("simple-page", Create'Access);
   end Register_Loader;

end Natools.Web.Simple_Pages;

------------------------------------------------------------------------------
-- Copyright (c) 2014-2017, Natacha Porté                                   --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

with Natools.S_Expressions.Atom_Ref_Constructors;
with Natools.S_Expressions.File_Readers;
with Natools.S_Expressions.Interpreter_Loop;
with Natools.S_Expressions.Templates.Dates;
with Natools.Static_Maps.Web.Simple_Pages;
with Natools.Web.Error_Pages;
with Natools.Web.Exchanges;
with Natools.Web.Fallback_Render;

package body Natools.Web.Simple_Pages is

   Expiration_Date_Key : constant S_Expressions.Atom
     := S_Expressions.To_Atom ("!expire");
   Publication_Date_Key : constant S_Expressions.Atom
     := S_Expressions.To_Atom ("!publish");

   procedure Append
     (Exchange : in out Sites.Exchange;
      Page : in Page_Data;
      Data : in S_Expressions.Atom);

   procedure Execute
     (Data : in out Page_Data;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class);

   procedure Render
     (Exchange : in out Sites.Exchange;
      Page : in Page_Data;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class);

   procedure Read_Page is new S_Expressions.Interpreter_Loop
     (Page_Data, Meaningless_Type, Execute);

   procedure Render_Page is new S_Expressions.Interpreter_Loop
     (Sites.Exchange, Page_Data, Render, Append);

   ---------------------------
   -- Page Data Constructor --
   ---------------------------

   procedure Execute
     (Data : in out Page_Data;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Context);
      package Components renames Natools.Static_Maps.Web.Simple_Pages;
   begin
      case Components.To_Component (S_Expressions.To_String (Name)) is
         when Components.Error =>
            Log (Severities.Error, "Unknown page component """
              & S_Expressions.To_String (Name) & '"');

         when Components.Comment_List =>
            Data.Comment_List.Set (Arguments);

         when Components.Dates =>
            Containers.Set_Dates (Data.Dates, Arguments);

         when Components.Elements =>
            Containers.Set_Expressions (Data.Elements, Arguments);

         when Components.Maps =>
            Data.Maps := String_Tables.Create (Arguments);

         when Components.Tags =>
            Tags.Append (Data.Tags, Arguments);
      end case;
   end Execute;

   -------------------
   -- Page Renderer --
   -------------------

   procedure Append
     (Exchange : in out Sites.Exchange;
      Page : in Page_Data;
      Data : in S_Expressions.Atom)
   is
      pragma Unreferenced (Page);
   begin
      Exchange.Append (Data);
   end Append;

   procedure Render
     (Exchange : in out Sites.Exchange;
      Page : in Page_Data;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class)
   is
      use type S_Expressions.Events.Event;

      procedure Re_Enter
        (Exchange : in out Sites.Exchange;
         Expression : in out S_Expressions.Lockable.Descriptor'Class);

      procedure Render_Date (Log_Error : in Boolean);

      procedure Re_Enter
        (Exchange : in out Sites.Exchange;
         Expression : in out S_Expressions.Lockable.Descriptor'Class) is
      begin
         Render_Page (Expression, Exchange, Page);
      end Re_Enter;

      procedure Render_Date (Log_Error : in Boolean) is
      begin
         if Arguments.Current_Event = S_Expressions.Events.Add_Atom then
            declare
               Cursor : constant Containers.Date_Maps.Cursor
                 := Page.Dates.Find (Arguments.Current_Atom);
            begin
               if not Containers.Date_Maps.Has_Element (Cursor) then
                  if Log_Error then
                     Log (Severities.Error, "Unable to find date """
                       & S_Expressions.To_String (Arguments.Current_Atom)
                       & """ in page date map");
                  end if;

                  return;
               end if;

               Arguments.Next;

               declare
                  Item : constant Containers.Date
                    := Containers.Date_Maps.Element (Cursor);
               begin
                  S_Expressions.Templates.Dates.Render
                    (Exchange, Arguments, Item.Time, Item.Offset);
               end;
            end;
         end if;
      end Render_Date;

      package Commands renames Natools.Static_Maps.Web.Simple_Pages;
   begin
      case Commands.To_Command (S_Expressions.To_String (Name)) is
         when Commands.Unknown_Command =>
            Fallback_Render
              (Exchange, Name, Arguments,
               "simple page",
               Re_Enter'Access, Page.Elements);

         when Commands.Comment_List =>
            Comments.Render (Exchange, Page.Comment_List, Arguments);

         when Commands.Date =>
            Render_Date (True);

         when Commands.My_Tags =>
            if Arguments.Current_Event = S_Expressions.Events.Add_Atom then
               declare
                  Prefix : constant S_Expressions.Atom
                    := Arguments.Current_Atom;
               begin
                  Arguments.Next;
                  Tags.Render
                    (Exchange,
                     Page.Tags,
                     Exchange.Site.Get_Tags,
                     Prefix,
                     Arguments);
               end;
            end if;

         when Commands.If_No_Date =>
            if Arguments.Current_Event = S_Expressions.Events.Add_Atom
              and then not Page.Dates.Contains (Arguments.Current_Atom)
            then
               Arguments.Next;
               Render_Page (Arguments, Exchange, Page);
            end if;

         when Commands.Maps =>
            String_Tables.Render (Exchange, Page.Maps, Arguments);

         when Commands.Optional_Date =>
            Render_Date (False);

         when Commands.Path =>
            Exchange.Append (Page.Web_Path.Query);

         when Commands.Tags =>
            Tags.Render
              (Exchange,
               Exchange.Site.Get_Tags,
               Arguments,
               Page.Tags);
      end case;
   end Render;

   -------------------------
   -- Page_Data Interface --
   -------------------------

   not overriding procedure Get_Element
     (Data : in Page_Data;
      Name : in S_Expressions.Atom;
      Element : out S_Expressions.Caches.Cursor;
      Found : out Boolean)
   is
      Cursor : constant Containers.Expression_Maps.Cursor
        := Data.Elements.Find (Name);
   begin
      Found := Containers.Expression_Maps.Has_Element (Cursor);

      if Found then
         Element := Containers.Expression_Maps.Element (Cursor);
      end if;
   end Get_Element;

   ----------------------
   -- Public Interface --
   ----------------------

   function Create
     (Expression : in out S_Expressions.Lockable.Descriptor'Class)
     return Page_Ref
   is
      Page : constant Data_Refs.Data_Access := new Page_Data;
      Result : constant Page_Ref := (Ref => Data_Refs.Create (Page));
   begin
      Page.Self := Tags.Visible_Access (Page);
      Read_Page (Expression, Page.all, Meaningless_Value);
      return Result;
   end Create;

   function Create
     (File_Path, Web_Path : in S_Expressions.Atom_Refs.Immutable_Reference)
     return Page_Ref
   is
      Page : constant Data_Refs.Data_Access := new Page_Data'
        (File_Path => File_Path,
         Web_Path => Web_Path,
         Tags => <>,
         Self => null,
         Comment_List | Elements | Dates | Maps => <>);
      Result : constant Page_Ref := (Ref => Data_Refs.Create (Page));
   begin
      Page.Self := Tags.Visible_Access (Page);

      Create_Page :
      declare
         Reader : Natools.S_Expressions.File_Readers.S_Reader
           := Natools.S_Expressions.File_Readers.Reader
              (S_Expressions.To_String (File_Path.Query));
      begin
         Read_Page (Reader, Page.all, Meaningless_Value);
      end Create_Page;

      return Result;
   end Create;

   procedure Get_Lifetime
     (Page : in Page_Ref;
      Publication : out Ada.Calendar.Time;
      Has_Publication : out Boolean;
      Expiration : out Ada.Calendar.Time;
      Has_Expiration : out Boolean)
   is
      Accessor : constant Data_Refs.Accessor := Page.Ref.Query;
      Cursor : Containers.Date_Maps.Cursor;
   begin
      Cursor := Accessor.Dates.Find (Expiration_Date_Key);

      if Containers.Date_Maps.Has_Element (Cursor) then
         Has_Expiration := True;
         Expiration := Containers.Date_Maps.Element (Cursor).Time;
      else
         Has_Expiration := False;
      end if;

      Cursor := Accessor.Dates.Find (Publication_Date_Key);

      if Containers.Date_Maps.Has_Element (Cursor) then
         Has_Publication := True;
         Publication := Containers.Date_Maps.Element (Cursor).Time;
      else
         Has_Publication := False;
      end if;
   end Get_Lifetime;

   procedure Register
     (Page : in Page_Ref;
      Builder : in out Sites.Site_Builder;
      Path : in S_Expressions.Atom) is
   begin
      Time_Check :
      declare
         use type Ada.Calendar.Time;
         Now : constant Ada.Calendar.Time := Ada.Calendar.Clock;
         Publication : Ada.Calendar.Time;
         Has_Publication : Boolean;
         Expiration : Ada.Calendar.Time;
         Has_Expiration : Boolean;
      begin
         Get_Lifetime
           (Page, Publication, Has_Publication, Expiration, Has_Expiration);

         if Has_Publication and then Publication >= Now then
            Sites.Expire_At (Builder, Publication);
            return;
         end if;

         if Has_Expiration then
            if Expiration < Now then
               return;
            else
               Sites.Expire_At (Builder, Expiration);
            end if;
         end if;
      end Time_Check;

      if Path'Length > 0 then
         Sites.Insert (Builder, Path, Page);
      end if;

      Sites.Insert (Builder, Page.Get_Tags, Page);

      Load_Comments :
      declare
         Mutator : constant Data_Refs.Mutator := Page.Ref.Update;
      begin
         Mutator.Comment_List.Load (Builder, Mutator.Self, Mutator.Web_Path);
      end Load_Comments;
   end Register;

   overriding procedure Render
     (Exchange : in out Sites.Exchange;
      Object : in Page_Ref;
      Expression : in out S_Expressions.Lockable.Descriptor'Class) is
   begin
      Render_Page
        (Expression,
         Exchange,
         Object.Ref.Query.Data.all);
   end Render;

   overriding procedure Render
     (Exchange : in out Sites.Exchange;
      Object : in Page_Data;
      Expression : in out S_Expressions.Lockable.Descriptor'Class) is
   begin
      Render_Page (Expression, Exchange, Object);
   end Render;

   overriding procedure Respond
     (Object : in out Page_Ref;
      Exchange : in out Sites.Exchange;
      Extra_Path : in S_Expressions.Atom)
   is
      use type S_Expressions.Offset;
   begin
      if Extra_Path'Length = 9
        and then S_Expressions.To_String (Extra_Path) = "/comments"
      then
         Object.Ref.Update.Comment_List.Respond
           (Exchange, Extra_Path (Extra_Path'First + 9 .. Extra_Path'Last));
         return;
      end if;

      if Extra_Path'Length > 0 then
         return;
      end if;

      declare
         Accessor : constant Data_Refs.Accessor := Object.Ref.Query;
         Expression : S_Expressions.Caches.Cursor;
      begin
         Check_Method :
         declare
            use Exchanges;
            Allowed : Boolean;
         begin
            Error_Pages.Check_Method
              (Exchange,
               (GET, HEAD),
               Allowed);

            if not Allowed then
               return;
            end if;
         end Check_Method;

         Expression := Exchange.Site.Get_Template
           (Accessor.Data.Elements,
            Expression,
            Exchange.Site.Default_Template,
            Lookup_Element => True,
            Lookup_Template => True,
            Lookup_Name => True);

         Render_Page (Expression, Exchange, Accessor.Data.all);
      end;
   end Respond;

   -----------------------
   -- Page Constructors --
   -----------------------

   function Create (File : in S_Expressions.Atom)
     return Sites.Page_Loader'Class is
   begin
      return Loader'(File_Path
        => S_Expressions.Atom_Ref_Constructors.Create (File));
   end Create;

   overriding procedure Load
     (Object : in out Loader;
      Builder : in out Sites.Site_Builder;
      Path : in S_Expressions.Atom)
   is
      Page : constant Page_Ref := Create
        (Object.File_Path,
         S_Expressions.Atom_Ref_Constructors.Create (Path));
   begin
      Register (Page, Builder, Path);
   end Load;

   procedure Register_Loader (Site : in out Sites.Site) is
   begin
      Site.Register ("simple-page", Create'Access);
   end Register_Loader;

end Natools.Web.Simple_Pages;

simple_pages: update site expiration to auto-publish and auto-expire