{-# LANGUAGE LambdaCase #-}

module Web.Hyperbole.Effect.GenRandom where

import Control.Monad (replicateM)
import Data.Aeson (FromJSON, ToJSON)
import Data.String.Conversions (cs)
import Data.Text (Text)
import Effectful
import Effectful.Dispatch.Dynamic
import System.Random (Random, randomRIO)
import Web.Hyperbole.Data.Param (FromParam, ToParam)


data GenRandom :: Effect where
  GenRandom :: (Random a) => (a, a) -> GenRandom m a
  GenRandomToken :: Int -> GenRandom m (Token a)
  GenRandomList :: (Random a) => [a] -> GenRandom m a


type instance DispatchOf GenRandom = 'Dynamic


runRandom
  :: (IOE :> es)
  => Eff (GenRandom : es) a
  -> Eff es a
runRandom :: forall (es :: [Effect]) a.
(IOE :> es) =>
Eff (GenRandom : es) a -> Eff es a
runRandom = EffectHandler GenRandom es -> Eff (GenRandom : es) a -> Eff es a
forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic) =>
EffectHandler e es -> Eff (e : es) a -> Eff es a
interpret (EffectHandler GenRandom es -> Eff (GenRandom : es) a -> Eff es a)
-> EffectHandler GenRandom es -> Eff (GenRandom : es) a -> Eff es a
forall a b. (a -> b) -> a -> b
$ \LocalEnv localEs es
_ -> \case
  GenRandom (a, a)
range -> IO a -> Eff es a
forall a. IO a -> Eff es a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Eff es a) -> IO a -> Eff es a
forall a b. (a -> b) -> a -> b
$ (a, a) -> IO a
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (a, a)
range
  GenRandomToken Int
n -> do
    let chars :: [Char]
chars = [Char
'a' .. Char
'z'] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char
'A' .. Char
'Z'] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char
'0' .. Char
'9']
    [Char]
randStr <- IO [Char] -> Eff es [Char]
forall a. IO a -> Eff es a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> Eff es [Char]) -> IO [Char] -> Eff es [Char]
forall a b. (a -> b) -> a -> b
$ Int -> IO Char -> IO [Char]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n ([Char] -> IO Char
forall a. Random a => [a] -> IO a
randomFromList [Char]
chars)
    a -> Eff es a
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Eff es a) -> a -> Eff es a
forall a b. (a -> b) -> a -> b
$ Text -> Token a
forall {k} (a :: k). Text -> Token a
Token (Text -> Token a) -> Text -> Token a
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs [Char]
randStr
  GenRandomList [a]
as ->
    IO a -> Eff es a
forall a. IO a -> Eff es a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Eff es a) -> IO a -> Eff es a
forall a b. (a -> b) -> a -> b
$ [a] -> IO a
forall a. Random a => [a] -> IO a
randomFromList [a]
as
 where
  randomFromList :: (Random a) => [a] -> IO a
  randomFromList :: forall a. Random a => [a] -> IO a
randomFromList [a]
as = do
    Int
index <- IO Int -> IO Int
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> IO Int) -> IO Int -> IO Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Int
0, [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
as Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ [a]
as [a] -> Int -> a
forall a. HasCallStack => [a] -> Int -> a
!! Int
index


genRandom :: (Random a, GenRandom :> es) => (a, a) -> Eff es a
genRandom :: forall a (es :: [Effect]).
(Random a, GenRandom :> es) =>
(a, a) -> Eff es a
genRandom (a, a)
range = GenRandom (Eff es) a -> Eff es a
forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es) =>
e (Eff es) a -> Eff es a
send (GenRandom (Eff es) a -> Eff es a)
-> GenRandom (Eff es) a -> Eff es a
forall a b. (a -> b) -> a -> b
$ (a, a) -> GenRandom (Eff es) a
forall a (m :: * -> *). Random a => (a, a) -> GenRandom m a
GenRandom (a, a)
range


genRandomToken :: (GenRandom :> es) => Int -> Eff es (Token a)
genRandomToken :: forall {k} (es :: [Effect]) (a :: k).
(GenRandom :> es) =>
Int -> Eff es (Token a)
genRandomToken Int
num = GenRandom (Eff es) (Token a) -> Eff es (Token a)
forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es) =>
e (Eff es) a -> Eff es a
send (GenRandom (Eff es) (Token a) -> Eff es (Token a))
-> GenRandom (Eff es) (Token a) -> Eff es (Token a)
forall a b. (a -> b) -> a -> b
$ Int -> GenRandom (Eff es) (Token a)
forall {k} (m :: * -> *) (a :: k). Int -> GenRandom m (Token a)
GenRandomToken Int
num


genRandomList :: (Random a, GenRandom :> es) => [a] -> Eff es a
genRandomList :: forall a (es :: [Effect]).
(Random a, GenRandom :> es) =>
[a] -> Eff es a
genRandomList [a]
as = GenRandom (Eff es) a -> Eff es a
forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es) =>
e (Eff es) a -> Eff es a
send (GenRandom (Eff es) a -> Eff es a)
-> GenRandom (Eff es) a -> Eff es a
forall a b. (a -> b) -> a -> b
$ [a] -> GenRandom (Eff es) a
forall a (m :: * -> *). Random a => [a] -> GenRandom m a
GenRandomList [a]
as


