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, logError, logInfo) 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. 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 $cto :: forall x. Rep PollingResponse x -> PollingResponse $cfrom :: forall x. PollingResponse -> Rep PollingResponse x Generic, Value -> Parser [PollingResponse] Value -> Parser PollingResponse forall a. (Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a parseJSONList :: Value -> Parser [PollingResponse] $cparseJSONList :: Value -> Parser [PollingResponse] parseJSON :: Value -> Parser PollingResponse $cparseJSON :: Value -> Parser PollingResponse FromJSON, Int -> PollingResponse -> ShowS [PollingResponse] -> ShowS PollingResponse -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [PollingResponse] -> ShowS $cshowList :: [PollingResponse] -> ShowS show :: PollingResponse -> String $cshow :: PollingResponse -> String showsPrec :: Int -> PollingResponse -> ShowS $cshowsPrec :: Int -> 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (forall (m :: * -> *) a. MonadCatch m => m a -> m (Either HttpException a) tryHTTP forall a b. (a -> b) -> a -> b $ Request -> Manager -> IO (Response ByteString) httpLbs Request request Manager manager) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case (Left HttpException err) -> do $(logError) (String -> Text T.pack forall a b. (a -> b) -> a -> b $ forall a. Show a => a -> String show HttpException err) forall (f :: * -> *) a. Applicative f => a -> f a pure Bool True (Right Response ByteString response) -> forall (m :: * -> *) body. MonadThrow m => Response body -> m () checkAuthorization Response ByteString response forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> 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 forall a b. (a -> b) -> a -> b $ Status -> Int statusCode forall a b. (a -> b) -> a -> b $ forall body. Response body -> Status responseStatus Response ByteString response = do $(logError) Text "polling stopping after receiving unrecoverable error" forall (f :: * -> *) a. Applicative f => a -> f a pure Bool False | forall body. Response body -> Status responseStatus Response ByteString response forall a. Eq a => a -> a -> Bool /= Status ok200 = do $(logError) Text "unexpected polling status code" forall (f :: * -> *) a. Applicative f => a -> f a pure Bool True | Bool otherwise = case (forall a. FromJSON a => ByteString -> Either String a eitherDecode (forall body. Response body -> body responseBody Response ByteString response) :: Either String PollingResponse) of (Left String err) -> do $(logError) (String -> Text T.pack forall a b. (a -> b) -> a -> b $ forall a. Show a => a -> String show String err) forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ Bool True (Right PollingResponse body) -> do Either Text () status <- forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO 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 forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO forall a b. (a -> b) -> a -> b $ DataSourceUpdates -> Status -> IO () dataSourceUpdatesSetStatus DataSourceUpdates dataSourceUpdates Status Initialized forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ Bool True Left Text err -> do $(logError) forall a b. (a -> b) -> a -> b $ Text -> Text -> Text T.append Text "store failed put: " Text err forall (f :: * -> *) a. Applicative f => a -> f a pure 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 = forall a b. (Integral a, Num b) => a -> b fromIntegral Natural pollingIntervalSeconds forall a. Num a => a -> a -> a * Int 1000000 Request req <- forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). MonadThrow m => HttpConfiguration -> String -> m Request prepareRequest (ClientContext -> HttpConfiguration httpConfiguration ClientContext clientContext) (Text -> String T.unpack Text baseURI forall a. [a] -> [a] -> [a] ++ String "/sdk/latest-all") forall (m :: * -> *). (MonadIO m, MonadLogger m, MonadCatch m) => DataSourceUpdates -> m () -> m () handleUnauthorized DataSourceUpdates dataSourceUpdates forall a b. (a -> b) -> a -> b $ (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 $(logInfo) Text "starting poll" forall (m :: * -> *). (MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) => Manager -> DataSourceUpdates -> Request -> m Bool processPoll (HttpConfiguration -> Manager tlsManager forall a b. (a -> b) -> a -> b $ ClientContext -> HttpConfiguration httpConfiguration ClientContext clientContext) DataSourceUpdates dataSourceUpdates Request req forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case Bool True -> do forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO forall a b. (a -> b) -> a -> b $ Int -> IO () threadDelay Int pollingMicroseconds forall (m :: * -> *). (MonadIO m, MonadLogger m, MonadMask m) => Request -> Int -> m () poll Request req Int pollingMicroseconds Bool False -> forall (f :: * -> *) a. Applicative f => a -> f a pure ()