summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAdrian Cochrane <adrian@openwork.nz>2021-01-05 20:55:03 +1300
committerAdrian Cochrane <adrian@openwork.nz>2021-01-05 20:55:03 +1300
commite08dc01d58062b8794982e605d66e22886e28221 (patch)
tree8c87b26b83b0d380cd8fbe686a093812abe14841
parenta168fd74f6e229b0e4b45e055c6e7f4a5f77f0d5 (diff)
downloadhurl-e08dc01d58062b8794982e605d66e22886e28221.tar.gz
hurl-e08dc01d58062b8794982e605d66e22886e28221.tar.bz2
hurl-e08dc01d58062b8794982e605d66e22886e28221.zip
Fix actual & potential crashes.
-rw-r--r--hurl.cabal2
-rw-r--r--src/Network/URI/Fetch.hs30
-rw-r--r--src/Network/URI/Locale.hs1
-rw-r--r--src/Network/URI/XDG/AppStream.hs2
-rw-r--r--src/Network/URI/XDG/MimeApps.hs2
5 files changed, 18 insertions, 19 deletions
diff --git a/hurl.cabal b/hurl.cabal
index 3deffb2..cb825fa 100644
--- a/hurl.cabal
+++ b/hurl.cabal
@@ -105,6 +105,8 @@ library
-- Directories containing source files.
hs-source-dirs: src
+
+ ghc-options: -fwarn-incomplete-patterns -fwarn-incomplete-uni-patterns
-- Base language which the package is written in.
default-language: Haskell2010
diff --git a/src/Network/URI/Fetch.hs b/src/Network/URI/Fetch.hs
index 6f67d2e..b4aab8b 100644
--- a/src/Network/URI/Fetch.hs
+++ b/src/Network/URI/Fetch.hs
@@ -94,7 +94,7 @@ data Session = Session {
-- | Additional files to serve from about: URIs.
aboutPages :: [(FilePath, ByteString)],
-- | Log of timestamped/profiled URL requests
- requestLog :: MVar [LogRecord],
+ requestLog :: Maybe (MVar [LogRecord]),
-- | How many redirects to follow for Gemini or HTTP(S) requests
redirectCount :: Int,
-- | Whether to cache network responses, avoiding sending requests
@@ -140,7 +140,6 @@ newSession' appname = do
#ifdef WITH_PLUGIN_REWRITES
rewriters <- parseRewriters appname
#endif
- log <- newEmptyMVar
return Session {
#ifdef WITH_HTTP_URI
@@ -157,7 +156,7 @@ newSession' appname = do
#endif
locale = ietfLocale,
aboutPages = [],
- requestLog = log,
+ requestLog = Nothing,
redirectCount = 5,
cachingEnabled = True
}
@@ -175,19 +174,18 @@ fetchURL sess mimes uri = do
(_, mime, resp) <- fetchURL' sess mimes uri
return (mime, resp)
-fetchURLLogged sess mimes uri = do
+fetchURLLogged log sess mimes uri = do
begin' <- getCurrentTime
res@(redirected', mimetype', response') <- fetchURL' sess mimes uri
end' <- getCurrentTime
- modifyMVar_ (requestLog sess) $ \log -> return (
- LogRecord uri mimes redirected' mimetype' response' begin' end' : log)
+ modifyMVar_ log $ \log' -> return (
+ LogRecord uri mimes redirected' mimetype' response' begin' end' : log')
return res
-- | Concurrently fetch given URLs.
fetchURLs :: Session -> [String] -> [URI] -> ((URI, String, Either Text ByteString) -> IO a) -> IO [(URI, a)]
fetchURLs sess mimes uris cb = do
- shouldntLog <- isEmptyMVar $ requestLog sess
- let fetch = if shouldntLog then fetchURL' else fetchURLLogged
+ let fetch = case requestLog sess of {Nothing -> fetchURL'; Just log -> fetchURLLogged log}
forConcurrently uris (\u -> fetch sess mimes u >>= cb) >>= return . L.zip uris
-- | Internal MIMEtypes for error reporting
@@ -283,10 +281,7 @@ fetchURL' session accept@(defaultMIME:_) uri | uriScheme uri `elem` ["http:", "h
Right (mime, body) ->
let mime' = L.map (Txt.unpack . Txt.strip) $ Txt.splitOn ";" mime
in return $ resolveCharset' uri mime' body
- `catches` [
- Handler $ \e -> do return (uri, mimeERR, Left $ Txt.pack $ trans (locale session) $ Http e),
- Handler $ \(ErrorCall msg) -> do return (uri, mimeERR, Left $ Txt.pack msg)
- ]
+ `catch` \e -> do return (uri, mimeERR, Left $ Txt.pack $ trans (locale session) $ Http e)
#endif
#ifdef WITH_GEMINI_URI
@@ -421,15 +416,14 @@ downloadToURI (_, mime, Right bytes) = nullURI {
}
-- Logging API
-enableLogging :: Session -> IO ()
+enableLogging :: Session -> IO Session
enableLogging session = do
- logInactive <- isEmptyMVar $ requestLog session
- if logInactive then putMVar (requestLog session) [] else return ()
+ log <- newMVar []
+ return session { requestLog = Just log }
retrieveLog :: Session -> IO [LogRecord]
-retrieveLog session = do
- logInactive <- isEmptyMVar $ requestLog session
- if logInactive then return [] else takeMVar $ requestLog session
+retrieveLog session@Session { requestLog = Just log } = swapMVar log []
+retrieveLog _ = return []
writeLog :: Handle -> Session -> IO ()
writeLog out session = do
diff --git a/src/Network/URI/Locale.hs b/src/Network/URI/Locale.hs
index ee9dc50..17dc360 100644
--- a/src/Network/URI/Locale.hs
+++ b/src/Network/URI/Locale.hs
@@ -44,4 +44,5 @@ firstJust [] fallback = fallback
split b (a:as) | a `elem` b = [] : split b as
| (head':tail') <- split b as = (a:head') : tail'
+ | otherwise = [a:as]
split _ [] = [[]]
diff --git a/src/Network/URI/XDG/AppStream.hs b/src/Network/URI/XDG/AppStream.hs
index 2865795..bfb6da2 100644
--- a/src/Network/URI/XDG/AppStream.hs
+++ b/src/Network/URI/XDG/AppStream.hs
@@ -91,7 +91,7 @@ mergeComponents' (comp:comps) = let base = mergeComponents' comps in
"append" -> M.unionWith (++) comp base
"replace" -> M.union comp base
"remove-component" -> M.empty
- "" -> comp
+ _ -> comp
localizeComponent :: [String] -> Component -> Component
localizeComponent locales comp = let locales' = map Txt.pack locales in
diff --git a/src/Network/URI/XDG/MimeApps.hs b/src/Network/URI/XDG/MimeApps.hs
index d2e9dde..a05f49f 100644
--- a/src/Network/URI/XDG/MimeApps.hs
+++ b/src/Network/URI/XDG/MimeApps.hs
@@ -50,6 +50,7 @@ queryHandlers config mime = nub (
queryHandlers' group (config:configs) mime =
queryHandlers'' group config mime ++ queryHandlers' group configs mime
+queryHandlers' group [] mime = []
queryHandlers'' group config mime
| Just apps <- iniLookup group mime config = filter (/= "") $ split ';' apps
| otherwise = []
@@ -62,4 +63,5 @@ fromMaybe' a Nothing = a
split b (a:as) | a == b = [] : split b as
| (head':tail') <- split b as = (a:head') : tail'
+ | otherwise = [a:as]
split _ [] = [[]]