{-# LANGUAGE DeriveAnyClass #-}

-- | Feature Flags are /temporary/ toggles.
module Hasura.Server.Init.FeatureFlag
  ( FeatureFlag (..),
    CheckFeatureFlag (..),
    ceCheckFeatureFlag,
    HasFeatureFlagChecker (..),
  )
where

--------------------------------------------------------------------------------

import Data.Aeson (FromJSON, ToJSON)
import Data.Char
import Data.Environment qualified as Env
import Data.Text qualified as T
import Hasura.Prelude

--------------------------------------------------------------------------------

newtype FeatureFlag = FeatureFlag
  { FeatureFlag -> Text
ffIdentifier :: Text
  }
  deriving stock (FeatureFlag -> FeatureFlag -> Bool
(FeatureFlag -> FeatureFlag -> Bool)
-> (FeatureFlag -> FeatureFlag -> Bool) -> Eq FeatureFlag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FeatureFlag -> FeatureFlag -> Bool
== :: FeatureFlag -> FeatureFlag -> Bool
$c/= :: FeatureFlag -> FeatureFlag -> Bool
/= :: FeatureFlag -> FeatureFlag -> Bool
Eq, (forall x. FeatureFlag -> Rep FeatureFlag x)
-> (forall x. Rep FeatureFlag x -> FeatureFlag)
-> Generic FeatureFlag
forall x. Rep FeatureFlag x -> FeatureFlag
forall x. FeatureFlag -> Rep FeatureFlag x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. FeatureFlag -> Rep FeatureFlag x
from :: forall x. FeatureFlag -> Rep FeatureFlag x
$cto :: forall x. Rep FeatureFlag x -> FeatureFlag
to :: forall x. Rep FeatureFlag x -> FeatureFlag
Generic)
  deriving anyclass (Eq FeatureFlag
Eq FeatureFlag
-> (Int -> FeatureFlag -> Int)
-> (FeatureFlag -> Int)
-> Hashable FeatureFlag
Int -> FeatureFlag -> Int
FeatureFlag -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> FeatureFlag -> Int
hashWithSalt :: Int -> FeatureFlag -> Int
$chash :: FeatureFlag -> Int
hash :: FeatureFlag -> Int
Hashable, Value -> Parser [FeatureFlag]
Value -> Parser FeatureFlag
(Value -> Parser FeatureFlag)
-> (Value -> Parser [FeatureFlag]) -> FromJSON FeatureFlag
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
$cparseJSON :: Value -> Parser FeatureFlag
parseJSON :: Value -> Parser FeatureFlag
$cparseJSONList :: Value -> Parser [FeatureFlag]
parseJSONList :: Value -> Parser [FeatureFlag]
FromJSON, [FeatureFlag] -> Value
[FeatureFlag] -> Encoding
FeatureFlag -> Value
FeatureFlag -> Encoding
(FeatureFlag -> Value)
-> (FeatureFlag -> Encoding)
-> ([FeatureFlag] -> Value)
-> ([FeatureFlag] -> Encoding)
-> ToJSON FeatureFlag
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: FeatureFlag -> Value
toJSON :: FeatureFlag -> Value
$ctoEncoding :: FeatureFlag -> Encoding
toEncoding :: FeatureFlag -> Encoding
$ctoJSONList :: [FeatureFlag] -> Value
toJSONList :: [FeatureFlag] -> Value
$ctoEncodingList :: [FeatureFlag] -> Encoding
toEncodingList :: [FeatureFlag] -> Encoding
ToJSON)

-- | In OSS we _may_ look for a environment variable or fall back to the default
-- value.
ceCheckFeatureFlag :: Env.Environment -> CheckFeatureFlag
ceCheckFeatureFlag :: Environment -> CheckFeatureFlag
ceCheckFeatureFlag Environment
env =
  CheckFeatureFlag
    { runCheckFeatureFlag :: FeatureFlag -> IO Bool
runCheckFeatureFlag = \cases
        ff :: FeatureFlag
ff@FeatureFlag {ffIdentifier :: FeatureFlag -> Text
ffIdentifier = Text
name}
          | FeatureFlag
ff FeatureFlag -> [FeatureFlag] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((FeatureFlag, Text) -> FeatureFlag)
-> [(FeatureFlag, Text)] -> [FeatureFlag]
forall a b. (a -> b) -> [a] -> [b]
map (FeatureFlag, Text) -> FeatureFlag
forall a b. (a, b) -> a
fst [(FeatureFlag, Text)]
ceFeatureFlags ->
              let envVar :: [Char]
envVar = [Char]
"HASURA_FF_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack ((Char -> Char) -> Text -> Text
T.map (Char -> Char
hypenToUnderscore (Char -> Char) -> (Char -> Char) -> Char -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char
toUpper) Text
name)
               in Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Environment -> [Char] -> Maybe [Char]
Env.lookupEnv Environment
env [Char]
envVar Maybe [Char] -> ([Char] -> Maybe Bool) -> Maybe Bool
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> Maybe Bool
forall a. Read a => [Char] -> Maybe a
readMaybe
        FeatureFlag
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False,
      listKnownFeatureFlags :: [(FeatureFlag, Text)]
listKnownFeatureFlags = [(FeatureFlag, Text)]
ceFeatureFlags
    }
  where
    hypenToUnderscore :: Char -> Char
