module System.Random.Effect.Raw ( Random
, mkRandom
, mkRandomIO
, mkSecureRandomIO
, forRandEff
, runRandomState
, randomInt
, randomWord
, randomInt64
, randomWord64
) where
import Control.Applicative
import Control.Arrow ( second )
import Data.Bits
import qualified Data.ByteString as B
import Data.Typeable
import Data.Int
import Data.Word
import qualified Crypto.Random as CR
import qualified System.Random.Mersenne.Pure64 as SR
import Control.Eff
import Control.Eff.Lift
import Control.Eff.State.Strict
data Random = FastRandom !SR.PureMT
| SecureRandom !CR.SystemRandom
deriving Typeable
randomInt :: Member (State Random) r
=> Eff r Int
randomInt = randomF SR.randomInt srandomBits
randomWord :: Member (State Random) r
=> Eff r Word
randomWord = randomF SR.randomWord srandomBits
randomInt64 :: Member (State Random) r
=> Eff r Int64
randomInt64 = randomF SR.randomInt64 srandomBits
randomWord64 :: Member (State Random) r
=> Eff r Word64
randomWord64 = randomF SR.randomWord64 srandomBits
mkRandom :: Word64 -> Random
mkRandom = FastRandom . SR.pureMT
mkRandomIO :: SetMember Lift (Lift IO) r
=> Eff r Random
mkRandomIO =
FastRandom <$> lift SR.newPureMT
mkSecureRandomIO :: SetMember Lift (Lift IO) r
=> Eff r Random
mkSecureRandomIO = do
SecureRandom <$> lift CR.newGenIO
forRandEff :: Eff r Random -> Eff (State Random :> r) w -> Eff r w
forRandEff rndgen e = rndgen >>= (`runRandomState` e)
runRandomState :: Random
-> Eff (State Random :> r) w
-> Eff r w
runRandomState seed computation =
snd <$> runState seed computation
foldBits :: (Bits a, Num a)
=> B.ByteString
-> a
foldBits bs =
let addByte byte bits =
(bits `unsafeShiftL` 8) .|. fromIntegral byte
in B.foldr' addByte 0 bs
srandomBits :: ( Bits a
, Num a )
=> CR.SystemRandom
-> (a, CR.SystemRandom)
srandomBits sr =
let z = clearBit (bit 0) 0
nBytes = bitSize z `div` 8
in case CR.genBytes nBytes sr of
Left err -> error $ "system-random-effect: System.Random.Effect.Secure: genBytes: " ++ show err
Right (bs, sr') -> (z .|. foldBits bs, sr')
randomF :: Member (State Random) r
=> (SR.PureMT -> (a, SR.PureMT))
-> (CR.SystemRandom -> (a, CR.SystemRandom))
-> Eff r a
randomF f s = do
old <- get
let (val, new) = case old of
(FastRandom r) -> second FastRandom (f r)
(SecureRandom r) -> second SecureRandom (s r)
put new
return val