maurice/snix
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source 
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>
This commit is contained in:
Profpatsch 2024-03-23 05:36:47 +01:00 • committed by clbot
parent 0b78998509
commit eeb5e7abd6
10 changed files with 201 additions and 42 deletions
Download patch file Download diff file Expand all files Collapse all files

30
users/Profpatsch/whatcd-resolver/src/Transmission.hs
View file

@ -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