From 259eca98aab4a11b37e9127d2d78d0816852bc50 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Wed, 21 Jul 2021 10:43:53 +1200 Subject: [PATCH] Allowing sending HTTP POST requests. --- ChangeLog.md | 7 +++ hurl.cabal | 2 +- src/Network/URI/Fetch.hs | 106 +++++++++++++++++++++++---------------- 3 files changed, 70 insertions(+), 45 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 2ecec91..408704d 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Revision history for hurl +## 2.1.0.1 -- 2021-03-09 +* Fixes a build failure. + +## 2.1.0.0 +* Added APIs for localizing MIMEtypes +* Crash fixes + ## 2.0.0.0 -- 2021-01-07 * Fix several real & potential crashes * Expose APIs for querying localized labels for MIME types from the OS diff --git a/hurl.cabal b/hurl.cabal index 04826a9..2526329 100644 --- a/hurl.cabal +++ b/hurl.cabal @@ -10,7 +10,7 @@ name: hurl -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 2.1.0.0 +version: 2.1.0.1 -- A short (one-line) description of the package. synopsis: Haskell URL resolver diff --git a/src/Network/URI/Fetch.hs b/src/Network/URI/Fetch.hs index eb4d6b3..d8563ea 100644 --- a/src/Network/URI/Fetch.hs +++ b/src/Network/URI/Fetch.hs @@ -196,6 +196,16 @@ mimeERR, htmlERR :: String mimeERR = "txt/x-error\t" htmlERR = "html/x-error\t" +submitURL :: Session -> [String] -> URI -> Text -> String -> IO (URI, String, Either Text ByteString) +#ifdef WITH_HTTP_URI +submitURL session accept uri "POST" query | uriScheme uri `elem` ["http:", "https:"] = + fetchHTTPCached session accept uri $ \req -> req { + HTTP.method = "POST", + HTTP.requestBody = HTTP.RequestBodyBS $ C8.pack query + } +#endif +submitURL session mimes uri _method query = fetchURL' session mimes uri { uriQuery = '?':query } + -- | As per `fetchURL`, but also returns the redirected URI. fetchURL' :: Session -> [String] -> URI -> IO (URI, String, Either Text ByteString) fetchURL' Session {redirectCount = 0, locale = locale'} _ uri = @@ -248,50 +258,8 @@ fetchURL' Session {aboutPages = pages} _ url@URI {uriScheme = "about:", uriPath Right $ llookup path "" pages) #ifdef WITH_HTTP_URI -fetchURL' session accept@(defaultMIME:_) uri | uriScheme uri `elem` ["http:", "https:"] = do - cached <- if cachingEnabled session then readCacheHTTP uri else return (Nothing, Nothing) - response <- case cached of - (Just (mime, body), Nothing) -> return $ Right (mime, body) - (cached, cachingHeaders) -> do - request <- HTTP.requestFromURI uri - response <- HTTP.httpLbs request { - HTTP.cookieJar = Nothing, -- Will only be supported by Rhapsode when submitting a form. - HTTP.requestHeaders = [ - ("Accept", C8.pack $ intercalate ", " accept), - ("Accept-Language", C8.pack $ intercalate ", " $ locale session) - ] ++ fromMaybe [] cachingHeaders, - HTTP.redirectCount = 0 - } $ managerHTTP session - case ( - HTTP.responseStatus response, - HTTP.responseBody response, - [val | ("content-type", val) <- HTTP.responseHeaders response] - ) of - (Status 304 _, _, _) | Just cached'@(_, body) <- cached -> do - cacheHTTP uri $ response { HTTP.responseBody = body } - return $ Right cached' - -- Manually handle redirects so the caller & HTTP cache gets the correct URI. - (Status code _, _, _) | code > 300 && code < 400, - Just location <- lookup "location" $ HTTP.responseHeaders response, - Just uri' <- parseURIReference $ C8.unpack location -> - return $ Left $ relativeTo uri' uri - (Status _ msg, "", _) -> return $ Right (Txt.pack mimeERR, B.fromStrict msg) - (_, body, (mimetype:_)) -> do - cacheHTTP uri response - forkIO cleanCacheHTTP -- Try to keep diskspace down... - - let mime = Txt.toLower $ convertCharset "utf-8" mimetype - return $ Right (mime, body) - (_, response, []) -> return $ Right (Txt.pack defaultMIME, response) - - case response of - Left redirect -> - let session' = session { redirectCount = redirectCount session - 1 } - in fetchURL' session' accept redirect - Right (mime, body) -> - let mime' = L.map (Txt.unpack . Txt.strip) $ Txt.splitOn ";" mime - in return $ resolveCharset' uri mime' body - `catch` \e -> do return (uri, mimeERR, Left $ Txt.pack $ trans (locale session) $ Http e) +fetchURL' session accept uri | uriScheme uri `elem` ["http:", "https:"] = + fetchHTTPCached session accept uri id #endif #ifdef WITH_GEMINI_URI @@ -392,6 +360,56 @@ dispatchByApp session@Session { locale = l } Application { appId = app} mime uri dispatchByApp _ _ _ _ = return False #endif +#ifdef WITH_HTTP_URI +fetchHTTPCached session accept@(defaultMIME:_) uri cb = do + cached <- if cachingEnabled session then readCacheHTTP uri else return (Nothing, Nothing) + response <- case cached of + (Just (mime, body), Nothing) -> return $ Right (mime, body) + (cached, cachingHeaders) -> do + request <- HTTP.requestFromURI uri + let request' = cb request { + HTTP.cookieJar = Nothing, -- Will only be supported by Rhapsode when submitting a form. + HTTP.requestHeaders = [ + ("Accept", C8.pack $ intercalate ", " accept), + ("Accept-Language", C8.pack $ intercalate ", " $ locale session) + ] ++ fromMaybe [] cachingHeaders, + HTTP.redirectCount = 0 + } + response <- HTTP.httpLbs request $ managerHTTP session + case ( + HTTP.responseStatus response, + HTTP.responseBody response, + [val | ("content-type", val) <- HTTP.responseHeaders response] + ) of + (Status 304 _, _, _) | Just cached'@(_, body) <- cached -> do + cacheHTTP uri $ response { HTTP.responseBody = body } + return $ Right cached' + -- Manually handle redirects so the caller & HTTP cache gets the correct URI. + (Status code _, _, _) | code > 300 && code < 400, + Just location <- lookup "location" $ HTTP.responseHeaders response, + Just uri' <- parseURIReference $ C8.unpack location -> + return $ Left $ relativeTo uri' uri + (Status _ msg, "", _) -> return $ Right (Txt.pack mimeERR, B.fromStrict msg) + (_, body, (mimetype:_)) -> do + cacheHTTP uri response + forkIO cleanCacheHTTP -- Try to keep diskspace down... + + let mime = Txt.toLower $ convertCharset "utf-8" mimetype + return $ Right (mime, body) + (_, response, []) -> return $ Right (Txt.pack defaultMIME, response) + + case response of + Left redirect -> + let session' = session { redirectCount = redirectCount session - 1 } + in fetchURL' session' accept redirect + Right (mime, body) -> + let mime' = L.map (Txt.unpack . Txt.strip) $ Txt.splitOn ";" mime + in return $ resolveCharset' uri mime' body + `catch` \e -> do return (uri, mimeERR, Left $ Txt.pack $ trans (locale session) $ Http e) +fetchHTTPCached session [] uri cb = + return (uri, mimeERR, Left $ Txt.pack $ trans (locale session) $ UnsupportedMIME "") +#endif + -- Downloads utilities -- | write download to a file in the given directory. saveDownload :: URI -> FilePath -> (URI, String, Either Text ByteString) -> IO URI -- 2.30.2