-----------------------------------------------------------------------
--  mat-frames - Representation of stack frames
--  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.Unchecked_Deallocation;
with Interfaces; use Interfaces;
with MAT.Types; use MAT.Types;
package body MAT.Frames is

   procedure Free is
      new Ada.Unchecked_Deallocation (Frame, Frame_Type);

   --  ------------------------------
   --  Return the parent frame.
   --  ------------------------------
   function Parent (Frame : in Frame_Type) return Frame_Type is
   begin
      if Frame = null then
         return null;
      else
         return Frame.Parent;
      end if;
   end Parent;

   --  ------------------------------
   --  Returns the backtrace of the current frame (up to the root).
   --  ------------------------------
   function Backtrace (Frame :  in Frame_Type) return Frame_Table is
      Pc      : Frame_Table (1 .. Frame.Depth);
      Current : Frame_Type := Frame;
      Pos     : Natural   := Current.Depth;
      New_Pos : Natural;
   begin
      while Current /= null and Pos /= 0 loop
         New_Pos := Pos - Current.Local_Depth + 1;
         Pc (New_Pos .. Pos) := Current.Calls (1 .. Current.Local_Depth);
         Pos     := New_Pos - 1;
         Current := Current.Parent;
      end loop;
      return Pc;
   end Backtrace;

   --  ------------------------------
   --  Returns the number of children in the frame.
   --  When recursive is true, compute in the sub-tree.
   --  ------------------------------
   function Count_Children (Frame     : in Frame_Type;
                            Recursive : in Boolean := False) return Natural is
      Count : Natural := 0;
      Child : Frame_Type;
   begin
      if Frame /= null then
         Child := Frame.Children;
         while Child /= null loop
            Count := Count + 1;
            if Recursive then
               declare
                  N : Natural := Count_Children (Child, True);
               begin
                  if N > 0 then
                     N := N - 1;
                  end if;
                  Count := Count + N;
               end;
            end if;
            Child := Child.Next;
         end loop;
      end if;
      return Count;
   end Count_Children;

   --  ------------------------------
   --  Returns all the direct calls made by the current frame.
   --  ------------------------------
   function Calls (Frame : in Frame_Type) return Frame_Table is
      Nb_Calls : Natural   := Count_Children (Frame);
      Pc       : Frame_Table (1 .. Nb_Calls);
   begin
      if Frame /= null then
         declare
            Child : Frame_Type := Frame.Children;
            Pos   : Natural   := 1;
         begin
            while Child /= null loop
               Pc (Pos) := Child.Calls (1);
               Pos   := Pos + 1;
               Child := Child.Next;
            end loop;
         end;
      end if;
      return Pc;
   end Calls;

   --  ------------------------------
   --  Returns the current stack depth (# of calls from the root
   --  to reach the frame).
   --  ------------------------------
   function Current_Depth (Frame : in Frame_Type) return Natural is
   begin
      if Frame = null then
         return 0;
      else
         return Frame.Depth;
      end if;
   end Current_Depth;

   --  ------------------------------
   --  Create a root for stack frame representation.
   --  ------------------------------
   function Create_Root return Frame_Type is
   begin
      return new Frame;
   end Create_Root;

   --  ------------------------------
   --  Destroy the frame tree recursively.
   --  ------------------------------
   procedure Destroy (Frame : in out Frame_Type) is
      F : Frame_Type;
   begin
      if Frame = null then
         return;
      end if;
      --  Destroy its children recursively.
      while Frame.Children /= null loop
         F := Frame.Children;
         Destroy (F);
      end loop;

      --  Unlink from parent list.
      if Frame.Parent /= null then
         F := Frame.Parent.Children;
         if F = Frame then
            Frame.Parent.Children := Frame.Next;
         else
            while F /= null and F.Next /= Frame loop
               F := F.Next;
            end loop;
            if F = null then
               raise Program_Error;
            end if;
            F.Next := Frame.Next;
         end if;
      end if;
      Free (Frame);
   end Destroy;

   --  ------------------------------
   --  Release the frame when its reference is no longer necessary.
   --  ------------------------------
   procedure Release (Frame : in Frame_Type) is
      Current : Frame_Type := Frame;
   begin
      --  Scan the frame until the root is reached
      --  and decrement the used counter.  Free the frames
      --  when the used counter reaches 0.
      while Current /= null loop
         if Current.Used <= 1 then
            declare
               Tree : Frame_Type := Current;
            begin
               Current := Current.Parent;
               Destroy (Tree);
            end;
         else
            Current.Used := Current.Used - 1;
            Current := Current.Parent;
         end if;
      end loop;
   end Release;

   --  Split the node pointed to by `F' at the position `Pos'
   --  in the caller chain.  A new parent is created for the node
   --  and the brothers of the node become the brothers of the
   --  new parent.
   --
   --  Returns in `F' the new parent node.
   procedure Split (F : in out Frame_Ptr; Pos : in Positive) is

      --  Before:                       After:
      --
      --    +-------+             +-------+
      --  /-|  P    |           /-|  P    |
      --  | +-------+           | +-------+
      --  |       ^             |       ^
      --  |   +-------+         |    +-------+
      --  ...>| node  |...      ....>|  new  |...        (0..N brothers)
      --      +-------+              +-------+
      --       |     ^              |      ^
      --       | +-------+          | +-------+
      --       ->|  c    |          ->| node  |-->0      (0 brother)
      --         +-------+            +-------+
      --                                    |
      --                                +-------+
      --                                |   c   |
      --                                +-------+
      --
      New_Parent : Frame_Ptr := new Frame '(Parent      => F.Parent,
                                            Next        => F.Next,
                                            Children    => F,
                                            Used        => F.Used,
                                            Depth       => F.Depth,
                                            Local_Depth => Pos,
                                            Calls       => (others => 0));
      Child : Frame_Ptr := F.Parent.Children;
   begin
      --  Move the PC values in the new parent.
      New_Parent.Calls (1 .. Pos) := F.Calls (1 .. Pos);
      F.Calls (1 .. F.Local_Depth - Pos) := F.Calls (Pos + 1 .. F.Local_Depth);
      F.Parent         := New_Parent;
      F.Next           := null;
      New_Parent.Depth := F.Depth - F.Local_Depth + Pos;
      F.Local_Depth    := F.Local_Depth - Pos;

      --  Remove F from its parent children list and replace if with New_Parent.
      if Child = F then
         New_Parent.Parent.Children := New_Parent;
      else
         while Child.Next /= F loop
            Child := Child.Next;
         end loop;
         Child.Next := New_Parent;
      end if;
      F := New_Parent;
   end Split;

   procedure Add_Frame (F  : in Frame_Ptr;
                        Pc : in Pc_Table;
                        Result : out Frame_Ptr) is
      Child         : Frame_Ptr := F;
      Pos           : Positive  := Pc'First;
      Current_Depth : Natural   := F.Depth;
      Cnt           : Local_Depth_Type;
   begin
      while Pos <= Pc'Last loop
         Cnt := Frame_Group_Size;
         if Pos + Cnt > Pc'Last then
            Cnt := Pc'Last - Pos + 1;
         end if;
         Current_Depth := Current_Depth + Cnt;
         Child := new Frame '(Parent      => Child,
                              Next        => Child.Children,
                              Children    => null,
                              Used        => 1,
                              Depth       => Current_Depth,
                              Local_Depth => Cnt,
                              Calls       => (others => 0));
         Child.Calls (1 .. Cnt) := Pc (Pos .. Pos + Cnt - 1);
         Pos := Pos + Cnt;
         Child.Parent.Children := Child;
      end loop;
      Result := Child;
   end Add_Frame;

   procedure Insert (F : in Frame_Ptr;
                     Pc : in Pc_Table;
                     Result : out Frame_Ptr) is
      Current : Frame_Ptr := F;
      Child   : Frame_Ptr;
      Pos     : Positive  := Pc'First;
      Lpos    : Positive  := 1;
      Addr    : Target_Addr;
   begin
      while Pos <= Pc'Last loop
         Addr := Pc (Pos);
         if Lpos <= Current.Local_Depth then
            if Addr = Current.Calls (Lpos) then
               Lpos := Lpos + 1;
               Pos  := Pos + 1;

               --  Split this node
            else
               if Lpos > 1 then
                  Split (Current, Lpos - 1);
               end if;
               Add_Frame (Current, Pc (Pos .. Pc'Last), Result);
               return;
            end if;
         else
            --  Find the first child which has the address.
            Child := Current.Children;
            while Child /= null loop
               exit when Child.Calls (1) = Addr;
               Child := Child.Next;
            end loop;
            if Child = null then
               Add_Frame (Current, Pc (Pos .. Pc'Last), Result);
               return;
            end if;
            Current := Child;
            Lpos    := 2;
            Pos     := Pos + 1;
            Current.Used := Current.Used + 1;
         end if;
      end loop;
      if Lpos <= Current.Local_Depth then
         Split (Current, Lpos - 1);
      end if;
      Result := Current;
   end Insert;

   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   function Find (F : in Frame_Ptr; Pc : in Target_Addr) return Frame_Ptr is
      Child : Frame_Ptr := F.Children;
   begin
      while Child /= null loop
         if Child.Local_Depth >= 1 and then Child.Calls (1) = Pc then
            return Child;
         end if;
         Child := Child.Next;
      end loop;
      raise Not_Found;
   end Find;

   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   function Find (F : in Frame_Ptr; Pc : in PC_Table) return Frame_Ptr is
      Child : Frame_Ptr := F;
      Pos   : Positive  := Pc'First;
      Lpos  : Positive;
   begin
      while Pos <= Pc'Last loop
         Child := Find (Child, Pc (Pos));
         Pos  := Pos + 1;
         Lpos := 2;
         --  All the PC of the child frame must match.
         while Pos <= Pc'Last and Lpos <= Child.Local_Depth loop
            if Child.Calls (Lpos) /= Pc (Pos) then
               raise Not_Found;
            end if;
            Lpos := Lpos + 1;
            Pos  := Pos + 1;
         end loop;
      end loop;
      return Child;
   end Find;

   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   procedure Find (F       : in Frame_Ptr;
                   Pc      : in PC_Table;
                   Result  : out Frame_Ptr;
                   Last_Pc : out Natural) is
      Current : Frame_Ptr := F;
      Pos     : Positive  := Pc'First;
      Lpos    : Positive;
   begin
      Main_Search:
      while Pos <= Pc'Last loop
         declare
            Addr  : Target_Addr := Pc (Pos);
            Child : Frame_Ptr   := Current.Children;
         begin
            --  Find the child which has the corresponding PC.
            loop
               exit Main_Search when Child = null;
               exit when Child.Local_Depth >= 1 and Child.Calls (1) = Addr;
               Child := Child.Next;
            end loop;

            Current := Child;
            Pos  := Pos + 1;
            Lpos := 2;
            --  All the PC of the child frame must match.
            while Pos <= Pc'Last and Lpos <= Current.Local_Depth loop
               exit Main_Search when Current.Calls (Lpos) /= Pc (Pos);
               Lpos := Lpos + 1;
               Pos  := Pos + 1;
            end loop;
         end;
      end loop Main_Search;
      Result := Current;
      if Pos > Pc'Last then
         Last_Pc := 0;
      else
         Last_Pc := Pos;
      end if;
   end Find;

end MAT.Frames;

-----------------------------------------------------------------------
--  mat-frames - Representation of stack frames
--  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.Unchecked_Deallocation;
with Interfaces; use Interfaces;
with MAT.Types; use MAT.Types;
package body MAT.Frames is

   procedure Free is
      new Ada.Unchecked_Deallocation (Frame, Frame_Type);

   --  ------------------------------
   --  Return the parent frame.
   --  ------------------------------
   function Parent (Frame : in Frame_Type) return Frame_Type is
   begin
      if Frame = null then
         return null;
      else
         return Frame.Parent;
      end if;
   end Parent;

   --  ------------------------------
   --  Returns the backtrace of the current frame (up to the root).
   --  ------------------------------
   function Backtrace (Frame :  in Frame_Type) return Frame_Table is
      Pc      : Frame_Table (1 .. Frame.Depth);
      Current : Frame_Type := Frame;
      Pos     : Natural   := Current.Depth;
      New_Pos : Natural;
   begin
      while Current /= null and Pos /= 0 loop
         New_Pos := Pos - Current.Local_Depth + 1;
         Pc (New_Pos .. Pos) := Current.Calls (1 .. Current.Local_Depth);
         Pos     := New_Pos - 1;
         Current := Current.Parent;
      end loop;
      return Pc;
   end Backtrace;

   --  ------------------------------
   --  Returns the number of children in the frame.
   --  When recursive is true, compute in the sub-tree.
   --  ------------------------------
   function Count_Children (Frame     : in Frame_Type;
                            Recursive : in Boolean := False) return Natural is
      Count : Natural := 0;
      Child : Frame_Type;
   begin
      if Frame /= null then
         Child := Frame.Children;
         while Child /= null loop
            Count := Count + 1;
            if Recursive then
               declare
                  N : Natural := Count_Children (Child, True);
               begin
                  if N > 0 then
                     N := N - 1;
                  end if;
                  Count := Count + N;
               end;
            end if;
            Child := Child.Next;
         end loop;
      end if;
      return Count;
   end Count_Children;

   --  ------------------------------
   --  Returns all the direct calls made by the current frame.
   --  ------------------------------
   function Calls (Frame : in Frame_Type) return Frame_Table is
      Nb_Calls : constant Natural   := Count_Children (Frame);
      Pc       : Frame_Table (1 .. Nb_Calls);
   begin
      if Frame /= null then
         declare
            Child : Frame_Type := Frame.Children;
            Pos   : Natural   := 1;
         begin
            while Child /= null loop
               Pc (Pos) := Child.Calls (1);
               Pos   := Pos + 1;
               Child := Child.Next;
            end loop;
         end;
      end if;
      return Pc;
   end Calls;

   --  ------------------------------
   --  Returns the current stack depth (# of calls from the root
   --  to reach the frame).
   --  ------------------------------
   function Current_Depth (Frame : in Frame_Type) return Natural is
   begin
      if Frame = null then
         return 0;
      else
         return Frame.Depth;
      end if;
   end Current_Depth;

   --  ------------------------------
   --  Create a root for stack frame representation.
   --  ------------------------------
   function Create_Root return Frame_Type is
   begin
      return new Frame;
   end Create_Root;

   --  ------------------------------
   --  Destroy the frame tree recursively.
   --  ------------------------------
   procedure Destroy (Frame : in out Frame_Type) is
      F : Frame_Type;
   begin
      if Frame = null then
         return;
      end if;
      --  Destroy its children recursively.
      while Frame.Children /= null loop
         F := Frame.Children;
         Destroy (F);
      end loop;

      --  Unlink from parent list.
      if Frame.Parent /= null then
         F := Frame.Parent.Children;
         if F = Frame then
            Frame.Parent.Children := Frame.Next;
         else
            while F /= null and F.Next /= Frame loop
               F := F.Next;
            end loop;
            if F = null then
               raise Program_Error;
            end if;
            F.Next := Frame.Next;
         end if;
      end if;
      Free (Frame);
   end Destroy;

   --  ------------------------------
   --  Release the frame when its reference is no longer necessary.
   --  ------------------------------
   procedure Release (Frame : in Frame_Type) is
      Current : Frame_Type := Frame;
   begin
      --  Scan the frame until the root is reached
      --  and decrement the used counter.  Free the frames
      --  when the used counter reaches 0.
      while Current /= null loop
         if Current.Used <= 1 then
            declare
               Tree : Frame_Type := Current;
            begin
               Current := Current.Parent;
               Destroy (Tree);
            end;
         else
            Current.Used := Current.Used - 1;
            Current := Current.Parent;
         end if;
      end loop;
   end Release;

   --  ------------------------------
   --  Split the node pointed to by `F' at the position `Pos'
   --  in the caller chain.  A new parent is created for the node
   --  and the brothers of the node become the brothers of the
   --  new parent.
   --
   --  Returns in `F' the new parent node.
   --  ------------------------------
   procedure Split (F     : in out Frame_Type;
                    Pos   : in Positive) is

      --  Before:                       After:
      --
      --    +-------+             +-------+
      --  /-|  P    |           /-|  P    |
      --  | +-------+           | +-------+
      --  |       ^             |       ^
      --  |   +-------+         |    +-------+
      --  ...>| node  |...      ....>|  new  |...        (0..N brothers)
      --      +-------+              +-------+
      --       |     ^              |      ^
      --       | +-------+          | +-------+
      --       ->|  c    |          ->| node  |-->0      (0 brother)
      --         +-------+            +-------+
      --                                    |
      --                                +-------+
      --                                |   c   |
      --                                +-------+
      --
      New_Parent : constant Frame_Type := new Frame '(Parent      => F.Parent,
                                                      Next        => F.Next,
                                                      Children    => F,
                                                      Used        => F.Used,
                                                      Depth       => F.Depth,
                                                      Local_Depth => Pos,
                                                      Calls       => (others => 0));
      Child : Frame_Type := F.Parent.Children;
   begin
      --  Move the PC values in the new parent.
      New_Parent.Calls (1 .. Pos) := F.Calls (1 .. Pos);
      F.Calls (1 .. F.Local_Depth - Pos) := F.Calls (Pos + 1 .. F.Local_Depth);
      F.Parent         := New_Parent;
      F.Next           := null;
      New_Parent.Depth := F.Depth - F.Local_Depth + Pos;
      F.Local_Depth    := F.Local_Depth - Pos;

      --  Remove F from its parent children list and replace if with New_Parent.
      if Child = F then
         New_Parent.Parent.Children := New_Parent;
      else
         while Child.Next /= F loop
            Child := Child.Next;
         end loop;
         Child.Next := New_Parent;
      end if;
      F := New_Parent;
   end Split;

   procedure Add_Frame (F      : in Frame_Type;
                        Pc     : in Frame_Table;
                        Result : out Frame_Type) is
      Child         : Frame_Type := F;
      Pos           : Positive   := Pc'First;
      Current_Depth : Natural    := F.Depth;
      Cnt           : Local_Depth_Type;
   begin
      while Pos <= Pc'Last loop
         Cnt := Frame_Group_Size;
         if Pos + Cnt > Pc'Last then
            Cnt := Pc'Last - Pos + 1;
         end if;
         Current_Depth := Current_Depth + Cnt;
         Child := new Frame '(Parent      => Child,
                              Next        => Child.Children,
                              Children    => null,
                              Used        => 1,
                              Depth       => Current_Depth,
                              Local_Depth => Cnt,
                              Calls       => (others => 0));
         Child.Calls (1 .. Cnt) := Pc (Pos .. Pos + Cnt - 1);
         Pos := Pos + Cnt;
         Child.Parent.Children := Child;
      end loop;
      Result := Child;
   end Add_Frame;

   procedure Insert (F : in Frame_Ptr;
                     Pc : in Pc_Table;
                     Result : out Frame_Ptr) is
      Current : Frame_Ptr := F;
      Child   : Frame_Ptr;
      Pos     : Positive  := Pc'First;
      Lpos    : Positive  := 1;
      Addr    : Target_Addr;
   begin
      while Pos <= Pc'Last loop
         Addr := Pc (Pos);
         if Lpos <= Current.Local_Depth then
            if Addr = Current.Calls (Lpos) then
               Lpos := Lpos + 1;
               Pos  := Pos + 1;

               --  Split this node
            else
               if Lpos > 1 then
                  Split (Current, Lpos - 1);
               end if;
               Add_Frame (Current, Pc (Pos .. Pc'Last), Result);
               return;
            end if;
         else
            --  Find the first child which has the address.
            Child := Current.Children;
            while Child /= null loop
               exit when Child.Calls (1) = Addr;
               Child := Child.Next;
            end loop;
            if Child = null then
               Add_Frame (Current, Pc (Pos .. Pc'Last), Result);
               return;
            end if;
            Current := Child;
            Lpos    := 2;
            Pos     := Pos + 1;
            Current.Used := Current.Used + 1;
         end if;
      end loop;
      if Lpos <= Current.Local_Depth then
         Split (Current, Lpos - 1);
      end if;
      Result := Current;
   end Insert;

   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   function Find (F : in Frame_Ptr; Pc : in Target_Addr) return Frame_Ptr is
      Child : Frame_Ptr := F.Children;
   begin
      while Child /= null loop
         if Child.Local_Depth >= 1 and then Child.Calls (1) = Pc then
            return Child;
         end if;
         Child := Child.Next;
      end loop;
      raise Not_Found;
   end Find;

   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   function Find (F : in Frame_Ptr; Pc : in PC_Table) return Frame_Ptr is
      Child : Frame_Ptr := F;
      Pos   : Positive  := Pc'First;
      Lpos  : Positive;
   begin
      while Pos <= Pc'Last loop
         Child := Find (Child, Pc (Pos));
         Pos  := Pos + 1;
         Lpos := 2;
         --  All the PC of the child frame must match.
         while Pos <= Pc'Last and Lpos <= Child.Local_Depth loop
            if Child.Calls (Lpos) /= Pc (Pos) then
               raise Not_Found;
            end if;
            Lpos := Lpos + 1;
            Pos  := Pos + 1;
         end loop;
      end loop;
      return Child;
   end Find;

   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   procedure Find (F       : in Frame_Ptr;
                   Pc      : in PC_Table;
                   Result  : out Frame_Ptr;
                   Last_Pc : out Natural) is
      Current : Frame_Ptr := F;
      Pos     : Positive  := Pc'First;
      Lpos    : Positive;
   begin
      Main_Search:
      while Pos <= Pc'Last loop
         declare
            Addr  : Target_Addr := Pc (Pos);
            Child : Frame_Ptr   := Current.Children;
         begin
            --  Find the child which has the corresponding PC.
            loop
               exit Main_Search when Child = null;
               exit when Child.Local_Depth >= 1 and Child.Calls (1) = Addr;
               Child := Child.Next;
            end loop;

            Current := Child;
            Pos  := Pos + 1;
            Lpos := 2;
            --  All the PC of the child frame must match.
            while Pos <= Pc'Last and Lpos <= Current.Local_Depth loop
               exit Main_Search when Current.Calls (Lpos) /= Pc (Pos);
               Lpos := Lpos + 1;
               Pos  := Pos + 1;
            end loop;
         end;
      end loop Main_Search;
      Result := Current;
      if Pos > Pc'Last then
         Last_Pc := 0;
      else
         Last_Pc := Pos;
      end if;
   end Find;

end MAT.Frames;

Refactor the Split operation

Refactor the Split operation


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

with Ada.Strings.Maps;

procedure Natools.Chunked_Strings.Tests.Bugfixes
  (Report : in out Natools.Tests.Reporter'Class)
is
   package NT renames Natools.Tests;
begin
   Report.Section ("Extra tests for complete coverage");

   declare
      Name : constant String := "Overreach of Index";
      CS : Chunked_String := To_Chunked_String ("abcd0123");
      N : Natural;
   begin
      CS.Head (4);
      N := CS.Index (Ada.Strings.Maps.To_Set ("0123456789"));

      if N /= 0 then
         Report.Item (Name, NT.Fail);
         Report.Info ("Index of digit" & Natural'Image (N) & ", expected 0.");
      else
         Report.Item (Name, NT.Success);
      end if;
   exception
      when Error : others => NT.Report_Exception (Report, Name, Error);
   end;

   Report.End_Section;
end Natools.Chunked_Strings.Tests.Bugfixes;

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

with Ada.Strings.Maps;

procedure Natools.Chunked_Strings.Tests.Bugfixes
  (Report : in out Natools.Tests.Reporter'Class)
is
   package NT renames Natools.Tests;
begin
   Report.Section ("Tests for known bugs");

   declare
      Name : constant String := "Overreach of Index";
      CS : Chunked_String := To_Chunked_String ("abcd0123");
      N : Natural;
   begin
      CS.Head (4);
      N := CS.Index (Ada.Strings.Maps.To_Set ("0123456789"));

      if N /= 0 then
         Report.Item (Name, NT.Fail);
         Report.Info ("Index of digit" & Natural'Image (N) & ", expected 0.");
      else
         Report.Item (Name, NT.Success);
      end if;
   exception
      when Error : others => NT.Report_Exception (Report, Name, Error);
   end;

   Report.End_Section;
end Natools.Chunked_Strings.Tests.Bugfixes;

Fix test suite description

chunked_strings-tests-bugfixes: Fix test suite description


-----------------------------------------------------------------------
--  awa-images-services -- Image service
--  Copyright (C) 2012, 2013, 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 Util.Processes;
with Util.Beans.Objects;
with Util.Log.Loggers;
with Util.Streams.Pipes;
with Util.Streams.Texts;

with ADO;
with ADO.Sessions;

with AWA.Images.Models;
with AWA.Services.Contexts;
with AWA.Storages.Services;
with AWA.Storages.Modules;
with Ada.Strings.Unbounded;

with EL.Variables.Default;
with EL.Contexts.Default;

--  == Storage Service ==
--  The <tt>Storage_Service</tt> provides the operations to access and use the persisent storage.
--  It controls the permissions that grant access to the service for users.
--
--  Other modules can be notified of storage changes by registering a listener
--  on the storage module.
package body AWA.Images.Services is

   package ASC renames AWA.Services.Contexts;

   --  ------------------------------
   --  Image Service
   --  ------------------------------

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Images.Services");

   --  ------------------------------
   --  Initializes the storage service.
   --  ------------------------------
   overriding
   procedure Initialize (Service : in out Image_Service;
                         Module  : in AWA.Modules.Module'Class) is
   begin
      AWA.Modules.Module_Manager (Service).Initialize (Module);

      Service.Thumbnail_Command := Module.Get_Config (PARAM_THUMBNAIL_COMMAND);
   end Initialize;

   procedure Create_Thumbnail (Service : in Image_Service;
                               Source  : in String;
                               Into    : in String;
                               Width   : out Natural;
                               Height  : out Natural) is
      Ctx       : EL.Contexts.Default.Default_Context;
      Variables : aliased EL.Variables.Default.Default_Variable_Mapper;

      Proc    : Util.Processes.Process;
      Pipe    : aliased Util.Streams.Pipes.Pipe_Stream;
   begin
      Variables.Bind ("src", Util.Beans.Objects.To_Object (Source));
      Variables.Bind ("dst", Util.Beans.Objects.To_Object (Into));
      Ctx.Set_Variable_Mapper (Variables'Unchecked_Access);
      declare
         Cmd     : constant Util.Beans.Objects.Object := Service.Thumbnail_Command.Get_Value (Ctx);
         Command : constant String := Util.Beans.Objects.To_String (Cmd);
         Input   : Util.Streams.Texts.Reader_Stream;
      begin
         Width  := 0;
         Height := 0;
         Pipe.Open (Command, Util.Processes.READ_ALL);
         Input.Initialize (null, Pipe'Unchecked_Access, 1024);
         while not Input.Is_Eof loop
            declare
               use Ada.Strings;

               Line : Ada.Strings.Unbounded.Unbounded_String;
               Pos  : Natural;
               Sep  : Natural;
               Last : Natural;
            begin
               Input.Read_Line (Into  => Line, Strip => False);
               exit when Ada.Strings.Unbounded.Length (Line) = 0;
               Log.Info ("Received: {0}", Line);

               --  The '-verbose' option of ImageMagick reports information about the original
               --  image.  Extract the picture width and height.
               --  image.png PNG 120x282 120x282+0+0 8-bit DirectClass 34.4KB 0.000u 0:00.018
               Pos := Ada.Strings.Unbounded.Index (Line, " ");
               if Pos > 0 and Width = 0 then
                  Pos := Ada.Strings.Unbounded.Index (Line, " ", Pos + 1);
                  if Pos > 0 then
                     Sep := Ada.Strings.Unbounded.Index (Line, "x", Pos + 1);
                     Last := Ada.Strings.Unbounded.Index (Line, "=", Pos + 1);
                     if Sep > 0 and Sep < Last then
                        Log.Info ("Dimension {0} - {1}..{2}",
                                  Ada.Strings.Unbounded.Slice (Line, Pos, Last),
                                  Natural'Image (Pos), Natural'Image (Last));
                        Width := Natural'Value (Unbounded.Slice (Line, Pos + 1, Sep - 1));
                        Height := Natural'Value (Unbounded.Slice (Line, Sep + 1, Last - 1));
                     end if;
                  end if;
               end if;
            end;
         end loop;
         Pipe.Close;

         Util.Processes.Wait (Proc);
         if Pipe.Get_Exit_Status /= 0 then
            Log.Error ("Command {0} exited with status {1}", Command,
                       Integer'Image (Pipe.Get_Exit_Status));
         end if;
      end;
   end Create_Thumbnail;

   --  Build a thumbnail for the image identified by the Id.
   procedure Build_Thumbnail (Service : in Image_Service;
                              Id      : in ADO.Identifier) is
      Storage_Service : constant AWA.Storages.Services.Storage_Service_Access
        := AWA.Storages.Modules.Get_Storage_Manager;
      Ctx         : constant ASC.Service_Context_Access := ASC.Current;
      DB          : ADO.Sessions.Master_Session := ASC.Get_Master_Session (Ctx);
      Img         : AWA.Images.Models.Image_Ref;
      Target_File : AWA.Storages.Storage_File;
      Local_File  : AWA.Storages.Storage_File;
      Width       : Natural;
      Height      : Natural;
   begin
      Img.Load (DB, Id);
      Storage_Service.Get_Local_File (From => Img.Get_Storage.Get_Id, Into => Local_File);
      Storage_Service.Create_Local_File (Target_File);
      Service.Create_Thumbnail (AWA.Storages.Get_Path (Local_File),
                                AWA.Storages.Get_Path (Target_File), Width, Height);
      Img.Set_Width (Width);
      Img.Set_Height (Height);
      Img.Set_Thumb_Width (64);
      Img.Set_Thumb_Height (64);
      Ctx.Start;
      Img.Save (DB);
      Ctx.Commit;
   end Build_Thumbnail;

   --  Save the data object contained in the Data part element into the
   --  target storage represented by Into.
   procedure Create_Image (Service : in Image_Service;
                           File    : in AWA.Storages.Models.Storage_Ref'Class) is
      pragma Unreferenced (Service);

      Ctx : constant AWA.Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      DB  : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Img : AWA.Images.Models.Image_Ref;
   begin
      Ctx.Start;
      Img.Set_Width (0);
      Img.Set_Height (0);
      Img.Set_Thumb_Height (0);
      Img.Set_Thumb_Width (0);
      Img.Set_Storage (File);
      Img.Set_Folder (File.Get_Folder);
      Img.Set_Owner (File.Get_Owner);
      Img.Save (DB);
      Ctx.Commit;
   end Create_Image;

   --  Deletes the storage instance.
   procedure Delete_Image (Service : in Image_Service;
                           File    : in AWA.Storages.Models.Storage_Ref'Class) is
   begin
      null;
   end Delete_Image;

end AWA.Images.Services;

-----------------------------------------------------------------------
--  awa-images-services -- Image service
--  Copyright (C) 2012, 2013, 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 Util.Processes;
with Util.Beans.Objects;
with Util.Log.Loggers;
with Util.Streams.Pipes;
with Util.Streams.Texts;

with ADO;
with ADO.Sessions;

with AWA.Images.Models;
with AWA.Services.Contexts;
with AWA.Storages.Services;
with AWA.Storages.Modules;
with Ada.Strings.Unbounded;

with EL.Variables.Default;
with EL.Contexts.Default;

--  == Storage Service ==
--  The <tt>Storage_Service</tt> provides the operations to access and use the persisent storage.
--  It controls the permissions that grant access to the service for users.
--
--  Other modules can be notified of storage changes by registering a listener
--  on the storage module.
package body AWA.Images.Services is

   package ASC renames AWA.Services.Contexts;

   --  ------------------------------
   --  Image Service
   --  ------------------------------

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Images.Services");

   --  ------------------------------
   --  Initializes the storage service.
   --  ------------------------------
   overriding
   procedure Initialize (Service : in out Image_Service;
                         Module  : in AWA.Modules.Module'Class) is
   begin
      AWA.Modules.Module_Manager (Service).Initialize (Module);

      Service.Thumbnail_Command := Module.Get_Config (PARAM_THUMBNAIL_COMMAND);
   end Initialize;

   procedure Create_Thumbnail (Service : in Image_Service;
                               Source  : in String;
                               Into    : in String;
                               Width   : out Natural;
                               Height  : out Natural) is
      Ctx       : EL.Contexts.Default.Default_Context;
      Variables : aliased EL.Variables.Default.Default_Variable_Mapper;

      Proc    : Util.Processes.Process;
      Pipe    : aliased Util.Streams.Pipes.Pipe_Stream;
   begin
      Variables.Bind ("src", Util.Beans.Objects.To_Object (Source));
      Variables.Bind ("dst", Util.Beans.Objects.To_Object (Into));
      Ctx.Set_Variable_Mapper (Variables'Unchecked_Access);
      declare
         Cmd     : constant Util.Beans.Objects.Object := Service.Thumbnail_Command.Get_Value (Ctx);
         Command : constant String := Util.Beans.Objects.To_String (Cmd);
         Input   : Util.Streams.Texts.Reader_Stream;
      begin
         Width  := 0;
         Height := 0;
         Pipe.Open (Command, Util.Processes.READ_ALL);
         Input.Initialize (null, Pipe'Unchecked_Access, 1024);
         while not Input.Is_Eof loop
            declare
               use Ada.Strings;

               Line : Ada.Strings.Unbounded.Unbounded_String;
               Pos  : Natural;
               Sep  : Natural;
               Last : Natural;
            begin
               Input.Read_Line (Into  => Line, Strip => False);
               exit when Ada.Strings.Unbounded.Length (Line) = 0;
               Log.Info ("Received: {0}", Line);

               --  The '-verbose' option of ImageMagick reports information about the original
               --  image.  Extract the picture width and height.
               --  image.png PNG 120x282 120x282+0+0 8-bit DirectClass 34.4KB 0.000u 0:00.018
               Pos := Ada.Strings.Unbounded.Index (Line, " ");
               if Pos > 0 and Width = 0 then
                  Pos := Ada.Strings.Unbounded.Index (Line, " ", Pos + 1);
                  if Pos > 0 then
                     Sep := Ada.Strings.Unbounded.Index (Line, "x", Pos + 1);
                     Last := Ada.Strings.Unbounded.Index (Line, "=", Pos + 1);
                     if Sep > 0 and Sep < Last then
                        Log.Info ("Dimension {0} - {1}..{2}",
                                  Ada.Strings.Unbounded.Slice (Line, Pos, Last),
                                  Natural'Image (Pos), Natural'Image (Last));
                        Width := Natural'Value (Unbounded.Slice (Line, Pos + 1, Sep - 1));
                        Height := Natural'Value (Unbounded.Slice (Line, Sep + 1, Last - 1));
                     end if;
                  end if;
               end if;
            end;
         end loop;
         Pipe.Close;

         Util.Processes.Wait (Proc);
         if Pipe.Get_Exit_Status /= 0 then
            Log.Error ("Command {0} exited with status {1}", Command,
                       Integer'Image (Pipe.Get_Exit_Status));
         end if;
      end;
   end Create_Thumbnail;

   --  Build a thumbnail for the image identified by the Id.
   procedure Build_Thumbnail (Service : in Image_Service;
                              Id      : in ADO.Identifier) is
      Storage_Service : constant AWA.Storages.Services.Storage_Service_Access
        := AWA.Storages.Modules.Get_Storage_Manager;
      Ctx         : constant ASC.Service_Context_Access := ASC.Current;
      DB          : ADO.Sessions.Master_Session := ASC.Get_Master_Session (Ctx);
      Img         : AWA.Images.Models.Image_Ref;
      Thumb       : AWA.Images.Models.Image_Ref;
      Target_File : AWA.Storages.Storage_File;
      Local_File  : AWA.Storages.Storage_File;
      Thumbnail   : AWA.Storages.Models.Storage_Ref;
      Width       : Natural;
      Height      : Natural;
      Name        : Ada.Strings.Unbounded.Unbounded_String;
   begin
      Img.Load (DB, Id);
      declare
         Image_File : constant AWA.Storages.Models.Storage_Ref'Class := Img.Get_Storage;
      begin
         Storage_Service.Get_Local_File (From => Image_File.Get_Id, Into => Local_File);
         Storage_Service.Create_Local_File (Target_File);

         Service.Create_Thumbnail (AWA.Storages.Get_Path (Local_File),
                                   AWA.Storages.Get_Path (Target_File), Width, Height);
         Thumbnail.Set_Mime_Type ("image/jpeg");
         Thumbnail.Set_Original (Image_File);
         Thumbnail.Set_Workspace (Image_File.Get_Workspace);
         Thumbnail.Set_Folder (Image_File.Get_Folder);
         Thumbnail.Set_Owner (Image_File.Get_Owner);
         Thumbnail.Set_Name (String '(Image_File.Get_Name));
         Storage_Service.Save (Thumbnail, Target_File, AWA.Storages.Models.DATABASE);
         Thumb.Set_Width (64);
         Thumb.Set_Height (64);
         Thumb.Set_Owner (Image_File.Get_Owner);
         Thumb.Set_Folder (Image_File.Get_Folder);
         Thumb.Set_Storage (Thumbnail);
         Img.Set_Width (Width);
         Img.Set_Height (Height);
         Img.Set_Thumb_Width (64);
         Img.Set_Thumb_Height (64);
         Img.Set_Thumbnail (Thumbnail);
         Ctx.Start;
         Img.Save (DB);
         Thumb.Save (DB);
         Ctx.Commit;
      end;
   end Build_Thumbnail;

   --  Save the data object contained in the Data part element into the
   --  target storage represented by Into.
   procedure Create_Image (Service : in Image_Service;
                           File    : in AWA.Storages.Models.Storage_Ref'Class) is
      pragma Unreferenced (Service);

      Ctx : constant AWA.Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      DB  : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Img : AWA.Images.Models.Image_Ref;
   begin
      Ctx.Start;
      Img.Set_Width (0);
      Img.Set_Height (0);
      Img.Set_Thumb_Height (0);
      Img.Set_Thumb_Width (0);
      Img.Set_Storage (File);
      Img.Set_Folder (File.Get_Folder);
      Img.Set_Owner (File.Get_Owner);
      Img.Save (DB);
      Ctx.Commit;
   end Create_Image;

   --  Deletes the storage instance.
   procedure Delete_Image (Service : in Image_Service;
                           File    : in AWA.Storages.Models.Storage_Ref'Class) is
   begin
      null;
   end Delete_Image;

end AWA.Images.Services;

Fix Build_Thumbnail to create the database information after a thumbnail image is created


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

with Ada.Finalization;
with Ada.Strings.Unbounded;

with Ada.Containers.Hashed_Maps;
with Ada.Containers.Vectors;

with Util.Strings;
with Util.Refs;
with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.IO.XML;

with GNAT.Regexp;

limited with Security.Controllers;
limited with Security.Contexts;

--  == Permissions ==
--  The Security.Permissions package defines the different permissions that can be
--  checked by the access control manager.
--
--  === 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.
--
package Security.Permissions is

   --  EL function name exposed by Set_Functions.
   HAS_PERMISSION_FN  : constant String := "hasPermission";

   --  URI for the EL functions exposed by the security package (See Set_Functions).
   AUTH_NAMESPACE_URI : constant String := "http://code.google.com/p/ada-asf/auth";

   Invalid_Name : exception;

   type Security_Context_Access is access all Contexts.Security_Context'Class;

   type Permission_Index is new Natural;

   type Controller_Access is access all Security.Controllers.Controller'Class;

   type Controller_Access_Array is array (Permission_Index range <>) of Controller_Access;

   --  Get the permission index associated with the name.
   function Get_Permission_Index (Name : in String) return Permission_Index;

   --  Get the last permission index registered in the global permission map.
   function Get_Last_Permission_Index return Permission_Index;

   --  Add the permission name and allocate a unique permission index.
   procedure Add_Permission (Name  : in String;
                             Index : out Permission_Index);

   --  The permission root class.
   type Abstract_Permission is abstract tagged limited null record;

   --  Each role is represented by a Role_Type number to provide a fast
   --  and efficient role check.
   type Role_Type is new Natural range 0 .. 63;

   type Role_Type_Array is array (Positive range <>) of Role_Type;

   --  The Role_Map represents a set of roles which are assigned to a user.
   --  Each role is represented by a boolean in the map.  The implementation is limited
   --  to 64 roles (the number of different permissions can be higher).
   type Role_Map is array (Role_Type'Range) of Boolean;
   pragma Pack (Role_Map);

   --  Each permission is represented by a Permission_Type number to provide a fast
   --  and efficient permission check.
   type Permission_Type is new Natural range 0 .. 63;

   --  The Permission_Map represents a set of permissions which are granted to a user.
   --  Each permission is represented by a boolean in the map.  The implementation is limited
   --  to 64 permissions.
   type Permission_Map is array (Permission_Type'Range) of Boolean;
   pragma Pack (Permission_Map);

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

   --  Returns true if the given role is stored in the user principal.
   function Has_Role (User : in Principal;
                      Role : in Role_Type) return Boolean is abstract;

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

   --  ------------------------------
   --  Permission
   --  ------------------------------

   --  Represents a permission for a given role.
   type Permission (Role : Permission_Type) is new Abstract_Permission with null record;

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

   --  ------------------------------
   --  File Permission
   --  ------------------------------

   type File_Mode is (READ, WRITE);

   --  Represents a permission to access a given file.
   type File_Permission (Len  : Natural;
                         Mode : File_Mode) is new Abstract_Permission with record
      Path : String (1 .. Len);
   end record;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------
   --  The Permission_Manager verifies through some policy that a permission
   --  is granted to a user.
   type Permission_Manager is new Ada.Finalization.Limited_Controlled with private;
   type Permission_Manager_Access is access all Permission_Manager'Class;

   procedure Add_Permission (Manager    : in out Permission_Manager;
                             Name       : in String;
                             Permission : in Controller_Access);

   --  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 Permission_Manager;
                       Name    : in String) return Role_Type;

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

   --  Returns True if the user has the given role permission.
   function Has_Permission (Manager    : in Permission_Manager;
                            User       : in Principal'Class;
                            Permission : in Permission_Type) return Boolean;

   --  Get the security controller associated with the permission index Index.
   --  Returns null if there is no such controller.
   function Get_Controller (Manager : in Permission_Manager'Class;
                            Index   : in Permission_Index) return Controller_Access;
   pragma Inline_Always (Get_Controller);

   --  Get the role name.
   function Get_Role_Name (Manager : in Permission_Manager;
                           Role    : in Role_Type) return String;

   --  Create a role
   procedure Create_Role (Manager : in out Permission_Manager;
                          Name    : in String;
                          Role    : out Role_Type);

   --  Get or add a role type for the given name.
   procedure Add_Role_Type (Manager   : in out Permission_Manager;
                            Name      : in String;
                            Result    : out Role_Type);

   --  Grant the permission to access to the given URI to users having the To
   --  permissions.
   procedure Grant_URI_Permission (Manager : in out Permission_Manager;
                                   URI     : in String;
                                   To      : in String);

   --  Grant the permission to access to the given Path to users having the To
   --  permissions.
   procedure Grant_File_Permission (Manager : in out Permission_Manager;
                                    Path    : in String;
                                    To      : in String);

   --  Read the policy file
   procedure Read_Policy (Manager : in out Permission_Manager;
                          File    : in String);

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

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

   generic
      Name : String;
   package Permission_ACL is
      function Permission return Permission_Index;
      pragma Inline_Always (Permission);
   end Permission_ACL;

   --  ------------------------------
   --  Policy Configuration
   --  ------------------------------
   type Policy_Config is record
      Id          : Natural := 0;
      Permissions : Util.Beans.Objects.Vectors.Vector;
      Patterns    : Util.Beans.Objects.Vectors.Vector;
      Manager     : Permission_Manager_Access;
   end record;
   type Policy_Config_Access is access all Policy_Config;

   --  Setup the XML parser to read the policy description.  For example:
   --
   --  <policy id='1'>
   --     <permission>create-workspace</permission>
   --     <permission>admin</permission>
   --     <url-pattern>/workspace/create</url-pattern>
   --     <url-pattern>/workspace/setup/*</url-pattern>
   --  </policy>
   --
   --  This policy gives access to the URL that match one of the URL pattern if the
   --  security context has the permission create-workspace or admin.
   generic
      Reader  : in out Util.Serialize.IO.XML.Parser;
      Manager : in Security.Permissions.Permission_Manager_Access;
   package Reader_Config is
      Config : aliased Policy_Config;
   end Reader_Config;

   --  Register a set of functions in the namespace
   --  xmlns:fn="http://code.google.com/p/ada-asf/auth"
   --  Functions:
   --    hasPermission(NAME)   --  Returns True if the permission NAME is granted
   --  procedure Set_Functions (Mapper : in out EL.Functions.Function_Mapper'Class);

private

   use Util.Strings;

   type Role_Name_Array is
     array (Role_Type'Range) of Ada.Strings.Unbounded.String_Access;

   type Permission_Type_Array is array (1 .. 10) of Permission_Type;

   type Permission_Index_Array is array (Positive range <>) of Permission_Index;

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

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

   --  No rule
--     No_Rule : constant Access_Rule := (Count => 0,
--                                        Permissions => (others => Permission_Index'First));

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

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

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

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

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

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

   type Rules_Ref_Access is access Rules_Ref.Atomic_Ref;

   type Controller_Access_Array_Access is access all Controller_Access_Array;

   type Permission_Manager is new Ada.Finalization.Limited_Controlled with record
      Names        : Role_Name_Array;
      Cache        : Rules_Ref_Access;
      Next_Role    : Role_Type := Role_Type'First;
      Policies     : Policy_Vector.Vector;
      Permissions  : Controller_Access_Array_Access;
      Last_Index   : Permission_Index := Permission_Index'First;
   end record;

   --  EL function to check if the given permission name is granted by the current
   --  security context.
   function Has_Permission (Value : in Util.Beans.Objects.Object)
                            return Util.Beans.Objects.Object;

end Security.Permissions;

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

with Ada.Finalization;
with Ada.Strings.Unbounded;

with Ada.Containers.Hashed_Maps;
with Ada.Containers.Vectors;

with Util.Strings;
with Util.Refs;
with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.IO.XML;

with GNAT.Regexp;

limited with Security.Controllers;
limited with Security.Contexts;

--  == Permissions ==
--  The Security.Permissions package defines the different permissions that can be
--  checked by the access control manager.
--
--  === 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.
--
package Security.Permissions is

   --  EL function name exposed by Set_Functions.
   HAS_PERMISSION_FN  : constant String := "hasPermission";

   --  URI for the EL functions exposed by the security package (See Set_Functions).
   AUTH_NAMESPACE_URI : constant String := "http://code.google.com/p/ada-asf/auth";

   Invalid_Name : exception;

   type Security_Context_Access is access all Contexts.Security_Context'Class;

   type Permission_Index is new Natural;

   type Controller_Access is access all Security.Controllers.Controller'Class;

   type Controller_Access_Array is array (Permission_Index range <>) of Controller_Access;

   --  Get the permission index associated with the name.
   function Get_Permission_Index (Name : in String) return Permission_Index;

   --  Get the last permission index registered in the global permission map.
   function Get_Last_Permission_Index return Permission_Index;

   --  Add the permission name and allocate a unique permission index.
   procedure Add_Permission (Name  : in String;
                             Index : out Permission_Index);

   --  The permission root class.
   type Abstract_Permission is abstract tagged limited null record;

   --  Each role is represented by a Role_Type number to provide a fast
   --  and efficient role check.
   type Role_Type is new Natural range 0 .. 63;

   type Role_Type_Array is array (Positive range <>) of Role_Type;

   --  The Role_Map represents a set of roles which are assigned to a user.
   --  Each role is represented by a boolean in the map.  The implementation is limited
   --  to 64 roles (the number of different permissions can be higher).
   type Role_Map is array (Role_Type'Range) of Boolean;
   pragma Pack (Role_Map);

   --  Each permission is represented by a Permission_Type number to provide a fast
   --  and efficient permission check.
   type Permission_Type is new Natural range 0 .. 63;

   --  The Permission_Map represents a set of permissions which are granted to a user.
   --  Each permission is represented by a boolean in the map.  The implementation is limited
   --  to 64 permissions.
   type Permission_Map is array (Permission_Type'Range) of Boolean;
   pragma Pack (Permission_Map);

   --  ------------------------------
   --  Permission
   --  ------------------------------

   --  Represents a permission for a given role.
   type Permission (Role : Permission_Type) is new Abstract_Permission with null record;

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

   --  ------------------------------
   --  File Permission
   --  ------------------------------

   type File_Mode is (READ, WRITE);

   --  Represents a permission to access a given file.
   type File_Permission (Len  : Natural;
                         Mode : File_Mode) is new Abstract_Permission with record
      Path : String (1 .. Len);
   end record;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------
   --  The Permission_Manager verifies through some policy that a permission
   --  is granted to a user.
   type Permission_Manager is new Ada.Finalization.Limited_Controlled with private;
   type Permission_Manager_Access is access all Permission_Manager'Class;

   procedure Add_Permission (Manager    : in out Permission_Manager;
                             Name       : in String;
                             Permission : in Controller_Access);

   --  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 Permission_Manager;
                       Name    : in String) return Role_Type;

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

   --  Returns True if the user has the given role permission.
   function Has_Permission (Manager    : in Permission_Manager;
                            User       : in Principal'Class;
                            Permission : in Permission_Type) return Boolean;

   --  Get the security controller associated with the permission index Index.
   --  Returns null if there is no such controller.
   function Get_Controller (Manager : in Permission_Manager'Class;
                            Index   : in Permission_Index) return Controller_Access;
   pragma Inline_Always (Get_Controller);

   --  Get the role name.
   function Get_Role_Name (Manager : in Permission_Manager;
                           Role    : in Role_Type) return String;

   --  Create a role
   procedure Create_Role (Manager : in out Permission_Manager;
                          Name    : in String;
                          Role    : out Role_Type);

   --  Get or add a role type for the given name.
   procedure Add_Role_Type (Manager   : in out Permission_Manager;
                            Name      : in String;
                            Result    : out Role_Type);

   --  Grant the permission to access to the given URI to users having the To
   --  permissions.
   procedure Grant_URI_Permission (Manager : in out Permission_Manager;
                                   URI     : in String;
                                   To      : in String);

   --  Grant the permission to access to the given Path to users having the To
   --  permissions.
   procedure Grant_File_Permission (Manager : in out Permission_Manager;
                                    Path    : in String;
                                    To      : in String);

   --  Read the policy file
   procedure Read_Policy (Manager : in out Permission_Manager;
                          File    : in String);

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

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

   generic
      Name : String;
   package Permission_ACL is
      function Permission return Permission_Index;
      pragma Inline_Always (Permission);
   end Permission_ACL;

   --  ------------------------------
   --  Policy Configuration
   --  ------------------------------
   type Policy_Config is record
      Id          : Natural := 0;
      Permissions : Util.Beans.Objects.Vectors.Vector;
      Patterns    : Util.Beans.Objects.Vectors.Vector;
      Manager     : Permission_Manager_Access;
   end record;
   type Policy_Config_Access is access all Policy_Config;

   --  Setup the XML parser to read the policy description.  For example:
   --
   --  <policy id='1'>
   --     <permission>create-workspace</permission>
   --     <permission>admin</permission>
   --     <url-pattern>/workspace/create</url-pattern>
   --     <url-pattern>/workspace/setup/*</url-pattern>
   --  </policy>
   --
   --  This policy gives access to the URL that match one of the URL pattern if the
   --  security context has the permission create-workspace or admin.
   generic
      Reader  : in out Util.Serialize.IO.XML.Parser;
      Manager : in Security.Permissions.Permission_Manager_Access;
   package Reader_Config is
      Config : aliased Policy_Config;
   end Reader_Config;

   --  Register a set of functions in the namespace
   --  xmlns:fn="http://code.google.com/p/ada-asf/auth"
   --  Functions:
   --    hasPermission(NAME)   --  Returns True if the permission NAME is granted
   --  procedure Set_Functions (Mapper : in out EL.Functions.Function_Mapper'Class);

private

   use Util.Strings;

   type Role_Name_Array is
     array (Role_Type'Range) of Ada.Strings.Unbounded.String_Access;

   type Permission_Type_Array is array (1 .. 10) of Permission_Type;

   type Permission_Index_Array is array (Positive range <>) of Permission_Index;

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

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

   --  No rule
--     No_Rule : constant Access_Rule := (Count => 0,
--                                        Permissions => (others => Permission_Index'First));

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

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

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

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

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

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

   type Rules_Ref_Access is access Rules_Ref.Atomic_Ref;

   type Controller_Access_Array_Access is access all Controller_Access_Array;

   type Permission_Manager is new Ada.Finalization.Limited_Controlled with record
      Names        : Role_Name_Array;
      Cache        : Rules_Ref_Access;
      Next_Role    : Role_Type := Role_Type'First;
      Policies     : Policy_Vector.Vector;
      Permissions  : Controller_Access_Array_Access;
      Last_Index   : Permission_Index := Permission_Index'First;
   end record;

   --  EL function to check if the given permission name is granted by the current
   --  security context.
   function Has_Permission (Value : in Util.Beans.Objects.Object)
                            return Util.Beans.Objects.Object;

end Security.Permissions;

Remove the Principal

Remove the Principal


with HAL;             use HAL;
with HAL.Framebuffer; use HAL.Framebuffer;

with Framebuffer_LTDC;
private with ILI9341;
private with STM32.GPIO;
private with STM32.Device;

package Framebuffer_ILI9341 is

   type Frame_Buffer is limited
     new Framebuffer_LTDC.Frame_Buffer with private;

   procedure Initialize
     (Display     : in out Frame_Buffer;
      Orientation : HAL.Framebuffer.Display_Orientation := Default;
      Mode        : HAL.Framebuffer.Wait_Mode := Interrupt);

private

   --  Chip select and Data/Command select fot the LCD screen
   LCD_CSX      : STM32.GPIO.GPIO_Point renames STM32.Device.PC2;
   LCD_WRX_DCX  : STM32.GPIO.GPIO_Point renames STM32.Device.PD13;
   LCD_RESET    : STM32.GPIO.GPIO_Point renames STM32.Device.PD12;

   type Frame_Buffer
   is limited new Framebuffer_LTDC.Frame_Buffer with record
      Device : ILI9341.ILI9341_Device (STM32.Device.SPI_5'Access,
                                       Chip_Select => LCD_CSX'Access,
                                       WRX         => LCD_WRX_DCX'Access,
                                       Reset       => LCD_RESET'Access);
   end record;

end Framebuffer_ILI9341;

with HAL;             use HAL;
with HAL.Framebuffer; use HAL.Framebuffer;

with Framebuffer_LTDC;
private with ILI9341;
private with STM32.GPIO;
private with STM32.Device;

package Framebuffer_ILI9341 is

   type Frame_Buffer is limited
     new Framebuffer_LTDC.Frame_Buffer with private;

   procedure Initialize
     (Display     : in out Frame_Buffer;
      Orientation : HAL.Framebuffer.Display_Orientation := Default;
      Mode        : HAL.Framebuffer.Wait_Mode := Interrupt);

private

   --  Chip select and Data/Command select for the LCD screen
   LCD_CSX      : STM32.GPIO.GPIO_Point renames STM32.Device.PC2;
   LCD_WRX_DCX  : STM32.GPIO.GPIO_Point renames STM32.Device.PD13;
   LCD_RESET    : STM32.GPIO.GPIO_Point renames STM32.Device.PD12;

   type Frame_Buffer
   is limited new Framebuffer_LTDC.Frame_Buffer with record
      Device : ILI9341.ILI9341_Device (STM32.Device.SPI_5'Access,
                                       Chip_Select => LCD_CSX'Access,
                                       WRX         => LCD_WRX_DCX'Access,
                                       Reset       => LCD_RESET'Access);
   end record;

end Framebuffer_ILI9341;

Correct typo in comment

Correct typo in comment


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

with ADO;
with Wiki.Strings;
with AWA.Modules;
with AWA.Blogs.Models;
with AWA.Counters.Definition;
with AWA.Blogs.Servlets;

with Security.Permissions;

--  == Integration ==
--  To be able to use the `Blogs` module, you will need to add the following line in your
--  GNAT project file:
--
--    with "awa_blogs";
--
--  The `Blog_Module` type manages the creation, update, removal of blog posts in an application.
--  It provides operations that are used by the blog beans or other services to create and update
--  posts.  An instance of the `Blog_Module` must be declared and registered in the
--  AWA application.  The module instance can be defined as follows:
--
--    with AWA.Blogs.Modules;
--    ...
--    type Application is new AWA.Applications.Application with record
--       Blog_Module : aliased AWA.Blogs.Modules.Blog_Module;
--    end record;
--
--  And registered in the `Initialize_Modules` procedure by using:
--
--    Register (App    => App.Self.all'Access,
--              Name   => AWA.Blogs.Modules.NAME,
--              URI    => "blogs",
--              Module => App.Blog_Module'Access);
--
package AWA.Blogs.Modules is

   NAME : constant String := "blogs";

   --  The configuration parameter that defines the image link prefix in rendered HTML content.
   PARAM_IMAGE_PREFIX : constant String := "image_prefix";

   --  Define the permissions.
   package ACL_Create_Blog is new Security.Permissions.Definition ("blog-create");
   package ACL_Delete_Blog is new Security.Permissions.Definition ("blog-delete");
   package ACL_Create_Post is new Security.Permissions.Definition ("blog-create-post");
   package ACL_Delete_Post is new Security.Permissions.Definition ("blog-delete-post");
   package ACL_Update_Post is new Security.Permissions.Definition ("blog-update-post");

   --  Define the read post counter.
   package Read_Counter is new AWA.Counters.Definition (Models.POST_TABLE, "read_count");

   Not_Found : exception;

   type Blog_Module is new AWA.Modules.Module with private;
   type Blog_Module_Access is access all Blog_Module'Class;

   --  Initialize the blog module.
   overriding
   procedure Initialize (Plugin : in out Blog_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config);

   --  Configures the module after its initialization and after having read its XML configuration.
   overriding
   procedure Configure (Plugin : in out Blog_Module;
                        Props  : in ASF.Applications.Config);

   --  Get the blog module instance associated with the current application.
   function Get_Blog_Module return Blog_Module_Access;

   --  Get the image prefix that was configured for the Blog module.
   function Get_Image_Prefix (Module : in Blog_Module)
                              return Wiki.Strings.UString;

   --  Create a new blog for the user workspace.
   procedure Create_Blog (Model        : in Blog_Module;
                          Title        : in String;
                          Result       : out ADO.Identifier);

   --  Create a new post associated with the given blog identifier.
   procedure Create_Post (Model   : in Blog_Module;
                          Blog_Id : in ADO.Identifier;
                          Title   : in String;
                          URI     : in String;
                          Text    : in String;
                          Comment : in Boolean;
                          Status  : in AWA.Blogs.Models.Post_Status_Type;
                          Result  : out ADO.Identifier);

   --  Update the post title and text associated with the blog post identified by <b>Post</b>.
   procedure Update_Post (Model   : in Blog_Module;
                          Post_Id : in ADO.Identifier;
                          Title   : in String;
                          URI     : in String;
                          Text    : in String;
                          Comment : in Boolean;
                          Publish_Date : in ADO.Nullable_Time;
                          Status  : in AWA.Blogs.Models.Post_Status_Type);

   --  Delete the post identified by the given identifier.
   procedure Delete_Post (Model   : in Blog_Module;
                          Post_Id : in ADO.Identifier);

   --  Load the image data associated with a blog post.  The image must be public and the
   --  post visible for the image to be retrieved by anonymous users.
   procedure Load_Image (Model    : in Blog_Module;
                         Post_Id  : in ADO.Identifier;
                         Image_Id : in ADO.Identifier;
                         Width    : in out Natural;
                         Height   : in out Natural;
                         Mime     : out Ada.Strings.Unbounded.Unbounded_String;
                         Date     : out Ada.Calendar.Time;
                         Into     : out ADO.Blob_Ref);

private

   type Blog_Module is new AWA.Modules.Module with record
      Image_Prefix : Wiki.Strings.UString;
      Image_Servlet : aliased AWA.Blogs.Servlets.Image_Servlet;
   end record;

end AWA.Blogs.Modules;

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

with ADO;
with Wiki.Strings;
with AWA.Modules;
with AWA.Blogs.Models;
with AWA.Counters.Definition;
with AWA.Blogs.Servlets;

with Security.Permissions;

--  == Integration ==
--  To be able to use the `Blogs` module, you will need to add the following line in your
--  GNAT project file:
--
--    with "awa_blogs";
--
--  The `Blog_Module` type manages the creation, update, removal of blog posts in an application.
--  It provides operations that are used by the blog beans or other services to create and update
--  posts.  An instance of the `Blog_Module` must be declared and registered in the
--  AWA application.  The module instance can be defined as follows:
--
--    with AWA.Blogs.Modules;
--    ...
--    type Application is new AWA.Applications.Application with record
--       Blog_Module : aliased AWA.Blogs.Modules.Blog_Module;
--    end record;
--
--  And registered in the `Initialize_Modules` procedure by using:
--
--    Register (App    => App.Self.all'Access,
--              Name   => AWA.Blogs.Modules.NAME,
--              URI    => "blogs",
--              Module => App.Blog_Module'Access);
--
package AWA.Blogs.Modules is

   NAME : constant String := "blogs";

   --  The configuration parameter that defines the image link prefix in rendered HTML content.
   PARAM_IMAGE_PREFIX : constant String := "image_prefix";

   --  Define the permissions.
   package ACL_Create_Blog is new Security.Permissions.Definition ("blog-create");
   package ACL_Delete_Blog is new Security.Permissions.Definition ("blog-delete");
   package ACL_Create_Post is new Security.Permissions.Definition ("blog-create-post");
   package ACL_Delete_Post is new Security.Permissions.Definition ("blog-delete-post");
   package ACL_Update_Post is new Security.Permissions.Definition ("blog-update-post");

   --  Define the read post counter.
   package Read_Counter is new AWA.Counters.Definition (Models.POST_TABLE, "read_count");

   Not_Found : exception;

   type Blog_Module is new AWA.Modules.Module with private;
   type Blog_Module_Access is access all Blog_Module'Class;

   --  Initialize the blog module.
   overriding
   procedure Initialize (Plugin : in out Blog_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config);

   --  Configures the module after its initialization and after having read its XML configuration.
   overriding
   procedure Configure (Plugin : in out Blog_Module;
                        Props  : in ASF.Applications.Config);

   --  Get the blog module instance associated with the current application.
   function Get_Blog_Module return Blog_Module_Access;

   --  Get the image prefix that was configured for the Blog module.
   function Get_Image_Prefix (Module : in Blog_Module)
                              return Wiki.Strings.UString;

   --  Create a new blog for the user workspace.
   procedure Create_Blog (Model        : in Blog_Module;
                          Title        : in String;
                          Result       : out ADO.Identifier);

   --  Create a new post associated with the given blog identifier.
   procedure Create_Post (Model   : in Blog_Module;
                          Blog_Id : in ADO.Identifier;
                          Title   : in String;
                          URI     : in String;
                          Text    : in String;
                          Summary : in String;
                          Format  : in AWA.Blogs.Models.Format_Type;
                          Comment : in Boolean;
                          Status  : in AWA.Blogs.Models.Post_Status_Type;
                          Result  : out ADO.Identifier);

   --  Update the post title and text associated with the blog post identified by <b>Post</b>.
   procedure Update_Post (Model   : in Blog_Module;
                          Post_Id : in ADO.Identifier;
                          Title   : in String;
                          Summary : in String;
                          URI     : in String;
                          Text    : in String;
                          Format  : in AWA.Blogs.Models.Format_Type;
                          Comment : in Boolean;
                          Publish_Date : in ADO.Nullable_Time;
                          Status  : in AWA.Blogs.Models.Post_Status_Type);

   --  Delete the post identified by the given identifier.
   procedure Delete_Post (Model   : in Blog_Module;
                          Post_Id : in ADO.Identifier);

   --  Load the image data associated with a blog post.  The image must be public and the
   --  post visible for the image to be retrieved by anonymous users.
   procedure Load_Image (Model    : in Blog_Module;
                         Post_Id  : in ADO.Identifier;
                         Image_Id : in ADO.Identifier;
                         Width    : in out Natural;
                         Height   : in out Natural;
                         Mime     : out Ada.Strings.Unbounded.Unbounded_String;
                         Date     : out Ada.Calendar.Time;
                         Into     : out ADO.Blob_Ref);

private

   type Blog_Module is new AWA.Modules.Module with record
      Image_Prefix : Wiki.Strings.UString;
      Image_Servlet : aliased AWA.Blogs.Servlets.Image_Servlet;
   end record;

end AWA.Blogs.Modules;

Update Create_Post and Update_Post to setup the summary and post format