-----------------------------------------------------------------------
--  security-permissions -- Definition of permissions
--  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.Unchecked_Deallocation;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;

with Util.Log.Loggers;
with Util.Serialize.Mappers.Record_Mapper;

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

--  The Security.Permissions package defines the different permissions that can be
--  checked by the access control manager.
package body Security.Permissions is

   use Util.Log;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------

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

   --  A global map to translate a string to a permission index.
   package Permission_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Permission_Index,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=",
                                                "="             => "=");

   protected type Global_Index is
      --  Get the permission index
      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;

      procedure Add_Permission (Name  : in String;
                                Index : out Permission_Index);
   private
      Map        : Permission_Maps.Map;
      Next_Index : Permission_Index := Permission_Index'First;
   end Global_Index;

   protected body Global_Index is
      function Get_Permission_Index (Name : in String) return Permission_Index is
         Pos : constant Permission_Maps.Cursor := Map.Find (Name);
      begin
         if Permission_Maps.Has_Element (Pos) then
            return Permission_Maps.Element (Pos);
         else
            raise Invalid_Name with "There is no permission '" & Name & "'";
         end if;
      end Get_Permission_Index;

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

      procedure Add_Permission (Name  : in String;
                                Index : out Permission_Index) is
         Pos : constant Permission_Maps.Cursor := Map.Find (Name);
      begin
         if Permission_Maps.Has_Element (Pos) then
            Index := Permission_Maps.Element (Pos);
         else
            Index := Next_Index;
            Log.Debug ("Creating permission index {1} for {0}",
                       Name, Permission_Index'Image (Index));
            Map.Insert (Name, Index);
            Next_Index := Next_Index + 1;
         end if;
      end Add_Permission;

   end Global_Index;

   Permission_Indexes : Global_Index;

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

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

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

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

      Matched : Boolean := False;
      Result  : Access_Rule_Ref;

      procedure Match (P : in Policy);

      procedure Match (P : in Policy) is
      begin
         if GNAT.Regexp.Match (URI, P.Pattern) then
            Matched := True;
            Result  := P.Rule;
         end if;
      end Match;

      Last : constant Natural := Manager.Policies.Last_Index;
   begin
      for I in 1 .. Last loop
         Manager.Policies.Query_Element (I, Match'Access);
         if Matched then
            return Result;
         end if;
      end loop;
      return Result;
   end Find_Access_Rule;

   procedure Add_Permission (Manager    : in out Permission_Manager;
                             Name       : in String;
                             Permission : in Controller_Access) is
      Index : Permission_Index;
   begin
      Log.Info ("Adding permission {0}", Name);

      Add_Permission (Name, Index);
      if Index >= Manager.Last_Index then
         declare
            Count : constant Permission_Index := Index + 32;
            Perms : constant Controller_Access_Array_Access
              := new Controller_Access_Array (0 .. Count);
         begin
            if Manager.Permissions /= null then
               Perms (Manager.Permissions'Range) := Manager.Permissions.all;
            end if;
            Manager.Permissions := Perms;
            Manager.Last_Index := Count;
         end;
      end if;
      Manager.Permissions (Index) := Permission;
   end Add_Permission;

   --  ------------------------------
   --  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 is
      Name  : constant String_Ref := To_String_Ref (Permission.URI);
      Ref   : constant Rules_Ref.Ref := Manager.Cache.Get;
      Rules : constant Rules_Access := Ref.Value;
      Pos   : constant Rules_Maps.Cursor := Rules.Map.Find (Name);
      Rule  : Access_Rule_Ref;
   begin
      --  If the rule is not in the cache, search for the access rule that
      --  matches our URI.  Update the cache.  This cache update is thread-safe
      --  as the cache map is never modified: a new cache map is installed.
      if not Rules_Maps.Has_Element (Pos) then
         declare
            New_Ref : constant Rules_Ref.Ref := Rules_Ref.Create;
         begin
            Rule := Manager.Find_Access_Rule (Permission.URI);
            New_Ref.Value.all.Map := Rules.Map;
            New_Ref.Value.all.Map.Insert (Name, Rule);
            Manager.Cache.Set (New_Ref);
         end;
      else
         Rule := Rules_Maps.Element (Pos);
      end if;

      --  Check if the user has one of the required permission.
      declare
         P       : constant Access_Rule_Access := Rule.Value;
         Granted : Boolean;
      begin
         if P /= null then
            for I in P.Permissions'Range loop
               Context.Has_Permission (P.Permissions (I), Granted);
               if Granted then
                  return True;
               end if;
            end loop;
         end if;
      end;
      return False;
   end Has_Permission;

   --  ------------------------------
   --  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 is
      pragma Unreferenced (Manager);
   begin
      --        return User.Has_Permission (Permission);
      return False;
   end Has_Permission;

   --  ------------------------------
   --  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 is
   begin
      if Index >= Manager.Last_Index then
         return null;
      else
         return Manager.Permissions (Index);
      end if;
   end Get_Controller;

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

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

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

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

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

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

   --  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) is
   begin
      null;
   end Grant_URI_Permission;

   --  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) is
   begin
      null;
   end Grant_File_Permission;

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

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

   type Policy_Fields is (FIELD_ID, FIELD_PERMISSION, FIELD_URL_PATTERN, FIELD_POLICY);

   procedure Set_Member (P     : in out Policy_Config;
                         Field : in Policy_Fields;
                         Value : in Util.Beans.Objects.Object);

   procedure Process (Policy : in Policy_Config);

   procedure Set_Member (P     : in out Policy_Config;
                         Field : in Policy_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_ID =>
            P.Id := Util.Beans.Objects.To_Integer (Value);

         when FIELD_PERMISSION =>
            P.Permissions.Append (Value);

         when FIELD_URL_PATTERN =>
            P.Patterns.Append (Value);

         when FIELD_POLICY =>
            Process (P);
            P.Id := 0;
            P.Permissions.Clear;
            P.Patterns.Clear;

      end case;
   end Set_Member;

   procedure Process (Policy : in Policy_Config) is
      Pol    : Security.Permissions.Policy;
      Count  : constant Natural := Natural (Policy.Permissions.Length);
      Rule   : constant Access_Rule_Ref := Access_Rule_Refs.Create (new Access_Rule (Count));
      Iter   : Util.Beans.Objects.Vectors.Cursor := Policy.Permissions.First;
      Pos    : Positive := 1;
   begin
      Pol.Rule := Rule;

      --  Step 1: Initialize the list of permission index in Access_Rule from the permission names.
      while Util.Beans.Objects.Vectors.Has_Element (Iter) loop
         declare
            Perm : constant Util.Beans.Objects.Object := Util.Beans.Objects.Vectors.Element (Iter);
            Name : constant String := Util.Beans.Objects.To_String (Perm);
         begin
            Rule.Value.all.Permissions (Pos) := Get_Permission_Index (Name);
            Pos := Pos + 1;

         exception
            when Invalid_Name =>
               raise Util.Serialize.Mappers.Field_Error with "Invalid permission: " & Name;
         end;
         Util.Beans.Objects.Vectors.Next (Iter);
      end loop;

      --  Step 2: Create one policy for each URL pattern
      Iter := Policy.Patterns.First;
      while Util.Beans.Objects.Vectors.Has_Element (Iter) loop
         declare
            Pattern : constant Util.Beans.Objects.Object
              := Util.Beans.Objects.Vectors.Element (Iter);
         begin
            Pol.Id   := Policy.Id;
            Pol.Pattern := GNAT.Regexp.Compile (Util.Beans.Objects.To_String (Pattern));
            Policy.Manager.Policies.Append (Pol);
         end;
         Util.Beans.Objects.Vectors.Next (Iter);
      end loop;
   end Process;

   package Policy_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Policy_Config,
                                               Element_Type_Access => Policy_Config_Access,
                                               Fields              => Policy_Fields,
                                               Set_Member          => Set_Member);

   Policy_Mapping        : aliased Policy_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the servlet and mapping rules context-param,
   --  filter-mapping and servlet-mapping.
   --  ------------------------------
   package body Reader_Config is
   begin
      Reader.Add_Mapping ("policy-rules", Policy_Mapping'Access);
      Reader.Add_Mapping ("module", Policy_Mapping'Access);
      Config.Manager := Manager;
      Policy_Mapper.Set_Context (Reader, Config'Unchecked_Access);
   end Reader_Config;

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

      use Util;

      Reader : Util.Serialize.IO.XML.Parser;

      package Policy_Config is
        new Reader_Config (Reader, Manager'Unchecked_Access);
      package Role_Config is
        new Security.Controllers.Roles.Reader_Config (Reader, Manager'Unchecked_Access);
      pragma Warnings (Off, Policy_Config);
      pragma Warnings (Off, Role_Config);
   begin
      Log.Info ("Reading policy file {0}", File);

      Reader.Parse (File);

   end Read_Policy;

   --  ------------------------------
   --  Initialize the permission manager.
   --  ------------------------------
   overriding
   procedure Initialize (Manager : in out Permission_Manager) is
   begin
      Manager.Cache := new Rules_Ref.Atomic_Ref;
      Manager.Cache.Set (Rules_Ref.Create);
   end Initialize;

   --  ------------------------------
   --  Finalize the permission manager.
   --  ------------------------------
   overriding
   procedure Finalize (Manager : in out Permission_Manager) is
      use Ada.Strings.Unbounded;
      use Security.Controllers;

      procedure Free is
        new Ada.Unchecked_Deallocation (Rules_Ref.Atomic_Ref,
                                        Rules_Ref_Access);
      procedure Free is
        new Ada.Unchecked_Deallocation (Security.Controllers.Controller'Class,
                                        Security.Controllers.Controller_Access);
      procedure Free is
        new Ada.Unchecked_Deallocation (Controller_Access_Array,
                                        Controller_Access_Array_Access);

   begin
      Free (Manager.Cache);
      for I in Manager.Names'Range loop
         exit when Manager.Names (I) = null;
         Ada.Strings.Unbounded.Free (Manager.Names (I));
      end loop;

      if Manager.Permissions /= null then
         for I in Manager.Permissions.all'Range loop
            exit when Manager.Permissions (I) = null;

            --  SCz 2011-12-03: GNAT 2011 reports a compilation error:
            --  'missing "with" clause on package "Security.Controllers"'
            --  if we use the 'Security.Controller_Access' type, even if this "with" clause exist.
            --  gcc 4.4.3 under Ubuntu does not have this issue.
            --  We use the 'Security.Controllers.Controller_Access' type to avoid the compiler bug
            --  but we have to use a temporary variable and do some type conversion...
            declare
               P : Security.Controllers.Controller_Access := Manager.Permissions (I).all'Access;
            begin
               Free (P);
               Manager.Permissions (I) := null;
            end;
         end loop;
         Free (Manager.Permissions);
      end if;
   end Finalize;

   package body Permission_ACL is
      P : Permission_Index;

      function Permission return Permission_Index is
      begin
         return P;
      end Permission;

   begin
      Add_Permission (Name => Name, Index => P);
   end Permission_ACL;

   --  ------------------------------
   --  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 is
      Name   : constant String := Util.Beans.Objects.To_String (Value);
   begin
      if Security.Contexts.Has_Permission (Name) then
         return Util.Beans.Objects.To_Object (True);
      else
         return Util.Beans.Objects.To_Object (False);
      end if;
   end Has_Permission;

   --  ------------------------------
   --  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) is
--   begin
--      Mapper.Set_Function (Name      => HAS_PERMISSION_FN,
--                           Namespace => AUTH_NAMESPACE_URI,
--                           Func      => Has_Permission'Access);
--   end Set_Functions;

begin
   Policy_Mapping.Add_Mapping ("policy", FIELD_POLICY);
   Policy_Mapping.Add_Mapping ("policy/@id", FIELD_ID);
   Policy_Mapping.Add_Mapping ("policy/permission", FIELD_PERMISSION);
   Policy_Mapping.Add_Mapping ("policy/url-pattern", FIELD_URL_PATTERN);
end Security.Permissions;

-----------------------------------------------------------------------
--  security-permissions -- Definition of permissions
--  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.Unchecked_Deallocation;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;

with Util.Log.Loggers;
with Util.Serialize.Mappers.Record_Mapper;

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

--  The <b>Security.Permissions</b> package defines the different permissions that can be
--  checked by the access control manager.
package body Security.Permissions is

   use Util.Log;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------

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

   --  A global map to translate a string to a permission index.
   package Permission_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Permission_Index,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=",
                                                "="             => "=");

   protected type Global_Index is
      --  Get the permission index
      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;

      procedure Add_Permission (Name  : in String;
                                Index : out Permission_Index);
   private
      Map        : Permission_Maps.Map;
      Next_Index : Permission_Index := Permission_Index'First;
   end Global_Index;

   protected body Global_Index is
      function Get_Permission_Index (Name : in String) return Permission_Index is
         Pos : constant Permission_Maps.Cursor := Map.Find (Name);
      begin
         if Permission_Maps.Has_Element (Pos) then
            return Permission_Maps.Element (Pos);
         else
            raise Invalid_Name with "There is no permission '" & Name & "'";
         end if;
      end Get_Permission_Index;

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

      procedure Add_Permission (Name  : in String;
                                Index : out Permission_Index) is
         Pos : constant Permission_Maps.Cursor := Map.Find (Name);
      begin
         if Permission_Maps.Has_Element (Pos) then
            Index := Permission_Maps.Element (Pos);
         else
            Index := Next_Index;
            Log.Debug ("Creating permission index {1} for {0}",
                       Name, Permission_Index'Image (Index));
            Map.Insert (Name, Index);
            Next_Index := Next_Index + 1;
         end if;
      end Add_Permission;

   end Global_Index;

   Permission_Indexes : Global_Index;

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

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

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

   package body Permission_ACL is
      P : Permission_Index;

      function Permission return Permission_Index is
      begin
         return P;
      end Permission;

   begin
      Add_Permission (Name => Name, Index => P);
   end Permission_ACL;

end Security.Permissions;

Remove the implementation of old operations which are now in Security.Policy, Security.Policy.Roles and Security.Policy.URLs


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

with Ada.Unchecked_Deallocation;
with Util.Test_Caller;
with Util.Systems.Os;
package body Util.Systems.Dlls.Tests is

   use Util.Tests;
   use type System.Address;

   package Caller is new Util.Test_Caller (Test, "Systems.Dlls");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Systems.Dlls.Load",
                       Test_Load'Access);
      Caller.Add_Test (Suite, "Test Util.Systems.Dlls.Get_Symbol",
                       Test_Get_Symbol'Access);
   end Add_Tests;

   function Get_Test_Library return String is
   begin
      if Util.Systems.Os.Directory_Separator = '/' then
         return "libcrypto.so";
      else
         return "";
      end if;
   end Get_Test_Library;

   function Get_Test_Symbol return String is
   begin
      if Util.Systems.Os.Directory_Separator = '/' then
         return "inflate";
      else
         return "";
      end if;
   end Get_Test_Symbol;

   --  ------------------------------
   --  Test the loading a shared library.
   --  ------------------------------
   procedure Test_Load (T : in out Test) is
      Lib : Handle;
   begin
      Lib := Util.Systems.Dlls.Load (Get_Test_Library);
      T.Assert (Lib /= Null_Handle, "Load operation returned null");

      begin
         Lib := Util.Systems.Dlls.Load ("some-invalid-library");

         T.Fail ("Load must raise an exception");

      exception
         when Load_Error =>
            null;
      end;
   end Test_Load;

   --  ------------------------------
   --  Test getting a shared library symbol.
   --  ------------------------------
   procedure Test_Get_Symbol (T : in out Test) is
      Lib : Handle;
      Sym : System.Address;
   begin
      Lib := Util.Systems.Dlls.Load (Get_Test_Library);
      T.Assert (Lib /= Null_Handle, "Load operation returned null");

      Sym := Util.Systems.Dlls.Get_Symbol (Lib, Get_Test_Symbol);
      T.Assert (Sym /= System.Null_Address, "Get_Symbol returned null");

      begin
         Sym := Util.Systems.Dlls.Get_Symbol (Lib, "some-invalid-symbol");
         T.Fail ("The Get_Symbol operation must raise an exception");

      exception
         when Not_Found =>
            null;

      end;
   end Test_Get_Symbol;

end Util.Systems.Dlls.Tests;

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

with Util.Test_Caller;
with Util.Systems.Os;
package body Util.Systems.DLLs.Tests is

   use Util.Tests;
   use type System.Address;

   function Get_Test_Library return String;
   function Get_Test_Symbol return String;

   package Caller is new Util.Test_Caller (Test, "Systems.Dlls");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Systems.Dlls.Load",
                       Test_Load'Access);
      Caller.Add_Test (Suite, "Test Util.Systems.Dlls.Get_Symbol",
                       Test_Get_Symbol'Access);
   end Add_Tests;

   function Get_Test_Library return String is
   begin
      if Util.Systems.Os.Directory_Separator = '/' then
         return "libcrypto.so";
      else
         return "libz.dll";
      end if;
   end Get_Test_Library;

   function Get_Test_Symbol return String is
   begin
      if Util.Systems.Os.Directory_Separator = '/' then
         return "inflate";
      else
         return "";
      end if;
   end Get_Test_Symbol;

   --  ------------------------------
   --  Test the loading a shared library.
   --  ------------------------------
   procedure Test_Load (T : in out Test) is
      Lib : Handle;
   begin
      Lib := Util.Systems.DLLs.Load (Get_Test_Library);
      T.Assert (Lib /= Null_Handle, "Load operation returned null");

      begin
         Lib := Util.Systems.DLLs.Load ("some-invalid-library");

         T.Fail ("Load must raise an exception");

      exception
         when Load_Error =>
            null;
      end;
   end Test_Load;

   --  ------------------------------
   --  Test getting a shared library symbol.
   --  ------------------------------
   procedure Test_Get_Symbol (T : in out Test) is
      Lib : Handle;
      Sym : System.Address;
   begin
      Lib := Util.Systems.DLLs.Load (Get_Test_Library);
      T.Assert (Lib /= Null_Handle, "Load operation returned null");

      Sym := Util.Systems.DLLs.Get_Symbol (Lib, Get_Test_Symbol);
      T.Assert (Sym /= System.Null_Address, "Get_Symbol returned null");

      begin
         Sym := Util.Systems.DLLs.Get_Symbol (Lib, "some-invalid-symbol");
         T.Fail ("The Get_Symbol operation must raise an exception");

      exception
         when Not_Found =>
            null;

      end;
   end Test_Get_Symbol;

end Util.Systems.DLLs.Tests;

Fix compilation warning and DLLs test load on Windows


with AdaBase;
with Connect;
with CommonText;
with Ada.Text_IO;
with AdaBase.Results.Sets;

procedure Autocommit is

   package CON renames Connect;
   package TIO renames Ada.Text_IO;
   package ARS renames AdaBase.Results.Sets;
   package CT  renames CommonText;

   insX : constant String := "INSERT INTO fruits (id, fruit, color, calories)";
   ins1 : constant String := insX & " VALUES (100,'cucumber','green',16)";
   ins2 : constant String := insX & " VALUES (101,'kumquat','yellow',71)";
   ins3 : constant String := insX & " VALUES (102,'persimmon','orange',127)";
   sel  : constant String := "SELECT * FROM fruits WHERE id > 99";
   del  : constant String := "DELETE FROM fruits WHERE id > 99";

   procedure clear_table;
   procedure test_uno (expected : Natural; version2 : Boolean);
   procedure test_dos (expected : Natural; version2 : Boolean);
   procedure test_tres (expected : Natural);
   procedure expect (impacted, expected : Natural);
   procedure show_results (expected : Natural);

   procedure expect (impacted, expected : Natural) is
   begin
      TIO.Put_Line ("Rows expected:" & expected'Img);
      TIO.Put_Line ("Rows returned:" & impacted'Img);
      if impacted = expected then
         TIO.Put_Line ("=== PASSED ===");
      else
         TIO.Put_Line ("=== FAILED ===   <<----------------------------");
      end if;
      TIO.Put_Line ("");
   end expect;

   procedure show_results (expected : Natural) is
   begin
      CON.connect_database;
      declare
         stmt : CON.Stmt_Type := CON.DR.query (sel);
         row  : ARS.Datarow;
         NR   : Natural := 0;
      begin
         loop
            row := stmt.fetch_next;
            exit when row.data_exhausted;
            NR := NR + 1;
         end loop;
         expect (NR, expected);
      end;
      CON.DR.disconnect;
   end show_results;

   procedure test_uno (expected : Natural; version2 : Boolean) is
      AR : AdaBase.Affected_Rows;
   begin
      CON.connect_database;
      AR := CON.DR.execute (ins1);
      AR := CON.DR.execute (ins2);
      if version2 then
         CON.DR.commit;
      end if;
      CON.DR.disconnect;
      show_results (expected);
   end test_uno;

   procedure test_dos (expected : Natural; version2 : Boolean)
   is
      AR : AdaBase.Affected_Rows;
   begin
      CON.connect_database;
      AR := CON.DR.execute (ins1);
      CON.DR.set_trait_autocommit (True);
      AR := CON.DR.execute (ins2);
      CON.DR.set_trait_autocommit (False);
      AR := CON.DR.execute (ins3);
      if version2 then
         CON.DR.commit;
      end if;
      CON.DR.disconnect;
      show_results (expected);
   end test_dos;

   procedure test_tres (expected : Natural)
   is
      AR : AdaBase.Affected_Rows;
   begin
      CON.connect_database;
      AR := CON.DR.execute (ins1);
      CON.DR.set_trait_autocommit (True);
      CON.DR.disconnect;
      show_results (expected);
   end test_tres;

   procedure clear_table
   is
      AR : AdaBase.Affected_Rows;
   begin
      CON.connect_database;
      AR := CON.DR.execute (del);
      if not CON.DR.trait_autocommit then
         CON.DR.commit;
      end if;
      CON.DR.disconnect;
   end clear_table;

begin

   clear_table;

   TIO.Put_Line ("=== PRECONNECT AUTOCOMMIT => OFF (DEFAULT) ===");
   CON.DR.set_trait_autocommit (False);
   test_uno (0, False);

   clear_table;

   TIO.Put_Line ("=== PRECONNECT AUTOCOMMIT => ON ===");
   CON.DR.set_trait_autocommit (True);
   test_uno (2, False);

   clear_table;

   TIO.Put_Line ("=== CONNECT AC=0, INS, AC=1, INS, AC=0, INS ===");
   CON.DR.set_trait_autocommit (False);
   test_dos (2, False);

   clear_table;

   TIO.Put_Line ("=== IMPLICIT COMMIT (AC/OFF => ON) ===");
   CON.DR.set_trait_autocommit (False);
   test_tres (1);

   clear_table;

   TIO.Put_Line ("=== PRECONNECT AUTOCOMMIT => OFF WITH COMMIT ===");
   CON.DR.set_trait_autocommit (False);
   test_uno (2, True);

   clear_table;

   TIO.Put_Line ("=== PRECONNECT AUTOCOMMIT => ON WITH COMMIT (NO-OP) ===");
   CON.DR.set_trait_autocommit (True);
   test_uno (2, True);

   clear_table;

   TIO.Put_Line ("=== CONNECT AC=0, INS, AC=1, INS, AC=0, INS COMMIT ===");
   CON.DR.set_trait_autocommit (False);
   test_dos (3, True);

end Autocommit;

with AdaBase;
with Connect;
with CommonText;
with Ada.Text_IO;
with AdaBase.Results.Sets;

procedure Autocommit is

   package CON renames Connect;
   package TIO renames Ada.Text_IO;
   package ARS renames AdaBase.Results.Sets;
   package CT  renames CommonText;

   insX : constant String := "INSERT INTO fruits (id, fruit, color, calories)";
   ins1 : constant String := insX & " VALUES (100,'cucumber','green',16)";
   ins2 : constant String := insX & " VALUES (101,'kumquat','yellow',71)";
   ins3 : constant String := insX & " VALUES (102,'persimmon','orange',127)";
   sel  : constant String := "SELECT * FROM fruits WHERE id > 99";
   del  : constant String := "DELETE FROM fruits WHERE id > 99";

   procedure clear_table;
   procedure test_uno (expected : Natural; version2 : Boolean);
   procedure test_dos (expected : Natural; version2 : Boolean);
   procedure test_tres (expected : Natural);
   procedure expect (impacted, expected : Natural);
   procedure show_results (expected : Natural);

   procedure expect (impacted, expected : Natural) is
   begin
      TIO.Put_Line ("Rows expected:" & expected'Img);
      TIO.Put_Line ("Rows returned:" & impacted'Img);
      if impacted = expected then
         TIO.Put_Line ("=== PASSED ===");
      else
         TIO.Put_Line ("=== FAILED ===   <<----------------------------");
      end if;
      TIO.Put_Line ("");
   end expect;

   procedure show_results (expected : Natural) is
   begin
      CON.connect_database;
      declare
         stmt : CON.Stmt_Type := CON.DR.query (sel);
         row  : ARS.Datarow;
         NR   : Natural := 0;
      begin
         loop
            row := stmt.fetch_next;
            exit when row.data_exhausted;
            NR := NR + 1;
         end loop;
         expect (NR, expected);
      end;
      CON.DR.disconnect;
   end show_results;

   procedure test_uno (expected : Natural; version2 : Boolean) is
      AR : AdaBase.Affected_Rows;
   begin
      CON.connect_database;
      AR := CON.DR.execute (ins1);
      AR := CON.DR.execute (ins2);
      if version2 then
         CON.DR.commit;
      end if;
      CON.DR.disconnect;
      show_results (expected);
   end test_uno;

   procedure test_dos (expected : Natural; version2 : Boolean)
   is
      AR : AdaBase.Affected_Rows;
   begin
      CON.connect_database;
      AR := CON.DR.execute (ins1);
      CON.DR.set_trait_autocommit (True);
      AR := CON.DR.execute (ins2);
      CON.DR.set_trait_autocommit (False);
      AR := CON.DR.execute (ins3);
      if version2 then
         CON.DR.commit;
      end if;
      CON.DR.disconnect;
      show_results (expected);
   end test_dos;

   procedure test_tres (expected : Natural)
   is
      AR : AdaBase.Affected_Rows;
   begin
      CON.connect_database;
      AR := CON.DR.execute (ins1);
      CON.DR.set_trait_autocommit (True);
      CON.DR.disconnect;
      show_results (expected);
   end test_tres;

   procedure clear_table
   is
      AR : AdaBase.Affected_Rows;
   begin
      CON.connect_database;
      AR := CON.DR.execute (del);
      if not CON.DR.trait_autocommit then
         CON.DR.commit;
      end if;
      CON.DR.disconnect;
   end clear_table;

begin

   clear_table;

   TIO.Put_Line ("=== PRECONNECT AUTOCOMMIT => OFF (DEFAULT) ===");
   CON.DR.set_trait_autocommit (False);
   test_uno (0, False);

   clear_table;

   TIO.Put_Line ("=== PRECONNECT AUTOCOMMIT => ON ===");
   CON.DR.set_trait_autocommit (True);
   test_uno (2, False);

   clear_table;

   TIO.Put_Line ("=== CONNECT AC=0, INS, AC=1, INS, AC=0, INS ===");
   CON.DR.set_trait_autocommit (False);
   test_dos (2, False);

   clear_table;

   TIO.Put_Line ("=== IMPLICIT COMMIT (AC/OFF => ON) ===");
   CON.DR.set_trait_autocommit (False);
   test_tres (1);

   clear_table;

   TIO.Put_Line ("=== PRECONNECT AUTOCOMMIT => OFF WITH COMMIT ===");
   CON.DR.set_trait_autocommit (False);
   test_uno (2, True);

   clear_table;

   TIO.Put_Line ("=== PRECONNECT AUTOCOMMIT => ON WITH COMMIT (NO-OP) ===");
   CON.DR.set_trait_autocommit (True);
   test_uno (2, True);

   clear_table;

   TIO.Put_Line ("=== CONNECT AC=0, INS, AC=1, INS, AC=0, INS COMMIT ===");
   CON.DR.set_trait_autocommit (False);
   test_dos (3, True);

   clear_table;

end Autocommit;

clean up after autocommit test case run

clean up after autocommit test case run


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

with Security.Auth.Tests;
with Security.OAuth.File_Registry;
package body Security.OAuth.Servers.Tests is

   use Auth.Tests;
   use File_Registry;

   package Caller is new Util.Test_Caller (Test, "Security.OAuth.Servers");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Security.OAuth.Servers.Find_Application",
                       Test_Application_Manager'Access);
      Caller.Add_Test (Suite, "Test Security.OAuth.Servers.Verify",
                       Test_User_Verify'Access);
      Caller.Add_Test (Suite, "Test Security.OAuth.Servers.Token",
                       Test_Token_Password'Access);
      Caller.Add_Test (Suite, "Test Security.OAuth.Servers.Authenticate",
                       Test_Bad_Token'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test the application manager.
   --  ------------------------------
   procedure Test_Application_Manager (T : in out Test) is
      Manager : File_Application_Manager;
      App     : Application;
   begin
      App.Set_Application_Identifier ("my-app-id");
      App.Set_Application_Secret ("my-secret");
      App.Set_Application_Callback ("my-callback");
      Manager.Add_Application (App);

      --  Check that we can find our application.
      declare
         A : constant Application'Class := Manager.Find_Application ("my-app-id");
      begin
         Util.Tests.Assert_Equals (T, "my-app-id", A.Get_Application_Identifier,
                                   "Invalid application returned by Find");
      end;

      --  Check that an exception is raised for an invalid client ID.
      begin
         declare
            A : constant Application'Class := Manager.Find_Application ("unkown-app-id");
         begin
            Util.Tests.Fail (T, "Found the application " & A.Get_Application_Identifier);
         end;

      exception
         when Invalid_Application =>
            null;
      end;
   end Test_Application_Manager;

   --  ------------------------------
   --  Test the user registration and verification.
   --  ------------------------------
   procedure Test_User_Verify (T : in out Test) is
      Manager : File_Realm_Manager;
      Auth    : Principal_Access;
   begin
      Manager.Add_User ("Gandalf", "Mithrandir");
      Manager.Verify ("Gandalf", "mithrandir", Auth);
      T.Assert (Auth = null, "Verify password should fail with an invalid password");

      Manager.Verify ("Sauron", "Mithrandir", Auth);
      T.Assert (Auth = null, "Verify password should fail with an invalid user");

      Manager.Verify ("Gandalf", "Mithrandir", Auth);
      T.Assert (Auth /= null, "Verify password operation failed for a good user/password");
   end Test_User_Verify;

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

      Apps       : aliased File_Application_Manager;
      Realm      : aliased File_Realm_Manager;
      Manager    : Auth_Manager;
      Auth       : Principal_Access;
      App        : Application;
      Grant      : Grant_Type;
      Auth_Grant : Grant_Type;
      Params     : Test_Parameters;
   begin
      --  Add one test application.
      App.Set_Application_Identifier ("my-app-id");
      App.Set_Application_Secret ("my-secret");
      App.Set_Application_Callback ("my-callback");
      Apps.Add_Application (App);

      --  Add one test user.
      Realm.Add_User ("Gandalf", "Mithrandir");

      --  Configure the auth manager.
      Manager.Set_Application_Manager (Apps'Unchecked_Access);
      Manager.Set_Realm_Manager (Realm'Unchecked_Access);
      Manager.Set_Private_Key ("server-private-key-no-so-secure");

      Manager.Token (Params, Grant);
      T.Assert (Grant.Status = Invalid_Grant, "Expecting Invalid_Grant when client_id is missing");

      Params.Set_Parameter (Security.OAuth.CLIENT_ID, "");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Status = Invalid_Grant, "Expecting Invalid_Grant when client_id is empty");

      Params.Set_Parameter (Security.OAuth.CLIENT_ID, "unkown-app");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Status = Invalid_Grant, "Expecting Invalid_Grant when client_id is invalid");

      Params.Set_Parameter (Security.OAuth.CLIENT_ID, "my-app-id");
      Params.Set_Parameter (Security.OAuth.GRANT_TYPE, "");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Status = Invalid_Grant, "Expecting Invalid_Grant when client_id is empty");

      Params.Set_Parameter (Security.OAuth.GRANT_TYPE, "password");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Request = Password_Grant, "Expecting Password_Grant for the grant request");
      T.Assert (Grant.Status = Invalid_Grant, "Expecting Invalid_Grant when the user/password is missing");

      Params.Set_Parameter (Security.OAuth.USERNAME, "Gandalf");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Request = Password_Grant, "Expecting Password_Grant for the grant request");
      T.Assert (Grant.Status = Invalid_Grant, "Expecting Invalid_Grant when the password is missing");

      Params.Set_Parameter (Security.OAuth.PASSWORD, "test");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Request = Password_Grant, "Expecting Password_Grant for the grant request");
      T.Assert (Grant.Status = Invalid_Grant, "Expecting Invalid_Grant when the password is invalid");

      Params.Set_Parameter (Security.OAuth.PASSWORD, "Mithrandir");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Request = Password_Grant, "Expecting Password_Grant for the grant request");
      T.Assert (Grant.Status = Valid_Grant, "Expecting Valid_Grant when the user/password are correct");
      T.Assert (Grant.Error = null, "Expecting null error");
      T.Assert (Length (Grant.Token) > 20, "Expecting a token with some reasonable size");
      T.Assert (Grant.Auth /= null, "Expecting a non null auth principal");
      Util.Tests.Assert_Equals (T, "Gandalf", Grant.Auth.Get_Name, "Invalid user name in the principal");

      --  Verify the access token.
      for I in 1 .. 5 loop
         Manager.Authenticate (To_String (Grant.Token), Auth_Grant);
         T.Assert (Auth_Grant.Request = Access_Grant, "Expecting Access_Grant for the authenticate");
         T.Assert (Auth_Grant.Status = Valid_Grant, "Expecting Valid_Grant when the access token is checked");
         T.Assert (Auth_Grant.Error = null, "Expecting null error for access_token");
         T.Assert (Auth_Grant.Auth = Grant.Auth, "Expecting valid auth principal");
      end loop;

      --  Verify the modified access token.
      Manager.Authenticate (To_String (Grant.Token) & "x", Auth_Grant);
      T.Assert (Auth_Grant.Status = Invalid_Grant, "Expecting Invalid_Grant for the authenticate");

      Manager.Revoke (To_String (Grant.Token));

      --  Verify the access is now denied.
      for I in 1 .. 5 loop
         Manager.Authenticate (To_String (Grant.Token), Auth_Grant);
         T.Assert (Auth_Grant.Status = Revoked_Grant, "Expecting Revoked_Grant for the authenticate");
      end loop;

      --  Change application token expiration time to 1 second.
      App.Expire_Timeout := 1.0;
      Apps.Add_Application (App);

      --  Make the access token.
      Manager.Token (Params, Grant);
      T.Assert (Grant.Status = Valid_Grant, "Expecting Valid_Grant when the user/password are correct");

      --  Verify the access token.
      for I in 1 .. 5 loop
         Manager.Authenticate (To_String (Grant.Token), Auth_Grant);
         T.Assert (Auth_Grant.Request = Access_Grant, "Expecting Access_Grant for the authenticate");
         T.Assert (Auth_Grant.Status = Valid_Grant, "Expecting Valid_Grant when the access token is checked");
         T.Assert (Auth_Grant.Error = null, "Expecting null error for access_token");
         T.Assert (Auth_Grant.Auth = Grant.Auth, "Expecting valid auth principal");
      end loop;

      --  Wait for the token to expire.
      delay 2.0;
      for I in 1 .. 5 loop
         Manager.Authenticate (To_String (Grant.Token), Auth_Grant);
         T.Assert (Auth_Grant.Status = Expired_Grant, "Expecting Expired when the access token is checked");
      end loop;

   end Test_Token_Password;

   --  ------------------------------
   --  Test the access token validation with invalid tokens (bad formed).
   --  ------------------------------
   procedure Test_Bad_Token (T : in out Test) is
      Manager    : Auth_Manager;
      Auth_Grant : Grant_Type;
      Params     : Test_Parameters;
   begin
      Manager.Authenticate ("x", Auth_Grant);
      T.Assert (Auth_Grant.Status = Invalid_Grant, "Expecting Invalid_Grant for badly formed token");
      Manager.Authenticate (".", Auth_Grant);
      T.Assert (Auth_Grant.Status = Invalid_Grant, "Expecting Invalid_Grant for badly formed token");
      Manager.Authenticate ("..", Auth_Grant);
      T.Assert (Auth_Grant.Status = Invalid_Grant, "Expecting Invalid_Grant for badly formed token");
      Manager.Authenticate ("a..", Auth_Grant);
      T.Assert (Auth_Grant.Status = Invalid_Grant, "Expecting Invalid_Grant for badly formed token");
      Manager.Authenticate ("..b", Auth_Grant);
      T.Assert (Auth_Grant.Status = Invalid_Grant, "Expecting Invalid_Grant for badly formed token");
      Manager.Authenticate ("a..b", Auth_Grant);
      T.Assert (Auth_Grant.Status = Invalid_Grant, "Expecting Invalid_Grant for badly formed token");
   end Test_Bad_Token;

end Security.OAuth.Servers.Tests;

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

with Security.Auth.Tests;
with Security.OAuth.File_Registry;
package body Security.OAuth.Servers.Tests is

   use Auth.Tests;
   use File_Registry;

   package Caller is new Util.Test_Caller (Test, "Security.OAuth.Servers");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Security.OAuth.Servers.Find_Application",
                       Test_Application_Manager'Access);
      Caller.Add_Test (Suite, "Test Security.OAuth.Servers.Verify",
                       Test_User_Verify'Access);
      Caller.Add_Test (Suite, "Test Security.OAuth.Servers.Token",
                       Test_Token_Password'Access);
      Caller.Add_Test (Suite, "Test Security.OAuth.Servers.Authenticate",
                       Test_Bad_Token'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test the application manager.
   --  ------------------------------
   procedure Test_Application_Manager (T : in out Test) is
      Manager : File_Application_Manager;
      App     : Application;
   begin
      App.Set_Application_Identifier ("my-app-id");
      App.Set_Application_Secret ("my-secret");
      App.Set_Application_Callback ("my-callback");
      Manager.Add_Application (App);

      --  Check that we can find our application.
      declare
         A : constant Application'Class := Manager.Find_Application ("my-app-id");
      begin
         Util.Tests.Assert_Equals (T, "my-app-id", A.Get_Application_Identifier,
                                   "Invalid application returned by Find");
      end;

      --  Check that an exception is raised for an invalid client ID.
      begin
         declare
            A : constant Application'Class := Manager.Find_Application ("unkown-app-id");
         begin
            Util.Tests.Fail (T, "Found the application " & A.Get_Application_Identifier);
         end;

      exception
         when Invalid_Application =>
            null;
      end;
   end Test_Application_Manager;

   --  ------------------------------
   --  Test the user registration and verification.
   --  ------------------------------
   procedure Test_User_Verify (T : in out Test) is
      Manager : File_Realm_Manager;
      Auth    : Principal_Access;
   begin
      Manager.Add_User ("Gandalf", "Mithrandir");
      Manager.Verify ("Gandalf", "mithrandir", Auth);
      T.Assert (Auth = null, "Verify password should fail with an invalid password");

      Manager.Verify ("Sauron", "Mithrandir", Auth);
      T.Assert (Auth = null, "Verify password should fail with an invalid user");

      Manager.Verify ("Gandalf", "Mithrandir", Auth);
      T.Assert (Auth /= null, "Verify password operation failed for a good user/password");
   end Test_User_Verify;

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

      Apps       : aliased File_Application_Manager;
      Realm      : aliased File_Realm_Manager;
      Manager    : Auth_Manager;
      App        : Application;
      Grant      : Grant_Type;
      Auth_Grant : Grant_Type;
      Params     : Test_Parameters;
   begin
      --  Add one test application.
      App.Set_Application_Identifier ("my-app-id");
      App.Set_Application_Secret ("my-secret");
      App.Set_Application_Callback ("my-callback");
      Apps.Add_Application (App);

      --  Add one test user.
      Realm.Add_User ("Gandalf", "Mithrandir");

      --  Configure the auth manager.
      Manager.Set_Application_Manager (Apps'Unchecked_Access);
      Manager.Set_Realm_Manager (Realm'Unchecked_Access);
      Manager.Set_Private_Key ("server-private-key-no-so-secure");

      Manager.Token (Params, Grant);
      T.Assert (Grant.Status = Invalid_Grant, "Expecting Invalid_Grant when client_id is missing");

      Params.Set_Parameter (Security.OAuth.CLIENT_ID, "");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Status = Invalid_Grant, "Expecting Invalid_Grant when client_id is empty");

      Params.Set_Parameter (Security.OAuth.CLIENT_ID, "unkown-app");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Status = Invalid_Grant, "Expecting Invalid_Grant when client_id is invalid");

      Params.Set_Parameter (Security.OAuth.CLIENT_ID, "my-app-id");
      Params.Set_Parameter (Security.OAuth.GRANT_TYPE, "");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant when client_id is empty");

      Params.Set_Parameter (Security.OAuth.GRANT_TYPE, "password");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Request = Password_Grant,
                "Expecting Password_Grant for the grant request");
      T.Assert (Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant when the user/password is missing");

      Params.Set_Parameter (Security.OAuth.USERNAME, "Gandalf");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Request = Password_Grant,
                "Expecting Password_Grant for the grant request");
      T.Assert (Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant when the password is missing");

      Params.Set_Parameter (Security.OAuth.PASSWORD, "test");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Request = Password_Grant,
                "Expecting Password_Grant for the grant request");
      T.Assert (Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant when the password is invalid");

      Params.Set_Parameter (Security.OAuth.PASSWORD, "Mithrandir");
      Manager.Token (Params, Grant);
      T.Assert (Grant.Request = Password_Grant,
                "Expecting Password_Grant for the grant request");
      T.Assert (Grant.Status = Valid_Grant,
                "Expecting Valid_Grant when the user/password are correct");
      T.Assert (Grant.Error = null, "Expecting null error");
      T.Assert (Length (Grant.Token) > 20,
                "Expecting a token with some reasonable size");
      T.Assert (Grant.Auth /= null,
                "Expecting a non null auth principal");
      Util.Tests.Assert_Equals (T, "Gandalf", Grant.Auth.Get_Name,
                                "Invalid user name in the principal");

      --  Verify the access token.
      for I in 1 .. 5 loop
         Manager.Authenticate (To_String (Grant.Token), Auth_Grant);
         T.Assert (Auth_Grant.Request = Access_Grant,
                   "Expecting Access_Grant for the authenticate");
         T.Assert (Auth_Grant.Status = Valid_Grant,
                   "Expecting Valid_Grant when the access token is checked");
         T.Assert (Auth_Grant.Error = null, "Expecting null error for access_token");
         T.Assert (Auth_Grant.Auth = Grant.Auth, "Expecting valid auth principal");
      end loop;

      --  Verify the modified access token.
      Manager.Authenticate (To_String (Grant.Token) & "x", Auth_Grant);
      T.Assert (Auth_Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant for the authenticate");

      Manager.Revoke (To_String (Grant.Token));

      --  Verify the access is now denied.
      for I in 1 .. 5 loop
         Manager.Authenticate (To_String (Grant.Token), Auth_Grant);
         T.Assert (Auth_Grant.Status = Revoked_Grant,
                   "Expecting Revoked_Grant for the authenticate");
      end loop;

      --  Change application token expiration time to 1 second.
      App.Expire_Timeout := 1.0;
      Apps.Add_Application (App);

      --  Make the access token.
      Manager.Token (Params, Grant);
      T.Assert (Grant.Status = Valid_Grant,
                "Expecting Valid_Grant when the user/password are correct");

      --  Verify the access token.
      for I in 1 .. 5 loop
         Manager.Authenticate (To_String (Grant.Token), Auth_Grant);
         T.Assert (Auth_Grant.Request = Access_Grant,
                   "Expecting Access_Grant for the authenticate");
         T.Assert (Auth_Grant.Status = Valid_Grant,
                   "Expecting Valid_Grant when the access token is checked");
         T.Assert (Auth_Grant.Error = null,
                   "Expecting null error for access_token");
         T.Assert (Auth_Grant.Auth = Grant.Auth,
                   "Expecting valid auth principal");
      end loop;

      --  Wait for the token to expire.
      delay 2.0;
      for I in 1 .. 5 loop
         Manager.Authenticate (To_String (Grant.Token), Auth_Grant);
         T.Assert (Auth_Grant.Status = Expired_Grant,
                   "Expecting Expired when the access token is checked");
      end loop;

   end Test_Token_Password;

   --  ------------------------------
   --  Test the access token validation with invalid tokens (bad formed).
   --  ------------------------------
   procedure Test_Bad_Token (T : in out Test) is
      Manager    : Auth_Manager;
      Auth_Grant : Grant_Type;
   begin
      Manager.Authenticate ("x", Auth_Grant);
      T.Assert (Auth_Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant for badly formed token");
      Manager.Authenticate (".", Auth_Grant);
      T.Assert (Auth_Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant for badly formed token");
      Manager.Authenticate ("..", Auth_Grant);
      T.Assert (Auth_Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant for badly formed token");
      Manager.Authenticate ("a..", Auth_Grant);
      T.Assert (Auth_Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant for badly formed token");
      Manager.Authenticate ("..b", Auth_Grant);
      T.Assert (Auth_Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant for badly formed token");
      Manager.Authenticate ("a..b", Auth_Grant);
      T.Assert (Auth_Grant.Status = Invalid_Grant,
                "Expecting Invalid_Grant for badly formed token");
   end Test_Bad_Token;

end Security.OAuth.Servers.Tests;

Fix style and compilation warnings

Fix style and compilation warnings


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

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

package Security.Policies.Roles is

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

   type Role_Policy is new Policy with private;

   Invalid_Name : exception;

   --  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 Manager
   --  ------------------------------
   --  The Permission_Manager verifies through some policy that a permission
   --  is granted to a user.

   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type;

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

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

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

private

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

   type Role_Policy is new Policy with record
      Names        : Role_Name_Array;
      Next_Role    : Role_Type := Role_Type'First;
   end record;

end Security.Policies.Roles;

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

with Ada.Strings.Unbounded;

--  == Role Based Security Policy ==
--  The <tt>Security.Policies.Roles</tt> package implements a role based security policy.
--
--  A role is represented by a name in security configuration files.
package Security.Policies.Roles is

   --  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;
   for Role_Type'Size use 8;

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

   --  ------------------------------
   --  Role based policy
   --  ------------------------------
   type Role_Policy is new Policy with private;

   Invalid_Name : exception;

   --  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 Manager
   --  ------------------------------
   --  The Permission_Manager verifies through some policy that a permission
   --  is granted to a user.

   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type;

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

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

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

private

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

   type Role_Policy is new Policy with record
      Names        : Role_Name_Array;
      Next_Role    : Role_Type := Role_Type'First;
   end record;

   type Controller_Config is record
      Name    : Util.Beans.Objects.Object;
      Roles   : Permissions.Role_Type_Array (1 .. Integer (Permissions.Role_Type'Last));
      Count   : Natural := 0;
      Manager : Security.Permissions.Permission_Manager_Access;
   end record;

   --  Setup the XML parser to read the role-permission description.  For example:
   --
   --  <security-role>
   --    <role-name>admin</role-name>
   --  </security-role>
   --  <role-permission>
   --     <name>create-workspace</name>
   --     <role>admin</role>
   --     <role>manager</role>
   --  </role-permission>
   --
   --  This defines a permission create-workspace that will be granted if the
   --  user has either the admin or the manager role.
   overriding
   procedure Set_Reader_Config (Pol     : in out Policy;
                                Reader  : in out Util.Serialize.IO.XML.Parser);

end Security.Policies.Roles;

Define Set_Reader_Config to allow reading the XML configuration for role based policies


------------------------------------------------------------------------------
--                                                                          --
--                     Copyright (C) 2015-2016, AdaCore                     --
--                                                                          --
--  Redistribution and use in source and binary forms, with or without      --
--  modification, are permitted provided that the following conditions are  --
--  met:                                                                    --
--     1. Redistributions of source code must retain the above copyright    --
--        notice, this list of conditions and the following disclaimer.     --
--     2. Redistributions in binary form must reproduce the above copyright --
--        notice, this list of conditions and the following disclaimer in   --
--        the documentation and/or other materials provided with the        --
--        distribution.                                                     --
--     3. Neither the name of the copyright holder nor the names of its     --
--        contributors may be used to endorse or promote products derived   --
--        from this software without specific prior written permission.     --
--                                                                          --
--   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    --
--   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      --
--   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR  --
--   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT   --
--   HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --
--   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT       --
--   LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,  --
--   DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY  --
--   THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT    --
--   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE  --
--   OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.   --
--                                                                          --
------------------------------------------------------------------------------

--  A very simple draw application.
--  Use your finger to draw pixels.

with Last_Chance_Handler;  pragma Unreferenced (Last_Chance_Handler);
--  The "last chance handler" is the user-defined routine that is called when
--  an exception is propagated. We need it in the executable, therefore it
--  must be somewhere in the closure of the context clauses.

with STM32.Board;           use STM32.Board;
with HAL.Bitmap;            use HAL.Bitmap;
with HAL.Touch_Panel;       use HAL.Touch_Panel;
with STM32.User_Button;     use STM32;

procedure Draw
is
   procedure Clear;

   -----------
   -- Clear --
   -----------

   procedure Clear is
   begin
      Display.Hidden_Buffer (1).Fill ((Alpha => 255, others => 64));
      Display.Update_Layer (1, Copy_Back => True);
   end Clear;

   Last_X : Integer := -1;
   Last_Y : Integer := -1;

begin
   --  Initialize LCD
   Display.Initialize;
   Display.Initialize_Layer (1, ARGB_8888);

   --  Initialize touch panel
   Touch_Panel.Initialize;

   --  Initialize button
   User_Button.Initialize;

   --  Clear LCD (set background)
   Clear;

   --  The application: set pixel where the finger is (so that you
   --  cannot see what you are drawing).
   loop
      if User_Button.Has_Been_Pressed then
         Clear;
      end if;

      declare
         State : constant TP_State := Touch_Panel.Get_All_Touch_Points;
      begin
         if State'Length = 0 then
            Last_X := -1;
            Last_Y := -1;

         elsif State'Length = 1 then
            --  Lines can be drawn between two consecutive points only when
            --  one touch point is active: the order of the touch data is not
            --  necessarily preserved by the hardware.
            if Last_X > 0 then
               Draw_Line
                 (Display.Hidden_Buffer (1).all,
                  Color     => HAL.Bitmap.Green,
                  Start     => (Last_X, Last_Y),
                  Stop      => (State (State'First).X, State (State'First).Y),
                  Thickness => State (State'First).Weight / 2,
                  Fast      => False);
            end if;

            Last_X := State (State'First).X;
            Last_Y := State (State'First).Y;

         else
            Last_X := -1;
            Last_Y := -1;
         end if;

         for Id in State'Range loop
            Fill_Circle
              (Display.Hidden_Buffer (1).all,
               Color => HAL.Bitmap.Green,
               Center => (State (Id).X, State (Id).Y),
               Radius => State (Id).Weight / 4);
         end loop;

         if State'Length > 0 then
            Display.Update_Layer (1, Copy_Back => True);
         end if;
      end;
   end loop;
end Draw;

------------------------------------------------------------------------------
--                                                                          --
--                     Copyright (C) 2015-2016, AdaCore                     --
--                                                                          --
--  Redistribution and use in source and binary forms, with or without      --
--  modification, are permitted provided that the following conditions are  --
--  met:                                                                    --
--     1. Redistributions of source code must retain the above copyright    --
--        notice, this list of conditions and the following disclaimer.     --
--     2. Redistributions in binary form must reproduce the above copyright --
--        notice, this list of conditions and the following disclaimer in   --
--        the documentation and/or other materials provided with the        --
--        distribution.                                                     --
--     3. Neither the name of the copyright holder nor the names of its     --
--        contributors may be used to endorse or promote products derived   --
--        from this software without specific prior written permission.     --
--                                                                          --
--   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    --
--   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      --
--   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR  --
--   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT   --
--   HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --
--   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT       --
--   LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,  --
--   DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY  --
--   THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT    --
--   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE  --
--   OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.   --
--                                                                          --
------------------------------------------------------------------------------

--  A very simple draw application.
--  Use your finger to draw pixels.

with Last_Chance_Handler;  pragma Unreferenced (Last_Chance_Handler);
--  The "last chance handler" is the user-defined routine that is called when
--  an exception is propagated. We need it in the executable, therefore it
--  must be somewhere in the closure of the context clauses.

with STM32.Board;           use STM32.Board;
with HAL.Bitmap;            use HAL.Bitmap;
with HAL.Touch_Panel;       use HAL.Touch_Panel;
with STM32.User_Button;     use STM32;
with Bitmapped_Drawing;     use Bitmapped_Drawing;
with BMP_Fonts;

procedure Draw
is
   procedure Clear;

   -----------
   -- Clear --
   -----------

   procedure Clear is
      BG : constant Bitmap_Color := (Alpha => 255, others => 64);
   begin
      Display.Hidden_Buffer (1).Fill (BG);

      Draw_String (Buffer     => Display.Hidden_Buffer (1).all,
                   Start      => (0, 0),
                   Msg        => "Touch the screen to draw or",
                   Font       => BMP_Fonts.Font8x8,
                   Foreground => HAL.Bitmap.White,
                   Background => BG);

      Draw_String (Buffer     => Display.Hidden_Buffer (1).all,
                   Start      => (0, 10),
                   Msg        => "press the blue button for",
                   Font       => BMP_Fonts.Font8x8,
                   Foreground => HAL.Bitmap.White,
                   Background => BG);

      Draw_String (Buffer     => Display.Hidden_Buffer (1).all,
                   Start      => (0, 20),
                   Msg        => "a demo of drawing pimitives.",
                   Font       => BMP_Fonts.Font8x8,
                   Foreground => HAL.Bitmap.White,
                   Background => BG);

      Display.Update_Layer (1, Copy_Back => True);
   end Clear;

   Last_X : Integer := -1;
   Last_Y : Integer := -1;

   type Mode is (Drawing_Mode, Bitmap_Showcase_Mode);

   Current_Mode : Mode := Drawing_Mode;

begin
   --  Initialize LCD
   Display.Initialize;
   Display.Initialize_Layer (1, ARGB_8888);

   --  Initialize touch panel
   Touch_Panel.Initialize;

   --  Initialize button
   User_Button.Initialize;

   --  Clear LCD (set background)
   Clear;

   --  The application: set pixel where the finger is (so that you
   --  cannot see what you are drawing).
   loop
      if User_Button.Has_Been_Pressed then
         case Current_Mode is
            when Drawing_Mode =>
               Current_Mode := Bitmap_Showcase_Mode;
            when Bitmap_Showcase_Mode =>
               Clear;
               Current_Mode := Drawing_Mode;
         end case;
      end if;

      if Current_Mode = Drawing_Mode then

         declare
            State : constant TP_State := Touch_Panel.Get_All_Touch_Points;
         begin
            if State'Length = 0 then
               Last_X := -1;
               Last_Y := -1;

            elsif State'Length = 1 then
               --  Lines can be drawn between two consecutive points only when
               --  one touch point is active: the order of the touch data is not
               --  necessarily preserved by the hardware.
               if Last_X > 0 then
                  Draw_Line
                    (Display.Hidden_Buffer (1).all,
                     Color     => HAL.Bitmap.Green,
                     Start     => (Last_X, Last_Y),
                     Stop      => (State (State'First).X, State (State'First).Y),
                     Thickness => State (State'First).Weight / 2,
                     Fast      => False);
               end if;

               Last_X := State (State'First).X;
               Last_Y := State (State'First).Y;

            else
               Last_X := -1;
               Last_Y := -1;
            end if;

            for Id in State'Range loop
               Fill_Circle
                 (Display.Hidden_Buffer (1).all,
                  Color => HAL.Bitmap.Green,
                  Center => (State (Id).X, State (Id).Y),
                  Radius => State (Id).Weight / 4);
            end loop;

            if State'Length > 0 then
               Display.Update_Layer (1, Copy_Back => True);
            end if;
         end;

      else

         --  Show some of the supported drawing primitives

         Display.Hidden_Buffer (1).Fill (Black);

         Display.Hidden_Buffer (1).Fill_Rounded_Rect
           (HAL.Bitmap.Green, ((10, 10), 100, 100), 20);

         Display.Hidden_Buffer (1).Draw_Rounded_Rect
           (HAL.Bitmap.Red, ((10, 10), 100, 100), 20, Thickness => 4);

         Display.Hidden_Buffer (1).Fill_Circle (HAL.Bitmap.Yellow,
                                                (60, 60), 20);
         Display.Hidden_Buffer (1).Draw_Circle (HAL.Bitmap.Blue,
                                                (60, 60), 20);

         Display.Hidden_Buffer (1).Cubic_Bezier (Color     => HAL.Bitmap.Violet,
                                                 P1        => (10, 10),
                                                 P2        => (60, 10),
                                                 P3        => (60, 60),
                                                 P4        => (100, 100),
                                                 N         => 200,
                                                 Thickness => 5);

         Copy_Rect (Src_Buffer  => Display.Hidden_Buffer (1).all,
                    Src_Pt      => (0, 0),
                    Dst_Buffer  => Display.Hidden_Buffer (1).all,
                    Dst_Pt      => (100, 100),
                    Width       => 100,
                    Height      => 100,
                    Synchronous => True);

         Display.Update_Layer (1, Copy_Back => False);
      end if;
   end loop;
end Draw;

Add a bitmap drawing primitive demo

examples/draw: Add a bitmap drawing primitive demo

Pressing the blue button shows some of the primitives in action.


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

--  The <b>AWA.Applications.Configs</b> package reads the application configuration files.
package AWA.Applications.Configs is

   --  XML reader configuration.  By instantiating this generic package, the XML parser
   --  gets initialized to read the configuration for servlets, filters, managed beans,
   --  permissions, events and other configuration elements.
   generic
      Reader  : in out Util.Serialize.IO.XML.Parser;
      App     : in Application_Access;
      Context : in EL.Contexts.Default.Default_Context_Access;
      Override_Context : in Boolean;
   package Reader_Config is
   end Reader_Config;

   --  Read the application configuration file and configure the application
   procedure Read_Configuration (App     : in out Application'Class;
                                 File    : in String;
                                 Context : in EL.Contexts.Default.Default_Context_Access;
                                 Override_Context : in Boolean);

   --  Get the configuration path for the application name.
   --  The configuration path is search from:
   --  o the current directory,
   --  o the 'config' directory,
   --  o the Dynamo installation directory in share/dynamo
   function Get_Config_Path (Name : in String) return String;

end AWA.Applications.Configs;

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

--  The <b>AWA.Applications.Configs</b> package reads the application configuration files.
package AWA.Applications.Configs is

   --  XML reader configuration.  By instantiating this generic package, the XML parser
   --  gets initialized to read the configuration for servlets, filters, managed beans,
   --  permissions, events and other configuration elements.
   generic
      Mapper  : in out Util.Serialize.Mappers.Processing;
      App     : in Application_Access;
      Context : in EL.Contexts.Default.Default_Context_Access;
      Override_Context : in Boolean;
   package Reader_Config is
   end Reader_Config;

   --  Read the application configuration file and configure the application
   procedure Read_Configuration (App     : in out Application'Class;
                                 File    : in String;
                                 Context : in EL.Contexts.Default.Default_Context_Access;
                                 Override_Context : in Boolean);

   --  Get the configuration path for the application name.
   --  The configuration path is search from:
   --  o the current directory,
   --  o the 'config' directory,
   --  o the Dynamo installation directory in share/dynamo
   function Get_Config_Path (Name : in String) return String;

end AWA.Applications.Configs;

Update the Prepare_Config to use the new parser/mapper interface