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

package body Natools.Smaz_Implementations.Base_64 is

   package Tools renames Natools.Smaz_Implementations.Base_64_Tools;

   use type Ada.Streams.Stream_Element_Offset;
   use type Tools.Base_64_Digit;

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

   procedure Read_Code
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Code : out Natools.Smaz_Implementations.Base_64_Tools.Base_64_Digit;
      Verbatim_Length : out Natural;
      Last_Code : in Natools.Smaz_Implementations.Base_64_Tools.Base_64_Digit;
      Variable_Length_Verbatim : in Boolean)
   is
      Ignored : String (1 .. 2);
      Offset_Backup : Ada.Streams.Stream_Element_Offset;
      Finished : Boolean;
   begin
      Tools.Next_Digit_Or_End (Input, Offset, Code, Finished);

      if Finished then
         Code := Base_64_Tools.Base_64_Digit'Last;
         Verbatim_Length := 0;
         return;
      end if;

      if Code <= Last_Code then
         Verbatim_Length := 0;

      elsif Variable_Length_Verbatim then
         if Code < 63 then
            Verbatim_Length := 63 - Natural (Code);
         else
            Tools.Next_Digit (Input, Offset, Code);
            Verbatim_Length := Natural (Code) + 63 - Natural (Last_Code);
         end if;
         Code := 0;

      elsif Code = 63 then
         Tools.Next_Digit (Input, Offset, Code);
         Verbatim_Length := Natural (Code) * 3 + 3;
         Code := 0;

      elsif Code = 62 then
         Offset_Backup := Offset;
         Tools.Decode_Single (Input, Offset, Ignored (1), Code);
         Verbatim_Length := Natural (Code) * 3 + 1;
         Offset := Offset_Backup;
         Code := 0;

      else
         Offset_Backup := Offset;
         Verbatim_Length := (61 - Natural (Code)) * 4;
         Tools.Decode_Double (Input, Offset, Ignored, Code);
         Verbatim_Length := (Verbatim_Length + Natural (Code)) * 3 + 2;
         Offset := Offset_Backup;
         Code := 0;
      end if;
   end Read_Code;

   procedure Read_Verbatim
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Output : out String)
   is
      Ignored : Tools.Base_64_Digit;
      Output_Index : Natural := Output'First - 1;
   begin
      if Output'Length mod 3 = 1 then
         Tools.Decode_Single
           (Input, Offset, Output (Output_Index + 1), Ignored);
         Output_Index := Output_Index + 1;
      elsif Output'Length mod 3 = 2 then
         Tools.Decode_Double
           (Input, Offset,
            Output (Output_Index + 1 .. Output_Index + 2), Ignored);
         Output_Index := Output_Index + 2;
      end if;

      if Output_Index < Output'Last then
         Tools.Decode
           (Input, Offset, Output (Output_Index + 1 .. Output'Last));
      end if;
   end Read_Verbatim;

   procedure Skip_Verbatim
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Verbatim_Length : in Positive)
   is
      Code : Tools.Base_64_Digit;
   begin
      for I in 1 .. Tools.Image_Length (Verbatim_Length) loop
         Tools.Next_Digit (Input, Offset, Code);
      end loop;
   end Skip_Verbatim;

   function Verbatim_Size
     (Input_Length : in Positive;
      Last_Code : in Natools.Smaz_Implementations.Base_64_Tools.Base_64_Digit;
      Variable_Length_Verbatim : in Boolean)
     return Ada.Streams.Stream_Element_Count is
   begin
      if Variable_Length_Verbatim then
         declare
            Largest_Single : constant Positive := 62 - Natural (Last_Code);
            Largest_Run : constant Positive := 64 + Largest_Single;
            Run_Count : constant Natural
              := (Input_Length + Largest_Run - 1) / Largest_Run;
            Last_Run_Size : constant Positive
              := Input_Length - (Run_Count - 1) * Largest_Run;
            Last_Run_Header_Size : constant Ada.Streams.Stream_Element_Count
              := (if Last_Run_Size > Largest_Single then 2 else 1);
         begin
            return Ada.Streams.Stream_Element_Count (Run_Count)
                    * (Tools.Image_Length (Largest_Run) + 2)
                 + Tools.Image_Length (Last_Run_Size) + Last_Run_Header_Size;
         end;
      else
         declare
            Largest_Prefix : constant Natural
              := (case Input_Length mod 3 is
                  when 1 => 15 * 3 + 1,
                  when 2 => ((62 - Natural (Last_Code)) * 4 - 1) * 3 + 2,
                  when others => 0);
            Prefix_Header_Size : constant Ada.Streams.Stream_Element_Count
              := (if Largest_Prefix > 0 then 1 else 0);
            Largest_Run : constant Positive := 64 * 3;
            Prefix_Size : constant Natural
              := Natural'Min (Largest_Prefix, Input_Length);
            Run_Count : constant Natural
              := (Input_Length - Prefix_Size + Largest_Run - 1) / Largest_Run;
         begin
            if Run_Count > 0 then
               return Prefix_Header_Size + Tools.Image_Length (Prefix_Size)
                 + Ada.Streams.Stream_Element_Count (Run_Count - 1)
                    * (Tools.Image_Length (Largest_Run) + 2)
                 + Tools.Image_Length (Input_Length - Prefix_Size
                                       - (Run_Count - 1) * Largest_Run)
                   + 2;
            else
               return Prefix_Header_Size + Tools.Image_Length (Prefix_Size);
            end if;
         end;
      end if;
   end Verbatim_Size;

   procedure Write_Code
     (Output : in out Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Code : in Natools.Smaz_Implementations.Base_64_Tools.Base_64_Digit) is
   begin
      Output (Offset) := Tools.Image (Code);
      Offset := Offset + 1;
   end Write_Code;

   procedure Write_Verbatim
     (Output : in out Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Input : in String;
      Last_Code : in Natools.Smaz_Implementations.Base_64_Tools.Base_64_Digit;
      Variable_Length_Verbatim : in Boolean)
   is
      Index : Positive := Input'First;
   begin
      if Variable_Length_Verbatim then
         declare
            Largest_Single : constant Positive := 62 - Natural (Last_Code);
            Largest_Run : constant Positive := 64 + Largest_Single;
            Length, Last : Natural;
         begin
            while Index in Input'Range loop
               Length := Positive'Min (Largest_Run, Input'Last + 1 - Index);

               if Length > Largest_Single then
                  Write_Code (Output, Offset, 63);
                  Write_Code
                    (Output, Offset,
                     Tools.Base_64_Digit (Length - Largest_Single - 1));
               else
                  Write_Code
                    (Output, Offset,
                     Tools.Base_64_Digit (63 - Length));
               end if;

               if Length mod 3 = 1 then
                  Tools.Encode_Single (Input (Index), 0, Output, Offset);
                  Index := Index + 1;
                  Length := Length - 1;
               elsif Length mod 3 = 2 then
                  Tools.Encode_Double
                    (Input (Index .. Index + 1), 0, Output, Offset);
                  Index := Index + 2;
                  Length := Length - 2;
               end if;

               if Length > 0 then
                  Last := Index + Length - 1;
                  Tools.Encode (Input (Index .. Last), Output, Offset);
                  Index := Last + 1;
               end if;
            end loop;
         end;
      else
         if Input'Length mod 3 = 1 then
            declare
               Extra_Blocks : constant Natural
                 := Natural'Min (15, Input'Length / 3);
            begin
               Output (Offset) := Tools.Image (62);
               Offset := Offset + 1;

               Tools.Encode_Single
                 (Input (Index), Tools.Single_Byte_Padding (Extra_Blocks),
                  Output, Offset);
               Index := Index + 1;

               if Extra_Blocks > 0 then
                  Tools.Encode
                    (Input (Index .. Index + Extra_Blocks * 3 - 1),
                     Output, Offset);
                  Index := Index + Extra_Blocks * 3;
               end if;
            end;
         elsif Input'Length mod 3 = 2 then
            declare
               Extra_Blocks : constant Natural := Natural'Min
                 (Input'Length / 3,
                  (62 - Natural (Last_Code)) * 4 - 1);
            begin
               Output (Offset)
                 := Tools.Image (61 - Tools.Base_64_Digit (Extra_Blocks / 4));
               Offset := Offset + 1;

               Tools.Encode_Double
                 (Input (Index .. Index + 1),
                  Tools.Double_Byte_Padding (Extra_Blocks mod 4),
                  Output, Offset);
               Index := Index + 2;

               if Extra_Blocks > 0 then
                  Tools.Encode
                    (Input (Index .. Index + Extra_Blocks * 3 - 1),
                     Output, Offset);
                  Index := Index + Extra_Blocks * 3;
               end if;
            end;
         end if;

         pragma Assert ((Input'Last + 1 - Index) mod 3 = 0);

         while Index <= Input'Last loop
            declare
               Block_Count : constant Natural
                 := Natural'Min (64, (Input'Last + 1 - Index) / 3);
            begin
               Output (Offset) := Tools.Image (63);
               Output (Offset + 1)
                 := Tools.Image (Tools.Base_64_Digit (Block_Count - 1));
               Offset := Offset + 2;

               Tools.Encode
                 (Input (Index .. Index + Block_Count * 3 - 1),
                  Output, Offset);
               Index := Index + Block_Count * 3;
            end;
         end loop;
      end if;
   end Write_Verbatim;

