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
$cto :: forall x. Rep PollingResponse x -> PollingResponse
$cfrom :: forall x. PollingResponse -> Rep PollingResponse x
Generic, Value -> Parser [PollingResponse]
Value -> Parser PollingResponse
(Value -> Parser PollingResponse)
-> (Value -> Parser [PollingResponse]) -> FromJSON 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
(Int -> PollingResponse -> ShowS)
-> (PollingResponse -> String)
-> ([PollingResponse] -> ShowS)
-> Show PollingResponse
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 :: Manager -> DataSourceUpdates -> Request -> m Bool
processPoll manager :: Manager
manager dataSourceUpdates :: DataSourceUpdates
dataSourceUpdates request :: Request
request =
    IO (Either HttpException (Response ByteString))
-> m (Either HttpException (Response ByteString))
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        (Left err :: HttpException
err) -> do
            $(LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> m ()
(Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
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 (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        (Right response :: Response ByteString
response) ->
            Response ByteString -> m ()
forall (m :: * -> *) body. MonadThrow m => Response body -> m ()
checkAuthorization Response ByteString
response m () -> m Bool -> m Bool
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 :: Response ByteString -> m Bool
processResponse response :: 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
            $(LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> m ()
(Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
logError) "polling stopping after receiving unrecoverable error"
            Bool -> m Bool
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
            $(LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> m ()
(Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
logError) "unexpected polling status code"
            Bool -> m Bool
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 err :: String
err) -> do
                $(LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> m ()
(Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
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 (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Bool
True
            (Right body :: PollingResponse
body) -> do
                Either Text ()
status <- IO (Either Text ()) -> m (Either Text ())
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 (PollingResponse -> KeyMap Flag
forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"flags" PollingResponse
body) (PollingResponse -> KeyMap Segment
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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Bool
True
                    Left err :: Text
err -> do
                        $(LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> m ()
(Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
logError) (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
T.append "store failed put: " Text
err
                        Bool -> m Bool
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 :: Text -> Natural -> ClientContext -> DataSourceUpdates -> m ()
pollingThread baseURI :: Text
baseURI pollingIntervalSeconds :: Natural
pollingIntervalSeconds clientContext :: ClientContext
clientContext dataSourceUpdates :: 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
* 1000000
    Request
req <- IO Request -> m Request
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]
++ "/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 :: Request -> Int -> m ()
poll req :: Request
req pollingMicroseconds :: Int
pollingMicroseconds = do
        $(LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> m ()
(Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
logDebug) "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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            True -> do
                IO () -> m ()
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
            False -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()