From e3823795b1c4f31f9cd204008b75023465793b67 Mon Sep 17 00:00:00 2001 From: Nicolas Roche Date: Thu, 11 Jul 2024 22:21:52 +0200 Subject: [PATCH] Add OS-provided random source Add GNATCOLL.OS.Random that provides an Ada stream interface to read random data from. The interface is implemented using the OS provided CSPRNG. ref eng/toolchain/gnatcoll-core#63 --- core/gnatcoll_core.gpr | 4 + core/src/gnatcoll-random.adb | 270 ++++++++++++++++++++++ core/src/gnatcoll-random.ads | 70 ++++++ core/src/os/gnatcoll-os-fs.adb | 13 +- core/src/os/gnatcoll-os-fs.ads | 11 + core/src/os/gnatcoll-os-random.ads | 21 ++ core/src/os/gnatcoll-os-random__unix.adb | 47 ++++ core/src/os/gnatcoll-os-random__win32.adb | 127 ++++++++++ testsuite/tests/os/random/test.adb | 246 ++++++++++++++++++++ testsuite/tests/os/random/test.yaml | 5 + 10 files changed, 804 insertions(+), 10 deletions(-) create mode 100644 core/src/gnatcoll-random.adb create mode 100644 core/src/gnatcoll-random.ads create mode 100644 core/src/os/gnatcoll-os-random.ads create mode 100644 core/src/os/gnatcoll-os-random__unix.adb create mode 100644 core/src/os/gnatcoll-os-random__win32.adb create mode 100644 testsuite/tests/os/random/test.adb create mode 100644 testsuite/tests/os/random/test.yaml diff --git a/core/gnatcoll_core.gpr b/core/gnatcoll_core.gpr index 4892175d..f7e3d718 100644 --- a/core/gnatcoll_core.gpr +++ b/core/gnatcoll_core.gpr @@ -302,6 +302,8 @@ library project GNATCOLL_Core is use "gnatcoll-os-fsutil-create_symbolic_link__unix.adb"; for Implementation ("GNATCOLL.OS.FSUtil.Read_Symbolic_Link") use "gnatcoll-os-fsutil-read_symbolic_link__unix.adb"; + for Implementation ("GNATCOLL.OS.Random") + use "gnatcoll-os-random__unix.adb"; when "windows" => for Specification ("GNATCOLL.Mmap.System") use "gnatcoll-mmap-system__win32.ads"; @@ -361,6 +363,8 @@ library project GNATCOLL_Core is use "gnatcoll-os-fsutil-create_symbolic_link__win32.adb"; for Implementation ("GNATCOLL.OS.FSUtil.Read_Symbolic_Link") use "gnatcoll-os-fsutil-read_symbolic_link__win32.adb"; + for Implementation ("GNATCOLL.OS.Random") + use "gnatcoll-os-random__win32.adb"; end case; case OS is diff --git a/core/src/gnatcoll-random.adb b/core/src/gnatcoll-random.adb new file mode 100644 index 00000000..0498d6b7 --- /dev/null +++ b/core/src/gnatcoll-random.adb @@ -0,0 +1,270 @@ +with GNATCOLL.OS.Random; +with Interfaces.C; +with Ada.Unchecked_Conversion; + +package body GNATCOLL.Random is + + use type Interfaces.C.size_t; + + Alphanumerical_Mapping : constant array (1 .. 62) of Character := + ('0', '1', '2', '3', '4', '5', '6', '7', '8', '9', + 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', + 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', + 'u', 'v', 'w', 'x', 'y', 'z', + 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', + 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', + 'U', 'V', 'W', 'X', 'Y', 'Z'); + + --------------------------- + -- Random_Alphanumerical -- + --------------------------- + + function Random_Alphanumerical + (Case_Sensitive : Boolean := True) return Character + is + begin + if Case_Sensitive then + return Alphanumerical_Mapping + (Random_Integer_Range (First => 1, Last => 62)); + else + return Alphanumerical_Mapping + (Random_Integer_Range (First => 1, Last => 36)); + end if; + end Random_Alphanumerical; + + ---------------------------------- + -- Random_Alphanumerical_String -- + ---------------------------------- + + procedure Random_Alphanumerical_String + (Buffer : out String; Case_Sensitive : Boolean := True) + is + begin + for Idx in Buffer'Range loop + Buffer (Idx) := + Random_Alphanumerical (Case_Sensitive => Case_Sensitive); + end loop; + end Random_Alphanumerical_String; + + ------------------ + -- Random_Array -- + ------------------ + + procedure Random_Array (Buffer : out Data_Array) is + begin + if Buffer'Length = 0 then + return; + end if; + + GNATCOLL.OS.Random.Random_Bytes + (Buffer (Buffer'First)'Address, Buffer'Size / 8); + end Random_Array; + + -------------------- + -- Random_Integer -- + -------------------- + + function Random_Integer return Integer is + function Internal is new Random_Value (Integer); + begin + return Internal; + end Random_Integer; + + -------------------------- + -- Random_Integer_Range -- + -------------------------- + + function Random_Integer_Range + (First : Integer; Last : Integer) return Integer + is + function Internal is new Random_Range (Integer); + begin + return Internal (First => First, Last => Last); + end Random_Integer_Range; + + ------------------ + -- Random_Range -- + ------------------ + + function Random_Range + (First : Data := Data'First; Last : Data := Data'Last) return Data + is + use Interfaces; + begin + if Last = First then + -- No need for randomness + return Last; + + elsif Last < First then + -- Invalid range + raise Constraint_Error; + + -- For a valid range the following approch is taken: + -- 1- Find an unsigned integer type that matches the size of Data'Base + -- (as only the right branch is taken during execution the warning + -- that may occurs regarding unequal size for Unchecked_Conversion + -- declarations can be ignored -- pragma Warnings Z and z calls). + -- 2- Generate a random number for that unsigned type and map it to a + -- given number in the range. Note that in order to avoid having a + -- bias in the generator, all values in the range are mapped to the + -- exact same number of values in the unsigned type range. This means + -- that, depending on the chosen range, some random unsigned values + -- might be discarded. In theory this might introduce an infinite + -- loop (in the worst case almost 50% of the values might be + -- discarded). + + elsif Data'Base'Size > 64 then + declare + pragma Warnings ("Z"); + function To_U128 is new Ada.Unchecked_Conversion + (Data'Base, Unsigned_128); + function To_Data is new Ada.Unchecked_Conversion + (Unsigned_128, Data'Base); + pragma Warnings ("z"); + + N : constant Unsigned_128 := To_U128 (Last) - To_U128 (First) + 1; + -- The length of the requested interval. Since we are working + -- with unsigned type, and since Last < First, N = 0 can only + -- occurs if the full 128 bits range is covered. + + begin + if N = 0 then + -- Full 128bits range is covered so just returned a converted + -- random 128bits unsigned. + return To_Data (To_U128 (First) + Random_Unsigned_128); + + else + declare + X : Unsigned_128 := Random_Unsigned_128; + -- Hold generated random 128 bits unsigned integers until + -- we find one that maps into the desired range. + + Last_Valid : constant Unsigned_128 := + Unsigned_128'Last - (Unsigned_128'Last rem N + 1); + -- Last valid value for X. if X > Last_Value we discard the + -- value in order to not introduce bias. + + begin + -- Though potentially there is here a potential infinite + -- loop, in practice this does not occur. + while X > Last_Valid loop + X := Random_Unsigned_128; + end loop; + + return To_Data (To_U128 (First) + X rem N); + end; + end if; + end; + + elsif Data'Base'Size > 32 then + declare + pragma Warnings ("Z"); + function To_U64 is + new Ada.Unchecked_Conversion (Data'Base, Unsigned_64); + function To_Data is + new Ada.Unchecked_Conversion (Unsigned_64, Data'Base); + pragma Warnings ("z"); + + N : constant Unsigned_64 := To_U64 (Last) - To_U64 (First) + 1; + -- The length of the requested interval. Since we are working + -- with unsigned type, and since Last < First, N = 0 can only + -- occurs if the full 64 bits range is covered. + + begin + if N = 0 then + -- Full 64 bits range is covered so just returned a converted + -- random 64 bits unsigned. + return To_Data (To_U64 (First) + Random_Unsigned_64); + + else + declare + X : Unsigned_64 := Random_Unsigned_64; + -- Hold generated random 64 bits unsigned intergers + + Last_Valid : constant Unsigned_64 := + Unsigned_64'Last - (Unsigned_64'Last rem N + 1); + -- Last valid value for X. if X > Last_Value we discard the + -- value in order to not introduce bias. + + begin + -- Though potentially there is here a potential infinite + -- loop, in practice this does not occur. + while X > Last_Valid loop + X := Random_Unsigned_64; + end loop; + + return To_Data (To_U64 (First) + X rem N); + end; + end if; + end; + + -- In the 32-bit case, we need to handle both integer and enumeration + -- types and, therefore, rely on 'Pos and 'Val in the computation. + -- In the 32-bit case we can use the Universal Integer type rather + -- than an intermediate unsigned integer. + + elsif Data'Pos (Last) - Data'Pos (First) = 2 ** 32 - 1 then + return Data'Val (Data'Pos (First) + + Unsigned_32'Pos (Random_Unsigned_32)); + else + declare + N : constant Unsigned_32 := + Unsigned_32 (Data'Pos (Last) - Data'Pos (First) + 1); + Last_Valid : constant Unsigned_32 := + Unsigned_32'Last - (Unsigned_32'Last rem N + 1); + X : Unsigned_32 := Random_Unsigned_32; + + begin + -- Though potentially there is here a potential infinite + -- loop, in practice this does not occur. + while X > Last_Valid loop + X := Random_Unsigned_32; + end loop; + + return Data'Val (Data'Pos (First) + Unsigned_32'Pos (X rem N)); + end; + end if; + end Random_Range; + + ------------------------ + -- Random_Unsigned_32 -- + ------------------------ + + function Random_Unsigned_32 return Interfaces.Unsigned_32 is + function Internal is new Random_Value (Interfaces.Unsigned_32); + begin + return Internal; + end Random_Unsigned_32; + + ------------------------ + -- Random_Unsigned_64 -- + ------------------------ + + function Random_Unsigned_64 return Interfaces.Unsigned_64 is + function Internal is new Random_Value (Interfaces.Unsigned_64); + begin + return Internal; + end Random_Unsigned_64; + + ------------------------- + -- Random_Unsigned_128 -- + ------------------------- + + function Random_Unsigned_128 return Interfaces.Unsigned_128 is + function Internal is new Random_Value (Interfaces.Unsigned_128); + begin + return Internal; + end Random_Unsigned_128; + + ------------------ + -- Random_Value -- + ------------------ + + function Random_Value return Data is + begin + return Result : Data do + GNATCOLL.OS.Random.Random_Bytes (Result'Address, Result'Size / 8); + end return; + end Random_Value; + +end GNATCOLL.Random; diff --git a/core/src/gnatcoll-random.ads b/core/src/gnatcoll-random.ads new file mode 100644 index 00000000..f1b63c45 --- /dev/null +++ b/core/src/gnatcoll-random.ads @@ -0,0 +1,70 @@ +-- +-- Copyright (C) 2024, AdaCore +-- +-- SPDX-License-Identifier: GPL-3.0-or-later WITH GCC-exception-3.1 +-- +-- The unit provides functions to generate random data using the OS CSPRNG +-- This means that this functions are suitable for cryptographic contexts +-- The downside is that that they around one order of magnitud slower than +-- implementation provided in the default Ada runtime. +with Interfaces; + +package GNATCOLL.Random is + + generic + type Data is private; + function Random_Value return Data; + -- Fill a value of type Data with random data + -- + -- Note that memory associated with the result will be filled with random + -- data. As a consequence the generated value might not be valid if there + -- are any constraints on the data layout. + + generic + type Data is (<>); + type Data_Array is array (Positive range <>) of Data; + procedure Random_Array (Buffer : out Data_Array); + -- Fill an array of Data with random Data + -- + -- Note that memory associated with the result will be filled with random + -- data. As a consequence the generated value might not be valid if there + -- are any constraints on the data layout. + + generic + type Data is (<>); + function Random_Range + (First : Data := Data'First; Last : Data := Data'Last) + return Data; + -- Generic function for discrete type that return a value in a subrange + + -- Declaration of functions for commonly used types + + function Random_Unsigned_32 return Interfaces.Unsigned_32 + with Inline => True; + -- Return a random unsigned 32bits integer + + function Random_Unsigned_64 return Interfaces.Unsigned_64 + with Inline => True; + -- Return a random unsigned 64bits integer + + function Random_Unsigned_128 return Interfaces.Unsigned_128 + with Inline => True; + -- Return a random unsigned 128bits integer + + function Random_Integer return Integer + with Inline => True; + -- Return a random integer + + function Random_Integer_Range + (First : Integer; Last : Integer) return Integer + with Inline => True; + + function Random_Alphanumerical (Case_Sensitive : Boolean := True) + return Character + with Inline => True; + + procedure Random_Alphanumerical_String + (Buffer : out String; Case_Sensitive : Boolean := True); + -- Return a random alpha-numerical string + +end GNATCOLL.Random; diff --git a/core/src/os/gnatcoll-os-fs.adb b/core/src/os/gnatcoll-os-fs.adb index 51ba639c..3ac7c6eb 100644 --- a/core/src/os/gnatcoll-os-fs.adb +++ b/core/src/os/gnatcoll-os-fs.adb @@ -77,21 +77,14 @@ package body GNATCOLL.OS.FS is function Read (FD : File_Descriptor; Buffer : in out String) return Integer is - function C_Read - (Fd : File_Descriptor; - Buffer : System.Address; - Size : size_t) - return int; - pragma Import (C, C_Read, "read"); - - Result : int; + Result : Integer; begin - Result := C_Read (FD, Buffer (Buffer'First)'Address, Buffer'Length); + Result := Unsafe_Read (FD, Buffer (Buffer'First)'Address, Buffer'Length); if Result < 0 then raise OS_Error with "read error"; end if; - return Integer (Result); + return Result; end Read; function Read diff --git a/core/src/os/gnatcoll-os-fs.ads b/core/src/os/gnatcoll-os-fs.ads index 87db32ff..8ad8f0b3 100644 --- a/core/src/os/gnatcoll-os-fs.ads +++ b/core/src/os/gnatcoll-os-fs.ads @@ -25,6 +25,7 @@ with Ada.Strings.UTF_Encoding; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +with Interfaces.C; package GNATCOLL.OS.FS is @@ -132,6 +133,16 @@ package GNATCOLL.OS.FS is -- Write Buffer content to FD. OS_Error is raised if write fails or is not -- complete. + function Unsafe_Read + (FD : File_Descriptor; + Buffer : System.Address; + Size : Interfaces.C.size_t) + return Integer; + pragma Import (C, Unsafe_Read, "read"); + -- Read data from FD and put it in Buffer. The call is blocking and + -- end-of-file is reached when Unsafe_Read returns 0, otherwise the + -- returned value is the number of bytes read. + generic type T is private; procedure Write_Bytes diff --git a/core/src/os/gnatcoll-os-random.ads b/core/src/os/gnatcoll-os-random.ads new file mode 100644 index 00000000..b2861099 --- /dev/null +++ b/core/src/os/gnatcoll-os-random.ads @@ -0,0 +1,21 @@ +-- +-- Copyright (C) 2024, AdaCore +-- +-- SPDX-License-Identifier: GPL-3.0-or-later WITH GCC-exception-3.1 +-- +-- The unit provices a low-level but portable access to an OS +-- Cryptographically-Secure Pseudo-Random Number Generator (CSPRNG) +-- +-- Note that for the general case, it's preferable to use GNATCOLL.Random +-- which provides higher level interface and rely on that unit +with Interfaces.C; + +package GNATCOLL.OS.Random is + + procedure Random_Bytes + (Buffer : System.Address; + Size : Interfaces.C.size_t); + -- Low level interface to the CSPRNG that fill a buffer of size Size with + -- random data. + +end GNATCOLL.OS.Random; diff --git a/core/src/os/gnatcoll-os-random__unix.adb b/core/src/os/gnatcoll-os-random__unix.adb new file mode 100644 index 00000000..f654a30e --- /dev/null +++ b/core/src/os/gnatcoll-os-random__unix.adb @@ -0,0 +1,47 @@ +-- +-- Copyright (C) 2024, AdaCore +-- +-- SPDX-License-Identifier: GPL-3.0-or-later WITH GCC-exception-3.1 +-- +with GNATCOLL.OS.FS; +with GNAT.Task_Lock; + +package body GNATCOLL.OS.Random is + + package FS renames GNATCOLL.OS.FS; + + use type FS.File_Descriptor; + use type Interfaces.C.size_t; + + Urandom_FD : FS.File_Descriptor := FS.Invalid_FD; + -- A file descriptor on "/dev/urandom". The file descriptor is shared by + -- all Ada tasks. + + ------------------ + -- Random_Bytes -- + ------------------ + + procedure Random_Bytes + (Buffer : System.Address; + Size : Interfaces.C.size_t) + is + Read_Bytes : Integer; + begin + -- Safely open one non-inherited handle to /dev/urandom. + if Urandom_FD = FS.Invalid_FD then + GNAT.Task_Lock.Lock; + if Urandom_FD = FS.Invalid_FD then + -- FS.Open does not raise exception in case of error so no need + -- to catch exceptions and call unlock. + Urandom_FD := FS.Open ("/dev/urandom"); + end if; + GNAT.Task_Lock.Unlock; + end if; + + Read_Bytes := FS.Unsafe_Read (Urandom_FD, Buffer, Size); + if Read_Bytes /= Integer (Size) then + raise OS_Error with "error while reading data from /dev/urandom"; + end if; + end Random_Bytes; + +end GNATCOLL.OS.Random; diff --git a/core/src/os/gnatcoll-os-random__win32.adb b/core/src/os/gnatcoll-os-random__win32.adb new file mode 100644 index 00000000..d383f1de --- /dev/null +++ b/core/src/os/gnatcoll-os-random__win32.adb @@ -0,0 +1,127 @@ +-- +-- Copyright (C) 2024, AdaCore +-- +-- SPDX-License-Identifier: GPL-3.0-or-later WITH GCC-exception-3.1 +-- +with GNATCOLL.OS.Win32; +with GNATCOLL.Plugins; +with GNAT.Task_Lock; + +package body GNATCOLL.OS.Random is + + package DLL renames GNATCOLL.Plugins; + + use type System.Address; + use type DLL.Plugin; + + BCryptPrimitives_Path : constant String := + "\bcryptprimitives.dll"; + -- Name of the system library containing the ProcessPrng symbols. + -- We prepend Windows SystemRoot to that value to ensure that the system + -- version of that DLL is always picked. + + BCryptPrimitives : DLL.Plugin := DLL.No_Plugin; + -- DLL handler that contains the ProcessPrng function + + ProcessPrng : System.Address := System.Null_Address; + -- Address of the ProcessPrng function + + ------------------ + -- Random_Bytes -- + ------------------ + + procedure Random_Bytes + (Buffer : System.Address; + Size : Interfaces.C.size_t) + is + begin + -- If ProcessPrng address is not set it means that bcryptprimitives.dll + -- should be loaded. Lock all tasks to ensure that only one perform the + -- load. Once loaded, other tasks can safely reuse the address. + if ProcessPrng = System.Null_Address then + GNAT.Task_Lock.Lock; + if ProcessPrng = System.Null_Address then + + declare + DLL_Path : String (1 .. 261); + -- The new max path is 32K on windows but using the former + -- is enough in that context. + DLL_Last : Integer; + + function GetSystemDirectoryA + (Buffer : System.Address; Size : Integer) return Integer + with Import => True, + Convention => Stdcall, + External_Name => "GetSystemDirectoryA"; + begin + -- Find the location of the Windows system directory. When + -- GNATCOLL.Plugins is updated to use Unicode APIs update + -- this call to use the Unicode version. + DLL_Last := GetSystemDirectoryA + (DLL_Path (1)'Address, DLL_Path'Length); + if DLL_Last = 0 or else DLL_Last > DLL_Path'Length then + GNAT.Task_Lock.Unlock; + raise OS_Error with + "cannot initialize PRNG (cannot find system dir)"; + end if; + + -- Check bounds + if DLL_Last + BCryptPrimitives_Path'Length > DLL_Path'Length + then + GNAT.Task_Lock.Unlock; + raise OS_Error with + "cannot initialize PRNG (system dir too long)"; + end if; + + DLL_Path + (DLL_Last + 1 .. DLL_Last + BCryptPrimitives_Path'Length) := + BCryptPrimitives_Path; + DLL_Last := DLL_Last + BCryptPrimitives_Path'Length; + + -- Try to load the DLL + BCryptPrimitives := DLL.Load (DLL_Path (1 .. DLL_Last)); + + if BCryptPrimitives = DLL.No_Plugin then + GNAT.Task_Lock.Unlock; + raise OS_Error with + "cannot initialize PRNG (cannot load " & + DLL_Path (1 .. DLL_Last) & ": " & + DLL.Last_Error_Message & ")"; + end if; + + -- Finally found ProcessPrng function + ProcessPrng := GNATCOLL.Plugins.Routine_Address + (BCryptPrimitives, "ProcessPrng"); + if ProcessPrng = System.Null_Address then + GNAT.Task_Lock.Unlock; + raise OS_Error with + "cannot initialize PRNG (cannot load ProcessPrng " & + "function: " & + DLL.Last_Error_Message & ")"; + end if; + end; + end if; + GNAT.Task_Lock.Unlock; + end if; + + -- Call ProcessPrng. Note that this the recommended call to do by + -- various implementations such as Rust rand, BoringSSL, ... + declare + Status : GNATCOLL.OS.Win32.BOOL; + pragma Unreferenced (Status); + -- No need to check Status as it is always True as stated by + -- Microsoft doc. + + function Internal + (Buffer : System.Address; + Size : Interfaces.C.size_t) + return GNATCOLL.OS.Win32.BOOL + with Import => True, + Convention => Stdcall, + Address => ProcessPrng; + begin + Status := Internal (Buffer => Buffer, Size => Size); + end; + end Random_Bytes; + +end GNATCOLL.OS.Random; diff --git a/testsuite/tests/os/random/test.adb b/testsuite/tests/os/random/test.adb new file mode 100644 index 00000000..a08fa6f2 --- /dev/null +++ b/testsuite/tests/os/random/test.adb @@ -0,0 +1,246 @@ +with GNATCOLL.Random; +with GNAT.IO; +with Test_Assert; +with Ada.Calendar; use Ada.Calendar; +with Ada.Containers.Ordered_Sets; +with Interfaces; + +function Test return Integer +is + package IO renames GNAT.IO; + package Rand renames GNATCOLL.Random; + package A renames Test_Assert; + Start_Time, End_Time : Time; + + package Int_Sets is new Ada.Containers.Ordered_Sets (Integer); + +begin + IO.Put_Line ("Test random integer generation"); + declare + RI : Integer; + begin + Start_Time := Clock; + for J in 1 .. 1_000_000 loop + RI := Rand.Random_Integer; + end loop; + End_Time := Clock; + IO.Put_Line ("Random integer sample:" & RI'Img); + IO.Put ("Time to generate 1_000_000 integers:"); + IO.Put_Line (Duration'Image (End_Time - Start_Time)); + end; + + IO.Put_Line ("Test random integer range generation"); + declare + RI : Integer; + Frequence : array (1 .. 62) of Integer := (others => 0); + Error : Long_Float; + begin + Start_Time := Clock; + for J in 1 .. 6_200_000 loop + RI := Rand.Random_Integer_Range (First => 1, Last => 62); + Frequence (RI) := Frequence (RI) + 1; + end loop; + End_Time := Clock; + IO.Put_Line ("Random integer sample:" & RI'Img); + IO.Put ("Time to generate 6_200_000 integers in range 1 .. 62:"); + IO.Put_Line (Duration'Image (End_Time - Start_Time)); + + -- Ideally each number should appears 100_000 times. This is not a real + -- test for the RNG quality. Rather a sanity check that there is no + -- obvious bias introduced by a mistake on the algorithm used on top of + -- the CSRNG. + for Idx in Frequence'Range loop + Error := Long_Float (Frequence (Idx) - 100_000) / 100_000.0; + A.Assert + (Error < 0.01, + Idx'Img & " appears " & Frequence (Idx)'Img & + " (error:" & Long_Float'Image (Error * 100.0) & "%)"); + end loop; + end; + + IO.Put_Line ("Test bad range exception"); + declare + I : Integer; + begin + I := Rand.Random_Integer_Range (First => 43, Last => 42); + A.Assert (False, "exception not raised. got integer" & I'Img); + exception + when Constraint_Error => + A.Assert (True, "right exception raised on bad range"); + when others => + A.Assert (False, "wrong exception raised on bad range"); + end; + + IO.Put_Line ("Test random random alphanumerical"); + declare + S1 : String (1 .. 100_000); + begin + Rand.Random_Alphanumerical_String (S1); + for Idx in S1'Range loop + if S1 (Idx) not in '0' .. '9' and then + S1 (Idx) not in 'a' .. 'z' and then + S1 (Idx) not in 'A' .. 'Z' + then + A.Assert + (False, + "invalid character returned by " & + "Random_Alphanumerical_String"); + end if; + end loop; + + Rand.Random_Alphanumerical_String (S1, Case_Sensitive => False); + for Idx in S1'Range loop + if S1 (Idx) not in '0' .. '9' and then + S1 (Idx) not in 'a' .. 'z' + then + A.Assert + (False, + "invalid character returned by " & + "Random_Alphanumerical_String"); + end if; + end loop; + + end; + + IO.Put_Line ("Unsigned generation"); + declare + use Interfaces; + use Rand; + U32 : constant Unsigned_32 := Random_Unsigned_32; + U64 : constant Unsigned_64 := Random_Unsigned_64; + U128 : constant Unsigned_128 := Random_Unsigned_128; + begin + A.Assert (U32 /= Random_Unsigned_32); + A.Assert (U64 /= Random_Unsigned_64); + A.Assert (U128 /= Random_Unsigned_128); + end; + + IO.Put_Line ("128 bits ranges"); + declare + use Interfaces; + use Rand; + function U128_Range is new Random_Range (Unsigned_128); + Result : Unsigned_128; + begin + Result := U128_Range; + Result := U128_Range (First => 42, Last => 42); + A.Assert (Result = 42); + for Idx in 1 .. 100_000 loop + Result := U128_Range (First => 0, Last => 10); + if Result > 10 then + A.Assert + (False, "128 bits number in the wrong range" & Result'Img); + end if; + end loop; + + -- Test that that tries to check the case in which some random values + -- are discarded (see implementation of Random_Range) + for Idx in 1 .. 100_000 loop + Result := U128_Range + (First => Unsigned_128'First, Last => Unsigned_128'Last / 2 + 1); + end loop; + A.Assert (Result <= Unsigned_128'Last / 2 + 1); + + end; + + IO.Put_Line ("64 bits ranges"); + declare + use Interfaces; + use Rand; + function U64_Range is new Random_Range (Unsigned_64); + Result : Unsigned_64; + begin + Result := U64_Range; + Result := U64_Range (First => 42, Last => 42); + A.Assert (Result = 42); + for Idx in 1 .. 100_000 loop + Result := U64_Range (First => 0, Last => 10); + if Result > 10 then + A.Assert + (False, "64 bits number in the wrong range" & Result'Img); + end if; + end loop; + + -- Test that that tries to check the case in which some random values + -- are discarded (see implementation of Random_Range) + for Idx in 1 .. 100_000 loop + Result := U64_Range + (First => Unsigned_64'First, Last => Unsigned_64'Last / 2 + 1); + end loop; + A.Assert (Result <= Unsigned_64'Last / 2 + 1); + end; + + IO.Put_Line ("32 bits ranges"); + declare + use Interfaces; + use Rand; + function U32_Range is new Random_Range (Unsigned_32); + Result : Unsigned_32; + begin + Result := U32_Range; + Result := U32_Range (First => 42, Last => 42); + A.Assert (Result = 42); + for Idx in 1 .. 100_000 loop + Result := U32_Range (First => 0, Last => 10); + if Result > 10 then + A.Assert + (False, "64 bits number in the wrong range" & Result'Img); + end if; + end loop; + + -- Test that that tries to check the case in which some random values + -- are discarded (see implementation of Random_Range) + for Idx in 1 .. 100_000 loop + Result := U32_Range + (First => Unsigned_32'First, Last => Unsigned_32'Last / 2 + 1); + end loop; + A.Assert (Result <= Unsigned_32'Last / 2 + 1); + end; + + IO.Put_Line ("We should not get duplicates on short set of integers"); + -- The test is just to check obvious errors in the RNG + declare + Result : Integer; + Counts : Int_Sets.Set; + begin + for Idx in 1 .. 1_000 loop + Result := Rand.Random_Integer_Range + (First => Integer'First, Last => Integer'Last / 2 + 1); + if Counts.Contains (Result) then + A.Assert (False, "repeating value not expected: " & Result'Img); + else + Counts.Insert (Result); + end if; + end loop; + A.Assert (Result <= Integer'Last / 2 + 1); + end; + + declare + Result : Integer; + Counts : Int_Sets.Set; + begin + for Idx in 1 .. 1_000 loop + Result := Rand.Random_Integer; + if Counts.Contains (Result) then + A.Assert + (False, "repeating integer value not expected: " & Result'Img); + else + Counts.Insert (Result); + end if; + end loop; + end; + + IO.Put_Line ("Test for random_array"); + declare + type Integer_Array is array (Positive range <>) of Integer; + procedure RA is new Rand.Random_Array (Integer, Integer_Array); + + A : Integer_Array (1 .. 128); + B : Integer_Array (1 .. 0); + begin + RA (A); + RA (B); + end; + + return A.Report; +end Test; diff --git a/testsuite/tests/os/random/test.yaml b/testsuite/tests/os/random/test.yaml new file mode 100644 index 00000000..09f1db5f --- /dev/null +++ b/testsuite/tests/os/random/test.yaml @@ -0,0 +1,5 @@ +title: GNATCOLL.Random tests +control: + - [SKIP, + "env.target.os.name == 'windows' and env.target.machine == 'wine'", + "Wine does not provides all the Windows cryptographic primitives"]