end Natools.Smaz_Implementations.Base_64;

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

package body Natools.Smaz_Implementations.Base_64 is

   package Tools renames Natools.Smaz_Implementations.Base_64_Tools;

   use type Ada.Streams.Stream_Element_Offset;
   use type Tools.Base_64_Digit;

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

   procedure Read_Code
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Code : out Natools.Smaz_Implementations.Base_64_Tools.Base_64_Digit;
      Verbatim_Length : out Natural;
      Last_Code : in Natools.Smaz_Implementations.Base_64_Tools.Base_64_Digit;
      Variable_Length_Verbatim : in Boolean)
   is
      Ignored : String (1 .. 2);
      Offset_Backup : Ada.Streams.Stream_Element_Offset;
      Finished : Boolean;
   begin
      Tools.Next_Digit_Or_End (Input, Offset, Code, Finished);

      if Finished then
         Code := Base_64_Tools.Base_64_Digit'Last;
         Verbatim_Length := 0;
         return;
      end if;

      if Code <= Last_Code then
         Verbatim_Length := 0;

      elsif Variable_Length_Verbatim then
         if Code < 63 then
            Verbatim_Length := 63 - Natural (Code);
         else
            Tools.Next_Digit (Input, Offset, Code);
            Verbatim_Length := Natural (Code) + 63 - Natural (Last_Code);
         end if;
         Code := 0;

      elsif Code = 63 then
         Tools.Next_Digit (Input, Offset, Code);
         Verbatim_Length := Natural (Code) * 3 + 3;
         Code := 0;

      elsif Code = 62 then
         Offset_Backup := Offset;
         Tools.Decode_Single (Input, Offset, Ignored (1), Code);
         Verbatim_Length := Natural (Code) * 3 + 1;
         Offset := Offset_Backup;
         Code := 0;

      else
         Offset_Backup := Offset;
         Verbatim_Length := (61 - Natural (Code)) * 4;
         Tools.Decode_Double (Input, Offset, Ignored, Code);
         Verbatim_Length := (Verbatim_Length + Natural (Code)) * 3 + 2;
         Offset := Offset_Backup;
         Code := 0;
      end if;
   end Read_Code;

   procedure Read_Verbatim
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Output : out String)
   is
      Ignored : Tools.Base_64_Digit;
      Output_Index : Natural := Output'First - 1;
   begin
      if Output'Length mod 3 = 1 then
         Tools.Decode_Single
           (Input, Offset, Output (Output_Index + 1), Ignored);
         Output_Index := Output_Index + 1;
      elsif Output'Length mod 3 = 2 then
         Tools.Decode_Double
           (Input, Offset,
            Output (Output_Index + 1 .. Output_Index + 2), Ignored);
         Output_Index := Output_Index + 2;
      end if;

      if Output_Index < Output'Last then
         Tools.Decode
           (Input, Offset, Output (Output_Index + 1 .. Output'Last));
      end if;
   end Read_Verbatim;

   procedure Skip_Verbatim
     (Input : in Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Verbatim_Length : in Positive)
   is
      Code : Tools.Base_64_Digit;
   begin
      for I in 1 .. Tools.Image_Length (Verbatim_Length) loop
         Tools.Next_Digit (Input, Offset, Code);
      end loop;
   end Skip_Verbatim;

   function Verbatim_Size
     (Input_Length : in Positive;
      Last_Code : in Natools.Smaz_Implementations.Base_64_Tools.Base_64_Digit;
      Variable_Length_Verbatim : in Boolean)
     return Ada.Streams.Stream_Element_Count is
   begin
      if Variable_Length_Verbatim then
         declare
            Largest_Single : constant Positive := 62 - Natural (Last_Code);
            Largest_Run : constant Positive := 64 + Largest_Single;
            Run_Count : constant Natural
              := (Input_Length + Largest_Run - 1) / Largest_Run;
            Last_Run_Size : constant Positive
              := Input_Length - (Run_Count - 1) * Largest_Run;
            Last_Run_Header_Size : constant Ada.Streams.Stream_Element_Count
              := (if Last_Run_Size > Largest_Single then 2 else 1);
         begin
            return Ada.Streams.Stream_Element_Count (Run_Count)
                    * (Tools.Image_Length (Largest_Run) + 2)
                 + Tools.Image_Length (Last_Run_Size) + Last_Run_Header_Size;
         end;
      else
         declare
            Largest_Prefix : constant Natural
              := (case Input_Length mod 3 is
                  when 1 => 15 * 3 + 1,
                  when 2 => ((61 - Natural (Last_Code)) * 4 - 1) * 3 + 2,
                  when others => 0);
            Prefix_Header_Size : constant Ada.Streams.Stream_Element_Count
              := (if Largest_Prefix > 0 then 1 else 0);
            Largest_Run : constant Positive := 64 * 3;
            Prefix_Size : constant Natural
              := Natural'Min (Largest_Prefix, Input_Length);
            Run_Count : constant Natural
              := (Input_Length - Prefix_Size + Largest_Run - 1) / Largest_Run;
         begin
            if Run_Count > 0 then
               return Prefix_Header_Size + Tools.Image_Length (Prefix_Size)
                 + Ada.Streams.Stream_Element_Count (Run_Count - 1)
                    * (Tools.Image_Length (Largest_Run) + 2)
                 + Tools.Image_Length (Input_Length - Prefix_Size
                                       - (Run_Count - 1) * Largest_Run)
                   + 2;
            else
               return Prefix_Header_Size + Tools.Image_Length (Prefix_Size);
            end if;
         end;
      end if;
   end Verbatim_Size;

   procedure Write_Code
     (Output : in out Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Code : in Natools.Smaz_Implementations.Base_64_Tools.Base_64_Digit) is
   begin
      Output (Offset) := Tools.Image (Code);
      Offset := Offset + 1;
   end Write_Code;

   procedure Write_Verbatim
     (Output : in out Ada.Streams.Stream_Element_Array;
      Offset : in out Ada.Streams.Stream_Element_Offset;
      Input : in String;
      Last_Code : in Natools.Smaz_Implementations.Base_64_Tools.Base_64_Digit;
      Variable_Length_Verbatim : in Boolean)
   is
      Index : Positive := Input'First;
   begin
      if Variable_Length_Verbatim then
         declare
            Largest_Single : constant Positive := 62 - Natural (Last_Code);
            Largest_Run : constant Positive := 64 + Largest_Single;
            Length, Last : Natural;
         begin
            while Index in Input'Range loop
               Length := Positive'Min (Largest_Run, Input'Last + 1 - Index);

               if Length > Largest_Single then
                  Write_Code (Output, Offset, 63);
                  Write_Code
                    (Output, Offset,
                     Tools.Base_64_Digit (Length - Largest_Single - 1));
               else
                  Write_Code
                    (Output, Offset,
                     Tools.Base_64_Digit (63 - Length));
               end if;

               if Length mod 3 = 1 then
                  Tools.Encode_Single (Input (Index), 0, Output, Offset);
                  Index := Index + 1;
                  Length := Length - 1;
               elsif Length mod 3 = 2 then
                  Tools.Encode_Double
                    (Input (Index .. Index + 1), 0, Output, Offset);
                  Index := Index + 2;
                  Length := Length - 2;
               end if;

               if Length > 0 then
                  Last := Index + Length - 1;
                  Tools.Encode (Input (Index .. Last), Output, Offset);
                  Index := Last + 1;
               end if;
            end loop;
         end;
      else
         if Input'Length mod 3 = 1 then
            declare
               Extra_Blocks : constant Natural
                 := Natural'Min (15, Input'Length / 3);
            begin
               Output (Offset) := Tools.Image (62);
               Offset := Offset + 1;

               Tools.Encode_Single
                 (Input (Index), Tools.Single_Byte_Padding (Extra_Blocks),
                  Output, Offset);
               Index := Index + 1;

               if Extra_Blocks > 0 then
                  Tools.Encode
                    (Input (Index .. Index + Extra_Blocks * 3 - 1),
                     Output, Offset);
                  Index := Index + Extra_Blocks * 3;
               end if;
            end;
         elsif Input'Length mod 3 = 2 then
            declare
               Extra_Blocks : constant Natural := Natural'Min
                 (Input'Length / 3,
                  (61 - Natural (Last_Code)) * 4 - 1);
            begin
               Output (Offset)
                 := Tools.Image (61 - Tools.Base_64_Digit (Extra_Blocks / 4));
               Offset := Offset + 1;

               Tools.Encode_Double
                 (Input (Index .. Index + 1),
                  Tools.Double_Byte_Padding (Extra_Blocks mod 4),
                  Output, Offset);
               Index := Index + 2;

               if Extra_Blocks > 0 then
                  Tools.Encode
                    (Input (Index .. Index + Extra_Blocks * 3 - 1),
                     Output, Offset);
                  Index := Index + Extra_Blocks * 3;
               end if;
            end;
         end if;

         pragma Assert ((Input'Last + 1 - Index) mod 3 = 0);

         while Index <= Input'Last loop
            declare
               Block_Count : constant Natural
                 := Natural'Min (64, (Input'Last + 1 - Index) / 3);
            begin
               Output (Offset) := Tools.Image (63);
               Output (Offset + 1)
                 := Tools.Image (Tools.Base_64_Digit (Block_Count - 1));
               Offset := Offset + 2;

               Tools.Encode
                 (Input (Index .. Index + Block_Count * 3 - 1),
                  Output, Offset);
               Index := Index + Block_Count * 3;
            end;
         end loop;
      end if;
   end Write_Verbatim;

