1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393

{-# LANGUAGE QuasiQuotes #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Http
  ( textToURI,
    uriToHttpClientRequest,
    uriToRequestOptions,
    uriToRequestOptionsGet,
    RequestOptions (..),
    mkRequestOptions,
    httpJsonWithRateLimit,
    requestOptionsUrlPretty,
    requestOptionsToXhCommand,
    executeRequestOptions,
    Http.httpBS,
    Http.Request,
    Http.setRequestMethod,
    Http.setQueryString,
    Http.setRequestBodyLBS,
    Http.setRequestHeader,
    Http.getResponseStatus,
    Http.getResponseHeader,
    Http.getResponseHeaders,
    Http.getResponseBody,
  )
where

import AppT
import Builder
import Control.Exception (Exception (..), SomeException)
import Control.Monad.Catch.Pure (runCatch)
import Data.Aeson qualified as Json
import Data.Aeson.BetterErrors qualified as Json
import Data.ByteString qualified as ByteString
import Data.ByteString.Builder qualified as Builder
import Data.CaseInsensitive (CI (original))
import Data.Char qualified as Char
import Data.Error.Tree
import Data.Functor.Contravariant
import Data.List qualified as List
import Data.List.NonEmpty qualified as NonEmpty
import Data.Ord (clamp)
import Data.Text qualified as Text
import Data.Text.Punycode qualified as Punycode
import FieldParser (FieldParser' (..))
import FieldParser qualified as Field
import Json qualified
import Json.Enc qualified as Enc
import Label
import MyLabel
import MyPrelude
import Network.HTTP.Client
import Network.HTTP.Client qualified as Http
import Network.HTTP.Simple qualified as Http
import Network.HTTP.Types.Status (Status (..))
import Network.HTTP.Types.URI (urlEncodeBuilder)
import Network.URI (URI, parseURI, uriAuthority, uriPath, uriPort, uriRegName, uriScheme)
import Network.Wai.Parse qualified as Wai
import Optional
import Parse (Parse)
import Parse qualified
import Pretty
import UnliftIO.Concurrent (threadDelay)
import Prelude hiding (span)

-- | Make sure we can parse the given Text into an URI.
textToURI :: Parse Text URI
textToURI =
  Parse.fieldParser
    ( FieldParser $ \text ->
        text
          & textToString
          & Network.URI.parseURI
          & annotate [fmt|Cannot parse this as a URL: "{text}"|]
    )

-- | Make sure we can parse the given URI into a Request.
--
-- This tries to work around the horrible, horrible interface in Http.Client.
uriToHttpClientRequest :: Parse URI Http.Request
uriToHttpClientRequest =
  Parse.mkParseNoContext
    ( \url ->
        (url & Http.requestFromURI)
          & runCatch
          & first (checkException @Http.HttpException)
          & \case
            Left (Right (Http.InvalidUrlException urlText reason)) ->
              Left [fmt|Unable to set the url "{urlText}" as request URL, reason: {reason}|]
            Left (Right exc@(Http.HttpExceptionRequest _ _)) ->
              Left [fmt|Weird! Should not get a HttpExceptionRequest when parsing an URL (bad library design), was {exc & displayException}|]
            Left (Left someExc) ->
              Left [fmt|Weird! Should not get anyhting but a HttpException when parsing an URL (bad library design), was {someExc & displayException}|]
            Right req -> pure req
    )
  where
    checkException :: (Exception b) => SomeException -> Either SomeException b
    checkException some = case fromException some of
      Nothing -> Left some
      Just e -> Right e

-- | Parse a URI into RequestOptions with sensible defaults.
uriToRequestOptionsGet :: Parse URI RequestOptions
uriToRequestOptionsGet = uriToRequestOptions (t2 #method "GET" #headers [])

-- | Parse a URI into RequestOptions with custom method and headers.
uriToRequestOptions :: (HasField "method" opts ByteString, HasField "headers" opts [Http.Header]) => opts -> Parse URI RequestOptions
uriToRequestOptions opts =
  Parse.mkParseNoContext $ \uri -> do
    scheme <- parseScheme uri
    (host, port) <- parseAuthority uri scheme
    pathParts <- parsePath uri

    let baseOpts = mkRequestOptions (t2 #method opts.method #host host)
    pure $
      baseOpts
        { port = mkOptional port,
          path = mkOptional pathParts,
          usePlainHttp = mkOptional (scheme /= "https"),
          headers = mkOptional opts.headers
        }
  where
    parseScheme uri = case Network.URI.uriScheme uri of
      "https:" -> Right "https"
      "http:" -> Right "http"
      "" -> Left [fmt|URI missing scheme: {uri & showToText}|]
      other -> Left [fmt|Unsupported URI scheme: {other}|]

    parseAuthority uri scheme = case Network.URI.uriAuthority uri of
      Just auth -> do
        let host = Network.URI.uriRegName auth & stringToText
        port <- case Network.URI.uriPort auth of
          "" -> Right (if scheme == "https" then 443 else 80)
          portStr ->
            portStr
              & drop 1
              & stringToText
              & Field.runFieldParser (Field.decimalNatural >>> Field.integralToInteger >>> Field.bounded @Int "port number")
              & first (\err -> [fmt|Invalid port in URI: {portStr}, {err & showToText}|])
        pure (host, port)
      Nothing -> Left [fmt|URI missing authority (host): {uri & showToText}|]

    parsePath uri =
      let pathParts =
            Network.URI.uriPath uri
              & stringToText
              & Text.dropWhile (== '/')
              & Text.splitOn "/"
              & filter (not . Text.null)
       in Right pathParts

-- | HTTP request options that can be printed and converted to executable bash commands.
-- This is a printable alternative to the opaque Http.Request type.
data RequestOptions = RequestOptions
  { -- | HTTP method (GET, POST, etc.)
    method :: ByteString,
    -- | Host name (e.g. "redacted.sh")
    host :: Text,
    -- | Port number (defaults to 80 for HTTP, 443 for HTTPS)
    port :: Optional Int,
    -- | Path segments (e.g. ["api", "v1", "user"] becomes "/api/v1/user")
    path :: Optional [Text],
    -- | Query parameters (e.g. [("action", Just "browse"), ("format", Just "json")])
    queryParams :: Optional [(ByteString, Maybe ByteString)],
    -- | HTTP headers
    headers :: Optional [Http.Header],
    -- | Use plain HTTP instead of HTTPS (defaults to False)
    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,
      queryParams = defaults,
      headers = defaults,
      usePlainHttp = defaults
    }

httpJsonWithRateLimit ::
  ( MonadThrow m,
    MonadOtel m
  ) =>
  (Optional (Label "contentType" ByteString)) ->
  Json.Parse ErrorTree b ->
  RequestOptions ->
  m b
httpJsonWithRateLimit opts parser reqOpts = inSpan' "HTTP Request (JSON)" $ \span -> do
  let opts' = opts.withDefault (label @"contentType" "application/json")
  let go =
        executeRequestOptions reqOpts Nothing
          >>= ( \resp -> do
                  let statusCode = resp & Http.responseStatus & (.statusCode)
                      contentType =
                        resp
                          & Http.responseHeaders
                          & List.lookup "content-type"
                          <&> Wai.parseContentType
                          <&> (\(ct, _mimeAttributes) -> ct)
                  if
                    | statusCode == 200,
                      Just ct <- contentType,
                      ct == opts'.contentType ->
                        pure $ Right $ (resp & Http.responseBody)
                    | statusCode == 200,
                      Just otherType <- contentType ->
                        pure $ Left [fmt|Server returned a non-json body, with content-type "{otherType}"|]
                    | statusCode == 200,
                      Nothing <- contentType ->
                        pure $ Left [fmt|Server returned a body with unspecified content type|]
                    | statusCode == 429 -> do
                        let retryAfter =
                              resp
                                & Http.getResponseHeader "Retry-After"
                                & nonEmpty
                                >>= ( NonEmpty.head
                                        >>> Field.runFieldParser
                                          ( Field.utf8
                                              >>> (Field.decimalNatural <&> toInteger)
                                              >>> (Field.bounded @Int "Int" <&> clamp @Int (0, 10))
                                          )
                                        >>> hush
                                    )
                                  & fromMaybe 2
                        inSpan' "HTTP Request (JSON) - Rate Limited" $ \span' -> do
                          addAttribute span' "request.response.status" statusCode
                          addAttribute span' "request.response.retry-after" retryAfter
                          threadDelay (retryAfter * 1_000_000)
                          go
                    | code <- statusCode -> pure $ Left $ AppExceptionPretty [[fmt|Server returned an non-200 error code, code {code}:|], pretty resp]
              )
  go
    >>= orAppThrow span
    >>= \body -> do
      val <-
        Json.eitherDecodeStrict body
          & first (\err -> AppExceptionTree $ nestedError "HTTP response was not valid JSON" (err & stringToText & newError & singleError))
          & orAppThrow span

      let res = Json.parseValue parser val
      case res of
        Left e -> do
          let err = Json.jsonParseErrorToErrorTreeValCtx val e
          appThrow
            span
            ( AppExceptionEnc $
                Enc.tuple3
                  Enc.text
                  Enc.enc
                  (Enc.nullOr Enc.value)
                  ("Could not parse HTTP response", err.errorMessage, err.valueAtErrorPath)
            )
        Right a -> pure a

-- | Pretty print a RequestOptions as a complete URL for use in telemetry and debugging
requestOptionsUrlPretty :: RequestOptions -> Text
requestOptionsUrlPretty opts = buildBytes urlBuilder opts & bytesToTextUtf8Lenient
  where
    urlBuilder :: Build Byt RequestOptions
    urlBuilder =
      protocolBuilder
        <> "://"
        <> hostBuilder
        <> ":"
        <> portBuilder
        <> pathBuilder
        <> queryBuilder

    protocolBuilder :: Build Byt RequestOptions
    protocolBuilder =
      (.usePlainHttp)
        >$< optionalB
          "https"
          ( bytesB >&< \case
              True -> "http"
              False -> "https"
          )

    hostBuilder = (.host) >$< utf8B

    portBuilder = (\o -> o.port.withDefault (if o.usePlainHttp.withDefault False then 80 else 443)) >$< intDecimalB

    pathBuilder =
      ( \o -> case o.path.withDefault [] of
          [] -> mempty
          segs ->
            let pathBuilders = segs & map (urlEncodeBuilder False . textToBytesUtf8)
                combinedBuilder = mconcat . List.intersperse "/" $ pathBuilders
             in "/" <> Builder.toLazyByteString combinedBuilder
      )
        >$< bytesLazyB

    queryBuilder =
      ( \o -> case o.queryParams.withDefault [] of
          [] -> mempty
          ps ->
            let paramBuilders = ps & map encodeParam
                combinedBuilder = mconcat . List.intersperse "&" $ paramBuilders
             in "?" <> Builder.toLazyByteString combinedBuilder
      )
        >$< bytesLazyB
      where
        encodeParam (key, mValue) = case mValue of
          Just value -> urlEncodeBuilder True key <> "=" <> urlEncodeBuilder True value
          Nothing -> urlEncodeBuilder True key

-- | General version that handles both GET and POST requests
requestOptionsToXhCommand :: RequestOptions -> Maybe Enc.Enc -> Text
requestOptionsToXhCommand opts mVal = do
  let url = requestOptionsUrlPretty opts
  let headers = opts.headers.withDefault [] <&> \(hdr, v) -> hdr.original <> ":" <> v
  let method = opts.method & bytesToTextUtf8Lenient

  prettyArgsForBash $
    mconcat
      [ ["xh", method, url],
        headers <&> bytesToTextUtf8Lenient,
        case mVal of
          Just val -> ["--raw", val & Enc.encToBytesUtf8 & bytesToTextUtf8Lenient]
          Nothing -> []
      ]

-- | 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' <> "'"

-- | Execute an HTTP request from RequestOptions with OpenTelemetry tracing and bash command
executeRequestOptions ::
  (MonadOtel m) =>
  RequestOptions ->
  Maybe Enc.Enc ->
  m (Http.Response ByteString)
executeRequestOptions opts mVal = inSpan'
  [fmt|HTTP {opts.method & bytesToTextUtf8Lenient} {opts.host}|]
  $ \span -> do
    addAttribute span "http.method" (opts.method & bytesToTextUtf8Lenient)
    addAttribute span "http.url" (requestOptionsUrlPretty opts)
    addAttribute span "http.request.host" opts.host
    addAttribute span "http.request.scheme" (if opts & optsUsePlainHttp then "http" :: Text else "https")
    addAttribute span "http.request.bash_command" (requestOptionsToXhCommand opts mVal)
    let req = buildHttpRequest opts mVal
    resp <- Http.httpBS req
    let statusCode = resp & Http.responseStatus & (.statusCode)
    let statusMessage = resp & Http.responseStatus & (.statusMessage) & bytesToTextUtf8Lenient
    addAttribute span "http.response.status_code" statusCode
    addAttribute span "http.response.status_text" statusMessage
    addAttribute span "http.response.body_size" (resp & Http.responseBody & ByteString.length)
    pure resp
  where
    optsUsePlainHttp :: RequestOptions -> Bool
    optsUsePlainHttp req = req.usePlainHttp.withDefault False

    buildHttpRequest :: RequestOptions -> Maybe Enc.Enc -> Http.Request
    buildHttpRequest opts' mVal' =
      let baseReq =
            defaultRequest {secure = not (opts' & optsUsePlainHttp)}
              & Http.setRequestHost
                ( if opts'.host & Text.isAscii
                    then opts'.host & textToBytesUtf8
                    else opts'.host & Punycode.encode
                )
              & Http.setRequestPort (opts'.port.withDefault (if opts & optsUsePlainHttp then 80 else 443))
              & Http.setRequestPath (opts'.path & buildBytes (optionalB "/" (intersperseB "/" utf8B)))
              & Http.setRequestHeaders (opts'.headers.withDefault [])
              & Http.setRequestMethod opts'.method
              & Http.setQueryString (opts'.queryParams.withDefault [])
       in case mVal' of
            Just val -> Http.setRequestBodyLBS (Enc.encToBytesUtf8Lazy val) baseReq
            Nothing -> baseReq