feat(users/Profpatsch/whatcd-resolver): trace http requests

Move the http calls into their own module, so we can trace the request
and provide a simple copy-to-replay command.

We have to work around a bug in the otel library, which would limit
our attribute value length to 128 bytes because it uses the wrong
option value.

~~~

`ifExists` is finally made more useful for dealing with optional
attributes in e.g. lists.

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

users/Profpatsch/my-prelude/src/MyPrelude.hs

@@ -757,25 +757,19 @@ mapFromListOnMerge f xs =
 ifTrue :: (Monoid m) => Bool -> m -> m
 ifTrue pred' m = if pred' then m else mempty
 
--- | If the given @Maybe@ is @Just@, return the @m@, else return mempty.
+-- | If the given @Maybe@ is @Just@, return the result of `f` wrapped in `pure`, else return `mempty`.
 
 -- This can be used (together with `ifTrue`) to e.g. create lists with optional elements:
 --
 -- >>> import Data.Monoid (Sum(..))
 --
 -- >>> :{ mconcat [
---   ifExists (Just [1]),
---   [2, 3, 4],
---   ifExists Nothing,
--- ]
--- :}
--- [1,2,3,4]
+-- unknown command '{'
 --
 -- Or any other Monoid:
 --
--- >>> mconcat [ Sum 1, ifExists (Just (Sum 2)), Sum 3 ]
-
+-- >>> mconcat [ Sum 1, ifExists id (Just 2), Sum 3 ]
 -- Sum {getSum = 6}
 
-ifExists :: (Monoid m) => Maybe m -> m
-ifExists = fold
+ifExists :: (Monoid (f b), Applicative f) => (a -> b) -> Maybe a -> f b
+ifExists f m = m & foldMap @Maybe (pure . f)

users/Profpatsch/shell.nix

@@ -56,6 +56,7 @@ pkgs.mkShell {
       h.resource-pool
       h.xmonad-contrib
       h.hs-opentelemetry-sdk
+      h.punycode
     ]))
 
     pkgs.rustup

users/Profpatsch/whatcd-resolver/default.nix

@@ -13,7 +13,9 @@ let
       ./src/WhatcdResolver.hs
       ./src/AppT.hs
       ./src/JsonLd.hs
+      ./src/Optional.hs
       ./src/Html.hs
+      ./src/Http.hs
       ./src/Transmission.hs
       ./src/Redacted.hs
     ];

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

