module LaunchDarkly.Server.Network.Polling (pollingThread) where import GHC.Generics (Generic) import Data.Text (Text) import qualified Data.Text as T import Network.HTTP.Client (Manager, Request(..), Response(..), httpLbs) import Data.Generics.Product (getField) import Control.Monad (forever) import Control.Concurrent (threadDelay) import Data.Aeson (eitherDecode, FromJSON(..)) import Control.Monad.Logger (MonadLogger, logInfo, logError) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Catch (MonadMask, MonadThrow) import Network.HTTP.Types.Status (ok200) import LaunchDarkly.Server.Network.Common (checkAuthorization, tryHTTP, handleUnauthorized) import LaunchDarkly.Server.Features (Flag, Segment) import LaunchDarkly.AesonCompat (KeyMap) import GHC.Natural (Natural) import LaunchDarkly.Server.DataSource.Internal (DataSourceUpdates(..)) import LaunchDarkly.Server.Config.ClientContext import LaunchDarkly.Server.Client.Internal (Status(..)) import LaunchDarkly.Server.Config.HttpConfiguration (HttpConfiguration(..), prepareRequest) 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 () processPoll :: forall (m :: * -> *). (MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) => Manager -> DataSourceUpdates -> Request -> m () 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) -> $(logError) (String -> Text T.pack forall a b. (a -> b) -> a -> b $ forall a. Show a => a -> String show HttpException err) (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 >> if forall body. Response body -> Status responseStatus Response ByteString response forall a. Eq a => a -> a -> Bool /= Status ok200 then $(logError) Text "unexpected polling status code" else 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) -> $(logError) (String -> Text T.pack forall a b. (a -> b) -> a -> b $ forall a. Show a => a -> String show String err) (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 () -> 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 Left Text err -> $(logError) forall a b. (a -> b) -> a -> b $ Text -> Text -> Text T.append Text "store failed put: " Text err 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 (f :: * -> *) a b. Applicative f => f a -> f b forever forall a b. (a -> b) -> a -> b $ do $(logInfo) Text "starting poll" forall (m :: * -> *). (MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) => Manager -> DataSourceUpdates -> Request -> m () processPoll (HttpConfiguration -> Manager tlsManager forall a b. (a -> b) -> a -> b $ ClientContext -> HttpConfiguration httpConfiguration ClientContext clientContext) DataSourceUpdates dataSourceUpdates Request req $(logInfo) Text "finished poll" forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO forall a b. (a -> b) -> a -> b $ Int -> IO () threadDelay Int pollingMicroseconds