monadcryptorandom 0.5 → 0.5.1

raw patch · 2 files changed

+260/−98 lines, 2 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Control/Monad/CryptoRandom.hs +259/−97
• monadcryptorandom.cabal +1/−1

@@ -1,38 +1,46 @@ {-# LANGUAGE FlexibleInstances, TypeSynonymInstances, FlexibleContexts-  , GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+  , GeneralizedNewtypeDeriving, MultiParamTypeClasses, UndecidableInstances #-} {-|   Maintainer: Thomas.DuBuisson@gmail.com   Stability: beta-  Portability: portable +  Portability: portable  Much like the "MonadRandom" package ("Control.Monad.Random"), this module provides plumbing for the CryptoRandomGen generators.  -}- + module Control.Monad.CryptoRandom-        ( CRandom(..)-        , CRandomR(..)-        , MonadCRandom(..)-        , MonadCRandomR(..)-        , ContainsGenError(..)-        , CRandT-        , CRand-        , runCRandT-        , evalCRandT-        , runCRand-        , evalCRand-        , newGenCRand-        , module Crypto.Random-        ) where+  ( CRandom(..)+  , CRandomR(..)+  , MonadCRandom(..)+  , MonadCRandomR(..)+  , ContainsGenError(..)+  , CRandT+  , CRand+  , runCRandT+  , evalCRandT+  , runCRand+  , evalCRand+  , newGenCRand+  , module Crypto.Random+  ) where  import Control.Applicative import Control.Arrow (right, left) import Control.Monad (liftM)+import Control.Monad.Cont import Control.Monad.Error import Control.Monad.IO.Class import Control.Monad.Identity-import Control.Monad.State+import Control.Monad.Reader+import Control.Monad.RWS.Lazy as Lazy+import Control.Monad.RWS.Strict as Strict+import Control.Monad.State.Lazy as Lazy+import Control.Monad.State.Strict as Strict+import Control.Monad.Writer.Class+import Control.Monad.Writer.Lazy as Lazy+import Control.Monad.Writer.Strict as Strict import Crypto.Random (CryptoRandomGen(..), GenError(..)) import Data.Bits (xor, setBit, shiftR, shiftL, (.&.)) import Data.Int@@ -45,11 +53,81 @@ -- random values (or fail with a 'GenError').  It is suggested -- you use the 'CRandT' transformer in your monad stack. class (ContainsGenError e, MonadError e m) => MonadCRandom e m where-        getCRandom   :: CRandom a => m a-        getBytes     :: Int -> m B.ByteString-        getBytesWithEntropy :: Int -> B.ByteString -> m B.ByteString-        doReseed :: B.ByteString -> m ()+  getCRandom   :: CRandom a => m a+  getBytes     :: Int -> m B.ByteString+  getBytesWithEntropy :: Int -> B.ByteString -> m B.ByteString+  doReseed :: B.ByteString -> m () +instance MonadCRandom e m => MonadCRandom e (Lazy.StateT s m) where+  getCRandom = lift getCRandom+  {-# INLINE getCRandom #-}+  getBytes = lift . getBytes+  {-# INLINE getBytes #-}+  getBytesWithEntropy i = lift . getBytesWithEntropy i+  {-# INLINE getBytesWithEntropy #-}+  doReseed = lift . doReseed+  {-# INLINE doReseed #-}++instance MonadCRandom e m => MonadCRandom e (Strict.StateT s m) where+  getCRandom = lift getCRandom+  {-# INLINE getCRandom #-}+  getBytes = lift . getBytes+  {-# INLINE getBytes #-}+  getBytesWithEntropy i = lift . getBytesWithEntropy i+  {-# INLINE getBytesWithEntropy #-}+  doReseed = lift . doReseed+  {-# INLINE doReseed #-}++instance (Monoid w, MonadCRandom e m) => MonadCRandom e (Strict.WriterT w m) where+  getCRandom = lift getCRandom+  {-# INLINE getCRandom #-}+  getBytes = lift . getBytes+  {-# INLINE getBytes #-}+  getBytesWithEntropy i = lift . getBytesWithEntropy i+  {-# INLINE getBytesWithEntropy #-}+  doReseed = lift . doReseed+  {-# INLINE doReseed #-}++instance (Monoid w, MonadCRandom e m) => MonadCRandom e (Lazy.WriterT w m) where+  getCRandom = lift getCRandom+  {-# INLINE getCRandom #-}+  getBytes = lift . getBytes+  {-# INLINE getBytes #-}+  getBytesWithEntropy i = lift . getBytesWithEntropy i+  {-# INLINE getBytesWithEntropy #-}+  doReseed = lift . doReseed+  {-# INLINE doReseed #-}++instance MonadCRandom e m => MonadCRandom e (ReaderT r m) where+  getCRandom = lift getCRandom+  {-# INLINE getCRandom #-}+  getBytes = lift . getBytes+  {-# INLINE getBytes #-}+  getBytesWithEntropy i = lift . getBytesWithEntropy i+  {-# INLINE getBytesWithEntropy #-}+  doReseed = lift . doReseed+  {-# INLINE doReseed #-}++instance (Monoid w, MonadCRandom e m) => MonadCRandom e (Strict.RWST r w s m) where+  getCRandom = lift getCRandom+  {-# INLINE getCRandom #-}+  getBytes = lift . getBytes+  {-# INLINE getBytes #-}+  getBytesWithEntropy i = lift . getBytesWithEntropy i+  {-# INLINE getBytesWithEntropy #-}+  doReseed = lift . doReseed+  {-# INLINE doReseed #-}++instance (Monoid w, MonadCRandom e m) => MonadCRandom e (Lazy.RWST r w s m) where+  getCRandom = lift getCRandom+  {-# INLINE getCRandom #-}+  getBytes = lift . getBytes+  {-# INLINE getBytes #-}+  getBytesWithEntropy i = lift . getBytesWithEntropy i+  {-# INLINE getBytesWithEntropy #-}+  doReseed = lift . doReseed+  {-# INLINE doReseed #-}+ newGenCRand :: (CryptoRandomGen g, MonadCRandom GenError m, Functor m) => m g newGenCRand = go 0   where@@ -58,21 +136,21 @@                 getTypedGen :: (Functor m, CryptoRandomGen g, MonadCRandom GenError m)                             => Proxy g -> m (Either GenError g)                 getTypedGen pr = fmap newGen (getBytes $ proxy genSeedLength pr)-            res <- getTypedGen p +            res <- getTypedGen p             case res of                 Left _  -> go (i+1)                 Right g -> return (g `asProxyTypeOf` p)  class (ContainsGenError e, MonadError e m) => MonadCRandomR e m where-        getCRandomR  :: CRandomR a => (a,a) -> m a+  getCRandomR  :: CRandomR a => (a,a) -> m a  class ContainsGenError e where-        toGenError :: e -> Maybe GenError-        fromGenError :: GenError -> e+  toGenError :: e -> Maybe GenError+  fromGenError :: GenError -> e  instance ContainsGenError GenError where-        toGenError = Just-        fromGenError = id+  toGenError = Just+  fromGenError = id  -- |@CRandom a@ is much like the 'Random' class from the "System.Random" module in the "random" package. -- The main difference is CRandom builds on "crypto-api"'s 'CryptoRandomGen', so it allows@@ -83,118 +161,166 @@ -- -- Provided instances for @crandom g@ generates randoms between the bounds and between +/- 2^256 -- for Integer.--- +-- -- The 'crandomR' function has degraded (theoretically unbounded, probabilistically decent) performance -- the closer your range size (high - low) is to 2^n (from the top). class CRandom a where-    crandom   :: (CryptoRandomGen g) => g -> Either GenError (a, g)-    crandoms  :: (CryptoRandomGen g) => g -> [a]-    crandoms g =-        case crandom g of-                Left _       -> []-                Right (a,g') -> a : crandoms g'+  crandom   :: (CryptoRandomGen g) => g -> Either GenError (a, g)+  crandoms  :: (CryptoRandomGen g) => g -> [a]+  crandoms g =+    case crandom g of+      Left _       -> []+      Right (a,g') -> a : crandoms g'  class CRandomR a where-    crandomR  :: (CryptoRandomGen g) => (a, a) -> g -> Either GenError (a, g)-    crandomRs :: (CryptoRandomGen g) => (a, a) -> g -> [a]-    crandomRs r g =-        case crandomR r g of-                Left _       -> []-                Right (a,g') -> a : crandomRs r g'+  crandomR  :: (CryptoRandomGen g) => (a, a) -> g -> Either GenError (a, g)+  crandomRs :: (CryptoRandomGen g) => (a, a) -> g -> [a]+  crandomRs r g =+    case crandomR r g of+      Left _       -> []+      Right (a,g') -> a : crandomRs r g'  instance CRandomR Integer where-   crandomR = crandomR_Num+  crandomR = crandomR_Num+  {-# INLINE crandomR #-}  instance CRandom Int where-    crandom = crandomR (minBound, maxBound)+  crandom = crandomR (minBound, maxBound)+  {-# INLINE crandom #-}  instance CRandomR Int where-    crandomR = crandomR_Num+  crandomR = crandomR_Num+  {-# INLINE crandomR #-}  instance CRandom Word8 where-    crandom = crandomR (minBound, maxBound)+  crandom = crandomR (minBound, maxBound)+  {-# INLINE crandom #-}  instance CRandomR Word8 where-    crandomR = crandomR_Num+  crandomR = crandomR_Num+  {-# INLINE crandomR #-}  instance CRandom Word16 where-    crandom = crandomR (minBound, maxBound)+  crandom = crandomR (minBound, maxBound)+  {-# INLINE crandom #-}  instance CRandomR Word16 where-    crandomR = crandomR_Num+  crandomR = crandomR_Num+  {-# INLINE crandomR #-}  instance CRandom Word32 where-    crandom = crandomR (minBound, maxBound)+  crandom = crandomR (minBound, maxBound)+  {-# INLINE crandom #-}  instance CRandomR Word32 where-    crandomR = crandomR_Num+  crandomR = crandomR_Num+  {-# INLINE crandomR #-}  instance CRandom Word64 where-    crandom = crandomR (minBound, maxBound)+  crandom = crandomR (minBound, maxBound)+  {-# INLINE crandom #-}  instance CRandomR Word64 where-    crandomR = crandomR_Num+  crandomR = crandomR_Num+  {-# INLINE crandomR #-}  instance CRandom Int8 where-    crandom = crandomR (minBound, maxBound)+  crandom = crandomR (minBound, maxBound)+  {-# INLINE crandom #-}  instance CRandomR Int8 where-    crandomR = crandomR_Num+  crandomR = crandomR_Num+  {-# INLINE crandomR #-}  instance CRandom Int16 where-    crandom = crandomR (minBound, maxBound)+  crandom = crandomR (minBound, maxBound)+  {-# INLINE crandom #-}  instance CRandomR Int16 where-    crandomR = crandomR_Num+  crandomR = crandomR_Num+  {-# INLINE crandomR #-}  instance CRandom Int32 where-    crandom = crandomR (minBound, maxBound)+  crandom = crandomR (minBound, maxBound)+  {-# INLINE crandom #-}  instance CRandomR Int32 where-    crandomR = crandomR_Num+  crandomR = crandomR_Num+  {-# INLINE crandomR #-}  instance CRandom Int64 where-    crandom = crandomR (minBound, maxBound)+  crandom = crandomR (minBound, maxBound)+  {-# INLINE crandom #-}+ instance CRandomR Int64 where-    crandomR = crandomR_Num+  crandomR = crandomR_Num+  {-# INLINE crandomR #-}  crandomR_Num :: (Integral a, CryptoRandomGen g) => (a,a) -> g -> Either GenError (a,g) crandomR_Num (low, high) g-      | high < low = crandomR_Num  (high,low) g-      | high == low = Right (high, g)-      | otherwise = go g-      where-      mask    = foldl' setBit 0 [0 .. fromIntegral nrBits - 1]-      nrBits  = base2Log range-      range :: Integer-      range   = (fromIntegral high) - (fromIntegral low) + 1-      nrBytes = (nrBits + 7) `div` 8-      go gen =-        let offset = genBytes (fromIntegral nrBytes) gen-        in case offset of-        Left err -> Left err-        Right (bs, g') ->-                let res = fromIntegral low + (bs2i bs .&. mask)-                in if res > fromIntegral high then go g' else Right (fromIntegral res, g')+  | high < low = crandomR_Num  (high,low) g+  | high == low = Right (high, g)+  | otherwise = go g+  where+  mask    = foldl' setBit 0 [0 .. fromIntegral nrBits - 1]+  nrBits  = base2Log range+  range :: Integer+  range   = (fromIntegral high) - (fromIntegral low) + 1+  nrBytes = (nrBits + 7) `div` 8+  go gen =+    let offset = genBytes (fromIntegral nrBytes) gen+    in case offset of+    Left err -> Left err+    Right (bs, g') ->+      let res = fromIntegral low + (bs2i bs .&. mask)+      in if res > fromIntegral high then go g' else Right (fromIntegral res, g') {-# INLINE crandomR_Num #-}  wrap :: (Monad m, ContainsGenError e, Error e) => (g -> Either GenError (a,g)) -> CRandT g e m a wrap f = CRandT $ do-        g <- get-        case f g of-                Right (a,g') -> put g' >> return a-                Left x -> throwError (fromGenError x)+  g <- get+  case f g of+    Right (a,g') -> put g' >> return a+    Left x -> throwError (fromGenError x)+{-# INLINE wrap #-}  -- |CRandT is the transformer suggested for MonadCRandom.-newtype CRandT g e m a = CRandT { unCRandT :: StateT g (ErrorT e m) a } deriving (MonadError e, Monad, MonadIO, Functor, MonadFix)+newtype CRandT g e m a = CRandT { unCRandT :: Lazy.StateT g (ErrorT e m) a } deriving (MonadError e, Monad, MonadIO, Functor, MonadFix)  instance (Functor m,Monad m,Error e) => Applicative (CRandT g e m) where   pure = return+  {-# INLINE pure #-}   (<*>) = ap+  {-# INLINE (<*>) #-}  instance (Error e) => MonadTrans (CRandT g e) where-        lift = CRandT . lift . lift+  lift = CRandT . lift . lift+  {-# INLINE lift #-} +instance (MonadState s m, Error e) => MonadState s (CRandT g e m) where+  get = lift get+  {-# INLINE get #-}+  put = lift . put+  {-# INLINE put #-}++instance (MonadReader r m, Error e) => MonadReader r (CRandT g e m) where+  ask = lift ask+  {-# INLINE ask #-}+  local f = CRandT . local f . unCRandT+  {-# INLINE local #-}++instance (MonadWriter w m, Error e) => MonadWriter w (CRandT g e m) where+  tell = lift . tell+  {-# INLINE tell #-}+  listen = CRandT . listen . unCRandT+  {-# INLINE listen #-}+  pass = CRandT . pass . unCRandT+  {-# INLINE pass #-}++instance (MonadCont m, Error e) => MonadCont (CRandT g e m) where+  callCC f = CRandT $ callCC $ \amb -> unCRandT $ f (CRandT . amb)+  {-# INLINE callCC #-}+ -- |Simple users of generators can use CRand for -- quick and easy generation of randoms.  See -- below for a simple use of 'newGenIO' (from "crypto-api"),@@ -214,44 +340,80 @@ type CRand g e = CRandT g e Identity  runCRandT :: ContainsGenError e => CRandT g e m a -> g -> m (Either e (a,g))-runCRandT m g = runErrorT . flip runStateT g . unCRandT $ m+runCRandT m g = runErrorT . flip Lazy.runStateT g . unCRandT $ m+{-# INLINE runCRandT #-}  evalCRandT :: (ContainsGenError e, Monad m) => CRandT g e m a -> g -> m (Either e a) evalCRandT m g = liftM (right fst) (runCRandT m g)+{-# INLINE evalCRandT #-}  runCRand :: CRand g GenError a -> g -> Either GenError (a, g) runCRand m = runIdentity . runCRandT m+{-# INLINE runCRand #-}  evalCRand :: CRand g GenError a -> g -> Either GenError a evalCRand m = runIdentity . evalCRandT m+{-# INLINE evalCRand #-}  instance (ContainsGenError e, Error e, Monad m, CryptoRandomGen g) => MonadCRandom e (CRandT g e m) where-        getCRandom  = wrap crandom-        getBytes i = wrap (genBytes i)-        getBytesWithEntropy i e = wrap (genBytesWithEntropy i e)-        doReseed bs = CRandT $ do+  getCRandom  = wrap crandom+  {-# INLINE getCRandom #-}+  getBytes i = wrap (genBytes i)+  {-# INLINE getBytes #-}+  getBytesWithEntropy i e = wrap (genBytesWithEntropy i e)+  {-# INLINE getBytesWithEntropy #-}+  doReseed bs = CRandT $ do                         get >>= \g ->                          case reseed bs g of                             Right g' -> put g'                             Left  x  -> throwError (fromGenError x)+  {-# INLINE doReseed #-}  instance (ContainsGenError e, Error e, Monad m, CryptoRandomGen g) => MonadCRandomR e (CRandT g e m) where-        getCRandomR = wrap . crandomR+  getCRandomR = wrap . crandomR+  {-# INLINE getCRandomR #-} +instance MonadCRandomR e m => MonadCRandomR e (Lazy.StateT s m) where+  getCRandomR = lift . getCRandomR+  {-# INLINE getCRandomR #-}++instance MonadCRandomR e m => MonadCRandomR e (Strict.StateT s m) where+  getCRandomR = lift . getCRandomR+  {-# INLINE getCRandomR #-}++instance (MonadCRandomR e m, Monoid w) => MonadCRandomR e (Lazy.WriterT w m) where+  getCRandomR = lift . getCRandomR+  {-# INLINE getCRandomR #-}++instance (MonadCRandomR e m, Monoid w) => MonadCRandomR e (Strict.WriterT w m) where+  getCRandomR = lift . getCRandomR+  {-# INLINE getCRandomR #-}++instance MonadCRandomR e m => MonadCRandomR e (ReaderT r m) where+  getCRandomR = lift . getCRandomR+  {-# INLINE getCRandomR #-}++instance (MonadCRandomR e m, Monoid w) => MonadCRandomR e (Lazy.RWST r w s m) where+  getCRandomR = lift . getCRandomR+  {-# INLINE getCRandomR #-}++instance (MonadCRandomR e m, Monoid w) => MonadCRandomR e (Strict.RWST r w s m) where+  getCRandomR = lift . getCRandomR+  {-# INLINE getCRandomR #-}+ instance Error GenError where-        noMsg = GenErrorOther "noMsg"-        strMsg = GenErrorOther+  noMsg = GenErrorOther "noMsg"+  strMsg = GenErrorOther  base2Log :: Integer -> Integer base2Log i-        | i >= setBit 0 64 = 64 + base2Log (i `shiftR` 64)-        | i >= setBit 0 32 = 32 + base2Log (i `shiftR` 32)-        | i >= setBit 0 16 = 16 + base2Log (i `shiftR` 16)-        | i >= setBit 0 8  = 8  + base2Log (i `shiftR` 8)-        | i >= setBit 0 0  = 1  + base2Log (i `shiftR` 1)-        | otherwise        = 0+  | i >= setBit 0 64 = 64 + base2Log (i `shiftR` 64)+  | i >= setBit 0 32 = 32 + base2Log (i `shiftR` 32)+  | i >= setBit 0 16 = 16 + base2Log (i `shiftR` 16)+  | i >= setBit 0 8  = 8  + base2Log (i `shiftR` 8)+  | i >= setBit 0 0  = 1  + base2Log (i `shiftR` 1)+  | otherwise        = 0  bs2i :: B.ByteString -> Integer bs2i bs = B.foldl' (\i b -> (i `shiftL` 8) + fromIntegral b) 0 bs {-# INLINE bs2i #-}-

@@ -1,5 +1,5 @@ name:           monadcryptorandom-version:        0.5+version:        0.5.1 license:        BSD3 license-file:   LICENSE copyright:      Thomas DuBuisson <thomas.dubuisson@gmail.com>