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
|
{-# LANGUAGE QuasiQuotes #-}
module Http
( doRequestJson,
RequestOptions (..),
mkRequestOptions,
httpJson,
Http.setRequestMethod,
Http.setRequestBodyLBS,
Http.setRequestHeader,
Http.getResponseStatus,
Http.getResponseHeader,
Http.getResponseBody,
)
where
import AppT
import Data.Aeson.BetterErrors qualified as Json
import Data.CaseInsensitive (CI (original))
import Data.Char qualified as Char
import Data.Error.Tree
import Data.List qualified as List
import Data.Text qualified as Text
import Data.Text.Punycode qualified as Punycode
import Json qualified
import Json.Enc qualified as Enc
import Label
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.Wai.Parse qualified as Wai
import Optional
import Pretty
import Prelude hiding (span)
data RequestOptions = RequestOptions
{ method :: ByteString,
host :: Text,
port :: Optional Int,
path :: Optional [Text],
headers :: Optional [Http.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
}
httpJson ::
( MonadThrow m,
MonadOtel m
) =>
(Optional (Label "contentType" ByteString)) ->
Json.Parse ErrorTree b ->
Http.Request ->
m b
httpJson opts parser req = inSpan' "HTTP Request (JSON)" $ \span -> do
let opts' = opts.withDefault (label @"contentType" "application/json")
Http.httpBS req
>>= assertM
span
( \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 ->
Right $ (resp & Http.responseBody)
| statusCode == 200,
Just otherType <- contentType ->
Left [fmt|Server returned a non-json body, with content-type "{otherType}"|]
| statusCode == 200,
Nothing <- contentType ->
Left [fmt|Server returned a body with unspecified content type|]
| code <- statusCode -> Left [fmt|Server returned an non-200 error code, code {code}: {resp & showPretty}|]
)
>>= assertM
span
( \body ->
Json.parseStrict parser body
& first (Json.parseErrorTree "could not parse redacted response")
)
doRequestJson ::
(MonadOtel m) =>
RequestOptions ->
Enc.Enc ->
m (Response ByteString)
doRequestJson opts val = inSpan' "HTTP Request (JSON)" $ \span -> do
addAttribute span "request.xh" (requestToXhCommandLine opts val)
resp <-
defaultRequest {secure = not (opts & optsUsePlainHttp)}
& Http.setRequestHost (opts & optsHost)
& Http.setRequestPort (opts & optsPort)
-- TODO: is this automatically escaped by the library?
& Http.setRequestPath (opts & optsPath)
& Http.setRequestHeaders (opts & optsHeaders)
& Http.setRequestMethod opts.method
& Http.setRequestBodyLBS (Enc.encToBytesUtf8Lazy val)
& Http.httpBS
let code = resp & Http.getResponseStatus & (.statusCode)
let msg = resp & Http.getResponseStatus & (.statusMessage) & bytesToTextUtf8Lenient
addAttribute
span
"request.response.status"
([fmt|{code} {msg}|] :: Text)
pure resp
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 -> [Http.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' <> "'"
|
