hurl 2.1.0.1 → 2.1.1.0
raw patch · 3 files changed
+108/−47 lines, 3 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Network.URI.Fetch: submitURL :: Session -> [String] -> URI -> Text -> String -> IO (URI, String, Either Text ByteString)
Files
- ChangeLog.md +4/−0
- hurl.cabal +1/−1
- src/Network/URI/Fetch.hs +103/−46
ChangeLog.md view
@@ -1,5 +1,9 @@ # Revision history for hurl +## 2.1.1.0 -- 2021-07-22+* Add support for submitting forms (fallsback to normal URL resolution).+* Allow setting cookies in response HTTP POST, including retroactively for the sake of CSRF protections.+ ## 2.1.0.1 -- 2021-03-09 * Fixes a build failure.
hurl.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 2.1.0.1+version: 2.1.1.0 -- A short (one-line) description of the package. synopsis: Haskell URL resolver
src/Network/URI/Fetch.hs view
@@ -3,7 +3,7 @@ -- | Retrieves documents for a URL, supporting multiple URL schemes that can be -- disabled at build-time for reduced dependencies. module Network.URI.Fetch(Session(locale, aboutPages, redirectCount, cachingEnabled), newSession,- fetchURL, fetchURL', fetchURLs, mimeERR, htmlERR,+ fetchURL, fetchURL', fetchURLs, submitURL, mimeERR, htmlERR, dispatchByMIME, appsForMIME, Application(..), dispatchByApp, saveDownload, downloadToURI, -- logging API@@ -79,6 +79,9 @@ data Session = Session { #ifdef WITH_HTTP_URI managerHTTP :: HTTP.Manager,+ globalCookieJar :: MVar HTTP.CookieJar,+ cookiesPath :: FilePath,+ retroactiveCookies :: Maybe (MVar HTTP.CookieJar), #endif #ifdef WITH_RAW_CONNECTIONS connCtxt :: TLS.SSLContext,@@ -128,6 +131,15 @@ TLS.contextSetCADirectory httpsCtxt "/etc/ssl/certs" TLS.contextSetVerificationMode httpsCtxt $ TLS.VerifyPeer True True Nothing managerHTTP' <- HTTP.newManager $ TLS.opensslManagerSettings $ return httpsCtxt++ cookiesDir <- getXdgDirectory XdgData "nz.geek.adrian.hurl.cookies"+ let cookiesPath' = cookiesDir </> appname+ cookiesExist <- doesFileExist cookiesPath'+ cookies <- if cookiesExist then readMaybe <$> readFile cookiesPath' else return Nothing+ now <- getCurrentTime+ let cookies' = HTTP.createCookieJar $ fromMaybe [] cookies+ cookieJar <- newMVar $ HTTP.evictExpiredCookies cookies' now+ cookieJar' <- newMVar $ HTTP.createCookieJar [] #endif #ifdef WITH_RAW_CONNECTIONS connCtxt <- TLS.context@@ -146,6 +158,9 @@ return Session { #ifdef WITH_HTTP_URI managerHTTP = managerHTTP',+ globalCookieJar = cookieJar,+ cookiesPath = cookiesPath',+ retroactiveCookies = Just cookieJar', #endif #ifdef WITH_RAW_CONNECTIONS connCtxt = connCtxt,@@ -189,13 +204,38 @@ fetchURLs :: Session -> [String] -> [URI] -> ((URI, String, Either Text ByteString) -> IO a) -> IO [(URI, a)] fetchURLs sess mimes uris cb = do let fetch = case requestLog sess of {Nothing -> fetchURL'; Just log -> fetchURLLogged log}- forConcurrently uris (\u -> fetch sess mimes u >>= cb) >>= return . L.zip uris+ let sess' = sess {+#ifdef WITH_HTTP_URI+ retroactiveCookies = Nothing+#endif+ }+ forConcurrently uris (\u -> fetch sess' mimes u >>= cb) >>= return . L.zip uris -- | Internal MIMEtypes for error reporting 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:"] = do+ -- HURL is very strict on when it allows cookies to be set: Only POST HTTP requests are considered consent.+ -- For the sake of most webframeworks' CSRF protection, cookies from retrieving the form are retroactively set.+ csrfCookies <- case retroactiveCookies session of {+ Just cookies -> Just <$> readMVar cookies;+ Nothing -> return Nothing+ }+ fetchHTTPCached session accept uri (\req -> req {+ HTTP.cookieJar = firstJust csrfCookies $ HTTP.cookieJar req,+ HTTP.method = "POST",+ HTTP.requestBody = HTTP.RequestBodyBS $ C8.pack query+ }) $ \resp -> do+ let cookies = HTTP.responseCookieJar resp+ putMVar (globalCookieJar session) cookies+ writeFile (cookiesPath session) $ show $ HTTP.destroyCookieJar cookies+#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 +288,12 @@ 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 saveCookies+ where+ saveCookies resp+ | Just cookies <- retroactiveCookies session = putMVar cookies $ HTTP.responseCookieJar resp+ | otherwise = return () #endif #ifdef WITH_GEMINI_URI@@ -392,6 +394,58 @@ dispatchByApp _ _ _ _ = return False #endif +#ifdef WITH_HTTP_URI+fetchHTTPCached session accept@(defaultMIME:_) uri cbReq cbResp = 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+ cookieJar <- readMVar $ globalCookieJar session+ let request' = cbReq $ request {+ HTTP.cookieJar = Just $ cookieJar,+ 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+ cbResp response+ 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 _ _ =+ 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@@ -457,3 +511,6 @@ breakOn c (a:as) | c == a = ([], as) | otherwise = let (x, y) = breakOn c as in (a:x, y) breakOn _ [] = ([], [])++firstJust a@(Just _) _ = a+firstJust Nothing b = b