ThriftSource.hs

{-
  Copyright (c) Meta Platforms, Inc. and affiliates.
  All rights reserved.

  This source code is licensed under the BSD-style license found in the
  LICENSE file in the root directory of this source tree.
-}

module Glean.Util.ThriftSource (
  ThriftSource,
  ThriftSourceException(..),

  -- * Creation
  config,
  configDefault,
  file,
  value,
  once,
  mutable,
  parse,

  -- ** With a custom deserializer
  Deserializer,
  configWithDeserializer,
  configWithDeserializerDefault,
  fileWithDeserializer,
  parseWithDeserializer,
  genericConfig,

  -- * Reading
  withValue,
  load,
  loadDefault
) where

import Control.Exception
import qualified Data.ByteString as BS
import Data.Default
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Typeable (Typeable)

import Thrift.Protocol (ThriftSerializable)
import Thrift.Protocol.JSON (deserializeJSON)

import Glean.Util.ConfigProvider as Config
import Glean.Util.Observed as Observed

-- | A source of values that may change over time.
data ThriftSource a = ThriftSource
  { thriftSourceWith
      :: forall cfg b . (ConfigProvider cfg)
      => cfg
      -> (Observed a -> IO b)
      -> IO b
  , thriftSourceLoad :: forall cfg . (ConfigProvider cfg) => cfg -> IO a
  , thriftSourceShow :: String
  }

-- | Load a configuration value from a source. The value isn't cached - use
-- 'withValue' and 'Observed.get' for that.
load
  :: (ConfigProvider cfg, Typeable a)
  => cfg
  -> ThriftSource a
  -> IO a
load cfg t = thriftSourceLoad t cfg

-- | Subscribe to a 'ThriftSource' - 'get' will produce the current value.
--
-- If actions are added to the 'Observed' via 'doOnUpdate', no further
-- instances of the actions will be initiated after 'withValue'
-- returns.
--
withValue
  :: (ConfigProvider cfg, Typeable a)
  => cfg
  -> ThriftSource a
  -> (Observed a -> IO b)
  -> IO b
withValue cfg t = thriftSourceWith t cfg

instance Show (ThriftSource a) where
  show = thriftSourceShow

instance Functor ThriftSource where
  fmap f ThriftSource{..} = ThriftSource
    { thriftSourceWith = \cfg g -> thriftSourceWith cfg (\ob -> g (fmap f ob))
    , thriftSourceLoad = \cfg -> fmap f $ thriftSourceLoad cfg
    , .. }

instance Default a => Default (ThriftSource a) where
  def = value def

newtype ThriftSourceException = ThriftSourceException Text
  deriving(Show)

instance Exception ThriftSourceException

-- | A 'ThriftSource' whose value is obtained by looking up the given
-- key using the 'ConfigProvider'.
config
  :: Typeable a
  => ThriftSerializable a
  => Text
  -> ThriftSource a
config path = configWithDeserializer path deserializeJSON

-- | As 'config', except that 'Data.Default.def' is used if the config
-- is missing.
configDefault
  :: (Typeable a, Default a)
  => ThriftSerializable a
  => Text
  -> ThriftSource a
configDefault path = configWithDeserializerDefault path deserializeJSON

-- | A 'ThriftSource' whose value is obtained by looking up the given
-- key using the 'ConfigProvider', and converting it using the given
-- 'Deserializer'
configWithDeserializer
  :: Typeable a
  => Text
  -> Deserializer a
  -> ThriftSource a
configWithDeserializer path d = genericConfig path d (const return) Nothing

-- | As 'configWithDeserializer' except that 'Data.Default.def' is
-- used if the config is missing.
configWithDeserializerDefault
  :: (Typeable a, Default a)
  => Text
  -> Deserializer a
  -> ThriftSource a
configWithDeserializerDefault path d =
  genericConfig path d (const return) (Just def)

genericConfig
  :: (Typeable c)
  => Text
  -> Deserializer c
  -> (forall cfg. ConfigProvider cfg => cfg -> c -> IO a)
  -> Maybe a
  -> ThriftSource a
genericConfig key deserializer mkValue maybDefault = ThriftSource
  { thriftSourceWith = \cfg ->
      configWithValue cfg key deserializer mkValue maybDefault
  , thriftSourceLoad = \cfg ->
      configLoad cfg key deserializer mkValue maybDefault
  , thriftSourceShow = "ThriftSource Fixed"
  }

