about summary refs log tree commit diff
path: root/users/Profpatsch
diff options
context:
space:
mode:
Diffstat (limited to 'users/Profpatsch')
-rw-r--r--users/Profpatsch/whatcd-resolver/src/Http.hs85
-rw-r--r--users/Profpatsch/whatcd-resolver/src/JsonLd.hs3
-rw-r--r--users/Profpatsch/whatcd-resolver/src/Redacted.hs44
3 files changed, 70 insertions, 62 deletions
diff --git a/users/Profpatsch/whatcd-resolver/src/Http.hs b/users/Profpatsch/whatcd-resolver/src/Http.hs
index 487d55c21d88..4376b721e80a 100644
--- a/users/Profpatsch/whatcd-resolver/src/Http.hs
+++ b/users/Profpatsch/whatcd-resolver/src/Http.hs
@@ -4,27 +4,35 @@ module Http
   ( doRequestJson,
     RequestOptions (..),
     mkRequestOptions,
-    setRequestMethod,
-    setRequestBodyLBS,
-    setRequestHeader,
-    getResponseStatus,
-    getResponseHeader,
-    getResponseBody,
+    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.Simple
+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
@@ -32,7 +40,7 @@ data RequestOptions = RequestOptions
     host :: Text,
     port :: Optional Int,
     path :: Optional [Text],
-    headers :: Optional [Header],
+    headers :: Optional [Http.Header],
     usePlainHttp :: Optional Bool
   }
 
@@ -47,6 +55,47 @@ mkRequestOptions opts =
       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 ->
@@ -56,16 +105,16 @@ doRequestJson opts val = inSpan' "HTTP Request (JSON)" $ \span -> do
   addAttribute span "request.xh" (requestToXhCommandLine opts val)
   resp <-
     defaultRequest {secure = not (opts & optsUsePlainHttp)}
-      & setRequestHost (opts & optsHost)
-      & setRequestPort (opts & optsPort)
+      & Http.setRequestHost (opts & optsHost)
+      & Http.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
-  let code = resp & getResponseStatus & (.statusCode)
-  let msg = resp & getResponseStatus & (.statusMessage) & bytesToTextUtf8Lenient
+      & 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"
@@ -87,7 +136,7 @@ optsPort opts = opts.port.withDefault (if opts & optsUsePlainHttp then 80 else 4
 optsPath :: RequestOptions -> ByteString
 optsPath opts = opts.path.withDefault [] & Text.intercalate "/" & ("/" <>) & textToBytesUtf8
 
-optsHeaders :: RequestOptions -> [Header]
+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)
diff --git a/users/Profpatsch/whatcd-resolver/src/JsonLd.hs b/users/Profpatsch/whatcd-resolver/src/JsonLd.hs
index 1a021b706c63..80d04f8e78a5 100644
--- a/users/Profpatsch/whatcd-resolver/src/JsonLd.hs
+++ b/users/Profpatsch/whatcd-resolver/src/JsonLd.hs
@@ -11,16 +11,15 @@ import Data.Map.Strict qualified as Map
 import Data.Set (Set)
 import Data.Set qualified as Set
 import Html qualified
+import Http
 import IHP.HSX.QQ (hsx)
 import Json qualified
 import Label
 import MyPrelude
 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/Redacted.hs b/users/Profpatsch/whatcd-resolver/src/Redacted.hs
index 3427d9c940e6..0c9506e57e1e 100644
--- a/users/Profpatsch/whatcd-resolver/src/Redacted.hs
+++ b/users/Profpatsch/whatcd-resolver/src/Redacted.hs
@@ -15,6 +15,7 @@ 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 Http qualified
 import Json qualified
 import Label
 import MyPrelude
@@ -522,47 +523,6 @@ httpTorrent span req =
             | code <- statusCode -> Left [fmt|Redacted returned an non-200 error code, code {code}: {resp & showPretty}|]
       )
 
-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")
-      )
-
 redactedApiRequestJson ::
   ( MonadThrow m,
     HasField "action" p ByteString,
@@ -576,4 +536,4 @@ redactedApiRequestJson ::
 redactedApiRequestJson dat parser =
   do
     mkRedactedApiRequest dat
-    >>= httpJson defaults parser
+    >>= Http.httpJson defaults parser
generated by cgit-pink 1.4.1 (git 2.44.2) at 2024-11-25T12ยท05+0000