    {-# LANGUAGE CPP               #-}
    ------------------------------------------------------------------------------
    -- | This module contains functionality common among multiple back-ends.
    --

    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

    ------------------------------------------------------------------------------
    -- | High speed, mutable random number generator state
    newtype RNG = RNG (MVar GenIO)

    ------------------------------------------------------------------------------
    -- | Perform given action, mutating the RNG state
    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

    ------------------------------------------------------------------------------
    -- | Create a new RNG
    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)

    ------------------------------------------------------------------------------
    -- | Generates a random salt of given length
    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)

    ------------------------------------------------------------------------------
    -- | Generate a randomized CSRF token
    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