fix(users/Profpatsch/whatcd-resolver): fix transmission session

The logic around transmission session handling was f*cked, this fixes
that.

We use an IORef instead of an MVar, since we want to unconditionally
write the new value. Even if multiple requests race, I *hope* that
transmission returns the same session id, otherwise we might get a
request loop. But it should be fine. (The semantics is not nicely
documented in the RPC docs.)

Additionally, log the session ids in the requests.

Change-Id: Id7d33f8cb74cb349e502331cad5eb5abe8a624cd
Reviewed-on: https://cl.tvl.fyi/c/depot/+/11673
Autosubmit: Profpatsch <mail@profpatsch.de>
Reviewed-by: Profpatsch <mail@profpatsch.de>
Tested-by: BuildkiteCI

users/Profpatsch/whatcd-resolver/src/AppT.hs

@@ -27,7 +27,7 @@ data Context = Context
     tracer :: Otel.Tracer,
     pgFormat :: PgFormatPool,
     pgConnPool :: Pool Postgres.Connection,
-    transmissionSessionId :: MVar ByteString
+    transmissionSessionId :: IORef (Maybe ByteString)
   }
 
 newtype AppT m a = AppT {unAppT :: ReaderT Context m a}

users/Profpatsch/whatcd-resolver/src/Transmission.hs

@@ -25,6 +25,7 @@ import Json.Enc qualified as Enc
 import Label
 import MyPrelude
 import Network.HTTP.Types
+import OpenTelemetry.Attributes (ToAttribute (toAttribute))
 import OpenTelemetry.Trace qualified as Otel hiding (getTracer, inSpan, inSpan')
 import Optional
 import Postgres.MonadPostgres
@@ -226,7 +227,7 @@ doTransmissionRequest ::
   (TransmissionRequest, Json.Parse Error output) ->
   m (TransmissionResponse output)
 doTransmissionRequest span dat (req, parser) = do
-  sessionId <- getTransmissionId
+  sessionId <- getCurrentTransmissionSessionId
   let textArg t = (Enc.text t, Otel.toAttribute @Text t)
   let encArg enc = (enc, Otel.toAttribute @Text $ enc & Enc.encToTextPretty)
   let intArg i = (Enc.int i, Otel.toAttribute @Int i)
@@ -257,7 +258,7 @@ doTransmissionRequest span dat (req, parser) = do
       (body <&> second fst & Enc.object)
   -- Implement the CSRF protection thingy
   case resp & Http.getResponseStatus & (.statusCode) of
-    409 -> do
+    409 -> inSpan' "New Transmission Session ID" $ \span' -> do
       tid <-
         resp
           & Http.getResponseHeader "X-Transmission-Session-Id"
@@ -266,9 +267,21 @@ doTransmissionRequest span dat (req, parser) = do
           & unwrapIOError
           & liftIO
           <&> NonEmpty.head
-      setTransmissionId tid
+
+      addAttributes span' $
+        HashMap.fromList
+          [ ("transmission.new_session_id", tid & bytesToTextUtf8Lenient & toAttribute),
+            ("transmission.old_session_id", sessionId <&> bytesToTextUtf8Lenient & fromMaybe "<none yet>" & toAttribute)
+          ]
+
+      updateTransmissionSessionId tid
+
       doTransmissionRequest span dat (req, parser)
-    200 ->
+    200 -> do
+      addAttributes span $
+        HashMap.fromList
+          [ ("transmission.valid_session_id", sessionId <&> bytesToTextUtf8Lenient & fromMaybe "<none yet>" & toAttribute)
+          ]
       resp
         & Http.getResponseBody
         & Json.parseStrict
@@ -296,11 +309,11 @@ doTransmissionRequest span dat (req, parser) = do
     _ -> liftIO $ unwrapIOError $ Left [fmt|Non-200 response: {showPretty resp}|]
 
 class MonadTransmission m where
-  getTransmissionId :: m (Maybe ByteString)
+  getCurrentTransmissionSessionId :: m (Maybe ByteString)
-  setTransmissionId :: ByteString -> m ()
+  updateTransmissionSessionId :: ByteString -> m ()
 
 instance (MonadIO m) => MonadTransmission (AppT m) where
-  getTransmissionId = AppT (asks (.transmissionSessionId)) >>= tryTakeMVar
+  getCurrentTransmissionSessionId = AppT (asks (.transmissionSessionId)) >>= readIORef
-  setTransmissionId t = do
+  updateTransmissionSessionId t = do
     var <- AppT $ asks (.transmissionSessionId)
-    putMVar var t
+    writeIORef var (Just t)

users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs

@@ -688,7 +688,7 @@ runAppWith appT = withTracer $ \tracer -> withDb $ \db -> do
         {- resource destruction -} Postgres.close
         {- unusedResourceOpenTime -} 10
         {- max resources across all stripes -} 20
-  transmissionSessionId <- newEmptyMVar
+  transmissionSessionId <- newIORef Nothing
   let newAppT = do
         logInfo [fmt|Running with config: {showPretty config}|]
         logInfo [fmt|Connected to database at {db & TmpPg.toDataDirectory} on socket {db & TmpPg.toConnectionString}|]