end Natools.Smaz_Implementations.Base_64;

fix encoding issue with with multiblock

smaz_implementations-base_64: fix encoding issue with with multiblock


Fix set-options command for custom ports


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

with Util.Log.Loggers;
with Util.Files;
with Util.Encoders.Base16;
package body Babel.Files is

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

   Hex_Encoder : Util.Encoders.Base16.Encoder;

   --  ------------------------------
   --  Allocate a File_Type entry with the given name for the directory.
   --  ------------------------------
   function Allocate (Name : in String;
                      Dir  : in Directory_Type) return File_Type is
      Result : constant File_Type := new File '(Len    => Name'Length,
                                                Id     => NO_IDENTIFIER,
                                                Dir    => Dir,
                                                Name   => Name,
                                                others => <>);
   begin
      return Result;
   end Allocate;

   --  ------------------------------
   --  Allocate a Directory_Type entry with the given name for the directory.
   --  ------------------------------
   function Allocate (Name : in String;
                      Dir  : in Directory_Type) return Directory_Type is
      use Ada.Strings.Unbounded;

      Result : constant Directory_Type := new Directory '(Len    => Name'Length,
                                                          Id     => NO_IDENTIFIER,
                                                          Parent => Dir,
                                                          Name   => Name,
                                                          others => <>);
   begin
      if Dir /= null then
         Result.Path := To_Unbounded_String
           (Util.Files.Compose (To_String (Dir.Path), Name));
      end if;
      return Result;
   end Allocate;

   --  ------------------------------
   --  Return true if the file was modified and need a backup.
   --  ------------------------------
   function Is_Modified (Element : in File_Type) return Boolean is
      use type ADO.Identifier;
   begin
      if Element.Id = NO_IDENTIFIER then
         return True;
      elsif (Element.Status and FILE_MODIFIED) /= 0 then
         return True;
      else
         return False;
      end if;
   end Is_Modified;

   --  ------------------------------
   --  Set the file as modified.
   --  ------------------------------
   procedure Set_Modified (Element : in File_Type) is
   begin
      Element.Status := Element.Status or FILE_MODIFIED;
   end Set_Modified;

   --  ------------------------------
   --  Return the path for the file.
   --  ------------------------------
   function Get_Path (Element : in File_Type) return String is
   begin
      if Element.Dir = null then
         return Element.Name;
      else
         return Util.Files.Compose (Get_Path (Element.Dir), Element.Name);
      end if;
   end Get_Path;

   --  ------------------------------
   --  Return the path for the directory.
   --  ------------------------------
   function Get_Path (Element : in Directory_Type) return String is
   begin
      return Ada.Strings.Unbounded.To_String (Element.Path);
   end Get_Path;

   --  ------------------------------
   --  Return the SHA1 signature computed for the file.
   --  ------------------------------
   function Get_SHA1 (Element : in File_Type) return String is
   begin
      return Hex_Encoder.Transform (Element.SHA1);
   end Get_SHA1;

end Babel.Files;

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

with Util.Log.Loggers;
with Util.Files;
with Util.Encoders.Base16;
package body Babel.Files is

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

   Hex_Encoder : Util.Encoders.Base16.Encoder;

   --  ------------------------------
   --  Allocate a File_Type entry with the given name for the directory.
   --  ------------------------------
   function Allocate (Name : in String;
                      Dir  : in Directory_Type) return File_Type is
      Result : constant File_Type := new File '(Len    => Name'Length,
                                                Id     => NO_IDENTIFIER,
                                                Dir    => Dir,
                                                Name   => Name,
                                                others => <>);
   begin
      return Result;
   end Allocate;

   --  ------------------------------
   --  Allocate a Directory_Type entry with the given name for the directory.
   --  ------------------------------
   function Allocate (Name : in String;
                      Dir  : in Directory_Type) return Directory_Type is
      use Ada.Strings.Unbounded;

      Result : constant Directory_Type := new Directory '(Len    => Name'Length,
                                                          Id     => NO_IDENTIFIER,
                                                          Parent => Dir,
                                                          Name   => Name,
                                                          others => <>);
   begin
      if Dir /= null then
         Result.Path := To_Unbounded_String
           (Util.Files.Compose (To_String (Dir.Path), Name));
      end if;
      return Result;
   end Allocate;

   --  ------------------------------
   --  Return true if the file was modified and need a backup.
   --  ------------------------------
   function Is_Modified (Element : in File_Type) return Boolean is
      use type ADO.Identifier;
   begin
      if Element.Id = NO_IDENTIFIER then
         return True;
      elsif (Element.Status and FILE_MODIFIED) /= 0 then
         return True;
      else
         return False;
      end if;
   end Is_Modified;

   --  ------------------------------
   --  Set the file as modified.
   --  ------------------------------
   procedure Set_Modified (Element : in File_Type) is
   begin
      Element.Status := Element.Status or FILE_MODIFIED;
   end Set_Modified;

   --  ------------------------------
   --  Set the SHA1 signature that was computed for this file.
   --  If the computed signature is different from the current signature,
   --  the FILE_MODIFIED flag is set on the file.  The FILE_HAS_SHA1 flag
   --  is set on the file.
   --  ------------------------------
   procedure Set_Signature (Element   : in File_Type;
                            Signature : in Util.Encoders.SHA1.Hash_Array) is
      use type Util.Encoders.SHA1.Hash_Array;
   begin
      if (Element.Status and FILE_HAS_SHA1) /= 0 and then Element.SHA1 /= Signature then
         Element.Status := Element.Status or FILE_MODIFIED;
      end if;
      Element.Status := Element.Status or FILE_HAS_SHA1;
      Element.SHA1   := Signature;
   end Set_Signature;

   --  ------------------------------
   --  Return the path for the file.
   --  ------------------------------
   function Get_Path (Element : in File_Type) return String is
   begin
      if Element.Dir = null then
         return Element.Name;
      else
         return Util.Files.Compose (Get_Path (Element.Dir), Element.Name);
      end if;
   end Get_Path;

   --  ------------------------------
   --  Return the path for the directory.
   --  ------------------------------
   function Get_Path (Element : in Directory_Type) return String is
   begin
      return Ada.Strings.Unbounded.To_String (Element.Path);
   end Get_Path;

   --  ------------------------------
   --  Return the SHA1 signature computed for the file.
   --  ------------------------------
   function Get_SHA1 (Element : in File_Type) return String is
   begin
      return Hex_Encoder.Transform (Element.SHA1);
   end Get_SHA1;

end Babel.Files;

