-----------------------------------------------------------------------
--  security-policies-roles -- Role based policies
--  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 Util.Log.Loggers;
with Util.Serialize.Mappers.Record_Mapper;

with Security.Controllers;
with Security.Controllers.Roles;

package body Security.Policies.Roles is

   use Util.Log;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Security.Policies.Roles");

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

   --  ------------------------------
   --  Get the role name.
   --  ------------------------------
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      if Manager.Names (Role) = null then
         return "";
      else
         return Manager.Names (Role).all;
      end if;
   end Get_Role_Name;

   --  ------------------------------
   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   --  ------------------------------
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      Log.Debug ("Searching role {0}", Name);

      for I in Role_Type'First .. Manager.Next_Role loop
         exit when Manager.Names (I) = null;
         if Name = Manager.Names (I).all then
            return I;
         end if;
      end loop;

      Log.Debug ("Role {0} not found", Name);
      raise Invalid_Name;
   end Find_Role;

   --  ------------------------------
   --  Create a role
   --  ------------------------------
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type) is
   begin
      Role := Manager.Next_Role;
      Log.Info ("Role {0} is {1}", Name, Role_Type'Image (Role));

      if Manager.Next_Role = Role_Type'Last then
         Log.Error ("Too many roles allocated.  Number of roles is {0}",
                    Role_Type'Image (Role_Type'Last));
      else
         Manager.Next_Role := Manager.Next_Role + 1;
      end if;
      Manager.Names (Role) := new String '(Name);
   end Create_Role;

   --  ------------------------------
   --  Get or build a permission type for the given name.
   --  ------------------------------
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type) is
   begin
      Result := Manager.Find_Role (Name);

   exception
      when Invalid_Name =>
         Manager.Create_Role (Name, Result);
   end Add_Role_Type;

   type Config_Fields is (FIELD_NAME, FIELD_ROLE, FIELD_ROLE_PERMISSION, FIELD_ROLE_NAME);

   type Controller_Config_Access is access all Controller_Config;

   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Called while parsing the XML policy file when the <name>, <role> and <role-permission>
   --  XML entities are found.  Create the new permission when the complete permission definition
   --  has been parsed and save the permission in the security manager.
   --  ------------------------------
   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use Security.Controllers.Roles;
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_ROLE =>
            declare
               Role : constant String := Util.Beans.Objects.To_String (Value);
            begin
               Into.Roles (Into.Count + 1) := Into.Manager.Find_Role (Role);
               Into.Count := Into.Count + 1;

            exception
               when Permissions.Invalid_Name =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid role: " & Role;
            end;

         when FIELD_ROLE_PERMISSION =>
            if Into.Count = 0 then
               raise Util.Serialize.Mappers.Field_Error with "Missing at least one role";
            end if;
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Name);
               Perm : constant Role_Controller_Access
                 := new Role_Controller '(Count => Into.Count,
                                          Roles => Into.Roles (1 .. Into.Count));
            begin
               Into.Manager.Add_Permission (Name, Perm.all'Access);
               Into.Count := 0;
            end;

         when FIELD_ROLE_NAME =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
               Role : Role_Type;
            begin
               Into.Manager.Add_Role_Type (Name, Role);
            end;
      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Controller_Config,
                                               Element_Type_Access => Controller_Config_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Mapper : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the role-permission description.
   --  ------------------------------
   procedure Prepare_Config (Policy : in out Role_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser) is
      Config : Controller_Config_Access := new Controller_Config;
   begin
      Reader.Add_Mapping ("policy-rules", Mapper'Access);
      Reader.Add_Mapping ("module", Mapper'Access);
      Config.Manager := Policy'Unchecked_Access;
      Config_Mapper.Set_Context (Reader, Config);
   end Prepare_Config;

   --  ------------------------------
   --  Finalize the policy manager.
   --  ------------------------------
   overriding
   procedure Finalize (Policy : in out Role_Policy) is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      for I in Policy.Names'Range loop
         exit when Policy.Names (I) = null;
         Ada.Strings.Unbounded.Free (Policy.Names (I));
      end loop;
   end Finalize;

begin
   Mapper.Add_Mapping ("role-permission", FIELD_ROLE_PERMISSION);
   Mapper.Add_Mapping ("role-permission/name", FIELD_NAME);
   Mapper.Add_Mapping ("role-permission/role", FIELD_ROLE);
   Mapper.Add_Mapping ("security-role/role-name", FIELD_ROLE_NAME);
end Security.Policies.Roles;

-----------------------------------------------------------------------
--  security-policies-roles -- Role based policies
--  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 Util.Log.Loggers;
with Util.Serialize.Mappers.Record_Mapper;

with Security.Controllers;
with Security.Controllers.Roles;

package body Security.Policies.Roles is

   use Util.Log;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Security.Policies.Roles");

   --  ------------------------------
   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   --  ------------------------------
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in Role_Map) is
      Policy : constant Security.Policies.Policy_Access := Context.Get_Policy (NAME);
      Data   : Role_Policy_Context_Access;
   begin
      if Policy = null then
         Log.Error ("There is no security policy: " & NAME);
      end if;
      Data := new Role_Policy_Context;
      Data.Roles := Roles;

      Context.Set_Policy_Context (Policy, Data.all'Access);
   end Set_Role_Context;

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

   --  ------------------------------
   --  Get the role name.
   --  ------------------------------
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      if Manager.Names (Role) = null then
         return "";
      else
         return Manager.Names (Role).all;
      end if;
   end Get_Role_Name;

   --  ------------------------------
   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   --  ------------------------------
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      Log.Debug ("Searching role {0}", Name);

      for I in Role_Type'First .. Manager.Next_Role loop
         exit when Manager.Names (I) = null;
         if Name = Manager.Names (I).all then
            return I;
         end if;
      end loop;

      Log.Debug ("Role {0} not found", Name);
      raise Invalid_Name;
   end Find_Role;

   --  ------------------------------
   --  Create a role
   --  ------------------------------
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type) is
   begin
      Role := Manager.Next_Role;
      Log.Info ("Role {0} is {1}", Name, Role_Type'Image (Role));

      if Manager.Next_Role = Role_Type'Last then
         Log.Error ("Too many roles allocated.  Number of roles is {0}",
                    Role_Type'Image (Role_Type'Last));
      else
         Manager.Next_Role := Manager.Next_Role + 1;
      end if;
      Manager.Names (Role) := new String '(Name);
   end Create_Role;

   --  ------------------------------
   --  Get or build a permission type for the given name.
   --  ------------------------------
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type) is
   begin
      Result := Manager.Find_Role (Name);

   exception
      when Invalid_Name =>
         Manager.Create_Role (Name, Result);
   end Add_Role_Type;

   type Config_Fields is (FIELD_NAME, FIELD_ROLE, FIELD_ROLE_PERMISSION, FIELD_ROLE_NAME);

   type Controller_Config_Access is access all Controller_Config;

   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Called while parsing the XML policy file when the <name>, <role> and <role-permission>
   --  XML entities are found.  Create the new permission when the complete permission definition
   --  has been parsed and save the permission in the security manager.
   --  ------------------------------
   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use Security.Controllers.Roles;
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_ROLE =>
            declare
               Role : constant String := Util.Beans.Objects.To_String (Value);
            begin
               Into.Roles (Into.Count + 1) := Into.Manager.Find_Role (Role);
               Into.Count := Into.Count + 1;

            exception
               when Permissions.Invalid_Name =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid role: " & Role;
            end;

         when FIELD_ROLE_PERMISSION =>
            if Into.Count = 0 then
               raise Util.Serialize.Mappers.Field_Error with "Missing at least one role";
            end if;
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Name);
               Perm : constant Role_Controller_Access
                 := new Role_Controller '(Count => Into.Count,
                                          Roles => Into.Roles (1 .. Into.Count));
            begin
               Into.Manager.Add_Permission (Name, Perm.all'Access);
               Into.Count := 0;
            end;

         when FIELD_ROLE_NAME =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
               Role : Role_Type;
            begin
               Into.Manager.Add_Role_Type (Name, Role);
            end;
      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Controller_Config,
                                               Element_Type_Access => Controller_Config_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Mapper : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the role-permission description.
   --  ------------------------------
   procedure Prepare_Config (Policy : in out Role_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser) is
      Config : Controller_Config_Access := new Controller_Config;
   begin
      Reader.Add_Mapping ("policy-rules", Mapper'Access);
      Reader.Add_Mapping ("module", Mapper'Access);
      Config.Manager := Policy'Unchecked_Access;
      Config_Mapper.Set_Context (Reader, Config);
   end Prepare_Config;

   --  ------------------------------
   --  Finalize the policy manager.
   --  ------------------------------
   overriding
   procedure Finalize (Policy : in out Role_Policy) is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      for I in Policy.Names'Range loop
         exit when Policy.Names (I) = null;
         Ada.Strings.Unbounded.Free (Policy.Names (I));
      end loop;
   end Finalize;

begin
   Mapper.Add_Mapping ("role-permission", FIELD_ROLE_PERMISSION);
   Mapper.Add_Mapping ("role-permission/name", FIELD_NAME);
   Mapper.Add_Mapping ("role-permission/role", FIELD_ROLE);
   Mapper.Add_Mapping ("security-role/role-name", FIELD_ROLE_NAME);
end Security.Policies.Roles;

Implement Set_Role_Context

Implement Set_Role_Context


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

with Ada.IO_Exceptions;
with GNAT.MD5;

with Util.Log.Loggers;
with Util.Properties;
with Util.Beans.Basic;
with Util.Strings.Transforms;

with EL.Functions;

with ASF.Applications;
with ASF.Applications.Main;

with ADO.Queries;
with ADO.Sessions;

with AWA.Applications.Factory;
with AWA.Services.Contexts;
with Atlas.Applications.Models;

--  with Atlas.XXX.Module;
package body Atlas.Applications is

   package ASC renames AWA.Services.Contexts;

   use AWA.Applications;

   type User_Stat_Info_Access is access all Atlas.Applications.Models.User_Stat_Info;

   Log     : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Atlas");

   procedure Set_Functions (Mapper : in out EL.Functions.Function_Mapper'Class);
   function Create_User_Stat_Bean return Util.Beans.Basic.Readonly_Bean_Access;

   --  ------------------------------
   --  Create the user statistics bean which indicates what feature the user has used.
   --  ------------------------------
   function Create_User_Stat_Bean return Util.Beans.Basic.Readonly_Bean_Access is
      use type ASC.Service_Context_Access;

      Ctx    : constant ASC.Service_Context_Access := ASC.Current;
      Result : User_Stat_Info_Access;
   begin
      if Ctx /= null then
         declare
            List    : Atlas.Applications.Models.User_Stat_Info_List_Bean;
            Session : ADO.Sessions.Session := ASC.Get_Session (Ctx);
            User    : constant ADO.Identifier := Ctx.Get_User_Identifier;
            Query   : ADO.Queries.Context;
         begin
            Query.Set_Query (Atlas.Applications.Models.Query_User_Stat);
            Query.Bind_Param ("user_id", User);
            Atlas.Applications.Models.List (List, Session, Query);

            Result := new Atlas.Applications.Models.User_Stat_Info;
            Result.all := List.List.Element (0);
         end;
      else
         Result := new Atlas.Applications.Models.User_Stat_Info;
         Result.Post_Count     := 0;
         Result.Document_Count := 0;
         Result.Question_Count := 0;
         Result.Answer_Count   := 0;
      end if;
      return Result.all'Access;
   end Create_User_Stat_Bean;

   --  ------------------------------
   --  Given an Email address, return the Gravatar link to the user image.
   --  (See http://en.gravatar.com/site/implement/hash/ and
   --  http://en.gravatar.com/site/implement/images/)
   --  ------------------------------
   function Get_Gravatar_Link (Email : in String) return String is
      E : constant String := Util.Strings.Transforms.To_Lower_Case (Email);
      C : constant GNAT.MD5.Message_Digest := GNAT.MD5.Digest (E);
   begin
      return "http://www.gravatar.com/avatar/" & C;
   end Get_Gravatar_Link;

   --  ------------------------------
   --  EL function to convert an Email address to a Gravatar image.
   --  ------------------------------
   function To_Gravatar_Link (Email : in Util.Beans.Objects.Object)
                              return Util.Beans.Objects.Object is
      Link : constant String := Get_Gravatar_Link (Util.Beans.Objects.To_String (Email));
   begin
      return Util.Beans.Objects.To_Object (Link);
   end To_Gravatar_Link;

   procedure Set_Functions (Mapper : in out EL.Functions.Function_Mapper'Class) is
   begin
      Mapper.Set_Function (Name      => "gravatar",
                           Namespace => ATLAS_NS_URI,
                           Func      => To_Gravatar_Link'Access);
   end Set_Functions;

   --  ------------------------------
   --  Initialize the application:
   --

   --
Register the servlets and filters.
   --
Register the application modules.
   --
Define the servlet and filter mappings.
   --

   --  ------------------------------
   procedure Initialize (App : in Application_Access) is
      Fact  : AWA.Applications.Factory.Application_Factory;
      C     : ASF.Applications.Config;
   begin
      App.Self := App;
      begin
         C.Load_Properties ("atlas.properties");
         Util.Log.Loggers.Initialize (Util.Properties.Manager (C));

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Log.Error ("Cannot read application configuration file {0}", CONFIG_PATH);
      end;
      App.Initialize (C, Fact);

      App.Set_Global ("contextPath", CONTEXT_PATH);
   end Initialize;

   --  ------------------------------
   --  Initialize the ASF components provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the component factories used by the application.
   --  ------------------------------
   overriding
   procedure Initialize_Components (App : in out Application) is
      procedure Register is
         new ASF.Applications.Main.Register_Functions (Set_Functions);
   begin
      Register (App);
      AWA.Applications.Application (App).Initialize_Components;
      App.Add_Converter (Name      => "smartDateConverter",
                         Converter => App.Self.Rel_Date_Converter'Access);
      App.Add_Converter (Name      => "sizeConverter",
                         Converter => App.Self.Size_Converter'Access);

      App.Register_Class (Name => "Atlas.Applications.User_Stat_Bean",
                          Handler => Create_User_Stat_Bean'Access);
   end Initialize_Components;

   --  ------------------------------
   --  Initialize the servlets provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application servlets.
   --  ------------------------------
   overriding
   procedure Initialize_Servlets (App : in out Application) is
   begin
      Log.Info ("Initializing application servlets...");

      AWA.Applications.Application (App).Initialize_Servlets;
      App.Add_Servlet (Name => "faces", Server => App.Self.Faces'Access);
      App.Add_Servlet (Name => "files", Server => App.Self.Files'Access);
      App.Add_Servlet (Name => "ajax", Server => App.Self.Ajax'Access);
      App.Add_Servlet (Name => "measures", Server => App.Self.Measures'Access);
      App.Add_Servlet (Name => "auth", Server => App.Self.Auth'Access);
      App.Add_Servlet (Name => "verify-auth", Server => App.Self.Verify_Auth'Access);
   end Initialize_Servlets;

   --  ------------------------------
   --  Initialize the filters provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application filters.
   --  ------------------------------
   overriding
   procedure Initialize_Filters (App : in out Application) is
   begin
      Log.Info ("Initializing application filters...");

      AWA.Applications.Application (App).Initialize_Filters;
      App.Add_Filter (Name => "dump", Filter => App.Self.Dump'Access);
      App.Add_Filter (Name => "measures", Filter => App.Self.Measures'Access);
      App.Add_Filter (Name => "service", Filter => App.Self.Service_Filter'Access);
      App.Add_Filter (Name => "no-cache", Filter => App.Self.No_Cache'Access);
   end Initialize_Filters;

   --  ------------------------------
   --  Initialize the AWA modules provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the modules used by the application.
   --  ------------------------------
   overriding
   procedure Initialize_Modules (App : in out Application) is
   begin
      Log.Info ("Initializing application modules...");

      Register (App    => App.Self.all'Access,
                Name   => AWA.Users.Modules.NAME,
                URI    => "user",
                Module => App.User_Module'Access);

      Register (App    => App.Self.all'Access,
                Name   => AWA.Workspaces.Modules.NAME,
                URI    => "workspaces",
                Module => App.Workspace_Module'Access);

      Register (App    => App.Self.all'Access,
                Name   => AWA.Mail.Modules.NAME,
                URI    => "mail",
                Module => App.Mail_Module'Access);

      Register (App    => App.Self.all'Access,
                Name   => AWA.Counters.Modules.NAME,
                Module => App.Counter_Module'Access);

      Register (App    => App.Self.all'Access,
                Name   => AWA.Jobs.Modules.NAME,
                URI    => "jobs",
                Module => App.Job_Module'Access);

      Register (App    => App.Self.all'Access,
                Name   => AWA.Tags.Modules.NAME,
                URI    => "tags",
                Module => App.Tag_Module'Access);

      Register (App    => App.Self.all'Access,
                Name   => AWA.Comments.Modules.NAME,
                URI    => "comments",
                Module => App.Comment_Module'Access);

      Register (App    => App.Self.all'Access,
                Name   => AWA.Blogs.Modules.NAME,
                URI    => "blogs",
                Module => App.Blog_Module'Access);

      Register (App    => App.Self.all'Access,
                Name   => AWA.Storages.Modules.NAME,
                URI    => "storages",
                Module => App.Storage_Module'Access);

      Register (App    => App.Self.all'Access,
                Name   => AWA.Images.Modules.NAME,
                URI    => "images",
                Module => App.Image_Module'Access);

      Register (App    => App.Self.all'Access,
                Name   => AWA.Votes.Modules.NAME,
                URI    => "votes",
                Module => App.Vote_Module'Access);

      Register (App    => App.Self.all'Access,
                Name   => AWA.Questions.Modules.NAME,
                URI    => "questions",
                Module => App.Question_Module'Access);

      Register (App    => App.Self.all'Access,
                Name   => AWA.Wikis.Modules.NAME,
                URI    => "wikis",
                Module => App.Wiki_Module'Access);

      Register (App    => App.Self.all'Access,
                Name   => AWA.Wikis.Previews.NAME,
                URI    => "wikis-preview",
                Module => App.Preview_Module'Access);

      Register (App    => App.Self.all'Access,
                Name   => Atlas.Microblog.Modules.NAME,
                URI    => "microblog",
                Module => App.Microblog_Module'Access);

      Register (App    => App.Self.all'Access,
                Name   => Atlas.Reviews.Modules.NAME,
                URI    => "reviews",
                Module => App.Review_Module'Access);
   end Initialize_Modules;

end Atlas.Applications;

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

with GNAT.MD5;

with Util.Log.Loggers;
with Util.Beans.Basic;
with Util.Strings.Transforms;

with EL.Functions;

with ASF.Applications.Main;

with ADO.Queries;
with ADO.Sessions;

with AWA.Applications.Factory;
with AWA.Services.Contexts;
with Atlas.Applications.Models;

--  with Atlas.XXX.Module;
package body Atlas.Applications is

   package ASC renames AWA.Services.Contexts;

   use AWA.Applications;

   type User_Stat_Info_Access is access all Atlas.Applications.Models.User_Stat_Info;

   Log     : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Atlas");

   procedure Set_Functions (Mapper : in out EL.Functions.Function_Mapper'Class);
   function Create_User_Stat_Bean return Util.Beans.Basic.Readonly_Bean_Access;

   --  ------------------------------
   --  Create the user statistics bean which indicates what feature the user has used.
   --  ------------------------------
   function Create_User_Stat_Bean return Util.Beans.Basic.Readonly_Bean_Access is
      use type ASC.Service_Context_Access;

      Ctx    : constant ASC.Service_Context_Access := ASC.Current;
      Result : User_Stat_Info_Access;
   begin
      if Ctx /= null then
         declare
            List    : Atlas.Applications.Models.User_Stat_Info_List_Bean;
            Session : ADO.Sessions.Session := ASC.Get_Session (Ctx);
            User    : constant ADO.Identifier := Ctx.Get_User_Identifier;
            Query   : ADO.Queries.Context;
         begin
            Query.Set_Query (Atlas.Applications.Models.Query_User_Stat);
            Query.Bind_Param ("user_id", User);
            Atlas.Applications.Models.List (List, Session, Query);

            Result := new Atlas.Applications.Models.User_Stat_Info;
            Result.all := List.List.Element (0);
         end;
      else
         Result := new Atlas.Applications.Models.User_Stat_Info;
         Result.Post_Count     := 0;
         Result.Document_Count := 0;
         Result.Question_Count := 0;
         Result.Answer_Count   := 0;
      end if;
      return Result.all'Access;
   end Create_User_Stat_Bean;

   --  ------------------------------
   --  Given an Email address, return the Gravatar link to the user image.
   --  (See http://en.gravatar.com/site/implement/hash/ and
   --  http://en.gravatar.com/site/implement/images/)
   --  ------------------------------
   function Get_Gravatar_Link (Email : in String) return String is
      E : constant String := Util.Strings.Transforms.To_Lower_Case (Email);
      C : constant GNAT.MD5.Message_Digest := GNAT.MD5.Digest (E);
   begin
      return "http://www.gravatar.com/avatar/" & C;
   end Get_Gravatar_Link;

   --  ------------------------------
   --  EL function to convert an Email address to a Gravatar image.
   --  ------------------------------
   function To_Gravatar_Link (Email : in Util.Beans.Objects.Object)
                              return Util.Beans.Objects.Object is
      Link : constant String := Get_Gravatar_Link (Util.Beans.Objects.To_String (Email));
   begin
      return Util.Beans.Objects.To_Object (Link);
   end To_Gravatar_Link;

   procedure Set_Functions (Mapper : in out EL.Functions.Function_Mapper'Class) is
   begin
      Mapper.Set_Function (Name      => "gravatar",
                           Namespace => ATLAS_NS_URI,
                           Func      => To_Gravatar_Link'Access);
   end Set_Functions;

   --  ------------------------------
   --  Initialize the application:
   --

   --
Register the servlets and filters.
   --
Register the application modules.
   --
Define the servlet and filter mappings.
   --

   --  ------------------------------
   procedure Initialize (App    : in Application_Access;
                         Config : in ASF.Applications.Config) is
      Fact  : AWA.Applications.Factory.Application_Factory;
   begin
      App.Self := App;
      App.Initialize (Config, Fact);
      App.Set_Global ("contextPath", CONTEXT_PATH);
   end Initialize;

   --  ------------------------------
   --  Initialize the ASF components provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the component factories used by the application.
   --  ------------------------------
   overriding
   procedure Initialize_Components (App : in out Application) is
      procedure Register is
         new ASF.Applications.Main.Register_Functions (Set_Functions);
   begin
      Register (App);
      AWA.Applications.Application (App).Initialize_Components;
      App.Add_Converter (Name      => "smartDateConverter",
                         Converter => App.Self.Rel_Date_Converter'Access);
      App.Add_Converter (Name      => "sizeConverter",
                         Converter => App.Self.Size_Converter'Access);

      App.Register_Class (Name => "Atlas.Applications.User_Stat_Bean",
                          Handler => Create_User_Stat_Bean'Access);
   end Initialize_Components;

   --  ------------------------------
   --  Initialize the servlets provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application servlets.
   --  ------------------------------
   overriding
   procedure Initialize_Servlets (App : in out Application) is
   begin
      Log.Info ("Initializing application servlets...");

      AWA.Applications.Application (App).Initialize_Servlets;
      App.Add_Servlet (Name => "faces", Server => App.Self.Faces'Access);
      App.Add_Servlet (Name => "files", Server => App.Self.Files'Access);
      App.Add_Servlet (Name => "ajax", Server => App.Self.Ajax'Access);
      App.Add_Servlet (Name => "measures", Server => App.Self.Measures'Access);
      App.Add_Servlet (Name => "auth", Server => App.Self.Auth'Access);
      App.Add_Servlet (Name => "verify-auth", Server => App.Self.Verify_Auth'Access);
   end Initialize_Servlets;

   --  ------------------------------
   --  Initialize the filters provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application filters.
   --  ------------------------------
   overriding
   procedure Initialize_Filters (App : in out Application) is
   begin
      Log.Info ("Initializing application filters...");

      AWA.Applications.Application (App).Initialize_Filters;
      App.Add_Filter (Name => "dump", Filter => App.Self.Dump'Access);
      App.Add_Filter (Name => "measures", Filter => App.Self.Measures'Access);
      App.Add_Filter (Name => "service", Filter => App.Self.Service_Filter'Access);
      App.Add_Filter (Name => "no-cache", Filter => App.Self.No_Cache'Access);
   end Initialize_Filters;

   --  ------------------------------
   --  Initialize the AWA modules provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the modules used by the application.
   --  ------------------------------
   overriding
   procedure Initialize_Modules (App : in out Application) is
   begin
      Log.Info ("Initializing application modules...");

      Register (App    => App.Self.all'Access,
                Name   => AWA.Users.Modules.NAME,
                URI    => "user",
                Module => App.User_Module'Access);

      Register (App    => App.Self.all'Access,
                Name   => AWA.Workspaces.Modules.NAME,
                URI    => "workspaces",
                Module => App.Workspace_Module'Access);

      Register (App    => App.Self.all'Access,
                Name   => AWA.Mail.Modules.NAME,
                URI    => "mail",
                Module => App.Mail_Module'Access);

      Register (App    => App.Self.all'Access,
                Name   => AWA.Counters.Modules.NAME,
                Module => App.Counter_Module'Access);

      Register (App    => App.Self.all'Access,
                Name   => AWA.Jobs.Modules.NAME,
                URI    => "jobs",
                Module => App.Job_Module'Access);

      Register (App    => App.Self.all'Access,
                Name   => AWA.Tags.Modules.NAME,
                URI    => "tags",
                Module => App.Tag_Module'Access);

      Register (App    => App.Self.all'Access,
                Name   => AWA.Comments.Modules.NAME,
                URI    => "comments",
                Module => App.Comment_Module'Access);

      Register (App    => App.Self.all'Access,
                Name   => AWA.Blogs.Modules.NAME,
                URI    => "blogs",
                Module => App.Blog_Module'Access);

      Register (App    => App.Self.all'Access,
                Name   => AWA.Storages.Modules.NAME,
                URI    => "storages",
                Module => App.Storage_Module'Access);

      Register (App    => App.Self.all'Access,
                Name   => AWA.Images.Modules.NAME,
                URI    => "images",
                Module => App.Image_Module'Access);

      Register (App    => App.Self.all'Access,
                Name   => AWA.Votes.Modules.NAME,
                URI    => "votes",
                Module => App.Vote_Module'Access);

      Register (App    => App.Self.all'Access,
                Name   => AWA.Questions.Modules.NAME,
                URI    => "questions",
                Module => App.Question_Module'Access);

      Register (App    => App.Self.all'Access,
                Name   => AWA.Wikis.Modules.NAME,
                URI    => "wikis",
                Module => App.Wiki_Module'Access);

      Register (App    => App.Self.all'Access,
                Name   => AWA.Wikis.Previews.NAME,
                URI    => "wikis-preview",
                Module => App.Preview_Module'Access);

      Register (App    => App.Self.all'Access,
                Name   => Atlas.Microblog.Modules.NAME,
                URI    => "microblog",
                Module => App.Microblog_Module'Access);

      Register (App    => App.Self.all'Access,
                Name   => Atlas.Reviews.Modules.NAME,
                URI    => "reviews",
                Module => App.Review_Module'Access);
   end Initialize_Modules;

end Atlas.Applications;

Update the Initialize procedure to use the Config properties passed as parameter


-----------------------------------------------------------------------
--  util-serialize-io -- IO Drivers for serialization
--  Copyright (C) 2010, 2011, 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.Containers;
with Ada.Strings.Unbounded;

with Util.Beans.Objects;
with Util.Streams;
with Util.Streams.Buffered;
with Util.Serialize.Contexts;
with Util.Serialize.Mappers;
with Util.Log.Loggers;
with Util.Stacks;
package Util.Serialize.IO is

   Parse_Error : exception;

   --  ------------------------------
   --  Output stream for serialization
   --  ------------------------------
   --  The Output_Stream interface defines the abstract operations for
   --  the serialization framework to write objects on the stream according to
   --  a target format such as XML or JSON.
   type Output_Stream is limited interface and Util.Streams.Output_Stream;

   --  Start a document.
   procedure Start_Document (Stream : in out Output_Stream) is null;

   --  Finish a document.
   procedure End_Document (Stream : in out Output_Stream) is null;

   procedure Start_Entity (Stream : in out Output_Stream;
                           Name   : in String) is null;

   procedure End_Entity (Stream : in out Output_Stream;
                         Name   : in String) is null;

   --  Write the attribute name/value pair.
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in String) is abstract;

   procedure Write_Wide_Attribute (Stream : in out Output_Stream;
                                   Name   : in String;
                                   Value  : in Wide_Wide_String) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Integer) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Boolean) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream'Class;
                              Name   : in String;
                              Value  : in Ada.Strings.Unbounded.Unbounded_String);

   --  Write the entity value.
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in String) is abstract;

   procedure Write_Wide_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Wide_Wide_String) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Boolean) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Integer) is abstract;

   procedure Write_Long_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Long_Long_Integer) is abstract;

   procedure Write_Enum_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in String) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream'Class;
                           Name   : in String;
                           Value  : in Ada.Strings.Unbounded.Unbounded_String);

   procedure Start_Array (Stream : in out Output_Stream;
                          Name   : in String) is null;

   procedure End_Array (Stream : in out Output_Stream;
                        Name   : in String) is null;

   type Parser is abstract new Util.Serialize.Contexts.Context with private;

   --  Parse the stream using the JSON parser.
   procedure Parse (Handler : in out Parser;
                    Stream  : in out Util.Streams.Buffered.Buffered_Stream'Class) is abstract;

   --  Read the file and parse it using the parser.
   procedure Parse (Handler : in out Parser;
                    File    : in String);

   --  Parse the content string.
   procedure Parse_String (Handler : in out Parser;
                           Content : in String);

   --  Returns true if the Parse operation detected at least one error.
   function Has_Error (Handler : in Parser) return Boolean;

   --  Set the error logger to report messages while parsing and reading the input file.
   procedure Set_Logger (Handler : in out Parser;
                         Logger  : in Util.Log.Loggers.Logger_Access);

   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  Set_Member procedure will associate the name/value pair on the
   --  new object.
   procedure Start_Object (Handler : in out Parser;
                           Name    : in String);

   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   procedure Finish_Object (Handler : in out Parser;
                            Name    : in String);

   procedure Start_Array (Handler : in out Parser;
                          Name    : in String);

   procedure Finish_Array (Handler : in out Parser;
                           Name    : in String);

   --  Set the name/value pair on the current object.  For each active mapping,
   --  find whether a rule matches our name and execute it.
   procedure Set_Member (Handler   : in out Parser;
                         Name      : in String;
                         Value     : in Util.Beans.Objects.Object;
                         Attribute : in Boolean := False);

   --  Get the current location (file and line) to report an error message.
   function Get_Location (Handler : in Parser) return String;

   --  Report an error while parsing the input stream.  The error message will be reported
   --  on the logger associated with the parser.  The parser will be set as in error so that
   --  the Has_Error function will return True after parsing the whole file.
   procedure Error (Handler : in out Parser;
                    Message : in String);

   procedure Add_Mapping (Handler : in out Parser;
                          Path    : in String;
                          Mapper  : in Util.Serialize.Mappers.Mapper_Access);

   --  Dump the mapping tree on the logger using the INFO log level.
   procedure Dump (Handler : in Parser'Class;
                   Logger  : in Util.Log.Loggers.Logger'Class);

private

   --  Implementation limitation:  the max number of active mapping nodes
   MAX_NODES : constant Positive := 10;

   type Mapper_Access_Array is array (1 .. MAX_NODES) of Serialize.Mappers.Mapper_Access;

   procedure Push (Handler : in out Parser);

   --  Pop the context and restore the previous context when leaving an element
   procedure Pop (Handler  : in out Parser);

   function Find_Mapper (Handler : in Parser;
                         Name    : in String) return Util.Serialize.Mappers.Mapper_Access;

   type Element_Context is record
      --  The object mapper being process.
      Object_Mapper : Util.Serialize.Mappers.Mapper_Access;

      --  The active mapping nodes.
      Active_Nodes : Mapper_Access_Array;
   end record;
   type Element_Context_Access is access all Element_Context;

   package Context_Stack is new Util.Stacks (Element_Type => Element_Context,
                                             Element_Type_Access => Element_Context_Access);

   type Parser is abstract new Util.Serialize.Contexts.Context with record
      Error_Flag     : Boolean := False;
      Stack          : Context_Stack.Stack;
      Mapping_Tree   : aliased Mappers.Mapper;
      Current_Mapper : Util.Serialize.Mappers.Mapper_Access;

      --  The file name to use when reporting errors.
      File           : Ada.Strings.Unbounded.Unbounded_String;

      --  The logger which is used to report error messages when parsing an input file.
      Error_Logger   : Util.Log.Loggers.Logger_Access := null;
   end record;

end Util.Serialize.IO;

-----------------------------------------------------------------------
--  util-serialize-io -- IO Drivers for serialization
--  Copyright (C) 2010, 2011, 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.Containers;
with Ada.Strings.Unbounded;
with Ada.Calendar;

with Util.Beans.Objects;
with Util.Streams;
with Util.Streams.Buffered;
with Util.Serialize.Contexts;
with Util.Serialize.Mappers;
with Util.Log.Loggers;
with Util.Stacks;
package Util.Serialize.IO is

   Parse_Error : exception;

   --  ------------------------------
   --  Output stream for serialization
   --  ------------------------------
   --  The Output_Stream interface defines the abstract operations for
   --  the serialization framework to write objects on the stream according to
   --  a target format such as XML or JSON.
   type Output_Stream is limited interface and Util.Streams.Output_Stream;

   --  Start a document.
   procedure Start_Document (Stream : in out Output_Stream) is null;

   --  Finish a document.
   procedure End_Document (Stream : in out Output_Stream) is null;

   procedure Start_Entity (Stream : in out Output_Stream;
                           Name   : in String) is null;

   procedure End_Entity (Stream : in out Output_Stream;
                         Name   : in String) is null;

   --  Write the attribute name/value pair.
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in String) is abstract;

   procedure Write_Wide_Attribute (Stream : in out Output_Stream;
                                   Name   : in String;
                                   Value  : in Wide_Wide_String) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Integer) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Boolean) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream'Class;
                              Name   : in String;
                              Value  : in Ada.Strings.Unbounded.Unbounded_String);

   --  Write the entity value.
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in String) is abstract;

   procedure Write_Wide_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Wide_Wide_String) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Boolean) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Integer) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Ada.Calendar.Time) is abstract;

   procedure Write_Long_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Long_Long_Integer) is abstract;

   procedure Write_Enum_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in String) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream'Class;
                           Name   : in String;
                           Value  : in Ada.Strings.Unbounded.Unbounded_String);

   procedure Start_Array (Stream : in out Output_Stream;
                          Name   : in String) is null;

   procedure End_Array (Stream : in out Output_Stream;
                        Name   : in String) is null;

   type Parser is abstract new Util.Serialize.Contexts.Context with private;

   --  Parse the stream using the JSON parser.
   procedure Parse (Handler : in out Parser;
                    Stream  : in out Util.Streams.Buffered.Buffered_Stream'Class) is abstract;

   --  Read the file and parse it using the parser.
   procedure Parse (Handler : in out Parser;
                    File    : in String);

   --  Parse the content string.
   procedure Parse_String (Handler : in out Parser;
                           Content : in String);

   --  Returns true if the Parse operation detected at least one error.
   function Has_Error (Handler : in Parser) return Boolean;

   --  Set the error logger to report messages while parsing and reading the input file.
   procedure Set_Logger (Handler : in out Parser;
                         Logger  : in Util.Log.Loggers.Logger_Access);

   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  Set_Member procedure will associate the name/value pair on the
   --  new object.
   procedure Start_Object (Handler : in out Parser;
                           Name    : in String);

   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   procedure Finish_Object (Handler : in out Parser;
                            Name    : in String);

   procedure Start_Array (Handler : in out Parser;
                          Name    : in String);

   procedure Finish_Array (Handler : in out Parser;
                           Name    : in String);

   --  Set the name/value pair on the current object.  For each active mapping,
   --  find whether a rule matches our name and execute it.
   procedure Set_Member (Handler   : in out Parser;
                         Name      : in String;
                         Value     : in Util.Beans.Objects.Object;
                         Attribute : in Boolean := False);

   --  Get the current location (file and line) to report an error message.
   function Get_Location (Handler : in Parser) return String;

   --  Report an error while parsing the input stream.  The error message will be reported
   --  on the logger associated with the parser.  The parser will be set as in error so that
   --  the Has_Error function will return True after parsing the whole file.
   procedure Error (Handler : in out Parser;
                    Message : in String);

   procedure Add_Mapping (Handler : in out Parser;
                          Path    : in String;
                          Mapper  : in Util.Serialize.Mappers.Mapper_Access);

   --  Dump the mapping tree on the logger using the INFO log level.
   procedure Dump (Handler : in Parser'Class;
                   Logger  : in Util.Log.Loggers.Logger'Class);

private

   --  Implementation limitation:  the max number of active mapping nodes
   MAX_NODES : constant Positive := 10;

   type Mapper_Access_Array is array (1 .. MAX_NODES) of Serialize.Mappers.Mapper_Access;

   procedure Push (Handler : in out Parser);

   --  Pop the context and restore the previous context when leaving an element
   procedure Pop (Handler  : in out Parser);

   function Find_Mapper (Handler : in Parser;
                         Name    : in String) return Util.Serialize.Mappers.Mapper_Access;

   type Element_Context is record
      --  The object mapper being process.
      Object_Mapper : Util.Serialize.Mappers.Mapper_Access;

      --  The active mapping nodes.
      Active_Nodes : Mapper_Access_Array;
   end record;
   type Element_Context_Access is access all Element_Context;

   package Context_Stack is new Util.Stacks (Element_Type => Element_Context,
                                             Element_Type_Access => Element_Context_Access);

   type Parser is abstract new Util.Serialize.Contexts.Context with record
      Error_Flag     : Boolean := False;
      Stack          : Context_Stack.Stack;
      Mapping_Tree   : aliased Mappers.Mapper;
      Current_Mapper : Util.Serialize.Mappers.Mapper_Access;

      --  The file name to use when reporting errors.
      File           : Ada.Strings.Unbounded.Unbounded_String;

      --  The logger which is used to report error messages when parsing an input file.
      Error_Logger   : Util.Log.Loggers.Logger_Access := null;
   end record;

end Util.Serialize.IO;

Declare the Write_Entity operation with a date/time


-----------------------------------------------------------------------
--  wiki-filters-html -- Wiki HTML filters
--  Copyright (C) 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Wide_Wide_Characters.Handling;
package body Wiki.Filters.Html is
  function Need_Close (Tag         : in Html_Tag_Type;
                        Current_Tag : in Html_Tag_Type) return Boolean;

   type Tag_Name_Array is array (Html_Tag_Type) of Unbounded_Wide_Wide_String;

   No_End_Tag   : constant Tag_Boolean_Array :=
     (
      BASE_TAG   => True,
      LINK_TAG   => True,
      META_TAG   => True,
      IMG_TAG    => True,
      HR_TAG     => True,
      BR_TAG     => True,
      WBR_TAG    => True,
      INPUT_TAG  => True,
      KEYGEN_TAG => True,
      others     => False);

   Tag_Omission : constant Tag_Boolean_Array :=
     (
      --  Section 4.4 Grouping content
      LI_TAG    => True,
      DT_TAG    => True,
      DD_TAG    => True,

      --  Section 4.5 Text-level semantics
      RB_TAG    => True,
      RT_TAG    => True,
      RTC_TAG   => True,
      RP_TAG    => True,

      --  Section 4.9 Tabular data
      TH_TAG    => True,
      TD_TAG    => True,
      TR_TAG    => True,
      TBODY_TAG => True,
      THEAD_TAG => True,
      TFOOT_TAG => True,

      OPTGROUP_TAG => True,
      OPTION_TAG   => True,

      others    => False);

   --  ------------------------------
   --  Add a simple node such as N_LINE_BREAK, N_HORIZONTAL_RULE or N_PARAGRAPH to the document.
   --  ------------------------------
   overriding
   procedure Add_Node (Filter    : in out Html_Filter_Type;
                       Document  : in out Wiki.Nodes.Document;
                       Kind      : in Wiki.Nodes.Simple_Node_Kind) is
     Tag : Html_Tag_Type;
   begin
     case Kind is
        when N_LINE_BREAK =>
           Tag := BR_TAG;

        when N_PARAGRAPH =>
           Tag := P_TAG;

        when N_HORIZONTAL_RULE =>
           Tag := HR_TAG;

     end case;
     if Filter.Allowed (Tag) then
        Filter_Type (Filter).Add_Node (Document, Kind);
     end if;
   end Add_Node;

   --  ------------------------------
   --  Add a text content with the given format to the document.
   --  ------------------------------
   overriding
   procedure Add_Text (Filter    : in out Html_Filter_Type;
                       Document  : in out Wiki.Nodes.Document;
                       Text      : in Wiki.Strings.WString;
                       Format    : in Wiki.Nodes.Format_Map) is
   begin
      if Filter.Hide_Level > 0 then
         return;
      elsif not Filter.Stack.Is_Empty then
         declare
            Current_Tag : constant Html_Tag_Type := Filter.Stack.Last_Element;
         begin
            if No_End_Tag (Current_Tag) then
               Filter_Type (Filter).Pop_Node (Document, Current_Tag);
               Filter.Stack.Delete_Last;
            end if;
         end;
      end if;
      Filter_Type (Filter).Add_Text (Document, Text, Format);
   end Add_Text;

   --  ------------------------------
   --  Add a section header with the given level in the document.
   --  ------------------------------
   overriding
   procedure Add_Header (Filter    : in out Html_Filter_Type;
                         Document  : in out Wiki.Nodes.Document;
                         Header    : in Wiki.Strings.WString;
                         Level     : in Natural) is
   begin
      Filter.Flush_Stack (Document);
      Filter_Type (Filter).Add_Header (Document, Header, Level);
   end Add_Header;

   --  ------------------------------
   --  Push a HTML node with the given tag to the document.
   --  ------------------------------
   overriding
   procedure Push_Node (Filter     : in out Html_Filter_Type;
                        Document   : in out Wiki.Nodes.Document;
                        Tag        : in Wiki.Nodes.Html_Tag_Type;
                        Attributes : in out Wiki.Attributes.Attribute_List_Type) is
      Current_Tag : Html_Tag_Type;
   begin
      while not Filter.Stack.Is_Empty loop
         Current_Tag := Filter.Stack.Last_Element;
         if Need_Close (Tag, Current_Tag) then
            if Filter.Hide_Level = 0 then
               Filter_Type (Filter).Pop_Node (Document, Current_Tag);
            end if;
            Filter.Stack.Delete_Last;
         end if;
         exit when not No_End_Tag (Current_Tag);
      end loop;
      if Filter.Hidden (Tag) then
         Filter.Hide_Level := Filter.Hide_Level + 1;
      elsif not Filter.Allowed (Tag) then
         return;
      end if;
      Filter.Stack.Append (Tag);
      if Filter.Hide_Level = 0 then
         Filter_Type (Filter).Push_Node (Document, Tag, Attributes);
      end if;
   end Push_Node;

   --  ------------------------------
   --  Pop a HTML node with the given tag.
   --  ------------------------------
   overriding
   procedure Pop_Node (Filter   : in out Html_Filter_Type;
                       Document : in out Wiki.Nodes.Document;
                       Tag      : in Wiki.Nodes.Html_Tag_Type) is
      Current_Tag : Html_Tag_Type;
   begin
      if Filter.Stack.Is_Empty then
         return;
      elsif not Filter.Allowed (Tag) and not Filter.Hidden (Tag) then
         return;
      end if;

      --  Emit a end tag element until we find our matching tag and the top most tag
      --  allows the end tag to be omitted (ex: a td, tr, td, dd, ...).
      while not Filter.Stack.Is_Empty loop
         Current_Tag := Filter.Stack.Last_Element;
         exit when Current_Tag = Tag or not Tag_Omission (Current_Tag);
         if Filter.Hide_Level = 0 then
            Filter_Type (Filter).Pop_Node (Document, Current_Tag);
         end if;
         Filter.Stack.Delete_Last;
      end loop;

      if Filter.Hide_Level = 0 then
         Filter_Type (Filter).Pop_Node (Document, Tag);
      end if;
      if Filter.Hidden (Current_Tag) then
         Filter.Hide_Level := Filter.Hide_Level - 1;
      end if;
      Filter.Stack.Delete_Last;
   end Pop_Node;

   --  ------------------------------
   --  Add a link.
   --  ------------------------------
   overriding
   procedure Add_Link (Filter     : in out Html_Filter_Type;
                       Document   : in out Wiki.Nodes.Document;
                       Name       : in Wiki.Strings.WString;
                       Attributes : in out Wiki.Attributes.Attribute_List_Type) is
   begin
      if Filter.Allowed (A_TAG) then
         Filter_Type (Filter).Add_Link (Document, Name, Attributes);
      end if;
   end Add_Link;

   --  ------------------------------
   --  Add an image.
   --  ------------------------------
   overriding
   procedure Add_Image (Filter     : in out Html_Filter_Type;
                        Document   : in out Wiki.Nodes.Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List_Type) is
   begin
      if Filter.Allowed (IMG_TAG) then
         Filter_Type (Filter).Add_Image (Document, Name, Attributes);
      end if;
   end Add_Image;

   --  ------------------------------
   --  Given the current tag on the top of the stack and the new tag that will be pushed,
   --  decide whether the current tag must be closed or not.
   --  Returns True if the current tag must be closed.
   --  ------------------------------
   function Need_Close (Tag         : in Html_Tag_Type;
                        Current_Tag : in Html_Tag_Type) return Boolean is
   begin
      if No_End_Tag (Current_Tag) then
         return True;
      elsif Current_Tag = Tag and Tag_Omission (Current_Tag) then
         return True;
      else
         case Current_Tag is
            when DT_TAG | DD_TAG =>
               return Tag = DD_TAG or Tag = DL_TAG or Tag = DT_TAG;

            when TD_TAG =>
               return Tag = TD_TAG or Tag = TR_TAG or Tag = TH_TAG;

            when TR_TAG =>
               return False;

            when others =>
               return False;

         end case;
      end if;
   end Need_Close;

   --  ------------------------------
   --  Flush the HTML element that have not yet been closed.
   --  ------------------------------
   procedure Flush_Stack (Filter   : in out Html_Filter_Type;
                          Document : in out Wiki.Nodes.Document) is
   begin
      while not Filter.Stack.Is_Empty loop
         declare
            Tag : constant Html_Tag_Type := Filter.Stack.Last_Element;
         begin
            if Filter.Hide_Level = 0 then
               Filter_Type (Filter).Pop_Node (Document, Tag);
            end if;
            if Filter.Hidden (Tag) then
               Filter.Hide_Level := Filter.Hide_Level - 1;
            end if;
         end;
         Filter.Stack.Delete_Last;
      end loop;
   end Flush_Stack;

   --  ------------------------------
   --  Finish the document after complete wiki text has been parsed.
   --  ------------------------------
   overriding
   procedure Finish (Filter : in out Html_Filter_Type;
                     Document : in out Wiki.Nodes.Document) is
   begin
      Filter.Flush_Stack (Document);
      Filter_Type (Filter).Finish (Document);
   end Finish;

   --  ------------------------------
   --  Mark the HTML tag as being forbidden.
   --  ------------------------------
   procedure Forbidden (Filter : in out Html_Filter_Type;
                        Tag    : in Html_Tag_Type) is
   begin
      Filter.Allowed (Tag) := False;
   end Forbidden;

   --  ------------------------------
   --  Mark the HTML tag as being allowed.
   --  ------------------------------
   procedure Allowed (Filter : in out Html_Filter_Type;
                      Tag    : in Html_Tag_Type) is
   begin
      Filter.Allowed (Tag) := True;
   end Allowed;

   --  ------------------------------
   --  Mark the HTML tag as being hidden.  The tag and its inner content including the text
   --  will be removed and not passed to the final document.
   --  ------------------------------
   procedure Hide (Filter : in out Html_Filter_Type;
                   Tag    : in Html_Tag_Type) is
   begin
      Filter.Hidden (Tag) := True;
   end Hide;

   --  ------------------------------
   --  Mark the HTML tag as being visible.
   --  ------------------------------
   procedure Visible (Filter : in out Html_Filter_Type;
                      Tag    : in Html_Tag_Type) is
   begin
      Filter.Hidden (Tag) := False;
   end Visible;

end Wiki.Filters.Html;

-----------------------------------------------------------------------
--  wiki-filters-html -- Wiki HTML filters
--  Copyright (C) 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Wide_Wide_Characters.Handling;
package body Wiki.Filters.Html is
  function Need_Close (Tag         : in Html_Tag_Type;
                        Current_Tag : in Html_Tag_Type) return Boolean;

   No_End_Tag   : constant Tag_Boolean_Array :=
     (
      BASE_TAG   => True,
      LINK_TAG   => True,
      META_TAG   => True,
      IMG_TAG    => True,
      HR_TAG     => True,
      BR_TAG     => True,
      WBR_TAG    => True,
      INPUT_TAG  => True,
      KEYGEN_TAG => True,
      others     => False);

   Tag_Omission : constant Tag_Boolean_Array :=
     (
      --  Section 4.4 Grouping content
      LI_TAG    => True,
      DT_TAG    => True,
      DD_TAG    => True,

      --  Section 4.5 Text-level semantics
      RB_TAG    => True,
      RT_TAG    => True,
      RTC_TAG   => True,
      RP_TAG    => True,

      --  Section 4.9 Tabular data
      TH_TAG    => True,
      TD_TAG    => True,
      TR_TAG    => True,
      TBODY_TAG => True,
      THEAD_TAG => True,
      TFOOT_TAG => True,

      OPTGROUP_TAG => True,
      OPTION_TAG   => True,

      others    => False);

   --  ------------------------------
   --  Add a simple node such as N_LINE_BREAK, N_HORIZONTAL_RULE or N_PARAGRAPH to the document.
   --  ------------------------------
   overriding
   procedure Add_Node (Filter    : in out Html_Filter_Type;
                       Document  : in out Wiki.Nodes.Document;
                       Kind      : in Wiki.Nodes.Simple_Node_Kind) is
     Tag : Html_Tag_Type;
   begin
     case Kind is
        when N_LINE_BREAK =>
           Tag := BR_TAG;

        when N_PARAGRAPH =>
           Tag := P_TAG;

        when N_HORIZONTAL_RULE =>
           Tag := HR_TAG;

     end case;
     if Filter.Allowed (Tag) then
        Filter_Type (Filter).Add_Node (Document, Kind);
     end if;
   end Add_Node;

   --  ------------------------------
   --  Add a text content with the given format to the document.
   --  ------------------------------
   overriding
   procedure Add_Text (Filter    : in out Html_Filter_Type;
                       Document  : in out Wiki.Nodes.Document;
                       Text      : in Wiki.Strings.WString;
                       Format    : in Wiki.Format_Map) is
   begin
      if Filter.Hide_Level > 0 then
         return;
      elsif not Filter.Stack.Is_Empty then
         declare
            Current_Tag : constant Html_Tag_Type := Filter.Stack.Last_Element;
         begin
            if No_End_Tag (Current_Tag) then
               Filter_Type (Filter).Pop_Node (Document, Current_Tag);
               Filter.Stack.Delete_Last;
            end if;
         end;
      end if;
      Filter_Type (Filter).Add_Text (Document, Text, Format);
   end Add_Text;

   --  ------------------------------
   --  Add a section header with the given level in the document.
   --  ------------------------------
   overriding
   procedure Add_Header (Filter    : in out Html_Filter_Type;
                         Document  : in out Wiki.Nodes.Document;
                         Header    : in Wiki.Strings.WString;
                         Level     : in Natural) is
   begin
      Filter.Flush_Stack (Document);
      Filter_Type (Filter).Add_Header (Document, Header, Level);
   end Add_Header;

   --  ------------------------------
   --  Push a HTML node with the given tag to the document.
   --  ------------------------------
   overriding
   procedure Push_Node (Filter     : in out Html_Filter_Type;
                        Document   : in out Wiki.Nodes.Document;
                        Tag        : in Wiki.Nodes.Html_Tag_Type;
                        Attributes : in out Wiki.Attributes.Attribute_List_Type) is
      Current_Tag : Html_Tag_Type;
   begin
      while not Filter.Stack.Is_Empty loop
         Current_Tag := Filter.Stack.Last_Element;
         if Need_Close (Tag, Current_Tag) then
            if Filter.Hide_Level = 0 then
               Filter_Type (Filter).Pop_Node (Document, Current_Tag);
            end if;
            Filter.Stack.Delete_Last;
         end if;
         exit when not No_End_Tag (Current_Tag);
      end loop;
      if Filter.Hidden (Tag) then
         Filter.Hide_Level := Filter.Hide_Level + 1;
      elsif not Filter.Allowed (Tag) then
         return;
      end if;
      Filter.Stack.Append (Tag);
      if Filter.Hide_Level = 0 then
         Filter_Type (Filter).Push_Node (Document, Tag, Attributes);
      end if;
   end Push_Node;

   --  ------------------------------
   --  Pop a HTML node with the given tag.
   --  ------------------------------
   overriding
   procedure Pop_Node (Filter   : in out Html_Filter_Type;
                       Document : in out Wiki.Nodes.Document;
                       Tag      : in Wiki.Nodes.Html_Tag_Type) is
      Current_Tag : Html_Tag_Type;
   begin
      if Filter.Stack.Is_Empty then
         return;
      elsif not Filter.Allowed (Tag) and not Filter.Hidden (Tag) then
         return;
      end if;

      --  Emit a end tag element until we find our matching tag and the top most tag
      --  allows the end tag to be omitted (ex: a td, tr, td, dd, ...).
      while not Filter.Stack.Is_Empty loop
         Current_Tag := Filter.Stack.Last_Element;
         exit when Current_Tag = Tag or not Tag_Omission (Current_Tag);
         if Filter.Hide_Level = 0 then
            Filter_Type (Filter).Pop_Node (Document, Current_Tag);
         end if;
         Filter.Stack.Delete_Last;
      end loop;

      if Filter.Hide_Level = 0 then
         Filter_Type (Filter).Pop_Node (Document, Tag);
      end if;
      if Filter.Hidden (Current_Tag) then
         Filter.Hide_Level := Filter.Hide_Level - 1;
      end if;
      Filter.Stack.Delete_Last;
   end Pop_Node;

   --  ------------------------------
   --  Add a link.
   --  ------------------------------
   overriding
   procedure Add_Link (Filter     : in out Html_Filter_Type;
                       Document   : in out Wiki.Nodes.Document;
                       Name       : in Wiki.Strings.WString;
                       Attributes : in out Wiki.Attributes.Attribute_List_Type) is
   begin
      if Filter.Allowed (A_TAG) then
         Filter_Type (Filter).Add_Link (Document, Name, Attributes);
      end if;
   end Add_Link;

   --  ------------------------------
   --  Add an image.
   --  ------------------------------
   overriding
   procedure Add_Image (Filter     : in out Html_Filter_Type;
                        Document   : in out Wiki.Nodes.Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List_Type) is
   begin
      if Filter.Allowed (IMG_TAG) then
         Filter_Type (Filter).Add_Image (Document, Name, Attributes);
      end if;
   end Add_Image;

   --  ------------------------------
   --  Given the current tag on the top of the stack and the new tag that will be pushed,
   --  decide whether the current tag must be closed or not.
   --  Returns True if the current tag must be closed.
   --  ------------------------------
   function Need_Close (Tag         : in Html_Tag_Type;
                        Current_Tag : in Html_Tag_Type) return Boolean is
   begin
      if No_End_Tag (Current_Tag) then
         return True;
      elsif Current_Tag = Tag and Tag_Omission (Current_Tag) then
         return True;
      else
         case Current_Tag is
            when DT_TAG | DD_TAG =>
               return Tag = DD_TAG or Tag = DL_TAG or Tag = DT_TAG;

            when TD_TAG =>
               return Tag = TD_TAG or Tag = TR_TAG or Tag = TH_TAG;

            when TR_TAG =>
               return False;

            when others =>
               return False;

         end case;
      end if;
   end Need_Close;

   --  ------------------------------
   --  Flush the HTML element that have not yet been closed.
   --  ------------------------------
   procedure Flush_Stack (Filter   : in out Html_Filter_Type;
                          Document : in out Wiki.Nodes.Document) is
   begin
      while not Filter.Stack.Is_Empty loop
         declare
            Tag : constant Html_Tag_Type := Filter.Stack.Last_Element;
         begin
            if Filter.Hide_Level = 0 then
               Filter_Type (Filter).Pop_Node (Document, Tag);
            end if;
            if Filter.Hidden (Tag) then
               Filter.Hide_Level := Filter.Hide_Level - 1;
            end if;
         end;
         Filter.Stack.Delete_Last;
      end loop;
   end Flush_Stack;

   --  ------------------------------
   --  Finish the document after complete wiki text has been parsed.
   --  ------------------------------
   overriding
   procedure Finish (Filter : in out Html_Filter_Type;
                     Document : in out Wiki.Nodes.Document) is
   begin
      Filter.Flush_Stack (Document);
      Filter_Type (Filter).Finish (Document);
   end Finish;

   --  ------------------------------
   --  Mark the HTML tag as being forbidden.
   --  ------------------------------
   procedure Forbidden (Filter : in out Html_Filter_Type;
                        Tag    : in Html_Tag_Type) is
   begin
      Filter.Allowed (Tag) := False;
   end Forbidden;

   --  ------------------------------
   --  Mark the HTML tag as being allowed.
   --  ------------------------------
   procedure Allowed (Filter : in out Html_Filter_Type;
                      Tag    : in Html_Tag_Type) is
   begin
      Filter.Allowed (Tag) := True;
   end Allowed;

   --  ------------------------------
   --  Mark the HTML tag as being hidden.  The tag and its inner content including the text
   --  will be removed and not passed to the final document.
   --  ------------------------------
   procedure Hide (Filter : in out Html_Filter_Type;
                   Tag    : in Html_Tag_Type) is
   begin
      Filter.Hidden (Tag) := True;
   end Hide;

   --  ------------------------------
   --  Mark the HTML tag as being visible.
   --  ------------------------------
   procedure Visible (Filter : in out Html_Filter_Type;
                      Tag    : in Html_Tag_Type) is
   begin
      Filter.Hidden (Tag) := False;
   end Visible;

end Wiki.Filters.Html;

Use Wiki.Format_Map type

Use Wiki.Format_Map type


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

   function Need_Close (Tag         : in Html_Tag;
                        Current_Tag : in Html_Tag) return Boolean;

   No_End_Tag   : constant Tag_Boolean_Array :=
     (
      BASE_TAG   => True,
      LINK_TAG   => True,
      META_TAG   => True,
      IMG_TAG    => True,
      HR_TAG     => True,
      BR_TAG     => True,
      WBR_TAG    => True,
      INPUT_TAG  => True,
      KEYGEN_TAG => True,
      others     => False);

   Tag_Omission : constant Tag_Boolean_Array :=
     (
      --  Section 4.4 Grouping content
      LI_TAG    => True,
      DT_TAG    => True,
      DD_TAG    => True,

      --  Section 4.5 Text-level semantics
      RB_TAG    => True,
      RT_TAG    => True,
      RTC_TAG   => True,
      RP_TAG    => True,

      --  Section 4.9 Tabular data
      TH_TAG    => True,
      TD_TAG    => True,
      TR_TAG    => True,
      TBODY_TAG => True,
      THEAD_TAG => True,
      TFOOT_TAG => True,

      OPTGROUP_TAG => True,
      OPTION_TAG   => True,

      others    => False);

   --  ------------------------------
   --  Add a simple node such as N_LINE_BREAK, N_HORIZONTAL_RULE or N_PARAGRAPH to the document.
   --  ------------------------------
   overriding
   procedure Add_Node (Filter    : in out Html_Filter_Type;
                       Document  : in out Wiki.Documents.Document;
                       Kind      : in Wiki.Nodes.Simple_Node_Kind) is
      Tag : Html_Tag;
   begin
      case Kind is
         when N_LINE_BREAK =>
            Tag := BR_TAG;

         when N_PARAGRAPH =>
            Tag := P_TAG;

         when N_HORIZONTAL_RULE =>
            Tag := HR_TAG;

      end case;
      if Filter.Allowed (Tag) then
         Filter_Type (Filter).Add_Node (Document, Kind);
      end if;
   end Add_Node;

   --  ------------------------------
   --  Add a text content with the given format to the document.
   --  ------------------------------
   overriding
   procedure Add_Text (Filter    : in out Html_Filter_Type;
                       Document  : in out Wiki.Documents.Document;
                       Text      : in Wiki.Strings.WString;
                       Format    : in Wiki.Format_Map) is
   begin
      if Filter.Hide_Level > 0 then
         return;
      elsif not Filter.Stack.Is_Empty then
         declare
            Current_Tag : constant Html_Tag := Filter.Stack.Last_Element;
         begin
            if No_End_Tag (Current_Tag) then
               Filter_Type (Filter).Pop_Node (Document, Current_Tag);
               Filter.Stack.Delete_Last;
            end if;
         end;
      end if;
      Filter_Type (Filter).Add_Text (Document, Text, Format);
   end Add_Text;

   --  ------------------------------
   --  Add a section header with the given level in the document.
   --  ------------------------------
   overriding
   procedure Add_Header (Filter    : in out Html_Filter_Type;
                         Document  : in out Wiki.Documents.Document;
                         Header    : in Wiki.Strings.WString;
                         Level     : in Natural) is
   begin
      Filter.Flush_Stack (Document);
      Filter_Type (Filter).Add_Header (Document, Header, Level);
   end Add_Header;

   --  ------------------------------
   --  Push a HTML node with the given tag to the document.
   --  ------------------------------
   overriding
   procedure Push_Node (Filter     : in out Html_Filter_Type;
                        Document   : in out Wiki.Documents.Document;
                        Tag        : in Wiki.Html_Tag;
                        Attributes : in out Wiki.Attributes.Attribute_List) is
      Current_Tag : Html_Tag;
   begin
      while not Filter.Stack.Is_Empty loop
         Current_Tag := Filter.Stack.Last_Element;
         if Need_Close (Tag, Current_Tag) then
            if Filter.Hide_Level = 0 then
               Filter_Type (Filter).Pop_Node (Document, Current_Tag);
            end if;
            Filter.Stack.Delete_Last;
         end if;
         exit when not No_End_Tag (Current_Tag);
      end loop;
      if Filter.Hidden (Tag) then
         Filter.Hide_Level := Filter.Hide_Level + 1;
      elsif not Filter.Allowed (Tag) then
         return;
      end if;
      Filter.Stack.Append (Tag);
      if Filter.Hide_Level = 0 then
         Filter_Type (Filter).Push_Node (Document, Tag, Attributes);
      end if;
   end Push_Node;

   --  ------------------------------
   --  Pop a HTML node with the given tag.
   --  ------------------------------
   overriding
   procedure Pop_Node (Filter   : in out Html_Filter_Type;
                       Document : in out Wiki.Documents.Document;
                       Tag      : in Wiki.Html_Tag) is
      Current_Tag : Html_Tag;
   begin
      if Filter.Stack.Is_Empty then
         return;
      elsif not Filter.Allowed (Tag) and not Filter.Hidden (Tag) then
         return;
      end if;

      --  Emit a end tag element until we find our matching tag and the top most tag
      --  allows the end tag to be omitted (ex: a td, tr, td, dd, ...).
      while not Filter.Stack.Is_Empty loop
         Current_Tag := Filter.Stack.Last_Element;
         exit when Current_Tag = Tag or not Tag_Omission (Current_Tag);
         if Filter.Hide_Level = 0 then
            Filter_Type (Filter).Pop_Node (Document, Current_Tag);
         end if;
         Filter.Stack.Delete_Last;
      end loop;

      if Filter.Hide_Level = 0 then
         Filter_Type (Filter).Pop_Node (Document, Tag);
      end if;
      if Filter.Hidden (Current_Tag) then
         Filter.Hide_Level := Filter.Hide_Level - 1;
      end if;
      Filter.Stack.Delete_Last;
   end Pop_Node;

   --  ------------------------------
   --  Add a link.
   --  ------------------------------
   overriding
   procedure Add_Link (Filter     : in out Html_Filter_Type;
                       Document   : in out Wiki.Documents.Document;
                       Name       : in Wiki.Strings.WString;
                       Attributes : in out Wiki.Attributes.Attribute_List) is
   begin
      if Filter.Allowed (A_TAG) then
         Filter_Type (Filter).Add_Link (Document, Name, Attributes);
      end if;
   end Add_Link;

   --  ------------------------------
   --  Add an image.
   --  ------------------------------
   overriding
   procedure Add_Image (Filter     : in out Html_Filter_Type;
                        Document   : in out Wiki.Documents.Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List) is
   begin
      if Filter.Allowed (IMG_TAG) then
         Filter_Type (Filter).Add_Image (Document, Name, Attributes);
      end if;
   end Add_Image;

   --  ------------------------------
   --  Given the current tag on the top of the stack and the new tag that will be pushed,
   --  decide whether the current tag must be closed or not.
   --  Returns True if the current tag must be closed.
   --  ------------------------------
   function Need_Close (Tag         : in Html_Tag;
                        Current_Tag : in Html_Tag) return Boolean is
   begin
      if No_End_Tag (Current_Tag) then
         return True;
      elsif Current_Tag = Tag and Tag_Omission (Current_Tag) then
         return True;
      else
         case Current_Tag is
            when DT_TAG | DD_TAG =>
               return Tag = DD_TAG or Tag = DL_TAG or Tag = DT_TAG;

            when TD_TAG =>
               return Tag = TD_TAG or Tag = TR_TAG or Tag = TH_TAG;

            when TR_TAG =>
               return False;

            when others =>
               return False;

         end case;
      end if;
   end Need_Close;

   --  ------------------------------
   --  Flush the HTML element that have not yet been closed.
   --  ------------------------------
   procedure Flush_Stack (Filter   : in out Html_Filter_Type;
                          Document : in out Wiki.Documents.Document) is
   begin
      while not Filter.Stack.Is_Empty loop
         declare
            Tag : constant Html_Tag := Filter.Stack.Last_Element;
         begin
            if Filter.Hide_Level = 0 then
               Filter_Type (Filter).Pop_Node (Document, Tag);
            end if;
            if Filter.Hidden (Tag) then
               Filter.Hide_Level := Filter.Hide_Level - 1;
            end if;
         end;
         Filter.Stack.Delete_Last;
      end loop;
   end Flush_Stack;

   --  ------------------------------
   --  Finish the document after complete wiki text has been parsed.
   --  ------------------------------
   overriding
   procedure Finish (Filter : in out Html_Filter_Type;
                     Document : in out Wiki.Documents.Document) is
   begin
      Filter.Flush_Stack (Document);
      Filter_Type (Filter).Finish (Document);
   end Finish;

   --  ------------------------------
   --  Mark the HTML tag as being forbidden.
   --  ------------------------------
   procedure Forbidden (Filter : in out Html_Filter_Type;
                        Tag    : in Html_Tag) is
   begin
      Filter.Allowed (Tag) := False;
   end Forbidden;

   --  ------------------------------
   --  Mark the HTML tag as being allowed.
   --  ------------------------------
   procedure Allowed (Filter : in out Html_Filter_Type;
                      Tag    : in Html_Tag) is
   begin
      Filter.Allowed (Tag) := True;
   end Allowed;

   --  ------------------------------
   --  Mark the HTML tag as being hidden.  The tag and its inner content including the text
   --  will be removed and not passed to the final document.
   --  ------------------------------
   procedure Hide (Filter : in out Html_Filter_Type;
                   Tag    : in Html_Tag) is
   begin
      Filter.Hidden (Tag) := True;
   end Hide;

   --  ------------------------------
   --  Mark the HTML tag as being visible.
   --  ------------------------------
   procedure Visible (Filter : in out Html_Filter_Type;
                      Tag    : in Html_Tag) is
   begin
      Filter.Hidden (Tag) := False;
   end Visible;

end Wiki.Filters.Html;

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

   --  ------------------------------
   --  Add a simple node such as N_LINE_BREAK, N_HORIZONTAL_RULE or N_PARAGRAPH to the document.
   --  ------------------------------
   overriding
   procedure Add_Node (Filter    : in out Html_Filter_Type;
                       Document  : in out Wiki.Documents.Document;
                       Kind      : in Wiki.Nodes.Simple_Node_Kind) is
      Tag : Html_Tag;
   begin
      case Kind is
         when N_LINE_BREAK =>
            Tag := BR_TAG;

         when N_PARAGRAPH =>
            Tag := P_TAG;

         when N_HORIZONTAL_RULE =>
            Tag := HR_TAG;

      end case;
      if Filter.Allowed (Tag) then
         Filter_Type (Filter).Add_Node (Document, Kind);
      end if;
   end Add_Node;

   --  ------------------------------
   --  Add a text content with the given format to the document.
   --  ------------------------------
   overriding
   procedure Add_Text (Filter    : in out Html_Filter_Type;
                       Document  : in out Wiki.Documents.Document;
                       Text      : in Wiki.Strings.WString;
                       Format    : in Wiki.Format_Map) is
   begin
      if Filter.Hide_Level > 0 then
         return;
      elsif not Filter.Stack.Is_Empty then
         declare
            Current_Tag : constant Html_Tag := Filter.Stack.Last_Element;
         begin
            if No_End_Tag (Current_Tag) then
               Filter_Type (Filter).Pop_Node (Document, Current_Tag);
               Filter.Stack.Delete_Last;
            end if;
         end;
      end if;
      Filter_Type (Filter).Add_Text (Document, Text, Format);
   end Add_Text;

   --  ------------------------------
   --  Add a section header with the given level in the document.
   --  ------------------------------
   overriding
   procedure Add_Header (Filter    : in out Html_Filter_Type;
                         Document  : in out Wiki.Documents.Document;
                         Header    : in Wiki.Strings.WString;
                         Level     : in Natural) is
   begin
      Filter.Flush_Stack (Document);
      Filter_Type (Filter).Add_Header (Document, Header, Level);
   end Add_Header;

   --  ------------------------------
   --  Push a HTML node with the given tag to the document.
   --  ------------------------------
   overriding
   procedure Push_Node (Filter     : in out Html_Filter_Type;
                        Document   : in out Wiki.Documents.Document;
                        Tag        : in Wiki.Html_Tag;
                        Attributes : in out Wiki.Attributes.Attribute_List) is
      Current_Tag : Html_Tag;
   begin
      while not Filter.Stack.Is_Empty loop
         Current_Tag := Filter.Stack.Last_Element;
         if Wiki.Helpers.Need_Close (Tag, Current_Tag) then
            if Filter.Hide_Level = 0 then
               Filter_Type (Filter).Pop_Node (Document, Current_Tag);
            end if;
            Filter.Stack.Delete_Last;
         end if;
         exit when not No_End_Tag (Current_Tag);
      end loop;
      if Filter.Hidden (Tag) then
         Filter.Hide_Level := Filter.Hide_Level + 1;
      elsif not Filter.Allowed (Tag) then
         return;
      end if;
      Filter.Stack.Append (Tag);
      if Filter.Hide_Level = 0 then
         Filter_Type (Filter).Push_Node (Document, Tag, Attributes);
      end if;
   end Push_Node;

   --  ------------------------------
   --  Pop a HTML node with the given tag.
   --  ------------------------------
   overriding
   procedure Pop_Node (Filter   : in out Html_Filter_Type;
                       Document : in out Wiki.Documents.Document;
                       Tag      : in Wiki.Html_Tag) is
      Current_Tag : Html_Tag;
   begin
      if Filter.Stack.Is_Empty then
         return;
      elsif not Filter.Allowed (Tag) and not Filter.Hidden (Tag) then
         return;
      end if;

      --  Emit a end tag element until we find our matching tag and the top most tag
      --  allows the end tag to be omitted (ex: a td, tr, td, dd, ...).
      while not Filter.Stack.Is_Empty loop
         Current_Tag := Filter.Stack.Last_Element;
         exit when Current_Tag = Tag or not Tag_Omission (Current_Tag);
         if Filter.Hide_Level = 0 then
            Filter_Type (Filter).Pop_Node (Document, Current_Tag);
         end if;
         Filter.Stack.Delete_Last;
      end loop;

      if Filter.Hide_Level = 0 then
         Filter_Type (Filter).Pop_Node (Document, Tag);
      end if;
      if Filter.Hidden (Current_Tag) then
         Filter.Hide_Level := Filter.Hide_Level - 1;
      end if;
      Filter.Stack.Delete_Last;
   end Pop_Node;

   --  ------------------------------
   --  Add a link.
   --  ------------------------------
   overriding
   procedure Add_Link (Filter     : in out Html_Filter_Type;
                       Document   : in out Wiki.Documents.Document;
                       Name       : in Wiki.Strings.WString;
                       Attributes : in out Wiki.Attributes.Attribute_List) is
   begin
      if Filter.Allowed (A_TAG) then
         Filter_Type (Filter).Add_Link (Document, Name, Attributes);
      end if;
   end Add_Link;

   --  ------------------------------
   --  Add an image.
   --  ------------------------------
   overriding
   procedure Add_Image (Filter     : in out Html_Filter_Type;
                        Document   : in out Wiki.Documents.Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List) is
   begin
      if Filter.Allowed (IMG_TAG) then
         Filter_Type (Filter).Add_Image (Document, Name, Attributes);
      end if;
   end Add_Image;

   --  ------------------------------
   --  Flush the HTML element that have not yet been closed.
   --  ------------------------------
   procedure Flush_Stack (Filter   : in out Html_Filter_Type;
                          Document : in out Wiki.Documents.Document) is
   begin
      while not Filter.Stack.Is_Empty loop
         declare
            Tag : constant Html_Tag := Filter.Stack.Last_Element;
         begin
            if Filter.Hide_Level = 0 then
               Filter_Type (Filter).Pop_Node (Document, Tag);
            end if;
            if Filter.Hidden (Tag) then
               Filter.Hide_Level := Filter.Hide_Level - 1;
            end if;
         end;
         Filter.Stack.Delete_Last;
      end loop;
   end Flush_Stack;

   --  ------------------------------
   --  Finish the document after complete wiki text has been parsed.
   --  ------------------------------
   overriding
   procedure Finish (Filter : in out Html_Filter_Type;
                     Document : in out Wiki.Documents.Document) is
   begin
      Filter.Flush_Stack (Document);
      Filter_Type (Filter).Finish (Document);
   end Finish;

   --  ------------------------------
   --  Mark the HTML tag as being forbidden.
   --  ------------------------------
   procedure Forbidden (Filter : in out Html_Filter_Type;
                        Tag    : in Html_Tag) is
   begin
      Filter.Allowed (Tag) := False;
   end Forbidden;

   --  ------------------------------
   --  Mark the HTML tag as being allowed.
   --  ------------------------------
   procedure Allowed (Filter : in out Html_Filter_Type;
                      Tag    : in Html_Tag) is
   begin
      Filter.Allowed (Tag) := True;
   end Allowed;

   --  ------------------------------
   --  Mark the HTML tag as being hidden.  The tag and its inner content including the text
   --  will be removed and not passed to the final document.
   --  ------------------------------
   procedure Hide (Filter : in out Html_Filter_Type;
                   Tag    : in Html_Tag) is
   begin
      Filter.Hidden (Tag) := True;
   end Hide;

   --  ------------------------------
   --  Mark the HTML tag as being visible.
   --  ------------------------------
   procedure Visible (Filter : in out Html_Filter_Type;
                      Tag    : in Html_Tag) is
   begin
      Filter.Hidden (Tag) := False;
   end Visible;

end Wiki.Filters.Html;

Move the Tag_Boolean_Array, Tag_Omission, No_End_Tag to the Wiki package