From e08dc01d58062b8794982e605d66e22886e28221 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Tue, 5 Jan 2021 20:55:03 +1300
Subject: [PATCH] Fix actual & potential crashes.

---
 hurl.cabal                       |  2 ++
 src/Network/URI/Fetch.hs         | 30 ++++++++++++------------------
 src/Network/URI/Locale.hs        |  1 +
 src/Network/URI/XDG/AppStream.hs |  2 +-
 src/Network/URI/XDG/MimeApps.hs  |  2 ++
 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 _ [] = [[]]
-- 
2.30.2