Implement the Set_Signature operation and setup the file status flags accordingly


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

   NO_IDENTIFIER : constant ADO.Identifier := ADO.NO_IDENTIFIER;

   subtype File_Identifier is ADO.Identifier;
   subtype Directory_Identifier is ADO.Identifier;
   subtype File_Size is Long_Long_Integer;
   type File_Mode is mod 2**16;
   type Uid_Type is mod 2**16;
   type Gid_Type is mod 2**16;

   type File_Type is private;
   type File_Type_Array is array (Positive range <>) of File_Type;
   type File_Type_Array_Access is access all File_Type_Array;

   type Directory_Type is private;
   type Directory_Type_Array is array (Positive range <>) of Directory_Type;
   type Directory_Type_Array_Access is access all Directory_Type_Array;

   NO_DIRECTORY : constant Directory_Type;
   NO_FILE      : constant File_Type;

   type Status_Type is mod 2**16;

   --  The file was modified.
   FILE_MODIFIED : constant Status_Type := 16#0001#;

   --  There was some error while processing this file.
   FILE_ERROR    : constant Status_Type := 16#8000#;

   --  The SHA1 signature for the file is known and valid.
   FILE_HAS_SHA1 : constant Status_Type := 16#0002#;

   --  Allocate a File_Type entry with the given name for the directory.
   function Allocate (Name : in String;
                      Dir  : in Directory_Type) return File_Type;

   --  Allocate a Directory_Type entry with the given name for the directory.
   function Allocate (Name : in String;
                      Dir  : in Directory_Type) return Directory_Type;

   type File (Len : Positive) is record
      Id     : File_Identifier := NO_IDENTIFIER;
      Size   : File_Size       := 0;
      Dir    : Directory_Type  := NO_DIRECTORY;
      Mode   : File_Mode       := 8#644#;
      User   : Uid_Type        := 0;
      Group  : Gid_Type        := 0;
      Status : Status_Type     := 0;
      Date   : Ada.Calendar.Time;
      SHA1   : Util.Encoders.SHA1.Hash_Array;
      Name   : aliased String (1 .. Len);
   end record;

   --  Return true if the file was modified and need a backup.
   function Is_Modified (Element : in File_Type) return Boolean;

   --  Set the file as modified.
   procedure Set_Modified (Element : in File_Type);

   --  Set the SHA1 signature that was computed for this file.
   --  If the computed signature is different from the current signature,
   --  the FILE_MODIFIED flag is set on the file.  The FILE_HAS_SHA1 flag
   --  is set on the file.
   procedure Set_Signature (Element   : in File_Type;
                            Signature : in Util.Encoders.SHA1.Hash_Array);

   --  Set the file size.  If the new size is different, the FILE_MODIFIED
   --  flag is set on the file.
   procedure Set_Size (Element : in File_Type;
                       Size    : in File_Size);

   --  Return the path for the file.
   function Get_Path (Element : in File_Type) return String;

   --  Return the path for the directory.
   function Get_Path (Element : in Directory_Type) return String;

   --  Return the SHA1 signature computed for the file.
   function Get_SHA1 (Element : in File_Type) return String;

   type File_Container is limited interface;

   --  Add the file with the given name in the container.
   procedure Add_File (Into    : in out File_Container;
                       Path    : in String;
                       Element : in File) is abstract;

   --  Add the directory with the given name in the container.
   procedure Add_Directory (Into : in out File_Container;
                            Path : in String;
                            Name : in String) is abstract;

   --  Create a new file instance with the given name in the container.
   function Create (Into : in File_Container;
                    Name : in String) return File_Type is abstract;

   --  Find the file with the given name in this file container.
   --  Returns NO_FILE if the file was not found.
   function Find (From : in File_Container;
                  Name : in String) return File_Type is abstract;

   --  Find the directory with the given name in this file container.
   --  Returns NO_DIRECTORY if the directory was not found.
   function Find (From : in File_Container;
                  Name : in String) return Directory_Type is abstract;

private

   type Directory (Len : Positive) is record
      Id       : Directory_Identifier := NO_IDENTIFIER;
      Parent   : Directory_Type;
      Mode     : File_Mode := 8#755#;
      User     : Uid_Type  := 0;
      Group    : Gid_Type  := 0;
      Files    : File_Type_Array_Access;
      Children : Directory_Type_Array_Access;
      Path     : Ada.Strings.Unbounded.Unbounded_String;
      Name     : aliased String (1 .. Len);
   end record;

   type File_Type is access all File;

   type Directory_Type is access all Directory;

   NO_DIRECTORY : constant Directory_Type := null;
   NO_FILE      : constant File_Type := null;

end Babel.Files;

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

   NO_IDENTIFIER : constant ADO.Identifier := ADO.NO_IDENTIFIER;

   subtype File_Identifier is ADO.Identifier;
   subtype Directory_Identifier is ADO.Identifier;
   subtype File_Size is Long_Long_Integer;
   type File_Mode is mod 2**16;
   type Uid_Type is mod 2**16;
   type Gid_Type is mod 2**16;

   type File_Type is private;
   type File_Type_Array is array (Positive range <>) of File_Type;
   type File_Type_Array_Access is access all File_Type_Array;

   type Directory_Type is private;
   type Directory_Type_Array is array (Positive range <>) of Directory_Type;
   type Directory_Type_Array_Access is access all Directory_Type_Array;

   NO_DIRECTORY : constant Directory_Type;
   NO_FILE      : constant File_Type;

   type Status_Type is mod 2**16;

   --  The file was modified.
   FILE_MODIFIED : constant Status_Type := 16#0001#;

   --  There was some error while processing this file.
   FILE_ERROR    : constant Status_Type := 16#8000#;

   --  The SHA1 signature for the file is known and valid.
   FILE_HAS_SHA1 : constant Status_Type := 16#0002#;

   --  Allocate a File_Type entry with the given name for the directory.
   function Allocate (Name : in String;
                      Dir  : in Directory_Type) return File_Type;

   --  Allocate a Directory_Type entry with the given name for the directory.
   function Allocate (Name : in String;
                      Dir  : in Directory_Type) return Directory_Type;

   type File (Len : Positive) is record
      Id     : File_Identifier := NO_IDENTIFIER;
      Size   : File_Size       := 0;
      Dir    : Directory_Type  := NO_DIRECTORY;
      Mode   : File_Mode       := 8#644#;
      User   : Uid_Type        := 0;
      Group  : Gid_Type        := 0;
      Status : Status_Type     := 0;
      Date   : Ada.Calendar.Time;
      SHA1   : Util.Encoders.SHA1.Hash_Array;
      Name   : aliased String (1 .. Len);
   end record;

   --  Return true if the file was modified and need a backup.
   function Is_Modified (Element : in File_Type) return Boolean;

   --  Set the file as modified.
   procedure Set_Modified (Element : in File_Type);

   --  Set the SHA1 signature that was computed for this file.
   --  If the computed signature is different from the current signature,
   --  the FILE_MODIFIED flag is set on the file.  The FILE_HAS_SHA1 flag
   --  is set on the file.
   procedure Set_Signature (Element   : in File_Type;
                            Signature : in Util.Encoders.SHA1.Hash_Array);

   --  Set the file size.  If the new size is different, the FILE_MODIFIED
   --  flag is set on the file.
   procedure Set_Size (Element : in File_Type;
                       Size    : in File_Size);

   --  Return the path for the file.
   function Get_Path (Element : in File_Type) return String;

   --  Return the path for the directory.
   function Get_Path (Element : in Directory_Type) return String;

   --  Return the SHA1 signature computed for the file.
   function Get_SHA1 (Element : in File_Type) return String;

   type File_Container is limited interface;

   --  Add the file with the given name in the container.
   procedure Add_File (Into    : in out File_Container;
                       Path    : in String;
                       Element : in File) is abstract;

   --  Add the directory with the given name in the container.
   procedure Add_Directory (Into : in out File_Container;
                            Path : in String;
                            Name : in String) is abstract;

   --  Create a new file instance with the given name in the container.
   function Create (Into : in File_Container;
                    Name : in String) return File_Type is abstract;

   --  Create a new directory instance with the given name in the container.
   function Create (Into : in File_Container;
                    Name : in String) return Directory_Type is abstract;

   --  Find the file with the given name in this file container.
   --  Returns NO_FILE if the file was not found.
   function Find (From : in File_Container;
                  Name : in String) return File_Type is abstract;

   --  Find the directory with the given name in this file container.
   --  Returns NO_DIRECTORY if the directory was not found.
   function Find (From : in File_Container;
                  Name : in String) return Directory_Type is abstract;

