{-# 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 store =
application store <$> Paths.getDataFileName "frontend/index.html"
application :: Flags flags => Store flags -> FilePath -> Wai.Application
application store frontend req respond = do
case (Wai.requestMethod req, Wai.pathInfo req) of
("GET", []) ->
respond $
Wai.responseFile
(toEnum 200)
[("Content-Type", "text/html; charset=UTF-8")]
frontend
Nothing
("GET", ["flags"]) -> do
configs <- readFlagConfigs (flags store) store
respond $
Wai.responseLBS
(toEnum 200)
[("Content-Type", "application/json")]
(Aeson.encode configs)
("PUT", ["flags", flagName]) -> do
body <- Wai.lazyRequestBody req
case Aeson.decode body of
Nothing ->
respond (Wai.responseLBS (toEnum 400) [] "")
Just percent -> do
setFlag flagName percent store
respond (Wai.responseLBS (toEnum 200) [] "")
_ -> respond (Wai.responseLBS (toEnum 404) [] "")
setFlag :: T.Text -> Percent -> Store flags -> IO ()
setFlag flag (Percent percentage) store =
writeKey
store
(TE.encodeUtf8 flag)
(TE.encodeUtf8 (T.pack (show (min 100 percentage))))
readFlagConfigs :: [T.Text] -> Store flags -> IO (Map.HashMap T.Text Percent)
readFlagConfigs keys store = do
let defaults = zip keys (repeat (Percent 0))
let keySet = Set.fromList keys
stored' <- Maybe.catMaybes . map decodeFlagConfig <$> readKeys store
let stored = filter (\(k, _) -> Set.member k keySet) stored'
pure $ Map.fromList $ defaults <> stored
decodeFlagConfig :: (B.ByteString, B.ByteString) -> Maybe (T.Text, Percent)
decodeFlagConfig (flag, config) = do
flag <- either (const Nothing) Just $ TE.decodeUtf8' flag
enabledString <- either (const Nothing) Just $ TE.decodeUtf8' config
(enabledInt, _) <- either (const Nothing) Just $ Read.decimal enabledString
pure (flag, percent enabledInt)
data Store flags
= Store
{
readKeys :: IO [(B.ByteString, B.ByteString)],
writeKey :: B.ByteString -> B.ByteString -> IO ()
}
memoryStore :: IO (Store flags)
memoryStore = do
ref <- IORef.newIORef Map.empty
pure
Store
{ readKeys = Map.toList <$> IORef.readIORef ref,
writeKey = \key value ->
IORef.atomicModifyIORef' ref (\xs -> (Map.insert key value xs, ()))
}
fetch :: forall flags. Flags flags => Store flags -> IO flags
fetch store = do
let keys = flags (Proxy :: Proxy flags)
configs <- readFlagConfigs keys store
smgen <- newSMGen
pure . fst $ generate configs smgen
newtype Percent = Percent Word.Word32 deriving (Aeson.ToJSON, Aeson.FromJSON)
percent :: Word.Word32 -> Percent
percent = Percent . min 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 configs gen = first GHC.Generics.to $ ggenerate configs gen
default flags :: (Generic flags, GFlags (Rep flags)) => proxy flags -> [T.Text]
flags _ = gflags (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 configs gen = first (M1 . M1) $ ggenerate configs gen
gflags _ = gflags (Proxy :: Proxy fields)
instance (GFlags l, GFlags r) => GFlags (l :*: r) where
ggenerate configs gen =
let (lval, gen') = ggenerate configs gen
(rval, gen'') = ggenerate configs gen'
in (lval :*: rval, gen'')
gflags _ = gflags (Proxy :: Proxy l) <> gflags (Proxy :: Proxy r)
instance
( KnownSymbol fieldName,
FromBool (IsBool bool) bool
) =>
GFlags (S1 ('MetaSel ('Just fieldName) su ss ds) (K1 i bool))
where
ggenerate configs gen =
first (M1 . K1 . fromBool (Proxy :: Proxy (IsBool bool))) $
case Map.lookup (T.pack $ symbolVal (Proxy :: Proxy fieldName)) configs of
Nothing -> (False, gen)
Just (Percent 0) -> (False, gen)
Just (Percent 100) -> (True, gen)
Just config -> roll gen config
gflags _ = [T.pack $ symbolVal (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 _ = id
instance TypeError InvalidFlagsTypeMessage => FromBool 'False a where
fromBool = error "unreachable"
instance TypeError InvalidFlagsTypeMessage => GFlags (D1 m (C1 ('MetaCons s f 'False) a)) where
ggenerate = error "unreachable"
gflags = error "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 gen (Percent trueChance) =
let (randomWord32, gen') = nextWord32 gen
between1And100 = 1 + (randomWord32 `mod` 100)
in (trueChance >= between1And100, gen')