{-# 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 #-}

-- | Use feature flags in WAI applications.
--
-- A feature flag is a way to toggle functionality on or off without having to
-- redeploy the application. Feature flags have many possible uses, one is
-- making it safer to release new functionality by providing a way to turn it
-- off immediately if it misbehaves.
--
-- An application using this library first needs to define which feature flags
-- is supports. This is done by creating a record type containing only boolean
-- fields and adding a 'Flags' instance to it.
--
-- > data Features
-- >   = Features
-- >       { openWindow :: Bool,
-- >         feedPigeons :: Bool
-- >       }
-- >   deriving (Generic)
-- >
-- > instance Flags Features
--
-- Then we need a place to persist flag data. This library provides a
-- 'memoryStore' but it doesn't remember flag states across restarts. For
-- production applications it's probably best to implement a 'Store' that reads
-- and writes flag data to the database or key,value store backing your project.
--
-- 'mkApplication' provides a frontend from which each feature flag can be
-- fully enabled, fully disabled, or enabled for a specific percentage of
-- traffic. It is compatible with @Wai@-based web frameworks like @spock@,
-- @scotty@, and @servant@. Setup instructions will be different for each. If
-- you're having trouble integrating this in your choice of web framework please
-- feel free to [open an issue](https://github.com/jwoudenberg/wai-feature-flags/issues).
--
-- Now you're all set up. You can use 'fetch' to read your feature flags from
-- your store and can use their values in conditionals. For a full example check
-- out this [sample application](https://github.com/jwoudenberg/wai-feature-flags/blob/trunk/example-app/Main.hs).
module Network.FeatureFlags
  ( -- * Flags
    Flags,
    fetch,

    -- * Store
    Store (..),
    memoryStore,

    -- * Feature flag frontend
    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)

-- FRONTEND

-- | Create a WAI application that serves a frontend for modifying feature flag
-- states. How you embed this into your real application depends on the web
-- framework you're using.
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)

-- STORES

-- | A type describing a store in which feature flag data can be saved. You are
-- recommended to define your own stores using a persistence mechanism of your
-- choice.
data Store flags
  = Store
      { -- | Read all key,value pairs from the store.
        forall {k} (flags :: k). Store flags -> IO [(Method, Method)]
readKeys :: IO [(B.ByteString, B.ByteString)],
        -- | Save a key,value pair to the store. Create the key,value pair if it
        -- does not exist yet and overwrite it otherwise.
        forall {k} (flags :: k). Store flags -> Method -> Method -> IO ()
writeKey :: B.ByteString -> B.ByteString -> IO ()
      }

-- | An in-memory store that does not persist feature flag data across
-- application restarts. Suitable for experimentation but not recommended for
-- production use.
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, ()))
      }

-- | Read feature flag states out of the store. The states of flags enabled for
-- part of the traffic will be determined by die-roll.
--
-- The default state for new flags and flags we cannot find values for in the
-- store is off. This library offers no way to set other defaults to keep it as
-- simple as possibe. You are encouraged to phrase your flag names in such a
-- way that off corresponds to what you'd like the default value to be, i.e.
-- @enableExperimentalDoodad@ is likely safer than @disableExperimentalDoodad@.
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

-- PERCENT

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

-- FLAGS

-- | The feature flags you define are described by a type you create yourself.
-- It needs to be a record though, with every field a boolean. Then we add a
-- `Flags` instance to it so this library is able to work with the type.
--
-- > data Features
-- >   = Features
-- >       { openWindow :: Bool,
-- >         feedPigeons :: Bool
-- >       }
-- >   deriving (Generic)
-- >
-- > instance Flags Features
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')