newtype Token a = Token {forall {k} (a :: k). Token a -> Text
value :: Text}
  deriving newtype (Maybe (Token a)
Value -> Parser [Token a]
Value -> Parser (Token a)
(Value -> Parser (Token a))
-> (Value -> Parser [Token a])
-> Maybe (Token a)
-> FromJSON (Token a)
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
forall k (a :: k). Maybe (Token a)
forall k (a :: k). Value -> Parser [Token a]
forall k (a :: k). Value -> Parser (Token a)
$cparseJSON :: forall k (a :: k). Value -> Parser (Token a)
parseJSON :: Value -> Parser (Token a)
$cparseJSONList :: forall k (a :: k). Value -> Parser [Token a]
parseJSONList :: Value -> Parser [Token a]
$comittedField :: forall k (a :: k). Maybe (Token a)
omittedField :: Maybe (Token a)
FromJSON, [Token a] -> Value
[Token a] -> Encoding
Token a -> Bool
Token a -> Value
Token a -> Encoding
(Token a -> Value)
-> (Token a -> Encoding)
-> ([Token a] -> Value)
-> ([Token a] -> Encoding)
-> (Token a -> Bool)
-> ToJSON (Token a)
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
forall k (a :: k). [Token a] -> Value
forall k (a :: k). [Token a] -> Encoding
forall k (a :: k). Token a -> Bool
forall k (a :: k). Token a -> Value
forall k (a :: k). Token a -> Encoding
$ctoJSON :: forall k (a :: k). Token a -> Value
toJSON :: Token a -> Value
$ctoEncoding :: forall k (a :: k). Token a -> Encoding
toEncoding :: Token a -> Encoding
$ctoJSONList :: forall k (a :: k). [Token a] -> Value
toJSONList :: [Token a] -> Value
$ctoEncodingList :: forall k (a :: k). [Token a] -> Encoding
toEncodingList :: [Token a] -> Encoding
$comitField :: forall k (a :: k). Token a -> Bool
omitField :: Token a -> Bool
ToJSON, Maybe Text -> Either [Char] (Token a)
ParamValue -> Either [Char] (Token a)
(ParamValue -> Either [Char] (Token a))
-> (Maybe Text -> Either [Char] (Token a)) -> FromParam (Token a)
forall a.
(ParamValue -> Either [Char] a)
-> (Maybe Text -> Either [Char] a) -> FromParam a
forall k (a :: k). Maybe Text -> Either [Char] (Token a)
forall k (a :: k). ParamValue -> Either [Char] (Token a)
$cparseParam :: forall k (a :: k). ParamValue -> Either [Char] (Token a)
parseParam :: ParamValue -> Either [Char] (Token a)
$cdecodeFormValue :: forall k (a :: k). Maybe Text -> Either [Char] (Token a)
decodeFormValue :: Maybe Text -> Either [Char] (Token a)
FromParam, Token a -> ParamValue
(Token a -> ParamValue) -> ToParam (Token a)
forall a. (a -> ParamValue) -> ToParam a
forall k (a :: k). Token a -> ParamValue
$ctoParam :: forall k (a :: k). Token a -> ParamValue
toParam :: Token a -> ParamValue
ToParam, Token a -> Token a -> Bool
(Token a -> Token a -> Bool)
-> (Token a -> Token a -> Bool) -> Eq (Token a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (a :: k). Token a -> Token a -> Bool
$c== :: forall k (a :: k). Token a -> Token a -> Bool
== :: Token a -> Token a -> Bool
$c/= :: forall k (a :: k). Token a -> Token a -> Bool
/= :: Token a -> Token a -> Bool
Eq, Int -> Token a -> [Char] -> [Char]
[Token a] -> [Char] -> [Char]
Token a -> [Char]
(Int -> Token a -> [Char] -> [Char])
-> (Token a -> [Char])
-> ([Token a] -> [Char] -> [Char])
-> Show (Token a)
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
forall k (a :: k). Int -> Token a -> [Char] -> [Char]
forall k (a :: k). [Token a] -> [Char] -> [Char]
forall k (a :: k). Token a -> [Char]
$cshowsPrec :: forall k (a :: k). Int -> Token a -> [Char] -> [Char]
showsPrec :: Int -> Token a -> [Char] -> [Char]
$cshow :: forall k (a :: k). Token a -> [Char]
show :: Token a -> [Char]
$cshowList :: forall k (a :: k). [Token a] -> [Char] -> [Char]
showList :: [Token a] -> [Char] -> [Char]
Show, ReadPrec [Token a]
ReadPrec (Token a)
Int -> ReadS (Token a)
ReadS [Token a]
(Int -> ReadS (Token a))
-> ReadS [Token a]
-> ReadPrec (Token a)
-> ReadPrec [Token a]
-> Read (Token a)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall k (a :: k). ReadPrec [Token a]
forall k (a :: k). ReadPrec (Token a)
forall k (a :: k). Int -> ReadS (Token a)
forall k (a :: k). ReadS [Token a]
$creadsPrec :: forall k (a :: k). Int -> ReadS (Token a)
readsPrec :: Int -> ReadS (Token a)
$creadList :: forall k (a :: k). ReadS [Token a]
readList :: ReadS [Token a]
$creadPrec :: forall k (a :: k). ReadPrec (Token a)
readPrec :: ReadPrec (Token a)
$creadListPrec :: forall k (a :: k). ReadPrec [Token a]
readListPrec :: ReadPrec [Token a]
Read)