private

   type Directory (Len : Positive) is record
      Id       : Directory_Identifier := NO_IDENTIFIER;
      Parent   : Directory_Type;
      Mode     : File_Mode := 8#755#;
      User     : Uid_Type  := 0;
      Group    : Gid_Type  := 0;
      Files    : File_Type_Array_Access;
      Children : Directory_Type_Array_Access;
      Path     : Ada.Strings.Unbounded.Unbounded_String;
      Name     : aliased String (1 .. Len);
   end record;

   type File_Type is access all File;

   type Directory_Type is access all Directory;

   NO_DIRECTORY : constant Directory_Type := null;
   NO_FILE      : constant File_Type := null;

end Babel.Files;

Add a Create function to the File_Container to create a new directory


-----------------------------------------------------------------------
--  security -- Security
--  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.
-----------------------------------------------------------------------

--  == Introduction ==
--  The <tt>Security</tt> package provides security frameworks that allows
--  an application to use OpenID or OAuth security frameworks.  This security
--  framework was first developed within the Ada Server Faces project.
--  This package defines abstractions that are close or similar to Java
--  security package.
--
--  @include security-permissions.ads
--  @include security-openid.ads
--  @include security-oauth.ads
--  @include security-contexts.ads
--  @include security-controllers.ads
package Security is

   --  ------------------------------
   --  Principal
   --  ------------------------------
   type Principal is limited interface;
   type Principal_Access is access all Principal'Class;

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

end Security;

-----------------------------------------------------------------------
--  security -- Security
--  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.
-----------------------------------------------------------------------

--  == Introduction ==
--  The <tt>Security</tt> package provides a security framework that allows
--  an application to use OpenID or OAuth security frameworks.  This security
--  framework was first developed within the Ada Server Faces project.
--  This package defines abstractions that are close or similar to Java
--  security package.
--
--  === Principal ===
--  The <tt>Principal</tt> is the entity that can be authenticated.  A principal is obtained
--  after successful authentication of a user or of a system through an authorization process.
--  The OpenID or OAuth authentication processes generate such security principal.
--
--  === Permission ===
--  The <tt>Permission</tt> represents an access to a system or application resource.
--  A permission is checked by using the security manager.  The security manager uses a
--  security controller to enforce the permission.
--
--  @include security-permissions.ads
--  @include security-openid.ads
--  @include security-oauth.ads
--  @include security-contexts.ads
--  @include security-controllers.ads
package Security is

   --  ------------------------------
   --  Principal
   --  ------------------------------
   type Principal is limited interface;
   type Principal_Access is access all Principal'Class;

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

end Security;

Document the permission

Document the permission


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

package Definitions is

   pragma Pure;

   synth_version_major : constant String := "2";
   synth_version_minor : constant String := "02";
   copyright_years     : constant String := "2015-2017";
   host_localbase      : constant String := "/usr/local";
   host_make           : constant String := "/usr/bin/make";
   host_pkg8           : constant String := host_localbase & "/sbin/pkg";
   host_bmake          : constant String := host_localbase & "/bin/bmake";
   host_make_program   : constant String := host_make;
   chroot_make         : constant String := "/usr/bin/make";
   chroot_bmake        : constant String := "/usr/pkg/bin/bmake -m /usr/pkg/share/mk";
   chroot_make_program : constant String := chroot_make;
   jobs_per_cpu        : constant := 2;

   type cpu_range is range 1 .. 32;
   type scanners  is range cpu_range'First .. cpu_range'Last;
   type builders  is range cpu_range'First .. cpu_range'Last * jobs_per_cpu;
   type package_system is (ports_collection, pkgsrc);

   software_framework : constant package_system := ports_collection;

   --  Notes for tailoring Synth.  Use sed to:
   --  1. Modify host_localbase to value of LOCALBASE
   --  2. Change software_framework to "pkgsrc" for pkgsrc version
   --  3. Change host_make_program to "host_bmake" for Non-NetBSD pkgsrc platforms
   --  4. Change chroot_make_program to "chroot_bmake" for pkgsrc version
   --  5. On replicant.ads, change "/usr/local" to "/usr/pkg" on pkgsrc

end Definitions;

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

package Definitions is

   pragma Pure;

   synth_version_major : constant String := "2";
   synth_version_minor : constant String := "03";
   copyright_years     : constant String := "2015-2017";
   host_localbase      : constant String := "/usr/local";
   host_make           : constant String := "/usr/bin/make";
   host_pkg8           : constant String := host_localbase & "/sbin/pkg";
   host_bmake          : constant String := host_localbase & "/bin/bmake";
   host_make_program   : constant String := host_make;
   chroot_make         : constant String := "/usr/bin/make";
   chroot_bmake        : constant String := "/usr/pkg/bin/bmake -m /usr/pkg/share/mk";
   chroot_make_program : constant String := chroot_make;
   jobs_per_cpu        : constant := 2;

   type cpu_range is range 1 .. 32;
   type scanners  is range cpu_range'First .. cpu_range'Last;
   type builders  is range cpu_range'First .. cpu_range'Last * jobs_per_cpu;
   type package_system is (ports_collection, pkgsrc);

   software_framework : constant package_system := ports_collection;

   --  Notes for tailoring Synth.  Use sed to:
   --  1. Modify host_localbase to value of LOCALBASE
   --  2. Change software_framework to "pkgsrc" for pkgsrc version
   --  3. Change host_make_program to "host_bmake" for Non-NetBSD pkgsrc platforms
   --  4. Change chroot_make_program to "chroot_bmake" for pkgsrc version
   --  5. On replicant.ads, change "/usr/local" to "/usr/pkg" on pkgsrc

end Definitions;

Bump version

Bump version


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

with Util.Tests;

package Security.OAuth.Servers.Tests is

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

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

   --  Test the application manager.
   procedure Test_Application_Manager (T : in out Test);

   --  Test the user registration and verification.
   procedure Test_User_Verify (T : in out Test);

   --  Test the token operation that produces an access token from user/password.
   --  RFC 6749: Section 4.3.  Resource Owner Password Credentials Grant
   procedure Test_Token_Password (T : in out Test);

   --  Test the access token validation with invalid tokens (bad formed).
   procedure Test_Bad_Token (T : in out Test);

end Security.OAuth.Servers.Tests;

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

with Util.Tests;

package Security.OAuth.Servers.Tests is

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

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

   --  Test the application manager.
   procedure Test_Application_Manager (T : in out Test);

   --  Test the user registration and verification.
   procedure Test_User_Verify (T : in out Test);

   --  Test the token operation that produces an access token from user/password.
   --  RFC 6749: Section 4.3.  Resource Owner Password Credentials Grant
   procedure Test_Token_Password (T : in out Test);

   --  Test the access token validation with invalid tokens (bad formed).
   procedure Test_Bad_Token (T : in out Test);

   --  Test the loading configuration files for the File_Registry.
   procedure Test_Load_Registry (T : in out Test);

end Security.OAuth.Servers.Tests;

