-----------------------------------------------------------------------
--  security-filters -- Security filter
--  Copyright (C) 2011 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 Util.Log.Loggers;

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

with Security.Contexts;
package body ASF.Security.Filters is

   use Util.Log;

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

   --  ------------------------------
   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   --  ------------------------------
   procedure Initialize (Server  : in out Auth_Filter;
                         Context : in ASF.Servlets.Servlet_Registry'Class) is
      use ASF.Applications.Main;
   begin
      if Context in Application'Class then
         Server.Set_Permission_Manager (Application'Class (Context).Get_Permission_Manager);
      end if;
   end Initialize;

   --  ------------------------------
   --  Set the permission manager that must be used to verify the permission.
   --  ------------------------------
   procedure Set_Permission_Manager (Filter  : in out Auth_Filter;
                                     Manager : in Permissions.Permission_Manager_Access) is
   begin
      Filter.Manager := Manager;
   end Set_Permission_Manager;

   --  ------------------------------
   --  Filter the request to make sure the user is authenticated.
   --  Invokes the Do_Login procedure if there is no user.
   --  If a permission manager is defined, check that the user has the permission
   --  to view the page.  Invokes the Do_Deny procedure if the permission
   --  is denied.
   --  ------------------------------
   procedure Do_Filter (F        : in Auth_Filter;
                        Request  : in out ASF.Requests.Request'Class;
                        Response : in out ASF.Responses.Response'Class;
                        Chain    : in out ASF.Servlets.Filter_Chain) is
      use Ada.Strings.Unbounded;
      use Permissions;
      use type ASF.Principals.Principal_Access;

      Session : ASF.Sessions.Session;
      SID     : Unbounded_String;
      AID     : Unbounded_String;
      Auth    : ASF.Principals.Principal_Access;

      pragma Unreferenced (SID);

      procedure Fetch_Cookie (Cookie : in ASF.Cookies.Cookie);

      --  ------------------------------
      --  Collect the AID and SID cookies.
      --  ------------------------------
      procedure Fetch_Cookie (Cookie : in ASF.Cookies.Cookie) is
         Name : constant String := ASF.Cookies.Get_Name (Cookie);
      begin
         if Name = SID_COOKIE then
            SID := To_Unbounded_String (ASF.Cookies.Get_Value (Cookie));
         elsif Name = AID_COOKIE then
            AID := To_Unbounded_String (ASF.Cookies.Get_Value (Cookie));
         end if;
      end Fetch_Cookie;

      Context : aliased Contexts.Security_Context;
   begin
      Request.Iterate_Cookies (Fetch_Cookie'Access);

      Session := Request.Get_Session (Create => True);

      --  If the session does not have a principal, try to authenticate the user with
      --  the auto-login cookie.
      Auth := Session.Get_Principal;
      if Auth = null then
         Auth_Filter'Class (F).Authenticate (Request, Response, Session, To_String (AID), Auth);
         if Auth /= null then
            Session.Set_Principal (Auth);
         end if;
      end if;

      --  No principal, redirect to the login page.
      if Auth = null then
         Auth_Filter'Class (F).Do_Login (Request, Response);
         return;
      end if;

      --  A permission manager is installed, check that the user can display the page.
      if F.Manager /= null then
         Context.Set_Context (F.Manager, Auth.all'Access);
         declare
            URI  : constant String := Request.Get_Path_Info;
            Perm : constant URI_Permission (URI'Length)
              := URI_Permission '(Len => URI'Length, URI => URI);
         begin
            if not F.Manager.Has_Permission (Context'Unchecked_Access, Perm) then
               Log.Info ("Deny access on {0}", URI);
--                 Auth_Filter'Class (F).Do_Deny (Request, Response);
--                 return;
            end if;
         end;
      end if;

      --  Request is authorized, proceed to the next filter.
      ASF.Servlets.Do_Filter (Chain    => Chain,
                              Request  => Request,
                              Response => Response);
   end Do_Filter;

   --  ------------------------------
   --  Display or redirects the user to the login page.  This procedure is called when
   --  the user is not authenticated.
   --  ------------------------------
   procedure Do_Login (F        : in Auth_Filter;
                       Request  : in out ASF.Requests.Request'Class;
                       Response : in out ASF.Responses.Response'Class) is
   begin
      null;
   end Do_Login;

   --  ------------------------------
   --  Display the forbidden access page.  This procedure is called when the user is not
   --  authorized to see the page.  The default implementation returns the SC_FORBIDDEN error.
   --  ------------------------------
   procedure Do_Deny (F        : in Auth_Filter;
                      Request  : in out ASF.Requests.Request'Class;
                      Response : in out ASF.Responses.Response'Class) is
      pragma Unreferenced (F, Request);
   begin
      Response.Set_Status (ASF.Responses.SC_FORBIDDEN);
   end Do_Deny;

   --  ------------------------------
   --  Authenticate a user by using the auto-login cookie.  This procedure is called if the
   --  current session does not have any principal.  Based on the request and the optional
   --  auto-login cookie passed in Auth_Id, it should identify the user and return
   --  a principal object.  The principal object will be freed when the session is closed.
   --  If the user cannot be authenticated, the returned principal should be null.
   --
   --  The default implementation returns a null principal.
   --  ------------------------------
   procedure Authenticate (F        : in Auth_Filter;
                           Request  : in out ASF.Requests.Request'Class;
                           Response : in out ASF.Responses.Response'Class;
                           Session  : in ASF.Sessions.Session;
                           Auth_Id  : in String;
                           Principal : out ASF.Principals.Principal_Access) is
      pragma Unreferenced (F, Request, Response, Session, Auth_Id);
   begin
      Principal := null;
   end Authenticate;

end ASF.Security.Filters;

-----------------------------------------------------------------------
--  security-filters -- Security filter
--  Copyright (C) 2011 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 Util.Log.Loggers;

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

with Security.Contexts;
with Security.Policies.Urls;
package body ASF.Security.Filters is

   use Util.Log;

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

   --  ------------------------------
   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   --  ------------------------------
   procedure Initialize (Server  : in out Auth_Filter;
                         Context : in ASF.Servlets.Servlet_Registry'Class) is
      use ASF.Applications.Main;
   begin
      if Context in Application'Class then
         Server.Set_Permission_Manager (Application'Class (Context).Get_Security_Manager);
      end if;
   end Initialize;

   --  ------------------------------
   --  Set the permission manager that must be used to verify the permission.
   --  ------------------------------
   procedure Set_Permission_Manager (Filter  : in out Auth_Filter;
                                     Manager : in Policies.Policy_Manager_Access) is
   begin
      Filter.Manager := Manager;
   end Set_Permission_Manager;

   --  ------------------------------
   --  Filter the request to make sure the user is authenticated.
   --  Invokes the Do_Login procedure if there is no user.
   --  If a permission manager is defined, check that the user has the permission
   --  to view the page.  Invokes the Do_Deny procedure if the permission
   --  is denied.
   --  ------------------------------
   procedure Do_Filter (F        : in Auth_Filter;
                        Request  : in out ASF.Requests.Request'Class;
                        Response : in out ASF.Responses.Response'Class;
                        Chain    : in out ASF.Servlets.Filter_Chain) is
      use Ada.Strings.Unbounded;
      use Policies.Urls;
      use type Policies.Policy_Manager_Access;

      Session : ASF.Sessions.Session;
      SID     : Unbounded_String;
      AID     : Unbounded_String;
      Auth    : ASF.Principals.Principal_Access;

      pragma Unreferenced (SID);

      procedure Fetch_Cookie (Cookie : in ASF.Cookies.Cookie);

      --  ------------------------------
      --  Collect the AID and SID cookies.
      --  ------------------------------
      procedure Fetch_Cookie (Cookie : in ASF.Cookies.Cookie) is
         Name : constant String := ASF.Cookies.Get_Name (Cookie);
      begin
         if Name = SID_COOKIE then
            SID := To_Unbounded_String (ASF.Cookies.Get_Value (Cookie));
         elsif Name = AID_COOKIE then
            AID := To_Unbounded_String (ASF.Cookies.Get_Value (Cookie));
         end if;
      end Fetch_Cookie;

      Context : aliased Contexts.Security_Context;
   begin
      Request.Iterate_Cookies (Fetch_Cookie'Access);

      Session := Request.Get_Session (Create => True);

      --  If the session does not have a principal, try to authenticate the user with
      --  the auto-login cookie.
      Auth := Session.Get_Principal;
      if Auth = null then
         Auth_Filter'Class (F).Authenticate (Request, Response, Session, To_String (AID), Auth);
         if Auth /= null then
            Session.Set_Principal (Auth);
         end if;
      end if;

      --  No principal, redirect to the login page.
      if Auth = null then
         Auth_Filter'Class (F).Do_Login (Request, Response);
         return;
      end if;

      --  A permission manager is installed, check that the user can display the page.
      if F.Manager /= null then
         Context.Set_Context (F.Manager, Auth.all'Access);
         declare
            URI  : constant String := Request.Get_Path_Info;
            Perm : constant Policies.URLs.URI_Permission (URI'Length)
              := URI_Permission '(Len => URI'Length, URI => URI);
         begin
            if not F.Manager.Has_Permission (Context, Perm) then
               Log.Info ("Deny access on {0}", URI);
--                 Auth_Filter'Class (F).Do_Deny (Request, Response);
--                 return;
            end if;
         end;
      end if;

      --  Request is authorized, proceed to the next filter.
      ASF.Servlets.Do_Filter (Chain    => Chain,
                              Request  => Request,
                              Response => Response);
   end Do_Filter;

   --  ------------------------------
   --  Display or redirects the user to the login page.  This procedure is called when
   --  the user is not authenticated.
   --  ------------------------------
   procedure Do_Login (F        : in Auth_Filter;
                       Request  : in out ASF.Requests.Request'Class;
                       Response : in out ASF.Responses.Response'Class) is
   begin
      null;
   end Do_Login;

   --  ------------------------------
   --  Display the forbidden access page.  This procedure is called when the user is not
   --  authorized to see the page.  The default implementation returns the SC_FORBIDDEN error.
   --  ------------------------------
   procedure Do_Deny (F        : in Auth_Filter;
                      Request  : in out ASF.Requests.Request'Class;
                      Response : in out ASF.Responses.Response'Class) is
      pragma Unreferenced (F, Request);
   begin
      Response.Set_Status (ASF.Responses.SC_FORBIDDEN);
   end Do_Deny;

   --  ------------------------------
   --  Authenticate a user by using the auto-login cookie.  This procedure is called if the
   --  current session does not have any principal.  Based on the request and the optional
   --  auto-login cookie passed in Auth_Id, it should identify the user and return
   --  a principal object.  The principal object will be freed when the session is closed.
   --  If the user cannot be authenticated, the returned principal should be null.
   --
   --  The default implementation returns a null principal.
   --  ------------------------------
   procedure Authenticate (F        : in Auth_Filter;
                           Request  : in out ASF.Requests.Request'Class;
                           Response : in out ASF.Responses.Response'Class;
                           Session  : in ASF.Sessions.Session;
                           Auth_Id  : in String;
                           Principal : out ASF.Principals.Principal_Access) is
      pragma Unreferenced (F, Request, Response, Session, Auth_Id);
   begin
      Principal := null;
   end Authenticate;

end ASF.Security.Filters;

Fix compilation for the new Security package


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

with ASF.Filters;
with ASF.Requests;
with ASF.Responses;
with ASF.Servlets;
with ASF.Sessions;
with ASF.Principals;
with Security.Policies;  use Security;

--  The Security.Filters package defines a servlet filter that can be activated
--  on requests to authenticate users and verify they have the permission to view
--  a page.
package ASF.Security.Filters is

   SID_COOKIE : constant String := "SID";

   AID_COOKIE : constant String := "AID";

   type Auth_Filter is new ASF.Filters.Filter with private;

   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   overriding
   procedure Initialize (Server  : in out Auth_Filter;
                         Context : in ASF.Servlets.Servlet_Registry'Class);

   --  Set the permission manager that must be used to verify the permission.
   procedure Set_Permission_Manager (Filter  : in out Auth_Filter;
                                     Manager : in Policies.Policy_Manager_Access);

   --  Filter the request to make sure the user is authenticated.
   --  Invokes the Do_Login procedure if there is no user.
   --  If a permission manager is defined, check that the user has the permission
   --  to view the page.  Invokes the Do_Deny procedure if the permission
   --  is denied.
   procedure Do_Filter (F        : in Auth_Filter;
                        Request  : in out ASF.Requests.Request'Class;
                        Response : in out ASF.Responses.Response'Class;
                        Chain    : in out ASF.Servlets.Filter_Chain);

   --  Display or redirects the user to the login page.  This procedure is called when
   --  the user is not authenticated.
   procedure Do_Login (F        : in Auth_Filter;
                       Request  : in out ASF.Requests.Request'Class;
                       Response : in out ASF.Responses.Response'Class);

   --  Display the forbidden access page.  This procedure is called when the user is not
   --  authorized to see the page.  The default implementation returns the SC_FORBIDDEN error.
   procedure Do_Deny (F        : in Auth_Filter;
                      Request  : in out ASF.Requests.Request'Class;
                      Response : in out ASF.Responses.Response'Class);

   --  Authenticate a user by using the auto-login cookie.  This procedure is called if the
   --  current session does not have any principal.  Based on the request and the optional
   --  auto-login cookie passed in Auth_Id, it should identify the user and return
   --  a principal object.  The principal object will be freed when the session is closed.
   --  If the user cannot be authenticated, the returned principal should be null.
   --
   --  The default implementation returns a null principal.
   procedure Authenticate (F        : in Auth_Filter;
                           Request  : in out ASF.Requests.Request'Class;
                           Response : in out ASF.Responses.Response'Class;
                           Session  : in ASF.Sessions.Session;
                           Auth_Id  : in String;
                           Principal : out ASF.Principals.Principal_Access);

private

   type Auth_Filter is new ASF.Filters.Filter with record
      Manager : Policies.Policy_Manager_Access := null;
   end record;

end ASF.Security.Filters;

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

with ASF.Filters;
with ASF.Requests;
with ASF.Responses;
with ASF.Servlets;
with ASF.Sessions;
with ASF.Principals;
with Security.Policies;  use Security;

--  The Security.Filters package defines a servlet filter that can be activated
--  on requests to authenticate users and verify they have the permission to view
--  a page.
package ASF.Security.Filters is

   SID_COOKIE : constant String := "SID";

   AID_COOKIE : constant String := "AID";

   type Auth_Filter is new ASF.Filters.Filter with private;

   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   overriding
   procedure Initialize (Server  : in out Auth_Filter;
                         Config  : in ASF.Servlets.Filter_Config);

   --  Set the permission manager that must be used to verify the permission.
   procedure Set_Permission_Manager (Filter  : in out Auth_Filter;
                                     Manager : in Policies.Policy_Manager_Access);

   --  Filter the request to make sure the user is authenticated.
   --  Invokes the Do_Login procedure if there is no user.
   --  If a permission manager is defined, check that the user has the permission
   --  to view the page.  Invokes the Do_Deny procedure if the permission
   --  is denied.
   procedure Do_Filter (F        : in Auth_Filter;
                        Request  : in out ASF.Requests.Request'Class;
                        Response : in out ASF.Responses.Response'Class;
                        Chain    : in out ASF.Servlets.Filter_Chain);

   --  Display or redirects the user to the login page.  This procedure is called when
   --  the user is not authenticated.
   procedure Do_Login (F        : in Auth_Filter;
                       Request  : in out ASF.Requests.Request'Class;
                       Response : in out ASF.Responses.Response'Class);

   --  Display the forbidden access page.  This procedure is called when the user is not
   --  authorized to see the page.  The default implementation returns the SC_FORBIDDEN error.
   procedure Do_Deny (F        : in Auth_Filter;
                      Request  : in out ASF.Requests.Request'Class;
                      Response : in out ASF.Responses.Response'Class);

   --  Authenticate a user by using the auto-login cookie.  This procedure is called if the
   --  current session does not have any principal.  Based on the request and the optional
   --  auto-login cookie passed in Auth_Id, it should identify the user and return
   --  a principal object.  The principal object will be freed when the session is closed.
   --  If the user cannot be authenticated, the returned principal should be null.
   --
   --  The default implementation returns a null principal.
   procedure Authenticate (F        : in Auth_Filter;
                           Request  : in out ASF.Requests.Request'Class;
                           Response : in out ASF.Responses.Response'Class;
                           Session  : in ASF.Sessions.Session;
                           Auth_Id  : in String;
                           Principal : out ASF.Principals.Principal_Access);

private

   type Auth_Filter is new ASF.Filters.Filter with record
      Manager : Policies.Policy_Manager_Access := null;
   end record;

end ASF.Security.Filters;

Update the use the Filter_Config for the Initialize procedure


-----------------------------------------------------------------------
--  util-refs -- Reference Counting
--  Copyright (C) 2010, 2011 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 Util.Concurrent.Counters;

--  The Util.Refs package provides support to implement object reference counting.
--
--  The data type to share through reference counting has to inherit from Ref_Entity
--  and the generic package References has to be instantiated.
--

--    type Data is new Util.Refs.Ref_Entity with record ... end record;
--    type Data_Access is access all Data;
--
--    package Data_Ref is new Utils.Refs.References (Data, Data_Access);
--

--
--  The reference is used as follows:
--
--

--     D  : Data_Ref.Ref := Data_Ref.Create;  --  Allocate and get a reference
--     D2 : Data_Ref.Ref := D;                --  Share reference
--     D.Value.all.XXXX  := 0;               --  Set data member XXXX
--

--
--  When a reference is shared in a multi-threaded environment, the reference has to
--  be protected by using the References.Atomic_Ref type.
--
--     R : Data_Ref.Atomic_Ref;
--
--  The reference is then obtained by the protected operation Get.
--
--     D : Data_Ref.Ref := R.Get;
--
package Util.Refs is

   --  Root of referenced objects.
   type Ref_Entity is abstract tagged limited private;

   --  Finalize the referenced object.  This is called before the object is freed.
   procedure Finalize (Object : in out Ref_Entity) is null;

   generic
      type Element_Type (<>) is new Ref_Entity with private;
      type Element_Access is access all Element_Type;
   package Indefinite_References is
      type Ref is new Ada.Finalization.Controlled with private;

      --  Create an element and return a reference to that element.
      function Create (Value : in Element_Access) return Ref;

      --  Get the element access value.
      function Value (Object : in Ref'Class) return Element_Access;
      pragma Inline_Always (Value);

      --  Returns true if the reference does not contain any element.
      function Is_Null (Object : in Ref'Class) return Boolean;
      pragma Inline_Always (Is_Null);

      --  The Atomic_Ref protected type defines a reference to an
      --  element which can be obtained and changed atomically.  The default
      --  Ada construct:
      --
      --     Ref1 := Ref2;
      --
      --  does not guarantee atomicity of the copy (assignment) and the increment
      --  of the reference counter (Adjust operation).  To replace shared reference
      --  by another one, the whole assignment and Adjust have to be protected.
      --  This is achieved by this protected type through the Get and Set
      protected type Atomic_Ref is
         --  Get the reference
         function Get return Ref;

         --  Change the reference
         procedure Set (Object : in Ref);
      private
         Value : Ref;
      end Atomic_Ref;

   private
      type Ref is new Ada.Finalization.Controlled with record
         Target : Element_Access := null;
      end record;

      --  Release the reference.  Invoke Finalize and free the storage if it was
      --  the last reference.
      overriding
      procedure Finalize (Obj : in out Ref);

      --  Update the reference counter after an assignment.
      overriding
      procedure Adjust (Obj : in out Ref);

   end Indefinite_References;

   generic
      type Element_Type is new Ref_Entity with private;
      type Element_Access is access all Element_Type;
   package References is
      package IR is new Indefinite_References (Element_Type, Element_Access);

      subtype Ref is IR.Ref;

      --  Create an element and return a reference to that element.
      function Create return Ref;

      --  The Atomic_Ref protected type defines a reference to an
      --  element which can be obtained and changed atomically.  The default
      --  Ada construct:
      --
      --     Ref1 := Ref2;
      --
      --  does not guarantee atomicity of the copy (assignment) and the increment
      --  of the reference counter (Adjust operation).  To replace shared reference
      --  by another one, the whole assignment and Adjust have to be protected.
      --  This is achieved by this protected type through the Get and Set
      subtype Atomic_Ref is IR.Atomic_Ref;

   end References;

private

   type Ref_Entity is abstract tagged limited record
      Ref_Counter : Util.Concurrent.Counters.Counter;
   end record;

end Util.Refs;

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

--  The Util.Refs package provides support to implement object reference counting.
--
--  The data type to share through reference counting has to inherit from Ref_Entity
--  and the generic package References has to be instantiated.
--

--    type Data is new Util.Refs.Ref_Entity with record ... end record;
--    type Data_Access is access all Data;
--
--    package Data_Ref is new Utils.Refs.References (Data, Data_Access);
--

--
--  The reference is used as follows:
--
--

--     D  : Data_Ref.Ref := Data_Ref.Create;  --  Allocate and get a reference
--     D2 : Data_Ref.Ref := D;                --  Share reference
--     D.Value.all.XXXX  := 0;               --  Set data member XXXX
--

--
--  When a reference is shared in a multi-threaded environment, the reference has to
--  be protected by using the References.Atomic_Ref type.
--
--     R : Data_Ref.Atomic_Ref;
--
--  The reference is then obtained by the protected operation Get.
--
--     D : Data_Ref.Ref := R.Get;
--
package Util.Refs is

   pragma Preelaborate;

   --  Root of referenced objects.
   type Ref_Entity is abstract tagged limited private;

   --  Finalize the referenced object.  This is called before the object is freed.
   procedure Finalize (Object : in out Ref_Entity) is null;

   generic
      type Element_Type (<>) is new Ref_Entity with private;
      type Element_Access is access all Element_Type;
   package Indefinite_References is

      type Ref is new Ada.Finalization.Controlled with private;

      --  Create an element and return a reference to that element.
      function Create (Value : in Element_Access) return Ref;

      --  Get the element access value.
      function Value (Object : in Ref'Class) return Element_Access;
      pragma Inline_Always (Value);

      --  Returns true if the reference does not contain any element.
      function Is_Null (Object : in Ref'Class) return Boolean;
      pragma Inline_Always (Is_Null);

      --  The Atomic_Ref protected type defines a reference to an
      --  element which can be obtained and changed atomically.  The default
      --  Ada construct:
      --
      --     Ref1 := Ref2;
      --
      --  does not guarantee atomicity of the copy (assignment) and the increment
      --  of the reference counter (Adjust operation).  To replace shared reference
      --  by another one, the whole assignment and Adjust have to be protected.
      --  This is achieved by this protected type through the Get and Set
      protected type Atomic_Ref is
         --  Get the reference
         function Get return Ref;

         --  Change the reference
         procedure Set (Object : in Ref);
      private
         Value : Ref;
      end Atomic_Ref;

   private
      type Ref is new Ada.Finalization.Controlled with record
         Target : Element_Access := null;
      end record;

      --  Release the reference.  Invoke Finalize and free the storage if it was
      --  the last reference.
      overriding
      procedure Finalize (Obj : in out Ref);

      --  Update the reference counter after an assignment.
      overriding
      procedure Adjust (Obj : in out Ref);

   end Indefinite_References;

   generic
      type Element_Type is new Ref_Entity with private;
      type Element_Access is access all Element_Type;
   package References is
      package IR is new Indefinite_References (Element_Type, Element_Access);

      subtype Ref is IR.Ref;

      --  Create an element and return a reference to that element.
      function Create return Ref;

      --  The Atomic_Ref protected type defines a reference to an
      --  element which can be obtained and changed atomically.  The default
      --  Ada construct:
      --
      --     Ref1 := Ref2;
      --
      --  does not guarantee atomicity of the copy (assignment) and the increment
      --  of the reference counter (Adjust operation).  To replace shared reference
      --  by another one, the whole assignment and Adjust have to be protected.
      --  This is achieved by this protected type through the Get and Set
      subtype Atomic_Ref is IR.Atomic_Ref;

   end References;

private

   type Ref_Entity is abstract tagged limited record
      Ref_Counter : Util.Concurrent.Counters.Counter;
   end record;

end Util.Refs;

Add pragma Preelaborate on Util.Refs package


-----------------------------------------------------------------------
--  security-contexts -- Context to provide security information and verify permissions
--  Copyright (C) 2011 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.Task_Attributes;

with Security.Controllers;
package body Security.Contexts is

   package Task_Context is new Ada.Task_Attributes
     (Security_Context_Access, null);

   --  ------------------------------
   --  Get the application associated with the current service operation.
   --  ------------------------------
   function Get_User_Principal (Context : in Security_Context'Class)
                                return Security.Principal_Access is
   begin
      return Context.Principal;
   end Get_User_Principal;

   --  ------------------------------
   --  Get the permission manager.
   --  ------------------------------
   function Get_Permission_Manager (Context : in Security_Context'Class)
                                    return Security.Permissions.Permission_Manager_Access is
   begin
      return Context.Manager;
   end Get_Permission_Manager;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in Security.Permissions.Permission_Index;
                             Result     : out Boolean) is
      use type Security.Permissions.Controller_Access;
      use type Security.Permissions.Permission_Manager_Access;
   begin
      if Context.Manager = null then
         Result := False;
         return;
      end if;
      declare
         C : constant Permissions.Controller_Access := Context.Manager.Get_Controller (Permission);
      begin
         if C = null then
            Result := False;
         else
            --              Result := C.Has_Permission (Context);
            Result := False;
         end if;
      end;
   end Has_Permission;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in String;
                             Result     : out Boolean) is
      Index : constant Permissions.Permission_Index
        := Permissions.Get_Permission_Index (Permission);
   begin
      Security_Context'Class (Context).Has_Permission (Index, Result);
   end Has_Permission;

   --  ------------------------------
   --  Initializes the service context.  By creating the Security_Context variable,
   --  the instance will be associated with the current task attribute.  If the current task
   --  already has a security context, the new security context is installed, the old one
   --  being kept.
   --  ------------------------------
   overriding
   procedure Initialize (Context : in out Security_Context) is
   begin
      Context.Previous := Task_Context.Value;
      Task_Context.Set_Value (Context'Unchecked_Access);
   end Initialize;

   --  ------------------------------
   --  Finalize the security context releases any object.  The previous security context is
   --  restored to the current task attribute.
   --  ------------------------------
   overriding
   procedure Finalize (Context : in out Security_Context) is
   begin
      Task_Context.Set_Value (Context.Previous);
   end Finalize;

   --  ------------------------------
   --  Add a context information represented by Value under the name identified by
   --  Name in the security context Context.
   --  ------------------------------
   procedure Add_Context (Context   : in out Security_Context;
                          Name      : in String;
                          Value     : in String) is
   begin
      Context.Context.Include (Key      => Name,
                               New_Item => Value);
   end Add_Context;

   --  ------------------------------
   --  Get the context information registered under the name Name in the security
   --  context Context.
   --  Raises Invalid_Context if there is no such information.
   --  ------------------------------
   function Get_Context (Context  : in Security_Context;
                         Name     : in String) return String is
      Pos : constant Util.Strings.Maps.Cursor := Context.Context.Find (Name);
   begin
      if Util.Strings.Maps.Has_Element (Pos) then
         return Util.Strings.Maps.Element (Pos);
      else
         raise Invalid_Context;
      end if;
   end Get_Context;

   --  ------------------------------
   --  Returns True if a context information was registered under the name Name.
   --  ------------------------------
   function Has_Context (Context : in Security_Context;
                         Name    : in String) return Boolean is
      use type Util.Strings.Maps.Cursor;
   begin
      return Context.Context.Find (Name) /= Util.Strings.Maps.No_Element;
   end Has_Context;

   --  ------------------------------
   --  Set the current application and user context.
   --  ------------------------------
   procedure Set_Context (Context   : in out Security_Context;
                          Manager   : in Security.Permissions.Permission_Manager_Access;
                          Principal : in Security.Principal_Access) is
   begin
      Context.Manager   := Manager;
      Context.Principal := Principal;
   end Set_Context;

   --  ------------------------------
   --  Get the current security context.
   --  Returns null if the current thread is not associated with any security context.
   --  ------------------------------
   function Current return Security_Context_Access is
   begin
      return Task_Context.Value;
   end Current;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   function Has_Permission (Permission : in Permissions.Permission_Index) return Boolean is
      Result  : Boolean;
      Context : constant Security_Context_Access := Current;
   begin
      if Context = null then
         return False;
      else
         Context.Has_Permission (Permission, Result);
         return Result;
      end if;
   end Has_Permission;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   function Has_Permission (Permission : in String) return Boolean is
      Result  : Boolean;
      Context : constant Security_Context_Access := Current;
   begin
      if Context = null then
         return False;
      else
         Context.Has_Permission (Permission, Result);
         return Result;
      end if;
   end Has_Permission;

end Security.Contexts;

-----------------------------------------------------------------------
--  security-contexts -- Context to provide security information and verify permissions
--  Copyright (C) 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.Task_Attributes;

with Security.Controllers;
package body Security.Contexts is

   package Task_Context is new Ada.Task_Attributes
     (Security_Context_Access, null);

   --  ------------------------------
   --  Get the application associated with the current service operation.
   --  ------------------------------
   function Get_User_Principal (Context : in Security_Context'Class)
                                return Security.Principal_Access is
   begin
      return Context.Principal;
   end Get_User_Principal;

   --  ------------------------------
   --  Get the permission manager.
   --  ------------------------------
   function Get_Permission_Manager (Context : in Security_Context'Class)
                                    return Security.Policies.Policy_Manager_Access is
   begin
      return Context.Manager;
   end Get_Permission_Manager;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in Security.Permissions.Permission_Index;
                             Result     : out Boolean) is
      use type Security.Policies.Controller_Access;
      use type Security.Policies.Policy_Manager_Access;
   begin
      if Context.Manager = null then
         Result := False;
         return;
      end if;
      declare
         C : constant Policies.Controller_Access := Context.Manager.Get_Controller (Permission);
      begin
         if C = null then
            Result := False;
         else
            --              Result := C.Has_Permission (Context);
            Result := False;
         end if;
      end;
   end Has_Permission;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in String;
                             Result     : out Boolean) is
      Index : constant Permissions.Permission_Index
        := Permissions.Get_Permission_Index (Permission);
   begin
      Security_Context'Class (Context).Has_Permission (Index, Result);
   end Has_Permission;

   --  ------------------------------
   --  Initializes the service context.  By creating the Security_Context variable,
   --  the instance will be associated with the current task attribute.  If the current task
   --  already has a security context, the new security context is installed, the old one
   --  being kept.
   --  ------------------------------
   overriding
   procedure Initialize (Context : in out Security_Context) is
   begin
      Context.Previous := Task_Context.Value;
      Task_Context.Set_Value (Context'Unchecked_Access);
   end Initialize;

   --  ------------------------------
   --  Finalize the security context releases any object.  The previous security context is
   --  restored to the current task attribute.
   --  ------------------------------
   overriding
   procedure Finalize (Context : in out Security_Context) is
   begin
      Task_Context.Set_Value (Context.Previous);
   end Finalize;

   --  ------------------------------
   --  Add a context information represented by Value under the name identified by
   --  Name in the security context Context.
   --  ------------------------------
   procedure Add_Context (Context   : in out Security_Context;
                          Name      : in String;
                          Value     : in String) is
   begin
      Context.Context.Include (Key      => Name,
                               New_Item => Value);
   end Add_Context;

   --  ------------------------------
   --  Get the context information registered under the name Name in the security
   --  context Context.
   --  Raises Invalid_Context if there is no such information.
   --  ------------------------------
   function Get_Context (Context  : in Security_Context;
                         Name     : in String) return String is
      Pos : constant Util.Strings.Maps.Cursor := Context.Context.Find (Name);
   begin
      if Util.Strings.Maps.Has_Element (Pos) then
         return Util.Strings.Maps.Element (Pos);
      else
         raise Invalid_Context;
      end if;
   end Get_Context;

   --  ------------------------------
   --  Returns True if a context information was registered under the name Name.
   --  ------------------------------
   function Has_Context (Context : in Security_Context;
                         Name    : in String) return Boolean is
      use type Util.Strings.Maps.Cursor;
   begin
      return Context.Context.Find (Name) /= Util.Strings.Maps.No_Element;
   end Has_Context;

   --  ------------------------------
   --  Set the current application and user context.
   --  ------------------------------
   procedure Set_Context (Context   : in out Security_Context;
                          Manager   : in Security.Policies.Policy_Manager_Access;
                          Principal : in Security.Principal_Access) is
   begin
      Context.Manager   := Manager;
      Context.Principal := Principal;
   end Set_Context;

   --  ------------------------------
   --  Get the current security context.
   --  Returns null if the current thread is not associated with any security context.
   --  ------------------------------
   function Current return Security_Context_Access is
   begin
      return Task_Context.Value;
   end Current;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   function Has_Permission (Permission : in Permissions.Permission_Index) return Boolean is
      Result  : Boolean;
      Context : constant Security_Context_Access := Current;
   begin
      if Context = null then
         return False;
      else
         Context.Has_Permission (Permission, Result);
         return Result;
      end if;
   end Has_Permission;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   function Has_Permission (Permission : in String) return Boolean is
      Result  : Boolean;
      Context : constant Security_Context_Access := Current;
   begin
      if Context = null then
         return False;
      else
         Context.Has_Permission (Permission, Result);
         return Result;
      end if;
   end Has_Permission;

end Security.Contexts;

Use the policy manager

Use the policy manager


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

with MAT.Memory.Probes;
package body MAT.Memory.Targets is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Memory.Targets");

   --  ------------------------------
   --  Initialize the target memory object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory events.
   --  ------------------------------
   procedure Initialize (Memory  : in out Target_Memory;
                         Manager : in out MAT.Events.Probes.Probe_Manager_Type'Class) is
      Memory_Probe : constant MAT.Memory.Probes.Memory_Probe_Type_Access
        := new MAT.Memory.Probes.Memory_Probe_Type;
   begin
--        Memory.Manager    := Memory_Probe.all'Access;
      Memory_Probe.Data := Memory'Unrestricted_Access;
      MAT.Memory.Probes.Register (Manager, Memory_Probe);
   end Initialize;

   --  ------------------------------
   --  Add the memory region from the list of memory region managed by the program.
   --  ------------------------------
   procedure Add_Region (Memory : in out Target_Memory;
                         Region : in Region_Info) is
   begin
      Log.Info ("Add region [" & MAT.Types.Hex_Image (Region.Start_Addr) & "-"
                  & MAT.Types.Hex_Image (Region.End_Addr) & "]");
      Memory.Memory.Add_Region (Region);
   end Add_Region;

   --  ------------------------------
   --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
   --  in the used slots map.  The freed slots that intersect the malloc'ed region are
   --  removed from the freed map.
   --  ------------------------------
   procedure Probe_Malloc (Memory : in out Target_Memory;
                           Addr   : in MAT.Types.Target_Addr;
                           Slot   : in Allocation) is
   begin
      Memory.Memory.Probe_Malloc (Addr, Slot);
   end Probe_Malloc;

   --  ------------------------------
   --  Take into account a free probe.  Add the memory slot in the freed map and remove
   --  the slot from the used slots map.
   --  ------------------------------
   procedure Probe_Free (Memory : in out Target_Memory;
                         Addr   : in MAT.Types.Target_Addr;
                         Slot   : in Allocation) is
   begin
      Memory.Memory.Probe_Free (Addr, Slot);
   end Probe_Free;

   --  ------------------------------
   --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
   --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
   --  inserted in the used slots map.
   --  ------------------------------
   procedure Probe_Realloc (Memory : in out Target_Memory;
                            Addr     : in MAT.Types.Target_Addr;
                            Old_Addr : in MAT.Types.Target_Addr;
                            Slot     : in Allocation) is
   begin
      Memory.Memory.Probe_Realloc (Addr, Old_Addr, Slot);
   end Probe_Realloc;

   --  ------------------------------
   --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
   --  If the frame is already known, the frame reference counter is incremented.
   --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
   --  ------------------------------
   procedure Create_Frame (Memory : in out Target_Memory;
                           Pc     : in MAT.Frames.Frame_Table;
                           Result : out MAT.Frames.Frame_Type) is
   begin
      Memory.Memory.Create_Frame (Pc, Result);
   end Create_Frame;

   --  ------------------------------
   --  Collect the information about memory slot sizes allocated by the application.
   --  ------------------------------
   procedure Size_Information (Memory : in out Target_Memory;
                               Sizes  : in out MAT.Memory.Tools.Size_Info_Map) is
   begin
      Memory.Memory.Size_Information (Sizes);
   end Size_Information;

   --  ------------------------------
   --  Collect the information about threads and the memory allocations they've made.
   --  ------------------------------
   procedure Thread_Information (Memory  : in out Target_Memory;
                                 Threads : in out Memory_Info_Map) is
   begin
      Memory.Memory.Thread_Information (Threads);
   end Thread_Information;

   --  ------------------------------
   --  Collect the information about frames and the memory allocations they've made.
   --  ------------------------------
   procedure Frame_Information (Memory : in out Target_Memory;
                                Level  : in Natural;
                                Frames : in out Frame_Info_Map) is
   begin
      Memory.Memory.Frame_Information (Level, Frames);
   end Frame_Information;

   --  ------------------------------
   --  Get the global memory and allocation statistics.
   --  ------------------------------
   procedure Stat_Information (Memory : in out Target_Memory;
                               Result : out Memory_Stat) is
   begin
      Memory.Memory.Stat_Information (Result);
   end Stat_Information;

   --  ------------------------------
   --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
   --  the region [From .. To] and which is selected by the given filter expression.
   --  Add the memory slot in the <tt>Into</tt> list if it does not already contains
   --  the memory slot.
   --  ------------------------------
   procedure Find (Memory : in out Target_Memory;
                   From   : in MAT.Types.Target_Addr;
                   To     : in MAT.Types.Target_Addr;
                   Filter : in MAT.Expressions.Expression_Type;
                   Into   : in out MAT.Memory.Allocation_Map) is
   begin
      Memory.Memory.Find (From, To, Filter, Into);
   end Find;

   protected body Memory_Allocator is

      --  ------------------------------
      --  Add the memory region from the list of memory region managed by the program.
      --  ------------------------------
      procedure Add_Region (Region : in Region_Info) is
      begin
         Regions.Insert (Region.Start_Addr, Region);
      end Add_Region;

      --  ------------------------------
      --  Remove the memory region [Addr .. Addr + Size] from the free list.
      --  ------------------------------
      procedure Remove_Free (Addr : in MAT.Types.Target_Addr;
                             Size : in MAT.Types.Target_Size) is
         Iter : Allocation_Cursor;
         Last : constant MAT.Types.Target_Addr := Addr + MAT.Types.Target_Addr (Size);
         Slot : Allocation;
      begin
         --  Walk the list of free blocks and remove all the blocks which intersect the region
         --  [Addr .. Addr + Slot.Size].  We start walking at the first block below and near
         --  the address.  Slots are then removed when they intersect the malloc'ed region.
         Iter := Freed_Slots.Floor (Addr);
         while Allocation_Maps.Has_Element (Iter) loop
            declare
               Freed_Addr : constant MAT.Types.Target_Addr := Allocation_Maps.Key (Iter);
            begin
               exit when Freed_Addr > Last;
               Slot := Allocation_Maps.Element (Iter);
               if Freed_Addr + MAT.Types.Target_Addr (Slot.Size) > Addr then
                  if Stats.Total_Free > Slot.Size then
                     Stats.Total_Free := Stats.Total_Free - Slot.Size;
                  else
                     Stats.Total_Free := 0;
                  end if;
                  Freed_Slots.Delete (Iter);
                  Iter := Freed_Slots.Floor (Addr);
               else
                  Allocation_Maps.Next (Iter);
               end if;
            end;
         end loop;
      end Remove_Free;

      --  ------------------------------
      --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
      --  in the used slots map.  The freed slots that intersect the malloc'ed region are
      --  removed from the freed map.
      --  ------------------------------
      procedure Probe_Malloc (Addr   : in MAT.Types.Target_Addr;
                              Slot   : in Allocation) is
      begin
         if Log.Get_Level = Util.Log.DEBUG_LEVEL then
            Log.Debug ("Malloc at {0} size {1}", MAT.Types.Hex_Image (Addr),
                       MAT.Types.Target_Size'Image (Slot.Size));
         end if;
         Stats.Malloc_Count := Stats.Malloc_Count + 1;
         Stats.Total_Alloc := Stats.Total_Alloc + Slot.Size;
         Remove_Free (Addr, Slot.Size);
         Used_Slots.Insert (Addr, Slot);
      end Probe_Malloc;

      --  ------------------------------
      --  Take into account a free probe.  Add the memory slot in the freed map and remove
      --  the slot from the used slots map.
      --  ------------------------------
      procedure Probe_Free (Addr   : in MAT.Types.Target_Addr;
                            Slot   : in Allocation) is
         Item : Allocation;
         Iter : Allocation_Cursor;
      begin
         if Log.Get_Level = Util.Log.DEBUG_LEVEL then
            Log.Debug ("Free {0}", MAT.Types.Hex_Image (Addr));
         end if;
         Stats.Free_Count := Stats.Free_Count + 1;
         Iter := Used_Slots.Find (Addr);
         if Allocation_Maps.Has_Element (Iter) then
            Item := Allocation_Maps.Element (Iter);
            if Stats.Total_Alloc >= Item.Size then
               Stats.Total_Alloc := Stats.Total_Alloc - Item.Size;
            else
               Stats.Total_Alloc := 0;
            end if;
            Stats.Total_Free := Stats.Total_Free + Item.Size;
            MAT.Frames.Release (Item.Frame);
            Used_Slots.Delete (Iter);
            Item.Frame := Slot.Frame;
            Freed_Slots.Insert (Addr, Item);
         end if;
      end Probe_Free;

      --  ------------------------------
      --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
      --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
      --  inserted in the used slots map.
      --  ------------------------------
      procedure Probe_Realloc (Addr     : in MAT.Types.Target_Addr;
                               Old_Addr : in MAT.Types.Target_Addr;
                               Slot     : in Allocation) is
         procedure Update_Size (Key     : in MAT.Types.Target_Addr;
                                Element : in out Allocation);

         procedure Update_Size (Key     : in MAT.Types.Target_Addr;
                                Element : in out Allocation) is
            pragma Unreferenced (Key);
         begin
            if Stats.Total_Alloc >= Element.Size then
               Stats.Total_Alloc := Stats.Total_Alloc - Element.Size;
            else
               Stats.Total_Alloc := 0;
            end if;
            Element.Size := Slot.Size;
            MAT.Frames.Release (Element.Frame);
            Element.Frame := Slot.Frame;
         end Update_Size;

         Pos      : Allocation_Cursor;
      begin
         if Log.Get_Level = Util.Log.DEBUG_LEVEL then
            Log.Debug ("Realloc {0} to {1} size {2}", MAT.Types.Hex_Image (Old_Addr),
                       MAT.Types.Hex_Image (Addr), MAT.Types.Target_Size'Image (Slot.Size));
         end if;
         Stats.Realloc_Count := Stats.Realloc_Count + 1;
         if Addr /= 0 then
            Stats.Total_Alloc := Stats.Total_Alloc + Slot.Size;
            Pos := Used_Slots.Find (Old_Addr);
            if Allocation_Maps.Has_Element (Pos) then
               if Addr = Old_Addr then
                  Used_Slots.Update_Element (Pos, Update_Size'Access);
               else
                  Used_Slots.Delete (Pos);
                  Used_Slots.Insert (Addr, Slot);
               end if;
            else
               Used_Slots.Insert (Addr, Slot);
            end if;
            Remove_Free (Addr, Slot.Size);
         end if;
      end Probe_Realloc;

      --  ------------------------------
      --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
      --  If the frame is already known, the frame reference counter is incremented.
      --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
      --  ------------------------------
      procedure Create_Frame (Pc     : in MAT.Frames.Frame_Table;
                              Result : out MAT.Frames.Frame_Type) is
      begin
         MAT.Frames.Insert (Frames, Pc, Result);
      end Create_Frame;

      --  ------------------------------
      --  Collect the information about memory slot sizes allocated by the application.
      --  ------------------------------
      procedure Size_Information (Sizes  : in out MAT.Memory.Tools.Size_Info_Map) is
      begin
         MAT.Memory.Tools.Size_Information (Used_Slots, Sizes);
      end Size_Information;

      --  ------------------------------
      --  Collect the information about threads and the memory allocations they've made.
      --  ------------------------------
      procedure Thread_Information (Threads : in out Memory_Info_Map) is
      begin
         MAT.Memory.Tools.Thread_Information (Used_Slots, Threads);
      end Thread_Information;

      --  ------------------------------
      --  Collect the information about frames and the memory allocations they've made.
      --  ------------------------------
      procedure Frame_Information (Level  : in Natural;
                                   Frames : in out Frame_Info_Map) is
      begin
         MAT.Memory.Tools.Frame_Information (Used_Slots, Level, Frames);
      end Frame_Information;

      --  ------------------------------
      --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
      --  the region [From .. To] and which is selected by the given filter expression.
      --  Add the memory slot in the <tt>Into</tt> list if it does not already contains
      --  the memory slot.
      --  ------------------------------
      procedure Find (From   : in MAT.Types.Target_Addr;
                      To     : in MAT.Types.Target_Addr;
                      Filter : in MAT.Expressions.Expression_Type;
                      Into   : in out MAT.Memory.Allocation_Map) is
      begin
         MAT.Memory.Tools.Find (Used_Slots, From, To, Filter, Into);
      end Find;

      --  ------------------------------
      --  Get the global memory and allocation statistics.
      --  ------------------------------
      procedure Stat_Information (Result : out Memory_Stat) is
      begin
         Result := Stats;
      end Stat_Information;

   end Memory_Allocator;

end MAT.Memory.Targets;

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

with MAT.Memory.Probes;
package body MAT.Memory.Targets is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Memory.Targets");

   --  ------------------------------
   --  Initialize the target memory object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory events.
   --  ------------------------------
   procedure Initialize (Memory  : in out Target_Memory;
                         Manager : in out MAT.Events.Probes.Probe_Manager_Type'Class) is
      Memory_Probe : constant MAT.Memory.Probes.Memory_Probe_Type_Access
        := new MAT.Memory.Probes.Memory_Probe_Type;
   begin
--        Memory.Manager    := Memory_Probe.all'Access;
      Memory_Probe.Data := Memory'Unrestricted_Access;
      MAT.Memory.Probes.Register (Manager, Memory_Probe);
   end Initialize;

   --  ------------------------------
   --  Add the memory region from the list of memory region managed by the program.
   --  ------------------------------
   procedure Add_Region (Memory : in out Target_Memory;
                         Region : in Region_Info) is
   begin
      Log.Info ("Add region [" & MAT.Types.Hex_Image (Region.Start_Addr) & "-"
                  & MAT.Types.Hex_Image (Region.End_Addr) & "]");
      Memory.Memory.Add_Region (Region);
   end Add_Region;

   --  ------------------------------
   --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
   --  in the used slots map.  The freed slots that intersect the malloc'ed region are
   --  removed from the freed map.
   --  ------------------------------
   procedure Probe_Malloc (Memory : in out Target_Memory;
                           Addr   : in MAT.Types.Target_Addr;
                           Slot   : in Allocation) is
   begin
      Memory.Memory.Probe_Malloc (Addr, Slot);
   end Probe_Malloc;

   --  ------------------------------
   --  Take into account a free probe.  Add the memory slot in the freed map and remove
   --  the slot from the used slots map.
   --  ------------------------------
   procedure Probe_Free (Memory : in out Target_Memory;
                         Addr   : in MAT.Types.Target_Addr;
                         Slot   : in Allocation) is
   begin
      Memory.Memory.Probe_Free (Addr, Slot);
   end Probe_Free;

   --  ------------------------------
   --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
   --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
   --  inserted in the used slots map.
   --  ------------------------------
   procedure Probe_Realloc (Memory : in out Target_Memory;
                            Addr     : in MAT.Types.Target_Addr;
                            Old_Addr : in MAT.Types.Target_Addr;
                            Slot     : in Allocation) is
   begin
      Memory.Memory.Probe_Realloc (Addr, Old_Addr, Slot);
   end Probe_Realloc;

   --  ------------------------------
   --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
   --  If the frame is already known, the frame reference counter is incremented.
   --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
   --  ------------------------------
   procedure Create_Frame (Memory : in out Target_Memory;
                           Pc     : in MAT.Frames.Frame_Table;
                           Result : out MAT.Frames.Frame_Type) is
   begin
      Memory.Memory.Create_Frame (Pc, Result);
   end Create_Frame;

   --  ------------------------------
   --  Collect the information about memory slot sizes allocated by the application.
   --  ------------------------------
   procedure Size_Information (Memory : in out Target_Memory;
                               Sizes  : in out MAT.Memory.Tools.Size_Info_Map) is
   begin
      Memory.Memory.Size_Information (Sizes);
   end Size_Information;

   --  ------------------------------
   --  Collect the information about threads and the memory allocations they've made.
   --  ------------------------------
   procedure Thread_Information (Memory  : in out Target_Memory;
                                 Threads : in out Memory_Info_Map) is
   begin
      Memory.Memory.Thread_Information (Threads);
   end Thread_Information;

   --  ------------------------------
   --  Collect the information about frames and the memory allocations they've made.
   --  ------------------------------
   procedure Frame_Information (Memory : in out Target_Memory;
                                Level  : in Natural;
                                Frames : in out Frame_Info_Map) is
   begin
      Memory.Memory.Frame_Information (Level, Frames);
   end Frame_Information;

   --  ------------------------------
   --  Get the global memory and allocation statistics.
   --  ------------------------------
   procedure Stat_Information (Memory : in out Target_Memory;
                               Result : out Memory_Stat) is
   begin
      Memory.Memory.Stat_Information (Result);
   end Stat_Information;

   --  ------------------------------
   --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
   --  the region [From .. To] and which is selected by the given filter expression.
   --  Add the memory slot in the <tt>Into</tt> list if it does not already contains
   --  the memory slot.
   --  ------------------------------
   procedure Find (Memory : in out Target_Memory;
                   From   : in MAT.Types.Target_Addr;
                   To     : in MAT.Types.Target_Addr;
                   Filter : in MAT.Expressions.Expression_Type;
                   Into   : in out MAT.Memory.Allocation_Map) is
   begin
      Memory.Memory.Find (From, To, Filter, Into);
   end Find;

   protected body Memory_Allocator is

      --  ------------------------------
      --  Add the memory region from the list of memory region managed by the program.
      --  ------------------------------
      procedure Add_Region (Region : in Region_Info) is
      begin
         Regions.Insert (Region.Start_Addr, Region);
      end Add_Region;

      --  ------------------------------
      --  Remove the memory region [Addr .. Addr + Size] from the free list.
      --  ------------------------------
      procedure Remove_Free (Addr : in MAT.Types.Target_Addr;
                             Size : in MAT.Types.Target_Size) is
         Iter : Allocation_Cursor;
         Last : constant MAT.Types.Target_Addr := Addr + MAT.Types.Target_Addr (Size);
         Slot : Allocation;
      begin
         --  Walk the list of free blocks and remove all the blocks which intersect the region
         --  [Addr .. Addr + Slot.Size].  We start walking at the first block below and near
         --  the address.  Slots are then removed when they intersect the malloc'ed region.
         Iter := Freed_Slots.Floor (Addr);
         while Allocation_Maps.Has_Element (Iter) loop
            declare
               Freed_Addr : constant MAT.Types.Target_Addr := Allocation_Maps.Key (Iter);
            begin
               exit when Freed_Addr > Last;
               Slot := Allocation_Maps.Element (Iter);
               if Freed_Addr + MAT.Types.Target_Addr (Slot.Size) > Addr then
                  if Stats.Total_Free > Slot.Size then
                     Stats.Total_Free := Stats.Total_Free - Slot.Size;
                  else
                     Stats.Total_Free := 0;
                  end if;
                  Freed_Slots.Delete (Iter);
                  Iter := Freed_Slots.Floor (Addr);
               else
                  Allocation_Maps.Next (Iter);
               end if;
            end;
         end loop;
      end Remove_Free;

      --  ------------------------------
      --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
      --  in the used slots map.  The freed slots that intersect the malloc'ed region are
      --  removed from the freed map.
      --  ------------------------------
      procedure Probe_Malloc (Addr   : in MAT.Types.Target_Addr;
                              Slot   : in Allocation) is
      begin
         if Log.Get_Level = Util.Log.DEBUG_LEVEL then
            Log.Debug ("Malloc at {0} size {1}", MAT.Types.Hex_Image (Addr),
                       MAT.Types.Target_Size'Image (Slot.Size));
         end if;
         Stats.Malloc_Count := Stats.Malloc_Count + 1;
         if Addr /= 0 then
            Stats.Total_Alloc := Stats.Total_Alloc + Slot.Size;
            Remove_Free (Addr, Slot.Size);
            Used_Slots.Insert (Addr, Slot);
         end if;
      end Probe_Malloc;

      --  ------------------------------
      --  Take into account a free probe.  Add the memory slot in the freed map and remove
      --  the slot from the used slots map.
      --  ------------------------------
      procedure Probe_Free (Addr   : in MAT.Types.Target_Addr;
                            Slot   : in Allocation) is
         Item : Allocation;
         Iter : Allocation_Cursor;
      begin
         if Log.Get_Level = Util.Log.DEBUG_LEVEL then
            Log.Debug ("Free {0}", MAT.Types.Hex_Image (Addr));
         end if;
         Stats.Free_Count := Stats.Free_Count + 1;
         Iter := Used_Slots.Find (Addr);
         if Allocation_Maps.Has_Element (Iter) then
            Item := Allocation_Maps.Element (Iter);
            if Stats.Total_Alloc >= Item.Size then
               Stats.Total_Alloc := Stats.Total_Alloc - Item.Size;
            else
               Stats.Total_Alloc := 0;
            end if;
            Stats.Total_Free := Stats.Total_Free + Item.Size;
            MAT.Frames.Release (Item.Frame);
            Used_Slots.Delete (Iter);
            Item.Frame := Slot.Frame;
            Freed_Slots.Insert (Addr, Item);
         end if;
      end Probe_Free;

      --  ------------------------------
      --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
      --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
      --  inserted in the used slots map.
      --  ------------------------------
      procedure Probe_Realloc (Addr     : in MAT.Types.Target_Addr;
                               Old_Addr : in MAT.Types.Target_Addr;
                               Slot     : in Allocation) is
         procedure Update_Size (Key     : in MAT.Types.Target_Addr;
                                Element : in out Allocation);

         procedure Update_Size (Key     : in MAT.Types.Target_Addr;
                                Element : in out Allocation) is
            pragma Unreferenced (Key);
         begin
            if Stats.Total_Alloc >= Element.Size then
               Stats.Total_Alloc := Stats.Total_Alloc - Element.Size;
            else
               Stats.Total_Alloc := 0;
            end if;
            Element.Size := Slot.Size;
            MAT.Frames.Release (Element.Frame);
            Element.Frame := Slot.Frame;
         end Update_Size;

         Pos      : Allocation_Cursor;
      begin
         if Log.Get_Level = Util.Log.DEBUG_LEVEL then
            Log.Debug ("Realloc {0} to {1} size {2}", MAT.Types.Hex_Image (Old_Addr),
                       MAT.Types.Hex_Image (Addr), MAT.Types.Target_Size'Image (Slot.Size));
         end if;
         Stats.Realloc_Count := Stats.Realloc_Count + 1;
         if Addr /= 0 then
            Stats.Total_Alloc := Stats.Total_Alloc + Slot.Size;
            Pos := Used_Slots.Find (Old_Addr);
            if Allocation_Maps.Has_Element (Pos) then
               if Addr = Old_Addr then
                  Used_Slots.Update_Element (Pos, Update_Size'Access);
               else
                  Used_Slots.Delete (Pos);
                  Used_Slots.Insert (Addr, Slot);
               end if;
            else
               Used_Slots.Insert (Addr, Slot);
            end if;
            Remove_Free (Addr, Slot.Size);
         end if;
      end Probe_Realloc;

      --  ------------------------------
      --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
      --  If the frame is already known, the frame reference counter is incremented.
      --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
      --  ------------------------------
      procedure Create_Frame (Pc     : in MAT.Frames.Frame_Table;
                              Result : out MAT.Frames.Frame_Type) is
      begin
         MAT.Frames.Insert (Frames, Pc, Result);
      end Create_Frame;

      --  ------------------------------
      --  Collect the information about memory slot sizes allocated by the application.
      --  ------------------------------
      procedure Size_Information (Sizes  : in out MAT.Memory.Tools.Size_Info_Map) is
      begin
         MAT.Memory.Tools.Size_Information (Used_Slots, Sizes);
      end Size_Information;

      --  ------------------------------
      --  Collect the information about threads and the memory allocations they've made.
      --  ------------------------------
      procedure Thread_Information (Threads : in out Memory_Info_Map) is
      begin
         MAT.Memory.Tools.Thread_Information (Used_Slots, Threads);
      end Thread_Information;

      --  ------------------------------
      --  Collect the information about frames and the memory allocations they've made.
      --  ------------------------------
      procedure Frame_Information (Level  : in Natural;
                                   Frames : in out Frame_Info_Map) is
      begin
         MAT.Memory.Tools.Frame_Information (Used_Slots, Level, Frames);
      end Frame_Information;

      --  ------------------------------
      --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
      --  the region [From .. To] and which is selected by the given filter expression.
      --  Add the memory slot in the <tt>Into</tt> list if it does not already contains
      --  the memory slot.
      --  ------------------------------
      procedure Find (From   : in MAT.Types.Target_Addr;
                      To     : in MAT.Types.Target_Addr;
                      Filter : in MAT.Expressions.Expression_Type;
                      Into   : in out MAT.Memory.Allocation_Map) is
      begin
         MAT.Memory.Tools.Find (Used_Slots, From, To, Filter, Into);
      end Find;

      --  ------------------------------
      --  Get the global memory and allocation statistics.
      --  ------------------------------
      procedure Stat_Information (Result : out Memory_Stat) is
      begin
         Result := Stats;
      end Stat_Information;

   end Memory_Allocator;

end MAT.Memory.Targets;

Check if the address returned by malloc is 0 in which case don't insert it in the map: this is a memory allocation failure