From fa28bc7dadad55721712d147cba4de816b3af424 Mon Sep 17 00:00:00 2001 From: Matthew Keeler Date: Tue, 12 May 2026 16:48:08 -0400 Subject: [PATCH 1/3] feat: add X-LaunchDarkly-Instance-Id header (SDK-2355) Generate a v4 UUID once per SDK instance in the HTTP configuration builder and stamp it on defaultRequestHeaders. Because that header list is shared by the polling, streaming, and event clients, every outbound request carries the same stable per-instance identifier without per-channel plumbing. The builder lives in a new internal module LaunchDarkly.Server.Config.HttpConfigurationInternal so it can pull from Config.Internal without creating an import cycle through Config.ClientContext / DataSource.Internal. The instance-id header name and a thin makeInstanceIdHeader helper stay in LaunchDarkly.Server.Config.HttpConfiguration so unit tests can exercise the GUID generation directly. Registers the "instance-id" capability with the contract-test service so the cross-SDK harness can verify the header on stream, poll, and event requests. --- contract-tests/src/Main.hs | 1 + launchdarkly-server-sdk.cabal | 3 + src/LaunchDarkly/Server/Client.hs | 26 +----- .../Server/Config/HttpConfiguration.hs | 27 +++++- .../Config/HttpConfigurationInternal.hs | 57 +++++++++++++ test/Spec.hs | 2 + test/Spec/HttpConfiguration.hs | 85 +++++++++++++++++++ 7 files changed, 177 insertions(+), 24 deletions(-) create mode 100644 src/LaunchDarkly/Server/Config/HttpConfigurationInternal.hs create mode 100644 test/Spec/HttpConfiguration.hs 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..16c8643 100644 --- a/launchdarkly-server-sdk.cabal +++ b/launchdarkly-server-sdk.cabal @@ -52,6 +52,7 @@ library LaunchDarkly.Server.Client.Status LaunchDarkly.Server.Config.ClientContext LaunchDarkly.Server.Config.HttpConfiguration + LaunchDarkly.Server.Config.HttpConfigurationInternal LaunchDarkly.Server.Config.Internal LaunchDarkly.Server.Context.Internal LaunchDarkly.Server.DataSource.Internal @@ -140,6 +141,7 @@ test-suite haskell-server-sdk-test Spec.DataSource Spec.Evaluate Spec.Features + Spec.HttpConfiguration Spec.Integrations.FileData Spec.Integrations.TestData Spec.Operators @@ -157,6 +159,7 @@ test-suite haskell-server-sdk-test LaunchDarkly.Server.Config LaunchDarkly.Server.Config.ClientContext LaunchDarkly.Server.Config.HttpConfiguration + LaunchDarkly.Server.Config.HttpConfigurationInternal LaunchDarkly.Server.Config.Internal LaunchDarkly.Server.Context LaunchDarkly.Server.Context.Internal diff --git a/src/LaunchDarkly/Server/Client.hs b/src/LaunchDarkly/Server/Client.hs index fb0823d..987e270 100644 --- a/src/LaunchDarkly/Server/Client.hs +++ b/src/LaunchDarkly/Server/Client.hs @@ -44,7 +44,6 @@ 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 (..)) @@ -52,8 +51,8 @@ import LaunchDarkly.AesonCompat (KeyMap, emptyObject, filterObject, insertKey, m import LaunchDarkly.Server.Client.Internal (Client (..), clientVersion, getStatusI) 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.HttpConfigurationInternal (makeHttpConfiguration) +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 +68,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,27 +90,10 @@ 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 - httpConfiguration <- makeHttpConfiguration config + httpConfiguration <- makeHttpConfiguration clientVersion config pure $ ClientContext {..} -- | Create a new instance of the LaunchDarkly client. diff --git a/src/LaunchDarkly/Server/Config/HttpConfiguration.hs b/src/LaunchDarkly/Server/Config/HttpConfiguration.hs index deb501b..ceda926 100644 --- a/src/LaunchDarkly/Server/Config/HttpConfiguration.hs +++ b/src/LaunchDarkly/Server/Config/HttpConfiguration.hs @@ -1,12 +1,17 @@ module LaunchDarkly.Server.Config.HttpConfiguration ( HttpConfiguration (..) , prepareRequest + , instanceIdHeader + , makeInstanceIdHeader ) where import Control.Monad.Catch (MonadThrow) +import Data.Text.Encoding (encodeUtf8) +import qualified Data.UUID as UUID +import qualified Data.UUID.V4 as UUIDv4 import Network.HTTP.Client (Manager, Request, ResponseTimeout, parseRequest, requestHeaders, responseTimeout, setRequestIgnoreStatus) -import Network.HTTP.Types (Header) +import Network.HTTP.Types (Header, HeaderName) data HttpConfiguration = HttpConfiguration { defaultRequestHeaders :: ![Header] @@ -14,6 +19,26 @@ data HttpConfiguration = HttpConfiguration , tlsManager :: !Manager } +-- | +-- The HTTP header used to identify this SDK instance for the purpose of estimating +-- server-connection-minutes when polling. It contains a v4 UUID that is generated once per SDK +-- instance and remains constant for the lifetime of the client. +-- +-- See: sdk-specs / SCMP-server-connection-minutes-polling. +instanceIdHeader :: HeaderName +instanceIdHeader = "X-LaunchDarkly-Instance-Id" + +-- | +-- Generate a fresh 'X-LaunchDarkly-Instance-Id' header carrying a new v4 UUID. +-- +-- The caller is expected to invoke this exactly once per SDK instance and store the result on +-- 'defaultRequestHeaders' so that the same identifier rides every polling, streaming, and event +-- request issued by that instance. +makeInstanceIdHeader :: IO Header +makeInstanceIdHeader = do + instanceId <- UUIDv4.nextRandom + pure (instanceIdHeader, encodeUtf8 $ UUID.toText instanceId) + prepareRequest :: (MonadThrow m) => HttpConfiguration -> String -> m Request prepareRequest config uri = do baseReq <- parseRequest uri diff --git a/src/LaunchDarkly/Server/Config/HttpConfigurationInternal.hs b/src/LaunchDarkly/Server/Config/HttpConfigurationInternal.hs new file mode 100644 index 0000000..2cd3052 --- /dev/null +++ b/src/LaunchDarkly/Server/Config/HttpConfigurationInternal.hs @@ -0,0 +1,57 @@ +-- | +-- Internal helpers for assembling an 'HttpConfiguration' from a 'Config'. +-- +-- This module exists separately from "LaunchDarkly.Server.Config.HttpConfiguration" so that the +-- builder can import 'Config.Internal' without creating an import cycle. ('Config.ClientContext' +-- depends on 'Config.HttpConfiguration', and 'Config.Internal' transitively depends on +-- 'Config.ClientContext' via 'DataSource.Internal', so 'Config.HttpConfiguration' itself cannot +-- import 'Config.Internal'.) +module LaunchDarkly.Server.Config.HttpConfigurationInternal + ( makeHttpConfiguration + ) where + +import Data.ByteString (ByteString) +import Data.Generics.Product (getField) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +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.Config.HttpConfiguration (HttpConfiguration (..), makeInstanceIdHeader) +import LaunchDarkly.Server.Config.Internal (ApplicationInfo, Config, getApplicationInfoHeader) + +-- | +-- 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. +-- +-- 'clientVersion' is supplied by the caller (rather than imported from +-- "LaunchDarkly.Server.Client.Internal") to avoid an import cycle. +makeHttpConfiguration :: Text -> Config -> IO HttpConfiguration +makeHttpConfiguration clientVersion config = do + tlsManager <- newManager tlsManagerSettings + -- Per SCMP-server-connection-minutes-polling, every polling request must carry a per-instance + -- GUID v4. We attach it to the default headers (rather than only on the poller) so that it is + -- also present on streaming and event requests; this matches the cross-SDK contract tests and + -- keeps the GUID stable for the lifetime of the SDK instance, since defaultRequestHeaders is + -- built once and never modified after construction. + instanceIdHdr <- makeInstanceIdHeader + let baseHeaders = + [ ("Authorization", encodeUtf8 $ getField @"key" config) + , ("User-Agent", "HaskellServerClient/" <> encodeUtf8 clientVersion) + , instanceIdHdr + ] + 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..532a5c1 --- /dev/null +++ b/test/Spec/HttpConfiguration.hs @@ -0,0 +1,85 @@ +module Spec.HttpConfiguration (allTests) where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import Data.List (nub) +import qualified Data.Text.Encoding as TE +import qualified Data.UUID as UUID +import Network.HTTP.Types (HeaderName) +import Test.HUnit + +import LaunchDarkly.Server.Config (makeConfig) +import LaunchDarkly.Server.Config.HttpConfiguration + ( HttpConfiguration (..) + , instanceIdHeader + , makeInstanceIdHeader + ) +import LaunchDarkly.Server.Config.HttpConfigurationInternal (makeHttpConfiguration) + +parseUUID :: BS.ByteString -> Maybe UUID.UUID +parseUUID = UUID.fromText . TE.decodeUtf8 + +testInstanceIdHeaderConstantName :: Test +testInstanceIdHeaderConstantName = TestCase $ do + -- 'HeaderName' is a case-insensitive 'ByteString'; comparison against the literal here + -- (lifted via OverloadedStrings) verifies we are using the spelling required by the spec. + assertEqual "" ("X-LaunchDarkly-Instance-Id" :: HeaderName) instanceIdHeader + +testMakeInstanceIdHeaderProducesV4 :: Test +testMakeInstanceIdHeaderProducesV4 = TestCase $ do + (name, value) <- makeInstanceIdHeader + assertEqual "header name is X-LaunchDarkly-Instance-Id" instanceIdHeader name + case parseUUID value of + Nothing -> assertFailure $ "value is not a parseable UUID: " <> BSC.unpack value + Just uuid -> + -- A version-4 UUID has version nibble 0x4 in byte index 6 (high nibble). + -- Data.UUID exposes this via 'UUID.toWords' (w2 high byte is version). + let (_, w2, _, _) = UUID.toWords uuid + versionNibble = (w2 `div` 0x1000) `mod` 0x10 + in assertEqual ("instance id " <> show uuid <> " must be UUID v4") 4 versionNibble + +testMakeInstanceIdHeaderProducesUniqueIds :: Test +testMakeInstanceIdHeaderProducesUniqueIds = TestCase $ do + -- Sample a handful of calls; any duplicate within this small set would indicate the GUID + -- source is broken (the v4 namespace has ~5.3e36 values, so genuine collisions are impossible). + ids <- mapM (const (snd <$> makeInstanceIdHeader)) [1 .. (10 :: Int)] + assertEqual "successive instance ids must all differ" (length ids) (length (nub ids)) + +testMakeHttpConfigurationAttachesInstanceIdHeader :: Test +testMakeHttpConfigurationAttachesInstanceIdHeader = TestCase $ do + httpConfig <- makeHttpConfiguration "test-version" (makeConfig "sdk-key") + let headers = defaultRequestHeaders httpConfig + case lookup instanceIdHeader 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 _ -> pure () + +testMakeHttpConfigurationSetsExactlyOneInstanceIdHeader :: Test +testMakeHttpConfigurationSetsExactlyOneInstanceIdHeader = TestCase $ do + httpConfig <- makeHttpConfiguration "test-version" (makeConfig "sdk-key") + let headers = defaultRequestHeaders httpConfig + matches = filter ((== instanceIdHeader) . fst) headers + assertEqual "exactly one X-LaunchDarkly-Instance-Id header should be set" 1 (length matches) + +testMakeHttpConfigurationGeneratesDistinctInstanceIds :: Test +testMakeHttpConfigurationGeneratesDistinctInstanceIds = TestCase $ do + -- Each call to makeHttpConfiguration represents a new SDK instance; each must get its own GUID. + h1 <- makeHttpConfiguration "test-version" (makeConfig "sdk-key") + h2 <- makeHttpConfiguration "test-version" (makeConfig "sdk-key") + let id1 = lookup instanceIdHeader (defaultRequestHeaders h1) + id2 = lookup instanceIdHeader (defaultRequestHeaders h2) + assertBool "first instance id present" (id1 /= Nothing) + assertBool "second instance id present" (id2 /= Nothing) + assertBool "each SDK instance should generate its own instance id" (id1 /= id2) + +allTests :: Test +allTests = + TestList + [ testInstanceIdHeaderConstantName + , testMakeInstanceIdHeaderProducesV4 + , testMakeInstanceIdHeaderProducesUniqueIds + , testMakeHttpConfigurationAttachesInstanceIdHeader + , testMakeHttpConfigurationSetsExactlyOneInstanceIdHeader + , testMakeHttpConfigurationGeneratesDistinctInstanceIds + ] From 715d86cbe483d13895ef5dcf09f0c264aa6f629a Mon Sep 17 00:00:00 2001 From: Matthew Keeler Date: Tue, 12 May 2026 17:42:48 -0400 Subject: [PATCH 2/3] chore: fix hlint warnings (SDK-2355) Replace `x /= Nothing` with `isJust x` in two assertions in Spec.HttpConfiguration, per hlint's "Use isJust" suggestion. The quality-checks CI job runs hlint with `fail-on: warning` and was failing on these two warnings. --- test/Spec/HttpConfiguration.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/test/Spec/HttpConfiguration.hs b/test/Spec/HttpConfiguration.hs index 532a5c1..9e3b954 100644 --- a/test/Spec/HttpConfiguration.hs +++ b/test/Spec/HttpConfiguration.hs @@ -3,6 +3,7 @@ module Spec.HttpConfiguration (allTests) where import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import Data.List (nub) +import Data.Maybe (isJust) import qualified Data.Text.Encoding as TE import qualified Data.UUID as UUID import Network.HTTP.Types (HeaderName) @@ -69,8 +70,8 @@ testMakeHttpConfigurationGeneratesDistinctInstanceIds = TestCase $ do h2 <- makeHttpConfiguration "test-version" (makeConfig "sdk-key") let id1 = lookup instanceIdHeader (defaultRequestHeaders h1) id2 = lookup instanceIdHeader (defaultRequestHeaders h2) - assertBool "first instance id present" (id1 /= Nothing) - assertBool "second instance id present" (id2 /= Nothing) + 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 From 28900f896efb28f71203f3c35cc451a998bac95f Mon Sep 17 00:00:00 2001 From: Matthew Keeler Date: Wed, 13 May 2026 16:38:40 -0400 Subject: [PATCH 3/3] chore: Consolidate HttpConfiguration builder into Client.Internal (SDK-2355) Moves makeHttpConfiguration into Client.Internal alongside clientVersion, removing the Config/HttpConfigurationInternal module that existed only to work around an import cycle. The instance-id header is generated inline in makeHttpConfiguration rather than via a separate makeInstanceIdHeader helper, so Config.HttpConfiguration is back to just the HttpConfiguration type and prepareRequest. --- launchdarkly-server-sdk.cabal | 2 - src/LaunchDarkly/Server/Client.hs | 5 +- src/LaunchDarkly/Server/Client/Internal.hs | 38 ++++++++++- .../Server/Config/HttpConfiguration.hs | 27 +------- .../Config/HttpConfigurationInternal.hs | 57 ---------------- test/Spec/HttpConfiguration.hs | 65 +++++-------------- 6 files changed, 58 insertions(+), 136 deletions(-) delete mode 100644 src/LaunchDarkly/Server/Config/HttpConfigurationInternal.hs diff --git a/launchdarkly-server-sdk.cabal b/launchdarkly-server-sdk.cabal index 16c8643..6ef83c2 100644 --- a/launchdarkly-server-sdk.cabal +++ b/launchdarkly-server-sdk.cabal @@ -52,7 +52,6 @@ library LaunchDarkly.Server.Client.Status LaunchDarkly.Server.Config.ClientContext LaunchDarkly.Server.Config.HttpConfiguration - LaunchDarkly.Server.Config.HttpConfigurationInternal LaunchDarkly.Server.Config.Internal LaunchDarkly.Server.Context.Internal LaunchDarkly.Server.DataSource.Internal @@ -159,7 +158,6 @@ test-suite haskell-server-sdk-test LaunchDarkly.Server.Config LaunchDarkly.Server.Config.ClientContext LaunchDarkly.Server.Config.HttpConfiguration - LaunchDarkly.Server.Config.HttpConfigurationInternal LaunchDarkly.Server.Config.Internal LaunchDarkly.Server.Context LaunchDarkly.Server.Context.Internal diff --git a/src/LaunchDarkly/Server/Client.hs b/src/LaunchDarkly/Server/Client.hs index 987e270..a1b5cf3 100644 --- a/src/LaunchDarkly/Server/Client.hs +++ b/src/LaunchDarkly/Server/Client.hs @@ -48,10 +48,9 @@ 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.HttpConfigurationInternal (makeHttpConfiguration) import LaunchDarkly.Server.Config.Internal (Config, shouldSendEvents) import LaunchDarkly.Server.Context (getValue) import LaunchDarkly.Server.Context.Internal (Context (Invalid), getCanonicalKey, getKey, optionallyRedactAnonymous, redactContext, redactContextRedactAnonymous) @@ -93,7 +92,7 @@ networkDataSourceFactory threadF clientContext dataSourceUpdates = do makeClientContext :: Config -> IO ClientContext makeClientContext config = do let runLogger = getField @"logger" config - httpConfiguration <- makeHttpConfiguration clientVersion config + httpConfiguration <- makeHttpConfiguration config pure $ ClientContext {..} -- | Create a new instance of the LaunchDarkly client. 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/src/LaunchDarkly/Server/Config/HttpConfiguration.hs b/src/LaunchDarkly/Server/Config/HttpConfiguration.hs index ceda926..deb501b 100644 --- a/src/LaunchDarkly/Server/Config/HttpConfiguration.hs +++ b/src/LaunchDarkly/Server/Config/HttpConfiguration.hs @@ -1,17 +1,12 @@ module LaunchDarkly.Server.Config.HttpConfiguration ( HttpConfiguration (..) , prepareRequest - , instanceIdHeader - , makeInstanceIdHeader ) where import Control.Monad.Catch (MonadThrow) -import Data.Text.Encoding (encodeUtf8) -import qualified Data.UUID as UUID -import qualified Data.UUID.V4 as UUIDv4 import Network.HTTP.Client (Manager, Request, ResponseTimeout, parseRequest, requestHeaders, responseTimeout, setRequestIgnoreStatus) -import Network.HTTP.Types (Header, HeaderName) +import Network.HTTP.Types (Header) data HttpConfiguration = HttpConfiguration { defaultRequestHeaders :: ![Header] @@ -19,26 +14,6 @@ data HttpConfiguration = HttpConfiguration , tlsManager :: !Manager } --- | --- The HTTP header used to identify this SDK instance for the purpose of estimating --- server-connection-minutes when polling. It contains a v4 UUID that is generated once per SDK --- instance and remains constant for the lifetime of the client. --- --- See: sdk-specs / SCMP-server-connection-minutes-polling. -instanceIdHeader :: HeaderName -instanceIdHeader = "X-LaunchDarkly-Instance-Id" - --- | --- Generate a fresh 'X-LaunchDarkly-Instance-Id' header carrying a new v4 UUID. --- --- The caller is expected to invoke this exactly once per SDK instance and store the result on --- 'defaultRequestHeaders' so that the same identifier rides every polling, streaming, and event --- request issued by that instance. -makeInstanceIdHeader :: IO Header -makeInstanceIdHeader = do - instanceId <- UUIDv4.nextRandom - pure (instanceIdHeader, encodeUtf8 $ UUID.toText instanceId) - prepareRequest :: (MonadThrow m) => HttpConfiguration -> String -> m Request prepareRequest config uri = do baseReq <- parseRequest uri diff --git a/src/LaunchDarkly/Server/Config/HttpConfigurationInternal.hs b/src/LaunchDarkly/Server/Config/HttpConfigurationInternal.hs deleted file mode 100644 index 2cd3052..0000000 --- a/src/LaunchDarkly/Server/Config/HttpConfigurationInternal.hs +++ /dev/null @@ -1,57 +0,0 @@ --- | --- Internal helpers for assembling an 'HttpConfiguration' from a 'Config'. --- --- This module exists separately from "LaunchDarkly.Server.Config.HttpConfiguration" so that the --- builder can import 'Config.Internal' without creating an import cycle. ('Config.ClientContext' --- depends on 'Config.HttpConfiguration', and 'Config.Internal' transitively depends on --- 'Config.ClientContext' via 'DataSource.Internal', so 'Config.HttpConfiguration' itself cannot --- import 'Config.Internal'.) -module LaunchDarkly.Server.Config.HttpConfigurationInternal - ( makeHttpConfiguration - ) where - -import Data.ByteString (ByteString) -import Data.Generics.Product (getField) -import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) -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.Config.HttpConfiguration (HttpConfiguration (..), makeInstanceIdHeader) -import LaunchDarkly.Server.Config.Internal (ApplicationInfo, Config, getApplicationInfoHeader) - --- | --- 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. --- --- 'clientVersion' is supplied by the caller (rather than imported from --- "LaunchDarkly.Server.Client.Internal") to avoid an import cycle. -makeHttpConfiguration :: Text -> Config -> IO HttpConfiguration -makeHttpConfiguration clientVersion config = do - tlsManager <- newManager tlsManagerSettings - -- Per SCMP-server-connection-minutes-polling, every polling request must carry a per-instance - -- GUID v4. We attach it to the default headers (rather than only on the poller) so that it is - -- also present on streaming and event requests; this matches the cross-SDK contract tests and - -- keeps the GUID stable for the lifetime of the SDK instance, since defaultRequestHeaders is - -- built once and never modified after construction. - instanceIdHdr <- makeInstanceIdHeader - let baseHeaders = - [ ("Authorization", encodeUtf8 $ getField @"key" config) - , ("User-Agent", "HaskellServerClient/" <> encodeUtf8 clientVersion) - , instanceIdHdr - ] - 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/HttpConfiguration.hs b/test/Spec/HttpConfiguration.hs index 9e3b954..0d17da1 100644 --- a/test/Spec/HttpConfiguration.hs +++ b/test/Spec/HttpConfiguration.hs @@ -2,74 +2,48 @@ module Spec.HttpConfiguration (allTests) where import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC -import Data.List (nub) 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 (..) - , instanceIdHeader - , makeInstanceIdHeader - ) -import LaunchDarkly.Server.Config.HttpConfigurationInternal (makeHttpConfiguration) +import LaunchDarkly.Server.Config.HttpConfiguration (HttpConfiguration (..)) + +instanceIdHeaderName :: HeaderName +instanceIdHeaderName = "X-LaunchDarkly-Instance-Id" parseUUID :: BS.ByteString -> Maybe UUID.UUID parseUUID = UUID.fromText . TE.decodeUtf8 -testInstanceIdHeaderConstantName :: Test -testInstanceIdHeaderConstantName = TestCase $ do - -- 'HeaderName' is a case-insensitive 'ByteString'; comparison against the literal here - -- (lifted via OverloadedStrings) verifies we are using the spelling required by the spec. - assertEqual "" ("X-LaunchDarkly-Instance-Id" :: HeaderName) instanceIdHeader - -testMakeInstanceIdHeaderProducesV4 :: Test -testMakeInstanceIdHeaderProducesV4 = TestCase $ do - (name, value) <- makeInstanceIdHeader - assertEqual "header name is X-LaunchDarkly-Instance-Id" instanceIdHeader name - case parseUUID value of - Nothing -> assertFailure $ "value is not a parseable UUID: " <> BSC.unpack value - Just uuid -> - -- A version-4 UUID has version nibble 0x4 in byte index 6 (high nibble). - -- Data.UUID exposes this via 'UUID.toWords' (w2 high byte is version). - let (_, w2, _, _) = UUID.toWords uuid - versionNibble = (w2 `div` 0x1000) `mod` 0x10 - in assertEqual ("instance id " <> show uuid <> " must be UUID v4") 4 versionNibble - -testMakeInstanceIdHeaderProducesUniqueIds :: Test -testMakeInstanceIdHeaderProducesUniqueIds = TestCase $ do - -- Sample a handful of calls; any duplicate within this small set would indicate the GUID - -- source is broken (the v4 namespace has ~5.3e36 values, so genuine collisions are impossible). - ids <- mapM (const (snd <$> makeInstanceIdHeader)) [1 .. (10 :: Int)] - assertEqual "successive instance ids must all differ" (length ids) (length (nub ids)) - testMakeHttpConfigurationAttachesInstanceIdHeader :: Test testMakeHttpConfigurationAttachesInstanceIdHeader = TestCase $ do - httpConfig <- makeHttpConfiguration "test-version" (makeConfig "sdk-key") + httpConfig <- makeHttpConfiguration (makeConfig "sdk-key") let headers = defaultRequestHeaders httpConfig - case lookup instanceIdHeader headers of + 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 _ -> pure () + 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 "test-version" (makeConfig "sdk-key") + httpConfig <- makeHttpConfiguration (makeConfig "sdk-key") let headers = defaultRequestHeaders httpConfig - matches = filter ((== instanceIdHeader) . fst) headers + matches = filter ((== instanceIdHeaderName) . fst) headers assertEqual "exactly one X-LaunchDarkly-Instance-Id header should be set" 1 (length matches) testMakeHttpConfigurationGeneratesDistinctInstanceIds :: Test testMakeHttpConfigurationGeneratesDistinctInstanceIds = TestCase $ do - -- Each call to makeHttpConfiguration represents a new SDK instance; each must get its own GUID. - h1 <- makeHttpConfiguration "test-version" (makeConfig "sdk-key") - h2 <- makeHttpConfiguration "test-version" (makeConfig "sdk-key") - let id1 = lookup instanceIdHeader (defaultRequestHeaders h1) - id2 = lookup instanceIdHeader (defaultRequestHeaders h2) + 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) @@ -77,10 +51,7 @@ testMakeHttpConfigurationGeneratesDistinctInstanceIds = TestCase $ do allTests :: Test allTests = TestList - [ testInstanceIdHeaderConstantName - , testMakeInstanceIdHeaderProducesV4 - , testMakeInstanceIdHeaderProducesUniqueIds - , testMakeHttpConfigurationAttachesInstanceIdHeader + [ testMakeHttpConfigurationAttachesInstanceIdHeader , testMakeHttpConfigurationSetsExactlyOneInstanceIdHeader , testMakeHttpConfigurationGeneratesDistinctInstanceIds ]