{-# LANGUAGE CPP #-}
module Snap.Snaplet.Session.Common
( RNG
, mkRNG
, withRNG
, randomToken
, mkCSRFToken
) where
import Control.Concurrent
import Control.Monad
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.Text.Encoding as T
import Data.Text (Text)
import Numeric
import System.Random.MWC
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
newtype RNG = RNG (MVar GenIO)
withRNG :: RNG
-> (GenIO -> IO a)
-> IO a
withRNG :: RNG -> (GenIO -> IO a) -> IO a
withRNG (RNG rng :: MVar GenIO
rng) m :: GenIO -> IO a
m = MVar (Gen RealWorld) -> (Gen RealWorld -> IO a) -> IO a
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar (Gen RealWorld)
MVar GenIO
rng Gen RealWorld -> IO a
GenIO -> IO a
m
mkRNG :: IO RNG
mkRNG :: IO RNG
mkRNG = (GenIO -> IO RNG) -> IO RNG
forall (m :: * -> *) a.
PrimBase m =>
(Gen (PrimState m) -> m a) -> IO a
withSystemRandom (Gen RealWorld -> IO (MVar (Gen RealWorld))
forall a. a -> IO (MVar a)
newMVar (Gen RealWorld -> IO (MVar (Gen RealWorld)))
-> (MVar (Gen RealWorld) -> IO RNG) -> Gen RealWorld -> IO RNG
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> RNG -> IO RNG
forall (m :: * -> *) a. Monad m => a -> m a
return (RNG -> IO RNG)
-> (MVar (Gen RealWorld) -> RNG) -> MVar (Gen RealWorld) -> IO RNG
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar (Gen RealWorld) -> RNG
MVar GenIO -> RNG
RNG)
randomToken :: Int -> RNG -> IO ByteString
randomToken :: Int -> RNG -> IO ByteString
randomToken n :: Int
n rng :: RNG
rng = do
[Int]
is <- RNG -> (GenIO -> IO [Int]) -> IO [Int]
forall a. RNG -> (GenIO -> IO a) -> IO a
withRNG RNG
rng ((GenIO -> IO [Int]) -> IO [Int])
-> (GenIO -> IO [Int]) -> IO [Int]
forall a b. (a -> b) -> a -> b
$ \gen :: GenIO
gen -> [IO Int] -> IO [Int]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([IO Int] -> IO [Int])
-> (IO Int -> [IO Int]) -> IO Int -> IO [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [IO Int] -> [IO Int]
forall a. Int -> [a] -> [a]
take Int
n ([IO Int] -> [IO Int])
-> (IO Int -> [IO Int]) -> IO Int -> [IO Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Int -> [IO Int]
forall a. a -> [a]
repeat (IO Int -> IO [Int]) -> IO Int -> IO [Int]
forall a b. (a -> b) -> a -> b
$ GenIO -> IO Int
mk GenIO
gen
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString)
-> ([Int] -> ByteString) -> [Int] -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
B.pack (String -> ByteString) -> ([Int] -> String) -> [Int] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> ([Int] -> [String]) -> [Int] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> String -> String) -> String -> Int -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> String -> String
forall a. (Integral a, Show a) => a -> String -> String
showHex "") ([Int] -> IO ByteString) -> [Int] -> IO ByteString
forall a b. (a -> b) -> a -> b
$ [Int]
is
where
mk :: GenIO -> IO Int
mk :: GenIO -> IO Int
mk = (Int, Int) -> GenIO -> IO Int
forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
(a, a) -> Gen (PrimState m) -> m a
uniformR (0,15)
mkCSRFToken :: RNG -> IO Text
mkCSRFToken :: RNG -> IO Text
mkCSRFToken rng :: RNG
rng = ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> IO ByteString -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> RNG -> IO ByteString
randomToken 40 RNG
rng