1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- |
-- Low level source of random values for seeds. It should work on both
-- unices and windows
module System.Random.MWC.SeedSource (
acquireSeedSystem
, acquireSeedTime
, randomSourceName
) where
import Control.Monad (liftM)
import Data.Word (Word32,Word64)
import Data.Bits (shiftR)
import Data.Ratio ((%), numerator)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Foreign.Storable
import Foreign.Marshal.Alloc (allocaBytes)
import Foreign.Marshal.Array (peekArray)
#if defined(mingw32_HOST_OS)
import Foreign.Ptr
import Foreign.C.Types
#else
import System.IO (IOMode(..), hGetBuf, withBinaryFile)
#endif
import System.CPUTime (cpuTimePrecision, getCPUTime)
-- Acquire seed from current time. This is horrible fallback for
-- Windows system.
acquireSeedTime :: IO [Word32]
acquireSeedTime = do
c <- (numerator . (% cpuTimePrecision)) `liftM` getCPUTime
t <- toRational `liftM` getPOSIXTime
let n = fromIntegral (numerator t) :: Word64
return [fromIntegral c, fromIntegral n, fromIntegral (n `shiftR` 32)]
-- | Acquire seed from the system entropy source. On Unix machines,
-- this will attempt to use @/dev/urandom@. On Windows, it will internally
-- use @RtlGenRandom@.
acquireSeedSystem :: forall a. Storable a => Int -> IO [a]
acquireSeedSystem nElts = do
let eltSize = sizeOf (undefined :: a)
nbytes = nElts * eltSize
#if !defined(mingw32_HOST_OS)
allocaBytes nbytes $ \buf -> do
nread <- withBinaryFile "/dev/urandom" ReadMode $ \h -> hGetBuf h buf nbytes
peekArray (nread `div` eltSize) buf
#else
-- Generate 256 random Word32s from RtlGenRandom
allocaBytes nbytes $ \buf -> do
ok <- c_RtlGenRandom buf (fromIntegral nbytes)
if ok then return () else fail "Couldn't use RtlGenRandom"
peekArray nElts buf
-- Note: on 64-bit Windows, the 'stdcall' calling convention
-- isn't supported, so we use 'ccall' instead.
#if defined(i386_HOST_ARCH)
# define WINDOWS_CCONV stdcall
#elif defined(x86_64_HOST_ARCH)
# define WINDOWS_CCONV ccall
#else
# error Unknown mingw32 architecture!
#endif
-- Note: On Windows, the typical convention would be to use
-- the CryptoGenRandom API in order to generate random data.
-- However, here we use 'SystemFunction036', AKA RtlGenRandom.
--
-- This is a commonly used API for this purpose; one bonus is
-- that it avoids having to bring in the CryptoAPI library,
-- and completely sidesteps the initialization cost of CryptoAPI.
--
-- While this function is technically "subject to change" that is
-- extremely unlikely in practice: rand_s in the Microsoft CRT uses
-- this, and they can't change it easily without also breaking
-- backwards compatibility with e.g. statically linked applications.
--
-- The name 'SystemFunction036' is the actual link-time name; the
-- display name is just for giggles, I guess.
--
-- See also:
-- - http://blogs.msdn.com/b/michael_howard/archive/2005/01/14/353379.aspx
-- - https://bugzilla.mozilla.org/show_bug.cgi?id=504270
--
foreign import WINDOWS_CCONV unsafe "SystemFunction036"
c_RtlGenRandom :: Ptr a -> CULong -> IO Bool
#endif
-- | Name of source of randomness. It should be used in error messages
randomSourceName :: String
#if !defined(mingw32_HOST_OS)
randomSourceName = "/dev/urandom"
#else
randomSourceName = "RtlGenRandom"
#endif
|
