module LaunchDarkly.Server.Network.Polling (pollingThread) where import Control.Concurrent (threadDelay) import Control.Monad.Catch (MonadMask, MonadThrow) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger (MonadLogger, logDebug, logError) import Data.Aeson (FromJSON (..), eitherDecode) import Data.Generics.Product (getField) import Data.Text (Text) import qualified Data.Text as T import GHC.Generics (Generic) import Network.HTTP.Client (Manager, Request (..), Response (..), httpLbs) import Network.HTTP.Types.Status (Status (statusCode), ok200) import LaunchDarkly.AesonCompat (KeyMap) import LaunchDarkly.Server.Features (Flag, Segment) import LaunchDarkly.Server.Network.Common (checkAuthorization, handleUnauthorized, isHttpUnrecoverable, tryHTTP) import Data.ByteString.Lazy (ByteString) import GHC.Natural (Natural) import LaunchDarkly.Server.Client.Internal (Status (..)) import LaunchDarkly.Server.Config.ClientContext import LaunchDarkly.Server.Config.HttpConfiguration (HttpConfiguration (..), prepareRequest) import LaunchDarkly.Server.DataSource.Internal (DataSourceUpdates (..)) data PollingResponse = PollingResponse { PollingResponse -> KeyMap Flag flags :: !(KeyMap Flag) , PollingResponse -> KeyMap Segment segments :: !(KeyMap Segment) } deriving ((forall x. PollingResponse -> Rep PollingResponse x) -> (forall x. Rep PollingResponse x -> PollingResponse) -> Generic PollingResponse forall x. Rep PollingResponse x -> PollingResponse forall x. PollingResponse -> Rep PollingResponse x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a $cfrom :: forall x. PollingResponse -> Rep PollingResponse x from :: forall x. PollingResponse -> Rep PollingResponse x $cto :: forall x. Rep PollingResponse x -> PollingResponse to :: forall x. Rep PollingResponse x -> PollingResponse Generic, Maybe PollingResponse Value -> Parser [PollingResponse] Value -> Parser PollingResponse (Value -> Parser PollingResponse) -> (Value -> Parser [PollingResponse]) -> Maybe PollingResponse -> FromJSON PollingResponse forall a. (Value -> Parser a) -> (Value -> Parser [a]) -> Maybe a -> FromJSON a $cparseJSON :: Value -> Parser PollingResponse parseJSON :: Value -> Parser PollingResponse $cparseJSONList :: Value -> Parser [PollingResponse] parseJSONList :: Value -> Parser [PollingResponse] $comittedField :: Maybe PollingResponse omittedField :: Maybe PollingResponse FromJSON, Int -> PollingResponse -> ShowS [PollingResponse] -> ShowS PollingResponse -> String (Int -> PollingResponse -> ShowS) -> (PollingResponse -> String) -> ([PollingResponse] -> ShowS) -> Show PollingResponse forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a $cshowsPrec :: Int -> PollingResponse -> ShowS showsPrec :: Int -> PollingResponse -> ShowS $cshow :: PollingResponse -> String show :: PollingResponse -> String $cshowList :: [PollingResponse] -> ShowS showList :: [PollingResponse] -> ShowS Show) processPoll :: (MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) => Manager -> DataSourceUpdates -> Request -> m Bool processPoll :: forall (m :: * -> *). (MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) => Manager -> DataSourceUpdates -> Request -> m Bool processPoll Manager manager DataSourceUpdates dataSourceUpdates Request request = IO (Either HttpException (Response ByteString)) -> m (Either HttpException (Response ByteString)) forall a. IO a -> m a forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Response ByteString) -> IO (Either HttpException (Response ByteString)) forall (m :: * -> *) a. MonadCatch m => m a -> m (Either HttpException a) tryHTTP (IO (Response ByteString) -> IO (Either HttpException (Response ByteString))) -> IO (Response ByteString) -> IO (Either HttpException (Response ByteString)) forall a b. (a -> b) -> a -> b $ Request -> Manager -> IO (Response ByteString) httpLbs Request request Manager manager) m (Either HttpException (Response ByteString)) -> (Either HttpException (Response ByteString) -> m Bool) -> m Bool forall a b. m a -> (a -> m b) -> m b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case (Left HttpException err) -> do $(logError) (String -> Text T.pack (String -> Text) -> String -> Text forall a b. (a -> b) -> a -> b $ HttpException -> String forall a. Show a => a -> String show HttpException err) Bool -> m Bool forall a. a -> m a forall (f :: * -> *) a. Applicative f => a -> f a pure Bool True (Right Response ByteString response) -> Response ByteString -> m () forall (m :: * -> *) body. MonadThrow m => Response body -> m () checkAuthorization Response ByteString response m () -> m Bool -> m Bool forall a b. m a -> m b -> m b forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> Response ByteString -> m Bool forall (m :: * -> *). (MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) => Response ByteString -> m Bool processResponse Response ByteString response where processResponse :: (MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) => Response ByteString -> m Bool processResponse :: forall (m :: * -> *). (MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) => Response ByteString -> m Bool processResponse Response ByteString response | Int -> Bool isHttpUnrecoverable (Int -> Bool) -> Int -> Bool forall a b. (a -> b) -> a -> b $ Status -> Int statusCode (Status -> Int) -> Status -> Int forall a b. (a -> b) -> a -> b $ Response ByteString -> Status forall body. Response body -> Status responseStatus Response ByteString response = do $(logError) Text "polling stopping after receiving unrecoverable error" Bool -> m Bool forall a. a -> m a forall (f :: * -> *) a. Applicative f => a -> f a pure Bool False | Response ByteString -> Status forall body. Response body -> Status responseStatus Response ByteString response Status -> Status -> Bool forall a. Eq a => a -> a -> Bool /= Status ok200 = do $(logError) Text "unexpected polling status code" Bool -> m Bool forall a. a -> m a forall (f :: * -> *) a. Applicative f => a -> f a pure Bool True | Bool otherwise = case (ByteString -> Either String PollingResponse forall a. FromJSON a => ByteString -> Either String a eitherDecode (Response ByteString -> ByteString forall body. Response body -> body responseBody Response ByteString response) :: Either String PollingResponse) of (Left String err) -> do $(logError) (String -> Text T.pack (String -> Text) -> String -> Text forall a b. (a -> b) -> a -> b $ ShowS forall a. Show a => a -> String show String err) Bool -> m Bool forall a. a -> m a forall (f :: * -> *) a. Applicative f => a -> f a pure (Bool -> m Bool) -> Bool -> m Bool forall a b. (a -> b) -> a -> b $ Bool True (Right PollingResponse body) -> do Either Text () status <- IO (Either Text ()) -> m (Either Text ()) forall a. IO a -> m a forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Either Text ()) -> m (Either Text ())) -> IO (Either Text ()) -> m (Either Text ()) forall a b. (a -> b) -> a -> b $ DataSourceUpdates -> KeyMap Flag -> KeyMap Segment -> IO (Either Text ()) dataSourceUpdatesInit DataSourceUpdates dataSourceUpdates (forall (f :: Symbol) a s. HasField' f s a => s -> a getField @"flags" PollingResponse body) (forall (f :: Symbol) a s. HasField' f s a => s -> a getField @"segments" PollingResponse body) case Either Text () status of Right () -> do IO () -> m () forall a. IO a -> m a forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO () -> m ()) -> IO () -> m () forall a b. (a -> b) -> a -> b $ DataSourceUpdates -> Status -> IO () dataSourceUpdatesSetStatus DataSourceUpdates dataSourceUpdates Status Initialized Bool -> m Bool forall a. a -> m a forall (f :: * -> *) a. Applicative f => a -> f a pure (Bool -> m Bool) -> Bool -> m Bool forall a b. (a -> b) -> a -> b $ Bool True Left Text err -> do $(logError) (Text -> m ()) -> Text -> m () forall a b. (a -> b) -> a -> b $ Text -> Text -> Text T.append Text "store failed put: " Text err Bool -> m Bool forall a. a -> m a forall (f :: * -> *) a. Applicative f => a -> f a pure (Bool -> m Bool) -> Bool -> m Bool forall a b. (a -> b) -> a -> b $ Bool True pollingThread :: (MonadIO m, MonadLogger m, MonadMask m) => Text -> Natural -> ClientContext -> DataSourceUpdates -> m () pollingThread :: forall (m :: * -> *). (MonadIO m, MonadLogger m, MonadMask m) => Text -> Natural -> ClientContext -> DataSourceUpdates -> m () pollingThread Text baseURI Natural pollingIntervalSeconds ClientContext clientContext DataSourceUpdates dataSourceUpdates = do let pollingMicroseconds :: Int pollingMicroseconds = Natural -> Int forall a b. (Integral a, Num b) => a -> b fromIntegral Natural pollingIntervalSeconds Int -> Int -> Int forall a. Num a => a -> a -> a * Int 1000000 Request req <- IO Request -> m Request forall a. IO a -> m a forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO Request -> m Request) -> IO Request -> m Request forall a b. (a -> b) -> a -> b $ HttpConfiguration -> String -> IO Request forall (m :: * -> *). MonadThrow m => HttpConfiguration -> String -> m Request prepareRequest (ClientContext -> HttpConfiguration httpConfiguration ClientContext clientContext) (Text -> String T.unpack Text baseURI String -> ShowS forall a. [a] -> [a] -> [a] ++ String "/sdk/latest-all") DataSourceUpdates -> m () -> m () forall (m :: * -> *). (MonadIO m, MonadLogger m, MonadCatch m) => DataSourceUpdates -> m () -> m () handleUnauthorized DataSourceUpdates dataSourceUpdates (m () -> m ()) -> m () -> m () forall a b. (a -> b) -> a -> b $ (Request -> Int -> m () forall (m :: * -> *). (MonadIO m, MonadLogger m, MonadMask m) => Request -> Int -> m () poll Request req Int pollingMicroseconds) where poll :: (MonadIO m, MonadLogger m, MonadMask m) => Request -> Int -> m () poll :: forall (m :: * -> *). (MonadIO m, MonadLogger m, MonadMask m) => Request -> Int -> m () poll Request req Int pollingMicroseconds = do $(logDebug) Text "starting poll" Manager -> DataSourceUpdates -> Request -> m Bool forall (m :: * -> *). (MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) => Manager -> DataSourceUpdates -> Request -> m Bool processPoll (HttpConfiguration -> Manager tlsManager (HttpConfiguration -> Manager) -> HttpConfiguration -> Manager forall a b. (a -> b) -> a -> b $ ClientContext -> HttpConfiguration httpConfiguration ClientContext clientContext) DataSourceUpdates dataSourceUpdates Request req m Bool -> (Bool -> m ()) -> m () forall a b. m a -> (a -> m b) -> m b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case Bool True -> do IO () -> m () forall a. IO a -> m a forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO () -> m ()) -> IO () -> m () forall a b. (a -> b) -> a -> b $ Int -> IO () threadDelay Int pollingMicroseconds Request -> Int -> m () forall (m :: * -> *). (MonadIO m, MonadLogger m, MonadMask m) => Request -> Int -> m () poll Request req Int pollingMicroseconds Bool False -> () -> m () forall a. a -> m a forall (f :: * -> *) a. Applicative f => a -> f a pure ()