diff --git a/contract-tests/src/Main.hs b/contract-tests/src/Main.hs index c86779c..035084e 100644 --- a/contract-tests/src/Main.hs +++ b/contract-tests/src/Main.hs @@ -55,6 +55,7 @@ getAppStatus = , "event-gzip" , "optional-event-gzip" , "polling-gzip" + , "instance-id" ] } diff --git a/launchdarkly-server-sdk.cabal b/launchdarkly-server-sdk.cabal index 3bf1c39..6ef83c2 100644 --- a/launchdarkly-server-sdk.cabal +++ b/launchdarkly-server-sdk.cabal @@ -140,6 +140,7 @@ test-suite haskell-server-sdk-test Spec.DataSource Spec.Evaluate Spec.Features + Spec.HttpConfiguration Spec.Integrations.FileData Spec.Integrations.TestData Spec.Operators diff --git a/src/LaunchDarkly/Server/Client.hs b/src/LaunchDarkly/Server/Client.hs index fb0823d..a1b5cf3 100644 --- a/src/LaunchDarkly/Server/Client.hs +++ b/src/LaunchDarkly/Server/Client.hs @@ -44,16 +44,14 @@ import Data.Text.Encoding (encodeUtf8) import GHC.Generics (Generic) import GHC.Natural (Natural) import Network.HTTP.Client (newManager) -import qualified Network.HTTP.Client as Http import Network.HTTP.Client.TLS (tlsManagerSettings) import System.Clock (TimeSpec (..)) import LaunchDarkly.AesonCompat (KeyMap, emptyObject, filterObject, insertKey, mapValues) -import LaunchDarkly.Server.Client.Internal (Client (..), clientVersion, getStatusI) +import LaunchDarkly.Server.Client.Internal (Client (..), clientVersion, getStatusI, makeHttpConfiguration) import LaunchDarkly.Server.Client.Status (Status (..)) import LaunchDarkly.Server.Config.ClientContext (ClientContext (..)) -import LaunchDarkly.Server.Config.HttpConfiguration (HttpConfiguration (..)) -import LaunchDarkly.Server.Config.Internal (ApplicationInfo, Config, getApplicationInfoHeader, shouldSendEvents) +import LaunchDarkly.Server.Config.Internal (Config, shouldSendEvents) import LaunchDarkly.Server.Context (getValue) import LaunchDarkly.Server.Context.Internal (Context (Invalid), getCanonicalKey, getKey, optionallyRedactAnonymous, redactContext, redactContextRedactAnonymous) import LaunchDarkly.Server.DataSource.Internal (DataSource (..), DataSourceFactory, DataSourceUpdates (..), defaultDataSourceUpdates, nullDataSourceFactory) @@ -69,9 +67,7 @@ import LaunchDarkly.Server.Store.Internal (getAllFlagsC, makeStoreIO) import Crypto.Hash.SHA256 (hash) import Crypto.MAC.HMAC (hmac) import Data.ByteArray.Encoding (Base (Base16), convertToBase) -import Data.ByteString (ByteString) import Data.Text.Encoding (decodeUtf8) -import Network.HTTP.Types (HeaderName) networkDataSourceFactory :: (ClientContext -> DataSourceUpdates -> LoggingT IO ()) -> DataSourceFactory networkDataSourceFactory threadF clientContext dataSourceUpdates = do @@ -93,23 +89,6 @@ networkDataSourceFactory threadF clientContext dataSourceUpdates = do pure $ DataSource {..} -makeHttpConfiguration :: Config -> IO HttpConfiguration -makeHttpConfiguration config = do - tlsManager <- newManager tlsManagerSettings - let headers = - [ ("Authorization", encodeUtf8 $ getField @"key" config) - , ("User-Agent", "HaskellServerClient/" <> encodeUtf8 clientVersion) - ] - defaultRequestHeaders = addTagsHeader headers (getField @"applicationInfo" config) - defaultRequestTimeout = Http.responseTimeoutMicro $ fromIntegral $ getField @"requestTimeoutSeconds" config * 1000000 - pure $ HttpConfiguration {..} - where - addTagsHeader :: [(HeaderName, ByteString)] -> Maybe ApplicationInfo -> [(HeaderName, ByteString)] - addTagsHeader headers Nothing = headers - addTagsHeader headers (Just info) = case getApplicationInfoHeader info of - Nothing -> headers - Just header -> ("X-LaunchDarkly-Tags", encodeUtf8 header) : headers - makeClientContext :: Config -> IO ClientContext makeClientContext config = do let runLogger = getField @"logger" config diff --git a/src/LaunchDarkly/Server/Client/Internal.hs b/src/LaunchDarkly/Server/Client/Internal.hs index 110c6d1..3b58447 100644 --- a/src/LaunchDarkly/Server/Client/Internal.hs +++ b/src/LaunchDarkly/Server/Client/Internal.hs @@ -2,19 +2,29 @@ module LaunchDarkly.Server.Client.Internal ( Client (..) , Status (..) , clientVersion + , makeHttpConfiguration , setStatus , getStatusI ) where import Control.Concurrent (ThreadId) import Control.Concurrent.MVar (MVar) +import Data.ByteString (ByteString) import Data.Generics.Product (getField) import Data.IORef (IORef, atomicModifyIORef', readIORef) import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import qualified Data.UUID as UUID +import qualified Data.UUID.V4 as UUIDv4 import GHC.Generics (Generic) +import Network.HTTP.Client (newManager) +import qualified Network.HTTP.Client as Http +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Network.HTTP.Types (HeaderName) import LaunchDarkly.Server.Client.Status (Status (..), transitionStatus) -import LaunchDarkly.Server.Config.Internal (Config) +import LaunchDarkly.Server.Config.HttpConfiguration (HttpConfiguration (..)) +import LaunchDarkly.Server.Config.Internal (ApplicationInfo, Config, getApplicationInfoHeader) import LaunchDarkly.Server.DataSource.Internal (DataSource) import LaunchDarkly.Server.Events (EventState) import LaunchDarkly.Server.Store.Internal (StoreHandle, getInitializedC) @@ -50,3 +60,29 @@ getStatusI client = getInitializedC (getField @"store" client) >>= \case Right True -> pure Initialized _ -> pure Uninitialized + +-- | +-- Build an 'HttpConfiguration' for the given 'Config'. A fresh TLS manager is created and a new +-- per-instance GUID v4 is generated for the 'X-LaunchDarkly-Instance-Id' header. Because the +-- returned 'defaultRequestHeaders' is shared by the polling, streaming, and event clients, every +-- outbound request carries the same stable per-instance identifier without per-channel plumbing. +-- +-- The SDK key, version banner, and (optional) application tags header are also attached here. +makeHttpConfiguration :: Config -> IO HttpConfiguration +makeHttpConfiguration config = do + tlsManager <- newManager tlsManagerSettings + instanceId <- UUIDv4.nextRandom + let baseHeaders = + [ ("Authorization", encodeUtf8 $ getField @"key" config) + , ("User-Agent", "HaskellServerClient/" <> encodeUtf8 clientVersion) + , ("X-LaunchDarkly-Instance-Id", encodeUtf8 $ UUID.toText instanceId) + ] + defaultRequestHeaders = addTagsHeader baseHeaders (getField @"applicationInfo" config) + defaultRequestTimeout = Http.responseTimeoutMicro $ fromIntegral $ getField @"requestTimeoutSeconds" config * 1000000 + pure $ HttpConfiguration {..} + where + addTagsHeader :: [(HeaderName, ByteString)] -> Maybe ApplicationInfo -> [(HeaderName, ByteString)] + addTagsHeader headers Nothing = headers + addTagsHeader headers (Just info) = case getApplicationInfoHeader info of + Nothing -> headers + Just header -> ("X-LaunchDarkly-Tags", encodeUtf8 header) : headers diff --git a/test/Spec.hs b/test/Spec.hs index d98271b..de9fbcc 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -10,6 +10,7 @@ import qualified Spec.Context import qualified Spec.DataSource import qualified Spec.Evaluate import qualified Spec.Features +import qualified Spec.HttpConfiguration import qualified Spec.Integrations.FileData import qualified Spec.Integrations.TestData import qualified Spec.Operators @@ -32,6 +33,7 @@ main = do , Spec.DataSource.allTests , Spec.Evaluate.allTests , Spec.Features.allTests + , Spec.HttpConfiguration.allTests , Spec.Operators.allTests , Spec.Reference.allTests , Spec.Segment.allTests diff --git a/test/Spec/HttpConfiguration.hs b/test/Spec/HttpConfiguration.hs new file mode 100644 index 0000000..0d17da1 --- /dev/null +++ b/test/Spec/HttpConfiguration.hs @@ -0,0 +1,57 @@ +module Spec.HttpConfiguration (allTests) where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import Data.Maybe (isJust) +import qualified Data.Text.Encoding as TE +import qualified Data.UUID as UUID +import Network.HTTP.Types (HeaderName) +import Test.HUnit + +import LaunchDarkly.Server.Client.Internal (makeHttpConfiguration) +import LaunchDarkly.Server.Config (makeConfig) +import LaunchDarkly.Server.Config.HttpConfiguration (HttpConfiguration (..)) + +instanceIdHeaderName :: HeaderName +instanceIdHeaderName = "X-LaunchDarkly-Instance-Id" + +parseUUID :: BS.ByteString -> Maybe UUID.UUID +parseUUID = UUID.fromText . TE.decodeUtf8 + +testMakeHttpConfigurationAttachesInstanceIdHeader :: Test +testMakeHttpConfigurationAttachesInstanceIdHeader = TestCase $ do + httpConfig <- makeHttpConfiguration (makeConfig "sdk-key") + let headers = defaultRequestHeaders httpConfig + case lookup instanceIdHeaderName headers of + Nothing -> assertFailure "X-LaunchDarkly-Instance-Id header missing from defaultRequestHeaders" + Just value -> case parseUUID value of + Nothing -> assertFailure $ "instance id is not a parseable UUID: " <> BSC.unpack value + Just uuid -> + let (_, w2, _, _) = UUID.toWords uuid + versionNibble = (w2 `div` 0x1000) `mod` 0x10 + in assertEqual ("instance id " <> show uuid <> " must be UUID v4") 4 versionNibble + +testMakeHttpConfigurationSetsExactlyOneInstanceIdHeader :: Test +testMakeHttpConfigurationSetsExactlyOneInstanceIdHeader = TestCase $ do + httpConfig <- makeHttpConfiguration (makeConfig "sdk-key") + let headers = defaultRequestHeaders httpConfig + matches = filter ((== instanceIdHeaderName) . fst) headers + assertEqual "exactly one X-LaunchDarkly-Instance-Id header should be set" 1 (length matches) + +testMakeHttpConfigurationGeneratesDistinctInstanceIds :: Test +testMakeHttpConfigurationGeneratesDistinctInstanceIds = TestCase $ do + h1 <- makeHttpConfiguration (makeConfig "sdk-key") + h2 <- makeHttpConfiguration (makeConfig "sdk-key") + let id1 = lookup instanceIdHeaderName (defaultRequestHeaders h1) + id2 = lookup instanceIdHeaderName (defaultRequestHeaders h2) + assertBool "first instance id present" (isJust id1) + assertBool "second instance id present" (isJust id2) + assertBool "each SDK instance should generate its own instance id" (id1 /= id2) + +allTests :: Test +allTests = + TestList + [ testMakeHttpConfigurationAttachesInstanceIdHeader + , testMakeHttpConfigurationSetsExactlyOneInstanceIdHeader + , testMakeHttpConfigurationGeneratesDistinctInstanceIds + ]