hypenToUnderscore Char
'-' = Char
'_'
    hypenToUnderscore Char
c = Char
c

data CheckFeatureFlag = CheckFeatureFlag
  { -- | Action that samples the value of a feature flag.
    -- Different products will want to do different things. For example, the
    -- Cloud product will want to use LaunchDarkly whereas the OSS and non-cloud
    -- EE products will want to sample environment variables.
    CheckFeatureFlag -> FeatureFlag -> IO Bool
runCheckFeatureFlag :: FeatureFlag -> IO Bool,
    -- | A registry of flags that are 'known' by the system. This is only used
    -- to inform of feature flag values via the '/v1alpha/config' endpoint.
    -- Ideally, the console should have a dedicated endpoint to sample feature
    -- flags so we don't _have_ to centralise that knowledge here.
    CheckFeatureFlag -> [(FeatureFlag, Text)]
listKnownFeatureFlags :: [(FeatureFlag, Text)]
  }

--------------------------------------------------------------------------------

-- | This is the list of feature flags that exist in the CE version
ceFeatureFlags :: [(FeatureFlag, Text)]
ceFeatureFlags :: [(FeatureFlag, Text)]
ceFeatureFlags =
  [ (FeatureFlag
testFlag, Text
"Testing feature flag integration")
  ]

--------------------------------------------------------------------------------

class (Monad m) => HasFeatureFlagChecker m where
  checkFlag :: FeatureFlag -> m Bool

instance (HasFeatureFlagChecker m) => HasFeatureFlagChecker (ReaderT r m) where
  checkFlag :: FeatureFlag -> ReaderT r m Bool
checkFlag = m Bool -> ReaderT r m Bool
forall (m :: * -> *) a. Monad m => m a -> ReaderT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Bool -> ReaderT r m Bool)
-> (FeatureFlag -> m Bool) -> FeatureFlag -> ReaderT r m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FeatureFlag -> m Bool
forall (m :: * -> *).
HasFeatureFlagChecker m =>
FeatureFlag -> m Bool
checkFlag

instance (HasFeatureFlagChecker m) => HasFeatureFlagChecker (ExceptT e m) where
  checkFlag :: FeatureFlag -> ExceptT e m Bool
checkFlag = m Bool -> ExceptT e m Bool
forall (m :: * -> *) a. Monad m => m a -> ExceptT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Bool -> ExceptT e m Bool)
-> (FeatureFlag -> m Bool) -> FeatureFlag -> ExceptT e m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FeatureFlag -> m Bool
forall (m :: * -> *).
HasFeatureFlagChecker m =>
FeatureFlag -> m Bool
checkFlag

instance (HasFeatureFlagChecker m) => HasFeatureFlagChecker (StateT s m) where
  checkFlag :: FeatureFlag -> StateT s m Bool
checkFlag = m Bool -> StateT s m Bool
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Bool -> StateT s m Bool)
-> (FeatureFlag -> m Bool) -> FeatureFlag -> StateT s m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FeatureFlag -> m Bool
forall (m :: * -> *).
HasFeatureFlagChecker m =>
FeatureFlag -> m Bool
checkFlag

--------------------------------------------------------------------------------

-- | Testing feature flag integration
testFlag :: FeatureFlag
testFlag :: FeatureFlag
testFlag = FeatureFlag {ffIdentifier :: Text
ffIdentifier = Text
"test-flag"}