{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
module Network.FeatureFlags
(
Flags,
fetch,
Store (..),
memoryStore,
mkApplication,
)
where
import qualified Data.Aeson as Aeson
import Data.Bifunctor (first)
import qualified Data.ByteString as B
import qualified Data.HashMap.Strict as Map
import qualified Data.HashSet as Set
import qualified Data.IORef as IORef
import Data.Kind (Type)
import qualified Data.Maybe as Maybe
import Data.Proxy (Proxy (Proxy))
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Read as Read
import qualified Data.Word as Word
import qualified Debug.Trace as Debug
import GHC.Generics
import GHC.TypeLits (ErrorMessage (..), KnownSymbol, TypeError, symbolVal)
import qualified Network.Wai as Wai
import qualified Paths_wai_feature_flags as Paths
import System.Random.SplitMix (SMGen, newSMGen, nextWord32)
mkApplication :: Flags flags => Store flags -> IO Wai.Application
mkApplication :: forall flags. Flags flags => Store flags -> IO Application
mkApplication Store flags
store =
Store flags -> FilePath -> Application
forall flags. Flags flags => Store flags -> FilePath -> Application
application Store flags
store (FilePath -> Application) -> IO FilePath -> IO Application
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FilePath
Paths.getDataFileName FilePath
"frontend/index.html"
application :: Flags flags => Store flags -> FilePath -> Wai.Application
application :: forall flags. Flags flags => Store flags -> FilePath -> Application
application Store flags
store FilePath
frontend Request
req Response -> IO ResponseReceived
respond = do
case (Request -> Method
Wai.requestMethod Request
req, Request -> [Text]
Wai.pathInfo Request
req) of
(Method
"GET", []) ->
Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$
Status -> ResponseHeaders -> FilePath -> Maybe FilePart -> Response
Wai.responseFile
(Int -> Status
forall a. Enum a => Int -> a
toEnum Int
200)
[(HeaderName
"Content-Type", Method
"text/html; charset=UTF-8")]
FilePath
frontend
Maybe FilePart
forall a. Maybe a
Nothing
(Method
"GET", [Text
"flags"]) -> do
HashMap Text Percent
configs <- [Text] -> Store flags -> IO (HashMap Text Percent)
forall {k} (flags :: k).
[Text] -> Store flags -> IO (HashMap Text Percent)
readFlagConfigs (Store flags -> [Text]
forall flags (proxy :: * -> *).
Flags flags =>
proxy flags -> [Text]
forall (proxy :: * -> *). proxy flags -> [Text]
flags Store flags
store) Store flags
store
Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$
Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS
(Int -> Status
forall a. Enum a => Int -> a
toEnum Int
200)
[(HeaderName
"Content-Type", Method
"application/json")]
(HashMap Text Percent -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode HashMap Text Percent
configs)
(Method
"PUT", [Text
"flags", Text
flagName]) -> do
ByteString
body <- Request -> IO ByteString
Wai.lazyRequestBody Request
req
case ByteString -> Maybe Percent
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode ByteString
body of
Maybe Percent
Nothing ->
Response -> IO ResponseReceived
respond (Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS (Int -> Status
forall a. Enum a => Int -> a
toEnum Int
400) [] ByteString
"")
Just Percent
percent -> do
Text -> Percent -> Store flags -> IO ()
forall {k} (flags :: k). Text -> Percent -> Store flags -> IO ()
setFlag Text
flagName Percent
percent Store flags
store
Response -> IO ResponseReceived
respond (Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS (Int -> Status
forall a. Enum a => Int -> a
toEnum Int
200) [] ByteString
"")
(Method, [Text])
_ -> Response -> IO ResponseReceived
respond (Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS (Int -> Status
forall a. Enum a => Int -> a
toEnum Int
404) [] ByteString
"")
setFlag :: T.Text -> Percent -> Store flags -> IO ()
setFlag :: forall {k} (flags :: k). Text -> Percent -> Store flags -> IO ()
setFlag Text
flag (Percent Word32
percentage) Store flags
store =
Store flags -> Method -> Method -> IO ()
forall {k} (flags :: k). Store flags -> Method -> Method -> IO ()
writeKey
Store flags
store
(Text -> Method
TE.encodeUtf8 Text
flag)
(Text -> Method
TE.encodeUtf8 (FilePath -> Text
T.pack (Word32 -> FilePath
forall a. Show a => a -> FilePath
show (Word32 -> Word32 -> Word32
forall a. Ord a => a -> a -> a
min Word32
100 Word32
percentage))))
readFlagConfigs :: [T.Text] -> Store flags -> IO (Map.HashMap T.Text Percent)
readFlagConfigs :: forall {k} (flags :: k).
[Text] -> Store flags -> IO (HashMap Text Percent)
readFlagConfigs [Text]
keys Store flags
store = do
let defaults :: [(Text, Percent)]
defaults = [Text] -> [Percent] -> [(Text, Percent)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
keys (Percent -> [Percent]
forall a. a -> [a]
repeat (Word32 -> Percent
Percent Word32
0))
let keySet :: HashSet Text
keySet = [Text] -> HashSet Text
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList [Text]
keys
[(Text, Percent)]
stored' <- [Maybe (Text, Percent)] -> [(Text, Percent)]
forall a. [Maybe a] -> [a]
Maybe.catMaybes ([Maybe (Text, Percent)] -> [(Text, Percent)])
-> ([(Method, Method)] -> [Maybe (Text, Percent)])
-> [(Method, Method)]
-> [(Text, Percent)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Method, Method) -> Maybe (Text, Percent))
-> [(Method, Method)] -> [Maybe (Text, Percent)]
forall a b. (a -> b) -> [a] -> [b]
map (Method, Method) -> Maybe (Text, Percent)
decodeFlagConfig ([(Method, Method)] -> [(Text, Percent)])
-> IO [(Method, Method)] -> IO [(Text, Percent)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Store flags -> IO [(Method, Method)]
forall {k} (flags :: k). Store flags -> IO [(Method, Method)]
readKeys Store flags
store
let stored :: [(Text, Percent)]
stored = ((Text, Percent) -> Bool) -> [(Text, Percent)] -> [(Text, Percent)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Text
k, Percent
_) -> Text -> HashSet Text -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
Set.member Text
k HashSet Text
keySet) [(Text, Percent)]
stored'
HashMap Text Percent -> IO (HashMap Text Percent)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap Text Percent -> IO (HashMap Text Percent))
-> HashMap Text Percent -> IO (HashMap Text Percent)
forall a b. (a -> b) -> a -> b
$ [(Text, Percent)] -> HashMap Text Percent
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList ([(Text, Percent)] -> HashMap Text Percent)
-> [(Text, Percent)] -> HashMap Text Percent
forall a b. (a -> b) -> a -> b
$ [(Text, Percent)]
defaults [(Text, Percent)] -> [(Text, Percent)] -> [(Text, Percent)]
forall a. Semigroup a => a -> a -> a
<> [(Text, Percent)]
stored
decodeFlagConfig :: (B.ByteString, B.ByteString) -> Maybe (T.Text, Percent)
decodeFlagConfig :: (Method, Method) -> Maybe (Text, Percent)
decodeFlagConfig (Method
flag, Method
config) = do
Text
flag <- (UnicodeException -> Maybe Text)
-> (Text -> Maybe Text)
-> Either UnicodeException Text
-> Maybe Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Text -> UnicodeException -> Maybe Text
forall a b. a -> b -> a
const Maybe Text
forall a. Maybe a
Nothing) Text -> Maybe Text
forall a. a -> Maybe a
Just (Either UnicodeException Text -> Maybe Text)
-> Either UnicodeException Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Method -> Either UnicodeException Text
TE.decodeUtf8' Method
flag
Text
enabledString <- (UnicodeException -> Maybe Text)
-> (Text -> Maybe Text)
-> Either UnicodeException Text
-> Maybe Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Text -> UnicodeException -> Maybe Text
forall a b. a -> b -> a
const Maybe Text
forall a. Maybe a
Nothing) Text -> Maybe Text
forall a. a -> Maybe a
Just (Either UnicodeException Text -> Maybe Text)
-> Either UnicodeException Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Method -> Either UnicodeException Text
TE.decodeUtf8' Method
config
(Word32
enabledInt, Text
_) <- (FilePath -> Maybe (Word32, Text))
-> ((Word32, Text) -> Maybe (Word32, Text))
-> Either FilePath (Word32, Text)
-> Maybe (Word32, Text)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe (Word32, Text) -> FilePath -> Maybe (Word32, Text)
forall a b. a -> b -> a
const Maybe (Word32, Text)
forall a. Maybe a
Nothing) (Word32, Text) -> Maybe (Word32, Text)
forall a. a -> Maybe a
Just (Either FilePath (Word32, Text) -> Maybe (Word32, Text))
-> Either FilePath (Word32, Text) -> Maybe (Word32, Text)
forall a b. (a -> b) -> a -> b
$ Reader Word32
forall a. Integral a => Reader a
Read.decimal Text
enabledString
(Text, Percent) -> Maybe (Text, Percent)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
flag, Word32 -> Percent
percent Word32
enabledInt)
data Store flags
= Store
{
forall {k} (flags :: k). Store flags -> IO [(Method, Method)]
readKeys :: IO [(B.ByteString, B.ByteString)],
forall {k} (flags :: k). Store flags -> Method -> Method -> IO ()
writeKey :: B.ByteString -> B.ByteString -> IO ()
}
memoryStore :: IO (Store flags)
memoryStore :: forall {k} (flags :: k). IO (Store flags)
memoryStore = do
IORef (HashMap Method Method)
ref <- HashMap Method Method -> IO (IORef (HashMap Method Method))
forall a. a -> IO (IORef a)
IORef.newIORef HashMap Method Method
forall k v. HashMap k v
Map.empty
Store flags -> IO (Store flags)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
Store
{ readKeys :: IO [(Method, Method)]
readKeys = HashMap Method Method -> [(Method, Method)]
forall k v. HashMap k v -> [(k, v)]
Map.toList (HashMap Method Method -> [(Method, Method)])
-> IO (HashMap Method Method) -> IO [(Method, Method)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (HashMap Method Method) -> IO (HashMap Method Method)
forall a. IORef a -> IO a
IORef.readIORef IORef (HashMap Method Method)
ref,
writeKey :: Method -> Method -> IO ()
writeKey = \Method
key Method
value ->
IORef (HashMap Method Method)
-> (HashMap Method Method -> (HashMap Method Method, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef (HashMap Method Method)
ref (\HashMap Method Method
xs -> (Method -> Method -> HashMap Method Method -> HashMap Method Method
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert Method
key Method
value HashMap Method Method
xs, ()))
}
fetch :: forall flags. Flags flags => Store flags -> IO flags
fetch :: forall flags. Flags flags => Store flags -> IO flags
fetch Store flags
store = do
let keys :: [Text]
keys = Proxy flags -> [Text]
forall flags (proxy :: * -> *).
Flags flags =>
proxy flags -> [Text]
forall (proxy :: * -> *). proxy flags -> [Text]
flags (Proxy flags
forall {k} (t :: k). Proxy t
Proxy :: Proxy flags)
HashMap Text Percent
configs <- [Text] -> Store flags -> IO (HashMap Text Percent)
forall {k} (flags :: k).
[Text] -> Store flags -> IO (HashMap Text Percent)
readFlagConfigs [Text]
keys Store flags
store
SMGen
smgen <- IO SMGen
newSMGen
flags -> IO flags
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (flags -> IO flags)
-> ((flags, SMGen) -> flags) -> (flags, SMGen) -> IO flags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (flags, SMGen) -> flags
forall a b. (a, b) -> a
fst ((flags, SMGen) -> IO flags) -> (flags, SMGen) -> IO flags
forall a b. (a -> b) -> a -> b
$ HashMap Text Percent -> SMGen -> (flags, SMGen)
forall flags.
Flags flags =>
HashMap Text Percent -> SMGen -> (flags, SMGen)
generate HashMap Text Percent
configs SMGen
smgen
newtype Percent = Percent Word.Word32 deriving ([Percent] -> Value
[Percent] -> Encoding
Percent -> Value
Percent -> Encoding
(Percent -> Value)
-> (Percent -> Encoding)
-> ([Percent] -> Value)
-> ([Percent] -> Encoding)
-> ToJSON Percent
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: Percent -> Value
toJSON :: Percent -> Value
$ctoEncoding :: Percent -> Encoding
toEncoding :: Percent -> Encoding
$ctoJSONList :: [Percent] -> Value
toJSONList :: [Percent] -> Value
$ctoEncodingList :: [Percent] -> Encoding
toEncodingList :: [Percent] -> Encoding
Aeson.ToJSON, Value -> Parser [Percent]
Value -> Parser Percent
(Value -> Parser Percent)
-> (Value -> Parser [Percent]) -> FromJSON Percent
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
$cparseJSON :: Value -> Parser Percent
parseJSON :: Value -> Parser Percent
$cparseJSONList :: Value -> Parser [Percent]
parseJSONList :: Value -> Parser [Percent]
Aeson.FromJSON)
percent :: Word.Word32 -> Percent
percent :: Word32 -> Percent
percent = Word32 -> Percent
Percent (Word32 -> Percent) -> (Word32 -> Word32) -> Word32 -> Percent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Word32 -> Word32
forall a. Ord a => a -> a -> a
min Word32
100
class Flags flags where
generate :: Map.HashMap T.Text Percent -> SMGen -> (flags, SMGen)
flags :: proxy flags -> [T.Text]
default generate :: (Generic flags, GFlags (Rep flags)) => Map.HashMap T.Text Percent -> SMGen -> (flags, SMGen)
generate HashMap Text Percent
configs SMGen
gen = (Rep flags Any -> flags)
-> (Rep flags Any, SMGen) -> (flags, SMGen)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Rep flags Any -> flags
forall a x. Generic a => Rep a x -> a
forall x. Rep flags x -> flags
GHC.Generics.to ((Rep flags Any, SMGen) -> (flags, SMGen))
-> (Rep flags Any, SMGen) -> (flags, SMGen)
forall a b. (a -> b) -> a -> b
$ HashMap Text Percent -> SMGen -> (Rep flags Any, SMGen)
forall g. HashMap Text Percent -> SMGen -> (Rep flags g, SMGen)
forall {k} (flags :: k -> *) (g :: k).
GFlags flags =>
HashMap Text Percent -> SMGen -> (flags g, SMGen)
ggenerate HashMap Text Percent
configs SMGen
gen
default flags :: (Generic flags, GFlags (Rep flags)) => proxy flags -> [T.Text]
flags proxy flags
_ = Proxy (Rep flags) -> [Text]
forall {k} (flags :: k -> *) (proxy :: (k -> *) -> *).
GFlags flags =>
proxy flags -> [Text]
forall (proxy :: (* -> *) -> *). proxy (Rep flags) -> [Text]
gflags (Proxy (Rep flags)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (Rep flags))
class GFlags flags where
ggenerate :: Map.HashMap T.Text Percent -> SMGen -> (flags g, SMGen)
gflags :: proxy flags -> [T.Text]
instance GFlags fields => GFlags (D1 m (C1 ('MetaCons s f 'True) fields)) where
ggenerate :: forall (g :: k).
HashMap Text Percent
-> SMGen -> (D1 m (C1 ('MetaCons s f 'True) fields) g, SMGen)
ggenerate HashMap Text Percent
configs SMGen
gen = (fields g -> D1 m (C1 ('MetaCons s f 'True) fields) g)
-> (fields g, SMGen)
-> (D1 m (C1 ('MetaCons s f 'True) fields) g, SMGen)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (C1 ('MetaCons s f 'True) fields g
-> D1 m (C1 ('MetaCons s f 'True) fields) g
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (C1 ('MetaCons s f 'True) fields g
-> D1 m (C1 ('MetaCons s f 'True) fields) g)
-> (fields g -> C1 ('MetaCons s f 'True) fields g)
-> fields g
-> D1 m (C1 ('MetaCons s f 'True) fields) g
forall b c a. (b -> c) -> (a -> b) -> a -> c
. fields g -> C1 ('MetaCons s f 'True) fields g
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1) ((fields g, SMGen)
-> (D1 m (C1 ('MetaCons s f 'True) fields) g, SMGen))
-> (fields g, SMGen)
-> (D1 m (C1 ('MetaCons s f 'True) fields) g, SMGen)
forall a b. (a -> b) -> a -> b
$ HashMap Text Percent -> SMGen -> (fields g, SMGen)
forall (g :: k). HashMap Text Percent -> SMGen -> (fields g, SMGen)
forall {k} (flags :: k -> *) (g :: k).
GFlags flags =>
HashMap Text Percent -> SMGen -> (flags g, SMGen)
ggenerate HashMap Text Percent
configs SMGen
gen
gflags :: forall (proxy :: (k -> *) -> *).
proxy (D1 m (C1 ('MetaCons s f 'True) fields)) -> [Text]
gflags proxy (D1 m (C1 ('MetaCons s f 'True) fields))
_ = Proxy fields -> [Text]
forall {k} (flags :: k -> *) (proxy :: (k -> *) -> *).
GFlags flags =>
proxy flags -> [Text]
forall (proxy :: (k -> *) -> *). proxy fields -> [Text]
gflags (Proxy fields
forall {k} (t :: k). Proxy t
Proxy :: Proxy fields)
instance (GFlags l, GFlags r) => GFlags (l :*: r) where
ggenerate :: forall (g :: k).
HashMap Text Percent -> SMGen -> ((:*:) l r g, SMGen)
ggenerate HashMap Text Percent
configs SMGen
gen =
let (l g
lval, SMGen
gen') = HashMap Text Percent -> SMGen -> (l g, SMGen)
forall (g :: k). HashMap Text Percent -> SMGen -> (l g, SMGen)
forall {k} (flags :: k -> *) (g :: k).
GFlags flags =>
HashMap Text Percent -> SMGen -> (flags g, SMGen)
ggenerate HashMap Text Percent
configs SMGen
gen
(r g
rval, SMGen
gen'') = HashMap Text Percent -> SMGen -> (r g, SMGen)
forall (g :: k). HashMap Text Percent -> SMGen -> (r g, SMGen)
forall {k} (flags :: k -> *) (g :: k).
GFlags flags =>
HashMap Text Percent -> SMGen -> (flags g, SMGen)
ggenerate HashMap Text Percent
configs SMGen
gen'
in (l g
lval l g -> r g -> (:*:) l r g
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: r g
rval, SMGen
gen'')
gflags :: forall (proxy :: (k -> *) -> *). proxy (l :*: r) -> [Text]
gflags proxy (l :*: r)
_ = Proxy l -> [Text]
forall {k} (flags :: k -> *) (proxy :: (k -> *) -> *).
GFlags flags =>
proxy flags -> [Text]
forall (proxy :: (k -> *) -> *). proxy l -> [Text]
gflags (Proxy l
forall {k} (t :: k). Proxy t
Proxy :: Proxy l) [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Proxy r -> [Text]
forall {k} (flags :: k -> *) (proxy :: (k -> *) -> *).
GFlags flags =>
proxy flags -> [Text]
forall (proxy :: (k -> *) -> *). proxy r -> [Text]
gflags (Proxy r
forall {k} (t :: k). Proxy t
Proxy :: Proxy r)
instance
( KnownSymbol fieldName,
FromBool (IsBool bool) bool
) =>
GFlags (S1 ('MetaSel ('Just fieldName) su ss ds) (K1 i bool))
where
ggenerate :: forall (g :: k).
HashMap Text Percent
-> SMGen
-> (S1 ('MetaSel ('Just fieldName) su ss ds) (K1 i bool) g, SMGen)
ggenerate HashMap Text Percent
configs SMGen
gen =
(Bool -> S1 ('MetaSel ('Just fieldName) su ss ds) (K1 i bool) g)
-> (Bool, SMGen)
-> (S1 ('MetaSel ('Just fieldName) su ss ds) (K1 i bool) g, SMGen)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (K1 i bool g
-> S1 ('MetaSel ('Just fieldName) su ss ds) (K1 i bool) g
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 i bool g
-> S1 ('MetaSel ('Just fieldName) su ss ds) (K1 i bool) g)
-> (Bool -> K1 i bool g)
-> Bool
-> S1 ('MetaSel ('Just fieldName) su ss ds) (K1 i bool) g
forall b c a. (b -> c) -> (a -> b) -> a -> c
. bool -> K1 i bool g
forall k i c (p :: k). c -> K1 i c p
K1 (bool -> K1 i bool g) -> (Bool -> bool) -> Bool -> K1 i bool g
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy (IsBool bool) -> Bool -> bool
forall (b :: Bool) a. FromBool b a => Proxy b -> Bool -> a
fromBool (Proxy (IsBool bool)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (IsBool bool))) ((Bool, SMGen)
-> (S1 ('MetaSel ('Just fieldName) su ss ds) (K1 i bool) g, SMGen))
-> (Bool, SMGen)
-> (S1 ('MetaSel ('Just fieldName) su ss ds) (K1 i bool) g, SMGen)
forall a b. (a -> b) -> a -> b
$
case Text -> HashMap Text Percent -> Maybe Percent
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup (FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Proxy fieldName -> FilePath
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> FilePath
symbolVal (Proxy fieldName
forall {k} (t :: k). Proxy t
Proxy :: Proxy fieldName)) HashMap Text Percent
configs of
Maybe Percent
Nothing -> (Bool
False, SMGen
gen)
Just (Percent Word32
0) -> (Bool
False, SMGen
gen)
Just (Percent Word32
100) -> (Bool
True, SMGen
gen)
Just Percent
config -> SMGen -> Percent -> (Bool, SMGen)
roll SMGen
gen Percent
config
gflags :: forall (proxy :: (k -> *) -> *).
proxy (S1 ('MetaSel ('Just fieldName) su ss ds) (K1 i bool))
-> [Text]
gflags proxy (S1 ('MetaSel ('Just fieldName) su ss ds) (K1 i bool))
_ = [FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Proxy fieldName -> FilePath
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> FilePath
symbolVal (Proxy fieldName
forall {k} (t :: k). Proxy t
Proxy :: Proxy fieldName)]
type family IsBool (b :: Type) :: Bool where
IsBool Bool = 'True
IsBool _ = 'False
class FromBool (b :: Bool) a where
fromBool :: Proxy b -> Bool -> a
instance FromBool 'True Bool where
fromBool :: Proxy 'True -> Bool -> Bool
fromBool Proxy 'True
_ = Bool -> Bool
forall a. a -> a
id
instance TypeError InvalidFlagsTypeMessage => FromBool 'False a where
fromBool :: Proxy 'False -> Bool -> a
fromBool = FilePath -> Proxy 'False -> Bool -> a
forall a. HasCallStack => FilePath -> a
error FilePath
"unreachable"
instance TypeError InvalidFlagsTypeMessage => GFlags (D1 m (C1 ('MetaCons s f 'False) a)) where
ggenerate :: forall (g :: k).
HashMap Text Percent
-> SMGen -> (D1 m (C1 ('MetaCons s f 'False) a) g, SMGen)
ggenerate = FilePath
-> HashMap Text Percent
-> SMGen
-> (D1 m (C1 ('MetaCons s f 'False) a) g, SMGen)
forall a. HasCallStack => FilePath -> a
error FilePath
"unreachable"
gflags :: forall (proxy :: (k -> *) -> *).
proxy (D1 m (C1 ('MetaCons s f 'False) a)) -> [Text]
gflags = FilePath -> proxy (D1 m (C1 ('MetaCons s f 'False) a)) -> [Text]
forall a. HasCallStack => FilePath -> a
error FilePath
"unreachable"
type InvalidFlagsTypeMessage =
'Text "Not a valid flags type."
:$$: 'Text "A flags type needs to be a record with boolean fields."
:$$: 'Text "For example:"
:$$: 'Text " data Flags ="
:$$: 'Text " Flags { showErrorPage :: Bool"
:$$: 'Text " , throttleRequests :: Bool }"
roll :: SMGen -> Percent -> (Bool, SMGen)
roll :: SMGen -> Percent -> (Bool, SMGen)
roll SMGen
gen (Percent Word32
trueChance) =
let (Word32
randomWord32, SMGen
gen') = SMGen -> (Word32, SMGen)
nextWord32 SMGen
gen
between1And100 :: Word32
between1And100 = Word32
1 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ (Word32
randomWord32 Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`mod` Word32
100)
in (Word32
trueChance Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word32
between1And100, SMGen
gen')