feat: add X-LaunchDarkly-Instance-Id header (SDK-2355)

contract-tests/src/Main.hs

@@ -55,6 +55,7 @@ getAppStatus =
                 , "event-gzip"
                 , "optional-event-gzip"
                 , "polling-gzip"
+                , "instance-id"
                 ]
             }
 

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

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

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

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

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
+        ]