From c72f07c93ef03f07b92cdb9f4ce6fc0d14e1f2d0 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Wed, 15 Jan 2020 21:51:30 +1300
Subject: [PATCH] Add Accept-Language support on UNIX systems.

---
 hurl.cabal                |  3 ++-
 src/Network/URI/Fetch.hs  | 22 ++++++++++++++++++++--
 src/Network/URI/Locale.hs | 34 ++++++++++++++++++++++++++++++++++
 3 files changed, 56 insertions(+), 3 deletions(-)
 create mode 100644 src/Network/URI/Locale.hs

diff --git a/hurl.cabal b/hurl.cabal
index eb2ea26..d6c96e3 100644
--- a/hurl.cabal
+++ b/hurl.cabal
@@ -82,7 +82,8 @@ library
   
   if flag(http)
     CPP-options:   -DWITH_HTTP_URI
-    build-depends: http-client >= 0.6 && <0.7, http-types >= 0.12 && <0.13
+    build-depends: http-client >= 0.6 && <0.7, http-types >= 0.12 && <0.13,
+                   http-client-tls >= 0.3 && <0.4
   if flag(file)
     CPP-options:   -DWITH_FILE_URI
   if flag(data)
diff --git a/src/Network/URI/Fetch.hs b/src/Network/URI/Fetch.hs
index 39dddc6..58f8bcd 100644
--- a/src/Network/URI/Fetch.hs
+++ b/src/Network/URI/Fetch.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
-module Network.URI.Fetch(fetchURL) where
+module Network.URI.Fetch(Session(..), newSession, fetchURL) where
 import qualified Data.Text as Txt
 import           Data.Text (Text)
 import           Network.URI
@@ -9,6 +9,7 @@ import qualified Data.ByteString.Lazy as B
 
 #ifdef WITH_HTTP_URI
 import qualified Network.HTTP.Client as HTTP
+import qualified Network.HTTP.Client.TLS as TLS
 import           Network.HTTP.Types
 import           Network.URI.Charset
 import           Data.List (intercalate)
@@ -19,12 +20,28 @@ import qualified Data.ByteString.Char8 as C8
 import qualified Data.ByteString.Base64 as B64
 #endif
 
+import Network.URI.Locale
+
 data Session = Session {
+    locale :: [String],
 #ifdef WITH_HTTP_URI
     managerHTTP :: HTTP.Manager
 #endif
 }
 
+newSession :: IO Session
+newSession = do
+    locale' <- rfc2616Locale
+#ifdef WITH_HTTP_URI
+    managerHTTP' <- HTTP.newManager TLS.tlsManagerSettings
+#endif
+    return Session {
+        locale = locale',
+#ifdef WITH_HTTP_URI
+        managerHTTP = managerHTTP'
+#endif
+    }
+
 fetchURL :: Session -> [String] -> URI -> IO (String, Either Text ByteString)
 #ifdef WITH_HTTP_URI
 fetchURL session accept@(defaultMIME:_) uri | uriScheme uri `elem` ["http:", "https:"] = do
@@ -32,7 +49,8 @@ fetchURL session accept@(defaultMIME:_) uri | uriScheme uri `elem` ["http:", "ht
     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", C8.pack $ intercalate ", " accept),
+                ("Accept-Language", C8.pack $ intercalate ", " $ locale session)
             ]
         } $ managerHTTP session
     return $ case (
diff --git a/src/Network/URI/Locale.hs b/src/Network/URI/Locale.hs
new file mode 100644
index 0000000..60d98b1
--- /dev/null
+++ b/src/Network/URI/Locale.hs
@@ -0,0 +1,34 @@
+module Network.URI.Locale(rfc2616Locale) where
+
+import System.Environment (lookupEnv)
+import Control.Monad (forM)
+import Data.Maybe (mapMaybe)
+import Data.Char (toLower)
+
+--- This file is based on logic in GNOME's LibSoup & GLib.
+
+rfc2616Locale :: IO [String]
+rfc2616Locale = do
+    locales <- forM ["LANGUAGE", "LC_ALL", "LC_MESSAGES", "LANG"] lookupEnv
+    return $ mapMaybe toRFC2616Lang $ split ':' $ firstJust locales "en_US"
+
+toRFC2616Lang "C" = Nothing
+toRFC2616Lang ('C':'.':_) = Nothing
+toRFC2616Lang ('C':'@':_) = Nothing
+toRFC2616Lang lang = case toRFC2616Lang' lang of
+    "" -> Nothing
+    lang' -> Just lang'
+
+toRFC2616Lang' ('_':cs) = '-' : toRFC2616Lang' cs
+toRFC2616Lang' ('.':_) = []
+toRFC2616Lang' ('@':_) = []
+toRFC2616Lang' (c:cs) = toLower c : toRFC2616Lang' cs
+toRFC2616Lang' [] = []
+
+firstJust (Just a:_) _ | a /= "" = a
+firstJust (_:maybes) fallback = firstJust maybes fallback
+firstJust [] fallback = fallback
+
+split b (a:as) | a == b = [] : split b as
+        | (head':tail') <- split b as = (a:head') : tail'
+split _ [] = [[]]
-- 
2.30.2