file :: ThriftSerializable a => FilePath -> ThriftSource a
file path = fileWithDeserializer path deserializeJSON

fileWithDeserializer :: FilePath -> Deserializer a -> ThriftSource a
fileWithDeserializer path deserializer = once $ do
  b <- BS.readFile path
  case deserializer b of
    Left err -> throwIO $ ThriftSourceException $ Text.pack $
      "invalid Thrift value in file '" ++ path ++ "': " ++ err
    Right a -> return a

value :: a -> ThriftSource a
value = once . return

once :: IO a -> ThriftSource a
once io = ThriftSource
  { thriftSourceWith = \_ f -> do x <- io; f (fixedValue x)
  , thriftSourceLoad = \_ -> io
  , thriftSourceShow = "ThriftSource Fixed"
  }

changes :: Observed a -> ThriftSource a
changes ob = ThriftSource
  { thriftSourceWith = \_ f -> f ob
  , thriftSourceLoad = \_ -> Observed.get ob
  , thriftSourceShow = "ThriftSource Changes"
  }

mutable :: a -> IO (ThriftSource a, (a -> a) -> IO ())
mutable x = do
  (ob, onUpdate) <- changingValue x
  return (changes ob, onUpdate)

-- | Parser for  \"config:PATH\" and \"file:PATH\" providers
parse
  :: (Typeable a, ThriftSerializable a)
  => String
  -> Either String (ThriftSource a)
parse s = parseWithDeserializer s deserializeJSON

-- | Parser for  \"config:PATH\" and \"file:PATH\" providers with a
-- custom deserializer.
parseWithDeserializer
  :: Typeable a
  => String
  -> Deserializer a
  -> Either String (ThriftSource a)
parseWithDeserializer s des = case break (==':') s of
  ("config",':':path) ->
    Right $ configWithDeserializer (Text.pack path) des
  ("file",':':path) -> Right $ fileWithDeserializer path des
  (p,':':_) -> Left $ "unsupported Thrift provider '" ++ p ++ "'"
  _ -> Left $ "invalid Thrift source '" ++ s ++ "'"

-- | Subscribe to a 'ThriftSource' - 'get' will produce the current value.
--
-- If actions are added to the 'Observed' via 'doOnUpdate', no further
-- instances of the actions will be initiated after 'withValue'
-- returns.
--
configWithValue
  :: (ConfigProvider cfg, Typeable c)
  => cfg
  -> Text
  -> Deserializer c
  -> (forall cfg. ConfigProvider cfg => cfg -> c -> IO a)
  -> Maybe a
  -> (Observed a -> IO b)
  -> IO b

configWithValue cfgapi path deserialize mkValue maybeDefault action =
  do
    (ob, onUpdate) <- changingValue
      (error "ThriftSource.withValue: internal error")
    let
      callback new = do a <- mkValue cfgapi new; onUpdate (const a)
      acquire =
        (Just <$> subscribe cfgapi path callback deserialize)
          `catch` \e -> if
            | isConfigFailure cfgapi e, Just val <- maybeDefault -> do
              onUpdate (const val)
              return Nothing
            | otherwise -> throwIO e
    bracket acquire (mapM (cancel cfgapi)) $ const $ action ob

configLoad
  :: (ConfigProvider cfg, Typeable c)
  => cfg
  -> Text
  -> Deserializer c
  -> (forall cfg. ConfigProvider cfg => cfg -> c -> IO a)
  -> Maybe a
  -> IO a
configLoad cfgapi path deserialize mkValue maybeDefault =
  (do c <- Config.get cfgapi path deserialize; mkValue cfgapi c)
    `catch` \e -> if
      | isConfigFailure cfgapi e, Just val <- maybeDefault ->
        return val
      | otherwise -> throwIO e

-- | Like 'load', but if the value cannot be retrieved then fall back
-- to using the default value given by the 'Default' instance.
loadDefault
  :: (ConfigProvider cfg, Default a, Typeable a)
  => cfg
  -> ThriftSource a
  -> IO a
loadDefault cfgAPI ts =
  load cfgAPI ts `catch` \e ->
    if isConfigFailure cfgAPI e then return def else throwIO e