@@ -0,0 +1,129 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Http
+  ( doRequestJson,
+    RequestOptions (..),
+    mkRequestOptions,
+    setRequestMethod,
+    setRequestBodyLBS,
+    setRequestHeader,
+    getResponseStatus,
+    getResponseHeader,
+    getResponseBody,
+  )
+where
+
+import AppT
+import Data.CaseInsensitive (CI (original))
+import Data.Char qualified as Char
+import Data.Int (Int64)
+import Data.List qualified as List
+import Data.Text qualified as Text
+import Data.Text.Lazy qualified as Lazy.Text
+import Data.Text.Punycode qualified as Punycode
+import Json.Enc qualified as Enc
+import MyPrelude
+import Network.HTTP.Client
+import Network.HTTP.Simple
+import OpenTelemetry.Attributes qualified as Otel
+import Optional
+import Prelude hiding (span)
+
+data RequestOptions = RequestOptions
+  { method :: ByteString,
+    host :: Text,
+    port :: Optional Int,
+    path :: Optional [Text],
+    headers :: Optional [Header],
+    usePlainHttp :: Optional Bool
+  }
+
+mkRequestOptions :: (HasField "method" r ByteString, HasField "host" r Text) => r -> RequestOptions
+mkRequestOptions opts =
+  RequestOptions
+    { method = opts.method,
+      port = defaults,
+      host = opts.host,
+      path = defaults,
+      headers = defaults,
+      usePlainHttp = defaults
+    }
+
+doRequestJson ::
+  (MonadOtel m) =>
+  RequestOptions ->
+  Enc.Enc ->
+  m (Response ByteString)
+doRequestJson opts val = inSpan' "HTTP Request (JSON)" $ \span -> do
+  let x = requestToXhCommandLine opts val
+  let attrs = [100, 200 .. fromIntegral @Int @Int64 (x & Text.length)]
+  for_ attrs $ \n -> do
+    addAttribute span [fmt|request.xh.{n}|] (Lazy.Text.repeat 'x' & Lazy.Text.take n & toStrict & Otel.TextAttribute)
+  addAttribute span "request.xh" (requestToXhCommandLine opts val)
+  defaultRequest {secure = not (opts & optsUsePlainHttp)}
+    & setRequestHost (opts & optsHost)
+    & setRequestPort (opts & optsPort)
+    -- TODO: is this automatically escaped by the library?
+    & setRequestPath (opts & optsPath)
+    & setRequestHeaders (opts & optsHeaders)
+    & setRequestMethod opts.method
+    & setRequestBodyLBS (Enc.encToBytesUtf8Lazy val)
+    & httpBS
+
+optsHost :: RequestOptions -> ByteString
+optsHost opts =
+  if opts.host & Text.isAscii
+    then opts.host & textToBytesUtf8
+    else opts.host & Punycode.encode
+
+optsUsePlainHttp :: RequestOptions -> Bool
+optsUsePlainHttp opts = opts.usePlainHttp.withDefault False
+
+optsPort :: RequestOptions -> Int
+optsPort opts = opts.port.withDefault (if opts & optsUsePlainHttp then 80 else 443)
+
+optsPath :: RequestOptions -> ByteString
+optsPath opts = opts.path.withDefault [] & Text.intercalate "/" & ("/" <>) & textToBytesUtf8
+
+optsHeaders :: RequestOptions -> [Header]
+optsHeaders opts = opts.headers.withDefault []
+
+-- | Create a string that can be pasted on the command line to invoke the same HTTP request via the `xh` tool (curl but nicer syntax)
+requestToXhCommandLine :: RequestOptions -> Enc.Enc -> Text
+requestToXhCommandLine opts val = do
+  let protocol = if opts & optsUsePlainHttp then "http" :: Text else "https"
+  let url = [fmt|{protocol}://{opts & optsHost}:{opts & optsPort}{opts & optsPath}|]
+  let headers = opts & optsHeaders <&> \(hdr, v) -> hdr.original <> ":" <> v
+
+  prettyArgsForBash $
+    mconcat
+      [ ["xh", url],
+        headers <&> bytesToTextUtf8Lenient,
+        ["--raw"],
+        [val & Enc.encToBytesUtf8 & bytesToTextUtf8Lenient]
+      ]
+
+-- | Pretty print a command line in a way that can be copied to bash.
+prettyArgsForBash :: [Text] -> Text
+prettyArgsForBash = Text.intercalate " " . map simpleBashEscape
+
+-- | Simple escaping for bash words. If they contain anything that’s not ascii chars
+-- and a bunch of often-used special characters, put the word in single quotes.
+simpleBashEscape :: Text -> Text
+simpleBashEscape t = do
+  case Text.find (not . isSimple) t of
+    Just _ -> escapeSingleQuote t
+    Nothing -> t
+  where
+    -- any word that is just ascii characters is simple (no spaces or control characters)
+    -- or contains a few often-used characters like - or .
+    isSimple c =
+      Char.isAsciiLower c
+        || Char.isAsciiUpper c
+        || Char.isDigit c
+        -- These are benign, bash will not interpret them as special characters.
+        || List.elem c ['-', '.', ':', '/']
+    -- Put the word in single quotes
+    -- If there is a single quote in the word,
+    -- close the single quoted word, add a single quote, open the word again
+    escapeSingleQuote t' = "'" <> Text.replace "'" "'\\''" t' <> "'"

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

@@ -20,6 +20,7 @@ import Network.HTTP.Client.Conduit qualified as Http
 import Network.HTTP.Simple qualified as Http
 import Network.HTTP.Types.URI qualified as Url
 import Network.URI (URI)
+import Optional
 import Redacted
 import Text.Blaze.Html (Html)
 import Prelude hiding (span)

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

@@ -0,0 +1,18 @@
+module Optional where
+
+import GHC.Records (getField)
+import MyPrelude
+
+newtype Optional a = OptionalInternal (Maybe a)
+  deriving newtype (Functor)
+
+mkOptional :: a -> Optional a
+mkOptional defaultValue = OptionalInternal $ Just defaultValue
+
+defaults :: Optional a
+defaults = OptionalInternal Nothing
+
+instance HasField "withDefault" (Optional a) (a -> a) where
+  getField (OptionalInternal m) defaultValue = case m of
+    Nothing -> defaultValue
+    Just a -> a

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

@@ -14,7 +14,6 @@ import Database.PostgreSQL.Simple (Binary (Binary), Only (..))
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Database.PostgreSQL.Simple.Types (PGArray (PGArray))
 import FieldParser qualified as Field
-import GHC.Records (HasField (..))
 import Json qualified
 import Label
 import MyPrelude
@@ -23,6 +22,7 @@ import Network.HTTP.Simple qualified as Http
 import Network.HTTP.Types
 import Network.Wai.Parse qualified as Wai
 import OpenTelemetry.Trace qualified as Otel hiding (getTracer, inSpan, inSpan')
+import Optional
 import Postgres.Decoder qualified as Dec
 import Postgres.MonadPostgres
 import Pretty
@@ -134,7 +134,7 @@ redactedSearchAndInsert extraArguments = do
       redactedSearch
         ( extraArguments
             -- pass the page (for every search but the first one)
-            <> ifExists (mpage <&> (\page -> [("page", (page :: Natural) & showToText & textToBytesUtf8)]))
+            <> (mpage & ifExists (\page -> ("page", (page :: Natural) & showToText & textToBytesUtf8)))
         )
         ( do
             status <- Json.key "status" Json.asText
@@ -361,7 +361,7 @@ data TorrentData transmissionInfo = TorrentData
     torrentId :: Int,
     seedingWeight :: Int,
     torrentJson :: Json.Value,
-    torrentGroupJson :: T2 "artist" Text "groupName" Text,
+    torrentGroupJson :: T3 "artist" Text "groupName" Text "groupYear" Int,
     torrentStatus :: TorrentStatus transmissionInfo
   }
 
@@ -411,7 +411,8 @@ getBestTorrents = do
           ( Dec.json $ do
               artist <- Json.keyLabel @"artist" "artist" Json.asText
               groupName <- Json.keyLabel @"groupName" "groupName" Json.asText
-              pure $ T2 artist groupName
+              groupYear <- Json.keyLabel @"groupYear" "groupYear" (Json.asIntegral @_ @Int)
+              pure $ T3 artist groupName groupYear
             )
         hasTorrentFile <- Dec.fromField @Bool
         transmissionTorrentHash <-
@@ -479,19 +480,6 @@ httpTorrent span req =
             | code <- statusCode -> Left [fmt|Redacted returned an non-200 error code, code {code}: {resp & showPretty}|]
       )
 
-newtype Optional a = OptionalInternal (Maybe a)
-
-mkOptional :: a -> Optional a
-mkOptional defaultValue = OptionalInternal $ Just defaultValue
-
-defaults :: Optional a
-defaults = OptionalInternal Nothing
-
-instance HasField "withDefault" (Optional a) (a -> a) where
-  getField (OptionalInternal m) defaultValue = case m of
-    Nothing -> defaultValue
-    Just a -> a
-
 httpJson ::
   ( MonadThrow m,
     MonadOtel m

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

@@ -18,15 +18,15 @@ import Database.PostgreSQL.Simple.Types (PGArray (PGArray))
 import FieldParser (FieldParser' (..))
 import FieldParser qualified as Field
 import Html qualified
+import Http qualified
 import Json qualified
 import Json.Enc (Enc)
 import Json.Enc qualified as Enc
 import Label
 import MyPrelude
-import Network.HTTP.Simple qualified as Http
 import Network.HTTP.Types
 import OpenTelemetry.Trace qualified as Otel hiding (getTracer, inSpan, inSpan')
-import OpenTelemetry.Trace.Monad qualified as Otel
+import Optional
 import Postgres.MonadPostgres
 import Pretty
 import Text.Blaze.Html (Html)
@@ -116,8 +116,8 @@ data TransmissionRequest = TransmissionRequest
   }
   deriving stock (Show)
 
-transmissionConnectionConfig :: T2 "host" Text "port" Text
-transmissionConnectionConfig = (T2 (label @"host" "localhost") (label @"port" "9091"))
+transmissionConnectionConfig :: T3 "host" Text "port" Int "usePlainHttp" Bool
+transmissionConnectionConfig = (T3 (label @"host" "localhost") (label @"port" 9091) (label @"usePlainHttp" True))
 
 transmissionRequestListAllTorrents :: (Monad m) => [Text] -> Json.ParseT e m out -> (TransmissionRequest, Json.ParseT e m [out])
 transmissionRequestListAllTorrents fields parseTorrent =
@@ -215,11 +215,11 @@ doTransmissionRequest' req = inSpan' "Transmission Request" $ \span -> do
 doTransmissionRequest ::
   ( MonadTransmission m,
     HasField "host" t1 Text,
-    HasField "port" t1 Text,
+    HasField "port" t1 Int,
+    HasField "usePlainHttp" t1 Bool,
     MonadThrow m,
     MonadLogger m,
-    Otel.MonadTracer m,
-    MonadUnliftIO m
+    MonadOtel m
   ) =>
   Otel.Span ->
   t1 ->
@@ -245,12 +245,16 @@ doTransmissionRequest span dat (req, parser) = do
             (\k -> [fmt|transmission.{k}|])
             (\(_, attr) -> attr)
     )
-  let httpReq =
-        [fmt|http://{dat.host}:{dat.port}/transmission/rpc|]
-          & Http.setRequestMethod "POST"
-          & Http.setRequestBodyLBS (Enc.encToBytesUtf8Lazy (body <&> second fst & Enc.object))
-          & (sessionId & maybe id (Http.setRequestHeader "X-Transmission-Session-Id" . (: [])))
-  resp <- Http.httpBS httpReq
+  resp <-
+    Http.doRequestJson
+      ( (Http.mkRequestOptions (T2 (label @"method" "POST") (label @"host" dat.host)))
+          { Http.path = mkOptional ["transmission", "rpc"],
+            Http.port = mkOptional dat.port,
+            Http.headers = mkOptional $ (sessionId & ifExists ("X-Transmission-Session-Id",)),
+            Http.usePlainHttp = mkOptional dat.usePlainHttp
+          }
+      )
+      (body <&> second fst & Enc.object)
   -- Implement the CSRF protection thingy
   case resp & Http.getResponseStatus & (.statusCode) of
     409 -> do

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

@@ -40,6 +40,7 @@ import Network.URI qualified as URI
 import Network.Wai qualified as Wai
 import Network.Wai.Handler.Warp qualified as Warp
 import Network.Wai.Parse qualified as Wai
+import OpenTelemetry.Attributes qualified as Otel
 import OpenTelemetry.Trace qualified as Otel hiding (getTracer, inSpan, inSpan')
 import OpenTelemetry.Trace.Monad qualified as Otel
 import Parse (Parse)
@@ -596,7 +597,22 @@ withTracer f = do
   setDefaultEnv "OTEL_SERVICE_NAME" "whatcd-resolver"
   bracket
     -- Install the SDK, pulling configuration from the environment
-    Otel.initializeGlobalTracerProvider
+    ( do
+        (processors, opts) <- Otel.getTracerProviderInitializationOptions
+        tp <-
+          Otel.createTracerProvider
+            processors
+            -- workaround the attribute length bug https://github.com/iand675/hs-opentelemetry/issues/113
+            ( opts
+                { Otel.tracerProviderOptionsAttributeLimits =
+                    opts.tracerProviderOptionsAttributeLimits
+                      { Otel.attributeCountLimit = Just 65_000
+                      }
+                }
+            )
+        Otel.setGlobalTracerProvider tp
+        pure tp
+    )
     -- Ensure that any spans that haven't been exported yet are flushed
     Otel.shutdownTracerProvider
     -- Get a tracer so you can create spans

users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal

@@ -66,6 +66,8 @@ library
        WhatcdResolver
        AppT
        JsonLd
+       Optional
+       Http
        Html
        Transmission
        Redacted
@@ -84,7 +86,9 @@ library
         aeson-better-errors,
         aeson,
         blaze-html,
+        blaze-markup,
         bytestring,
+        case-insensitive,
         containers,
         unordered-containers,
         directory,
@@ -95,12 +99,14 @@ library
         hs-opentelemetry-api,
         http-conduit,
         http-types,
+        http-client,
         ihp-hsx,
         monad-logger,
         mtl,
         network-uri,
         resource-pool,
         postgresql-simple,
+        punycode,
         scientific,
         selective,
         tmp-postgres,