summaryrefslogtreecommitdiff
path: root/src/Network/URI/Fetch.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network/URI/Fetch.hs')
-rw-r--r--src/Network/URI/Fetch.hs33
1 files changed, 16 insertions, 17 deletions
diff --git a/src/Network/URI/Fetch.hs b/src/Network/URI/Fetch.hs
index 1767d95..58bd6ae 100644
--- a/src/Network/URI/Fetch.hs
+++ b/src/Network/URI/Fetch.hs
@@ -2,7 +2,7 @@
{-# LANGUAGE OverloadedStrings #-}
-- | 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), newSession,
+module Network.URI.Fetch(Session(locale, aboutPages, redirectCount), newSession,
fetchURL, fetchURL', fetchURLs, mimeERR, htmlERR,
dispatchByMIME, saveDownload, downloadToURI,
-- logging API
@@ -84,7 +84,9 @@ data Session = Session {
-- | Additional files to serve from about: URIs.
aboutPages :: [(FilePath, ByteString)],
-- | Log of timestamped/profiled URL requests
- requestLog :: MVar [LogRecord]
+ requestLog :: MVar [LogRecord],
+ -- | How many redirects to follow for Gemini or HTTP(S) requests
+ redirectCount :: Int
}
data LogRecord = LogRecord {
@@ -143,7 +145,8 @@ newSession' appname = do
#endif
locale = ietfLocale,
aboutPages = [],
- requestLog = log
+ requestLog = log,
+ redirectCount = 5
}
llookup key fallback map = fallback `fromMaybe` listToMaybe [v | (k, v) <- map, k == key]
@@ -181,6 +184,9 @@ htmlERR = "html/x-error\t"
-- | 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 =
+ return (uri, mimeERR, Left $ Txt.pack $ trans locale' ExcessiveRedirects)
+
#ifdef WITH_PLUGIN_REWRITES
fetchURL' session mimes uri
| Just uri' <- applyRewriter (rewriter session) uri = fetchURL' session mimes uri'
@@ -202,7 +208,8 @@ fetchURL' session accept@(defaultMIME:_) uri | uriScheme uri `elem` ["http:", "h
HTTP.requestHeaders = [
("Accept", C8.pack $ intercalate ", " accept),
("Accept-Language", C8.pack $ intercalate ", " $ locale session)
- ]
+ ],
+ HTTP.redirectCount = redirectCount session
} $ managerHTTP session
return $ case (
HTTP.responseBody response,
@@ -233,11 +240,13 @@ fetchURL' sess@Session {connCtxt = ctxt, locale = l} mimes uri@URI {
"<input /></label></form>"
])
('2', _, mime) -> do
- body <- B.hGetContents input'
+ body <- Strict.hGetContents input'
let mime' = L.map (Txt.unpack . Txt.strip) $ Txt.splitOn ";" mime
- return $ resolveCharset' uri mime' body
+ return $ resolveCharset' uri mime' $ B.fromStrict body
('3', _, redirect) | Just redirect' <- parseURIReference $ Txt.unpack redirect ->
- fetchURL' sess mimes $ relativeTo redirect' uri
+ fetchURL' sess {
+ redirectCount = redirectCount sess - 1
+ } mimes $ relativeTo redirect' uri
-- TODO Implement client certificates, once I have a way for the user/caller to select one.
-- And once I figure out how to configure the TLS cryptography.
(_, _, err) -> return (uri, mimeERR, Left err)
@@ -358,13 +367,3 @@ breakOn c (a:as) | c == a = ([], as)
| otherwise = let (x, y) = breakOn c as in (a:x, y)
breakOn _ [] = ([], [])
#endif
-
-#ifdef WITH_GEMINI_URI
-mWhile test body = do
- cond <- test
- if cond then do
- x <- body
- xs <- mWhile test body
- return (x:xs)
- else return []
-#endif