diff options
Diffstat (limited to 'users/Profpatsch/whatcd-resolver')
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/default.nix | 2 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/Http.hs | 129 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/JsonLd.hs | 1 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/Optional.hs | 18 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/Redacted.hs | 22 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/Transmission.hs | 30 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs | 18 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal | 6 |
8 files changed, 195 insertions, 31 deletions
diff --git a/users/Profpatsch/whatcd-resolver/default.nix b/users/Profpatsch/whatcd-resolver/default.nix index 7862b8dc6584..6d5d0834b1a7 100644 --- a/users/Profpatsch/whatcd-resolver/default.nix +++ b/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 ]; diff --git a/users/Profpatsch/whatcd-resolver/src/Http.hs b/users/Profpatsch/whatcd-resolver/src/Http.hs new file mode 100644 index 000000000000..4fdbb306ad18 --- /dev/null +++ b/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' <> "'" diff --git a/users/Profpatsch/whatcd-resolver/src/JsonLd.hs b/users/Profpatsch/whatcd-resolver/src/JsonLd.hs index b27f25b4821b..16b1ab991b16 100644 --- a/users/Profpatsch/whatcd-resolver/src/JsonLd.hs +++ b/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) diff --git a/users/Profpatsch/whatcd-resolver/src/Optional.hs b/users/Profpatsch/whatcd-resolver/src/Optional.hs new file mode 100644 index 000000000000..9791c8497097 --- /dev/null +++ b/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 diff --git a/users/Profpatsch/whatcd-resolver/src/Redacted.hs b/users/Profpatsch/whatcd-resolver/src/Redacted.hs index 573dd75877bf..4369c184087a 100644 --- a/users/Profpatsch/whatcd-resolver/src/Redacted.hs +++ b/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 diff --git a/users/Profpatsch/whatcd-resolver/src/Transmission.hs b/users/Profpatsch/whatcd-resolver/src/Transmission.hs index 19365446900d..66dbeb9ce749 100644 --- a/users/Profpatsch/whatcd-resolver/src/Transmission.hs +++ b/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 diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs index 128fa2934c8f..b63d7f41e161 100644 --- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs +++ b/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 diff --git a/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal b/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal index 672199600d32..cad1fabe9905 100644 --- a/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal +++ b/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, |