{-# 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
#endif
import System.CPUTime   (cpuTimePrecision, getCPUTime)
import System.IO        (IOMode(..), hGetBuf, withBinaryFile)

-- Acquire seed from current time. This is horrible fallback for
-- Windows system.
acquireSeedTime :: IO [Word32]
acquireSeedTime :: IO [Word32]
acquireSeedTime = do
  Integer
c <- (Ratio Integer -> Integer
forall a. Ratio a -> a
numerator (Ratio Integer -> Integer)
-> (Integer -> Ratio Integer) -> Integer -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Integer -> Ratio Integer
forall a. Integral a => a -> a -> Ratio a
%Integer
cpuTimePrecision)) (Integer -> Integer) -> IO Integer -> IO Integer
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` IO Integer
getCPUTime
  Ratio Integer
t <- POSIXTime -> Ratio Integer
forall a. Real a => a -> Ratio Integer
toRational (POSIXTime -> Ratio Integer) -> IO POSIXTime -> IO (Ratio Integer)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` IO POSIXTime
getPOSIXTime
  let n :: Word64
n    = Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ratio Integer -> Integer
forall a. Ratio a -> a
numerator Ratio Integer
t) :: Word64
  [Word32] -> IO [Word32]
forall (m :: * -> *) a. Monad m => a -> m a
return [Integer -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
c, Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n, Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
n Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
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 :: Int -> IO [a]
acquireSeedSystem Int
nElts = do
  let eltSize :: Int
eltSize = a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined :: a)
      nbytes :: Int
nbytes  = Int
nElts Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
eltSize
#if !defined(mingw32_HOST_OS)
  Int -> (Ptr a -> IO [a]) -> IO [a]
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
nbytes ((Ptr a -> IO [a]) -> IO [a]) -> (Ptr a -> IO [a]) -> IO [a]
forall a b. (a -> b) -> a -> b
$ \Ptr a
buf -> do
    Int
nread <- FilePath -> IOMode -> (Handle -> IO Int) -> IO Int
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
"/dev/urandom" IOMode
ReadMode ((Handle -> IO Int) -> IO Int) -> (Handle -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Handle
h -> Handle -> Ptr a -> Int -> IO Int
forall a. Handle -> Ptr a -> Int -> IO Int
hGetBuf Handle
h Ptr a
buf Int
nbytes
    Int -> Ptr a -> IO [a]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray (Int
nread Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
eltSize) Ptr a
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 :: FilePath
randomSourceName = FilePath
"/dev/urandom"
#else
randomSourceName = "RtlGenRandom"
#endif