Declare the Test_Load_Registry procedure to test the File_Registry


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

   use Wiki.Helpers;
   use Wiki.Buffers;
   use type Wiki.Nodes.Node_Kind;

   function Get_Header_Level (Text : in Wiki.Strings.WString) return Natural is
   begin
      if Text'Length <= 4 or else Text (Text'First) /= 'h' then
         return 0;
      end if;
      if Text (Text'First + 2) /= '.' or not Is_Space (Text (Text'First + 3)) then
         return 0;
      end if;
      case Text (Text'First + 1) is
         when '1' =>
           return 1;

         when '2' =>
           return 2;

         when '3' =>
           return 3;

         when '4' =>
            return 4;

         when '5' =>
            return 5;

         when others =>
            return 0;
      end case;
   end Get_Header_Level;

   --  ------------------------------
   --  Parse a textile wiki heading in the form 'h<N>.'.
   --  Example:
   --    h1. Level 1
   --    h2. Level 2
   --  ------------------------------
   procedure Parse_Header (Parser  : in out Parser_Type;
                           Text    : in out Wiki.Buffers.Buffer_Access;
                           From    : in out Positive;
                           Level   : in Positive) is
   begin
      Flush_Text (Parser, Trim => Right);
      Pop_Block (Parser);
      Parser.Header_Level := Level;
      Push_Block (Parser, Nodes.N_HEADER);

      declare
         Pos    : Natural := From;
         Buffer : Wiki.Buffers.Buffer_Access := Text;
      begin
         while Buffer /= null loop
            declare
               Last : constant Natural := Buffer.Last;
            begin
               while Pos <= Last loop
                  if not Wiki.Helpers.Is_Space_Or_Newline (Buffer.Content (Pos)) then
                     Common.Append (Parser.Text, Buffer, Pos);
                     Text := null;
                     return;
                  end if;
                  Pos := Pos + 1;
               end loop;
            end;
            Buffer := Buffer.Next_Block;
            Pos := 1;
         end loop;
      end;
   end Parse_Header;

   --  ------------------------------
   --  Parse a textile image.
   --  Example:
   --    !image-link!
   --    !image-link(title)!
   --    !image-path!:http-link
   --  ------------------------------
   procedure Parse_Image (Parser  : in out Parser_Type;
                          Text    : in out Wiki.Buffers.Buffer_Access;
                          From    : in out Positive) is
      Block : Wiki.Buffers.Buffer_Access := Text;
      Pos   : Positive := From;
   begin
      Next (Block, Pos);
      Find (Block, Pos, '!');
      if Block = null then
         Common.Parse_Text (Parser, Text, From);
         return;
      end if;

      declare
         Link      : Wiki.Strings.BString (128);
         Title     : Wiki.Strings.BString (128);
         C         : Wiki.Strings.WChar := Wiki.Html_Parser.NUL;
      begin
         Block := Text;
         Pos := From;
         Next (Block, Pos);
         while Block /= null loop
            C := Block.Content (Pos);
            exit when C = '(' or C = '!';
            Append (Link, C);
            Next (Block, Pos);
         end loop;

         if C = '(' then
            Next (Block, Pos);
            while Block /= null loop
               C := Block.Content (Pos);
               exit when C = ')' or C = '!';
               Append (Title, C);
               Next (Block, Pos);
            end loop;
            if C /= ')' then
               Common.Parse_Text (Parser, Text, From);
               return;
            end if;
            Next (Block, Pos);
         end if;
         Next (Block, Pos);
         Text := Block;
         From := Pos;

         Flush_Text (Parser);
         if not Parser.Context.Is_Hidden then
            Wiki.Attributes.Clear (Parser.Attributes);
            Wiki.Attributes.Append (Parser.Attributes, "src", Link);
            Parser.Context.Filters.Add_Image (Parser.Document,
                                              Strings.To_WString (Title),
                                              Parser.Attributes);
         end if;
      end;
   end Parse_Image;

   --  ------------------------------
   --  Parse an external link:
   --  Example:
   --    "title":http-link
   --  ------------------------------
   procedure Parse_Link (Parser  : in out Parser_Type;
                         Text    : in out Wiki.Buffers.Buffer_Access;
                         From    : in out Positive) is
      Block : Wiki.Buffers.Buffer_Access := Text;
      Pos   : Positive := From;
      Http : constant Wiki.Strings.WString := ":http";
   begin
      Next (Block, Pos);
      Find (Block, Pos, '"');
      if Block = null then
         Common.Parse_Text (Parser, Text, From);
         return;
      end if;

      Next (Block, Pos);
      for Expect of Http loop
         if Block = null or else Block.Content (Pos) /= Expect then
            Common.Parse_Text (Parser, Text, From);
            return;
         end if;
         Next (Block, Pos);
      end loop;

      declare
         Title : Wiki.Strings.BString (128);
         Link  : Wiki.Strings.BString (128);
         C     : Wiki.Strings.WChar;
      begin
         Block := Text;
         Pos := From;
         Next (Block, Pos);
         while Block.Content (Pos) /= '"' loop
            Append (Title, Block.Content (Pos));
            Next (Block, Pos);
         end loop;

         --  Skip the ":
         Next (Block, Pos);
         Next (Block, Pos);

         while Block /= null loop
            C := Block.Content (Pos);
            exit when Wiki.Helpers.Is_Space_Or_Newline (C);
            Append (Link, C);
            Next (Block, Pos);
         end loop;

         Text := Block;
         From := Pos;

         Flush_Text (Parser);
         Wiki.Attributes.Clear (Parser.Attributes);

         Parser.Line_Pos := Pos;
         Parser.Empty_Line := False;
         if not Parser.Context.Is_Hidden then
            Wiki.Attributes.Append (Parser.Attributes, NAME_ATTR, Title);
            Wiki.Attributes.Append (Parser.Attributes, HREF_ATTR, Link);
            Parser.Context.Filters.Add_Link (Parser.Document,
                                             Wiki.Strings.To_WString (Title),
                                             Parser.Attributes);
         end if;
      end;
   end Parse_Link;

   procedure Parse_Line (Parser : in out Parser_Type;
                         Text   : in Wiki.Buffers.Buffer_Access) is
      Pos    : Natural := 1;
      C      : Wiki.Strings.WChar;
      Buffer : Wiki.Buffers.Buffer_Access := Text;
      Level  : Natural;
   begin
      --  Feed the HTML parser if there are some pending state.
      if not Wiki.Html_Parser.Is_Empty (Parser.Html) then
         Common.Parse_Html_Element (Parser, Buffer, Pos, Start => False);
         if Buffer = null then
            return;
         end if;
      end if;

      if Parser.Pre_Tag_Counter > 0 then
         Common.Parse_Html_Preformatted (Parser, Buffer, Pos);
         if Buffer = null then
            return;
         end if;
      end if;

      if Parser.Current_Node = Nodes.N_HEADER then
         Pop_Block (Parser);
      end if;

      C := Buffer.Content (Pos);
      case C is
         when CR | LF =>
            Common.Parse_Paragraph (Parser, Buffer, Pos);
            return;

         when 'h' =>
            Level := Get_Header_Level (Buffer.Content (1 .. Buffer.Last));
            if Level > 0 and Level <= 6 then
               Pos := 4;
               Parse_Header (Parser, Buffer, Pos, Level);
               return;
            end if;

         when '-' =>
            Common.Parse_Horizontal_Rule (Parser, Buffer, Pos, '-');
            if Buffer = null then
               return;
            end if;

         when '*' | '#' =>
            if Common.Is_List (Buffer, Pos) then
               Common.Parse_List (Parser, Buffer, Pos);
            end if;

         when ' ' =>
            Parser.Preformat_Indent := 1;
            Parser.Preformat_Fence := ' ';
            Parser.Preformat_Fcount := 1;
            Flush_Text (Parser, Trim => Right);
            Pop_Block (Parser);
            Push_Block (Parser, Nodes.N_PREFORMAT);
            Common.Append (Parser.Text, Buffer, Pos + 1);
            return;

         when ';' =>
            Common.Parse_Definition (Parser, Buffer, Pos);
            return;

         when ':' =>
            if Parser.Current_Node = Nodes.N_DEFINITION then
               Next (Buffer, Pos);
               Common.Skip_Spaces (Buffer, Pos);
            end if;

         when others =>
            if Parser.Current_Node /= Nodes.N_PARAGRAPH then
               Pop_List (Parser);
               Push_Block (Parser, Nodes.N_PARAGRAPH);
            end if;

      end case;

      Main :
      while Buffer /= null loop
         declare
            Last : constant Natural := Buffer.Last;
         begin
            while Pos <= Last loop
               C := Buffer.Content (Pos);
               case C is
                  when '*' =>
                     Parse_Format (Parser, Buffer, Pos, '*', Wiki.BOLD);
                     exit Main when Buffer = null;

                  when '@' =>
                     Parse_Format (Parser, Buffer, Pos, '@', Wiki.CODE);
                     exit Main when Buffer = null;

                  when '_' =>
                     Parse_Format (Parser, Buffer, Pos, '_', Wiki.EMPHASIS);
                     exit Main when Buffer = null;

                  when '^' =>
                     Parse_Format (Parser, Buffer, Pos, '^', Wiki.SUPERSCRIPT);
                     exit Main when Buffer = null;

                  when '[' =>
                     Common.Parse_Link (Parser, Buffer, Pos);
                     exit Main when Buffer = null;

                  when '?' =>
                     Parse_Format_Double (Parser, Buffer, Pos, '?', Wiki.CITE);
                     exit Main when Buffer = null;

                  when '{' =>
                     Common.Parse_Template (Parser, Buffer, Pos, '{');
                     exit Main when Buffer = null;

                  when '"' =>
                     Parse_Link (Parser, Buffer, Pos);
                     exit Main when Buffer = null;

                  when '!' =>
                     Parse_Image (Parser, Buffer, Pos);
                     exit Main when Buffer = null;

                  when CR | LF =>
                     Append (Parser.Text, ' ');
                     Pos := Pos + 1;

                  when '<' =>
                     Common.Parse_Html_Element (Parser, Buffer, Pos, Start => True);
                     exit Main when Buffer = null;

                  when '&' =>
                     Common.Parse_Entity (Parser, Buffer, Pos);
                     exit Main when Buffer = null;

                  when others =>
                     Append (Parser.Text, C);
                     Pos := Pos + 1;

               end case;
            end loop;
         end;
         Buffer := Buffer.Next_Block;
         Pos := 1;
      end loop Main;
   end Parse_Line;

end Wiki.Parsers.Textile;

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

   use Wiki.Helpers;
   use Wiki.Buffers;
   use type Wiki.Nodes.Node_Kind;

   function Get_Header_Level (Text : in Wiki.Strings.WString) return Natural is
   begin
      if Text'Length <= 4 or else Text (Text'First) /= 'h' then
         return 0;
      end if;
      if Text (Text'First + 2) /= '.' or not Is_Space (Text (Text'First + 3)) then
         return 0;
      end if;
      case Text (Text'First + 1) is
         when '1' =>
           return 1;

         when '2' =>
           return 2;

         when '3' =>
           return 3;

         when '4' =>
            return 4;

         when '5' =>
            return 5;

         when others =>
            return 0;
      end case;
   end Get_Header_Level;

   --  ------------------------------
   --  Parse a textile wiki heading in the form 'h<N>.'.
   --  Example:
   --    h1. Level 1
   --    h2. Level 2
   --  ------------------------------
   procedure Parse_Header (Parser  : in out Parser_Type;
                           Text    : in out Wiki.Buffers.Buffer_Access;
                           From    : in out Positive;
                           Level   : in Positive) is
   begin
      Flush_Text (Parser, Trim => Right);
      Pop_Block (Parser);
      Parser.Header_Level := Level;
      Push_Block (Parser, Nodes.N_HEADER);

      declare
         Pos    : Natural := From;
         Buffer : Wiki.Buffers.Buffer_Access := Text;
      begin
         while Buffer /= null loop
            declare
               Last : constant Natural := Buffer.Last;
            begin
               while Pos <= Last loop
                  if not Wiki.Helpers.Is_Space_Or_Newline (Buffer.Content (Pos)) then
                     Common.Append (Parser.Text, Buffer, Pos);
                     Text := null;
                     return;
                  end if;
                  Pos := Pos + 1;
               end loop;
            end;
            Buffer := Buffer.Next_Block;
            Pos := 1;
         end loop;
      end;
   end Parse_Header;

   --  ------------------------------
   --  Parse a textile image.
   --  Example:
   --    !image-link!
   --    !image-link(title)!
   --    !image-path!:http-link
   --  ------------------------------
   procedure Parse_Image (Parser  : in out Parser_Type;
                          Text    : in out Wiki.Buffers.Buffer_Access;
                          From    : in out Positive) is
      Block : Wiki.Buffers.Buffer_Access := Text;
      Pos   : Positive := From;
   begin
      Next (Block, Pos);
      Find (Block, Pos, '!');
      if Block = null then
         Common.Parse_Text (Parser, Text, From);
         return;
      end if;

      declare
         Link      : Wiki.Strings.BString (128);
         Title     : Wiki.Strings.BString (128);
         C         : Wiki.Strings.WChar := Wiki.Html_Parser.NUL;
      begin
         Block := Text;
         Pos := From;
         Next (Block, Pos);
         while Block /= null loop
            C := Block.Content (Pos);
            exit when C = '(' or C = '!';
            Append (Link, C);
            Next (Block, Pos);
         end loop;

         if C = '(' then
            Next (Block, Pos);
            while Block /= null loop
               C := Block.Content (Pos);
               exit when C = ')' or C = '!';
               Append (Title, C);
               Next (Block, Pos);
            end loop;
            if C /= ')' then
               Common.Parse_Text (Parser, Text, From);
               return;
            end if;
            Next (Block, Pos);
         end if;
         Next (Block, Pos);
         Text := Block;
         From := Pos;

         Flush_Text (Parser);
         if not Parser.Context.Is_Hidden then
            Wiki.Attributes.Clear (Parser.Attributes);
            Wiki.Attributes.Append (Parser.Attributes, "src", Link);
            Parser.Context.Filters.Add_Image (Parser.Document,
                                              Strings.To_WString (Title),
                                              Parser.Attributes);
         end if;
      end;
   end Parse_Image;

   --  ------------------------------
   --  Parse an external link:
   --  Example:
   --    "title":http-link
   --  ------------------------------
   procedure Parse_Link (Parser  : in out Parser_Type;
                         Text    : in out Wiki.Buffers.Buffer_Access;
                         From    : in out Positive) is
      Block : Wiki.Buffers.Buffer_Access := Text;
      Pos   : Positive := From;
      Http : constant Wiki.Strings.WString := ":http";
   begin
      Next (Block, Pos);
      Find (Block, Pos, '"');
      if Block = null then
         Common.Parse_Text (Parser, Text, From);
         return;
      end if;

      Next (Block, Pos);
      for Expect of Http loop
         if Block = null or else Block.Content (Pos) /= Expect then
            Common.Parse_Text (Parser, Text, From);
            return;
         end if;
         Next (Block, Pos);
      end loop;

      declare
         Title : Wiki.Strings.BString (128);
         Link  : Wiki.Strings.BString (128);
         C     : Wiki.Strings.WChar;
      begin
         Block := Text;
         Pos := From;
         Next (Block, Pos);
         while Block.Content (Pos) /= '"' loop
            Append (Title, Block.Content (Pos));
            Next (Block, Pos);
         end loop;

         --  Skip the ":
         Next (Block, Pos);
         Next (Block, Pos);

         while Block /= null loop
            C := Block.Content (Pos);
            exit when Wiki.Helpers.Is_Space_Or_Newline (C);
            Append (Link, C);
            Next (Block, Pos);
         end loop;

         Text := Block;
         From := Pos;

         Flush_Text (Parser);
         Wiki.Attributes.Clear (Parser.Attributes);

         Parser.Line_Pos := Pos;
         Parser.Empty_Line := False;
         if not Parser.Context.Is_Hidden then
            Wiki.Attributes.Append (Parser.Attributes, NAME_ATTR, Title);
            Wiki.Attributes.Append (Parser.Attributes, HREF_ATTR, Link);
            Parser.Context.Filters.Add_Link (Parser.Document,
                                             Wiki.Strings.To_WString (Title),
                                             Parser.Attributes);
         end if;
      end;
   end Parse_Link;

   procedure Parse_Line (Parser : in out Parser_Type;
                         Text   : in Wiki.Buffers.Buffer_Access) is
      Pos    : Natural := 1;
      C      : Wiki.Strings.WChar;
      Buffer : Wiki.Buffers.Buffer_Access := Text;
      Level  : Natural;
   begin
      --  Feed the HTML parser if there are some pending state.
      if not Wiki.Html_Parser.Is_Empty (Parser.Html) then
         Common.Parse_Html_Element (Parser, Buffer, Pos, Start => False);
         if Buffer = null then
            return;
         end if;
      end if;

      if Parser.Pre_Tag_Counter > 0 then
         Common.Parse_Html_Preformatted (Parser, Buffer, Pos);
         if Buffer = null then
            return;
         end if;
      end if;

      if Parser.Current_Node = Nodes.N_HEADER then
         Pop_Block (Parser);
      end if;

      C := Buffer.Content (Pos);
      case C is
         when CR | LF =>
            Common.Parse_Paragraph (Parser, Buffer, Pos);
            return;

         when 'h' =>
            Level := Get_Header_Level (Buffer.Content (1 .. Buffer.Last));
            if Level > 0 and Level <= 6 then
               Pos := 4;
               Parse_Header (Parser, Buffer, Pos, Level);
               return;
            end if;

         when '-' =>
            Common.Parse_Horizontal_Rule (Parser, Buffer, Pos, '-');
            if Buffer = null then
               return;
            end if;

         when '*' | '#' =>
            if Common.Is_List (Buffer, Pos) then
               Common.Parse_List (Parser, Buffer, Pos);
            end if;

         when ' ' =>
            Parser.Preformat_Indent := 1;
            Parser.Preformat_Fence := ' ';
            Parser.Preformat_Fcount := 1;
            Flush_Text (Parser, Trim => Right);
            Pop_Block (Parser);
            Push_Block (Parser, Nodes.N_PREFORMAT);
            Common.Append (Parser.Text, Buffer, Pos + 1);
            return;

         when ';' =>
            Common.Parse_Definition (Parser, Buffer, Pos);
            return;

         when ':' =>
            if Parser.Current_Node = Nodes.N_DEFINITION then
               Next (Buffer, Pos);
               Common.Skip_Spaces (Buffer, Pos);
            end if;

         when others =>
            if Parser.Current_Node /= Nodes.N_PARAGRAPH then
               Pop_List (Parser);
               Push_Block (Parser, Nodes.N_PARAGRAPH);
            end if;

      end case;

      Main :
      while Buffer /= null loop
         declare
            Last : constant Natural := Buffer.Last;
         begin
            while Pos <= Last loop
               C := Buffer.Content (Pos);
               case C is
                  when '*' =>
                     if Parser.Format (CODE) then
                        Append (Parser.Text, C);
                        Pos := Pos + 1;
                     else
                        Parse_Format (Parser, Buffer, Pos, '*', Wiki.BOLD);
                        exit Main when Buffer = null;
                     end if;

                  when '@' =>
                     Parse_Format (Parser, Buffer, Pos, '@', Wiki.CODE);
                     exit Main when Buffer = null;

                  when '_' =>
                     if Parser.Format (CODE) then
                        Append (Parser.Text, C);
                        Pos := Pos + 1;
                     else
                        Parse_Format (Parser, Buffer, Pos, '_', Wiki.EMPHASIS);
                        exit Main when Buffer = null;
                     end if;

                  when '^' =>
                     Parse_Format (Parser, Buffer, Pos, '^', Wiki.SUPERSCRIPT);
                     exit Main when Buffer = null;

                  when '[' =>
                     Common.Parse_Link (Parser, Buffer, Pos);
                     exit Main when Buffer = null;

                  when '?' =>
                     Parse_Format_Double (Parser, Buffer, Pos, '?', Wiki.CITE);
                     exit Main when Buffer = null;

                  when '{' =>
                     Common.Parse_Template (Parser, Buffer, Pos, '{');
                     exit Main when Buffer = null;

                  when '"' =>
                     Parse_Link (Parser, Buffer, Pos);
                     exit Main when Buffer = null;

                  when '!' =>
                     Parse_Image (Parser, Buffer, Pos);
                     exit Main when Buffer = null;

                  when CR | LF =>
                     Append (Parser.Text, ' ');
                     Pos := Pos + 1;

                  when '<' =>
                     Common.Parse_Html_Element (Parser, Buffer, Pos, Start => True);
                     exit Main when Buffer = null;

                  when '&' =>
                     Common.Parse_Entity (Parser, Buffer, Pos);
                     exit Main when Buffer = null;

                  when others =>
                     Append (Parser.Text, C);
                     Pos := Pos + 1;

               end case;
            end loop;
         end;
         Buffer := Buffer.Next_Block;
         Pos := 1;
      end loop Main;
   end Parse_Line;

end Wiki.Parsers.Textile;

Update textile parsing rules

Update textile parsing rules


-----------------------------------------------------------------------
--  wiki-filters-html -- Wiki HTML filters
--  Copyright (C) 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.
-----------------------------------------------------------------------
private with Ada.Containers.Vectors;

--  === HTML Filters ===
--  The <b>Wiki.Filters.Html</b> package implements a customizable HTML filter that verifies
--  the HTML content embedded in the Wiki text.
--
--  The HTML filter may be declared and configured as follows:
--
--    F : aliased Wiki.Filters.Html.Html_Filter_Type;
--    ...
--    F.Forbidden (Wiki.Filters.Html.SCRIPT_TAG);
--    F.Forbidden (Wiki.Filters.Html.A_TAG);
--
--  The <tt>Set_Document</tt> operation is used to link the HTML filter to a next filter
--  or to the HTML or text renderer:
--
--    F.Set_Document (Renderer'Access);
--
--  The HTML filter is then either inserted as a document for a previous filter or for
--  the wiki parser:
--
--    Wiki.Parsers.Parse (F'Access, Wiki_Text, Syntax);
--
package Wiki.Filters.Html is

   use Wiki.Nodes;

   --  ------------------------------
   --  Filter type
   --  ------------------------------
   type Html_Filter_Type is new Filter_Type with private;

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

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

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

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

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

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

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

   --  Finish the document after complete wiki text has been parsed.
   overriding
   procedure Finish (Document : in out Html_Filter_Type);

   --  Mark the HTML tag as being forbidden.
   procedure Forbidden (Filter : in out Html_Filter_Type;
                        Tag    : in Html_Tag_Type);

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

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

   --  Mark the HTML tag as being visible.
   procedure Visible (Filter : in out Html_Filter_Type;
                      Tag    : in Html_Tag_Type);

   --  Flush the HTML element that have not yet been closed.
   procedure Flush_Stack (Document : in out Html_Filter_Type);

private

   use Wiki.Nodes;

   type Tag_Boolean_Array is array (Html_Tag_Type) of Boolean;

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

   subtype Tag_Vector is Tag_Vectors.Vector;
   subtype Tag_Cursor is Tag_Vectors.Cursor;

   type Html_Filter_Type is new Filter_Type with record
      Allowed    : Tag_Boolean_Array := (UNKNOWN_TAG => False,
                                         SCRIPT_TAG  => False,
                                         HTML_TAG    => False,
                                         HEAD_TAG    => False,
                                         BODY_TAG    => False,
                                         META_TAG    => False,
                                         TITLE_TAG   => False,
                                         others      => True);

      Hidden     : Tag_Boolean_Array := (UNKNOWN_TAG => False,
                                         SCRIPT_TAG  => True,
                                         STYLE_TAG   => True,
                                         others      => False);
      Stack      : Tag_Vector;
      Hide_Level : Natural := 0;
   end record;

end Wiki.Filters.Html;

-----------------------------------------------------------------------
--  wiki-filters-html -- Wiki HTML filters
--  Copyright (C) 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.
-----------------------------------------------------------------------
private with Ada.Containers.Vectors;

--  === HTML Filters ===
--  The <b>Wiki.Filters.Html</b> package implements a customizable HTML filter that verifies
--  the HTML content embedded in the Wiki text.
--
--  The HTML filter may be declared and configured as follows:
--
--    F : aliased Wiki.Filters.Html.Html_Filter_Type;
--    ...
--    F.Forbidden (Wiki.Filters.Html.SCRIPT_TAG);
--    F.Forbidden (Wiki.Filters.Html.A_TAG);
--
--  The <tt>Set_Document</tt> operation is used to link the HTML filter to a next filter
--  or to the HTML or text renderer:
--
--    F.Set_Document (Renderer'Access);
--
--  The HTML filter is then either inserted as a document for a previous filter or for
--  the wiki parser:
--
--    Wiki.Parsers.Parse (F'Access, Wiki_Text, Syntax);
--
package Wiki.Filters.Html is

   use Wiki.Nodes;

   --  ------------------------------
   --  Filter type
   --  ------------------------------
   type Html_Filter_Type is new Filter_Type with private;

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

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

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

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

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

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

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

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

   --  Mark the HTML tag as being forbidden.
   procedure Forbidden (Filter : in out Html_Filter_Type;
                        Tag    : in Html_Tag_Type);

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

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

   --  Mark the HTML tag as being visible.
   procedure Visible (Filter : in out Html_Filter_Type;
                      Tag    : in Html_Tag_Type);

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

private

   use Wiki.Nodes;

   type Tag_Boolean_Array is array (Html_Tag_Type) of Boolean;

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

   subtype Tag_Vector is Tag_Vectors.Vector;
   subtype Tag_Cursor is Tag_Vectors.Cursor;

   type Html_Filter_Type is new Filter_Type with record
      Allowed    : Tag_Boolean_Array := (UNKNOWN_TAG => False,
                                         SCRIPT_TAG  => False,
                                         HTML_TAG    => False,
                                         HEAD_TAG    => False,
                                         BODY_TAG    => False,
                                         META_TAG    => False,
                                         TITLE_TAG   => False,
                                         others      => True);

      Hidden     : Tag_Boolean_Array := (UNKNOWN_TAG => False,
                                         SCRIPT_TAG  => True,
                                         STYLE_TAG   => True,
                                         others      => False);
      Stack      : Tag_Vector;
      Hide_Level : Natural := 0;
   end record;

end Wiki.Filters.Html;

Add Document parameter to Finish and Flush_Stack