4 files changed, 228 insertions(+), 42 deletions(-)

M hurl.cabal
M src/Network/URI/Cache.hs
M src/Network/URI/Fetch.hs
M src/Network/URI/Messages.hs

@@ 113,12 113,12 @@ library
   
   if flag(http)
     CPP-options:   -DWITH_HTTP_URI
-    build-depends: http-client, http-types >= 0.12 && <0.13,
-                   http-client-openssl, HsOpenSSL, time, cookie
+    build-depends: http-client, http-types >= 0.12 && <0.13, publicsuffixlist >= 0.1,
+                   http-client-tls, time, cookie
     other-modules: Network.URI.Cache, Network.URI.CookiesDB
   if flag(gemini)
     CPP-options:   -DWITH_GEMINI_URI -DWITH_RAW_CONNECTIONS
-    build-depends: HsOpenSSL, openssl-streams >= 1.2 && < 1.3, io-streams >= 1.5 && < 1.6
+    build-depends: connection, tls, data-default-class
   if flag(file)
     CPP-options:   -DWITH_FILE_URI
   if flag(data)

@@ 1,5 1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
-module Network.URI.Cache(shouldCacheHTTP, cacheHTTP, readCacheHTTP, cleanCacheHTTP) where
+module Network.URI.Cache(shouldCacheHTTP, cacheHTTP, readCacheHTTP, cleanCacheHTTP,
+    writeHSTS, readHSTS, appendHSTS, appendHSTSFromHeader, removeHSTS, testHSTS) where
 import Network.HTTP.Client
 import Network.HTTP.Types.Status
 import Network.HTTP.Types.Header


@@ 18,7 19,7 @@ import System.Directory
 import qualified Data.Text as Txt
 
 import Data.Maybe
-import Data.Char (isSpace)
+import Data.Char (isSpace, isDigit, toLower)
 import Data.List as L
 import Control.Monad (forM, void, when)
 import Text.Read (readMaybe)


@@ 130,14 131,16 @@ openKV key mode act = do
 readKV key = openKV key ReadMode parseHeaders
 
 parseHeaders h = do
-    line <- IO.hGetLine h
-    case L.break isSpace $ strip' line of
-        ("", "") -> do
-            body <- Lazy.hGetContents h
-            return ([], body)
-        (key, value) -> do
-            (headers, body) <- parseHeaders h
-            return ((key, strip' value):headers, body)
+    isEnd <- IO.hIsEOF h
+    if isEnd then return ([], "") else do
+        line <- IO.hGetLine h
+        case L.break isSpace $ strip' line of
+            ("", "") -> do
+                body <- Lazy.hGetContents h
+                return ([], body)
+            (key, value) -> do
+                (headers, body) <- parseHeaders h
+                return ((key, strip' value):headers, body)
 strip' = L.dropWhile isSpace . L.dropWhileEnd isSpace
 
 writeKV key (headers, body) = void $ openKV key WriteMode $ \h -> do


@@ 147,3 150,89 @@ writeKV key (headers, body) = void $ openKV key WriteMode $ \h -> do
     Lazy.hPut h body
 
 deleteKV key = pathKV key >>= removeFile
+
+--------
+---- HSTS Support
+--------
+readHSTS :: IO [(String, Bool, UTCTime)]
+readHSTS = do
+    (headers, _) <- fromMaybe ([], "") <$> readKV ".HSTS"
+    -- Remove expired & duplicate entries on startup via `nubHSTS`
+    now <- getCurrentTime
+    let db = nubHSTS now (L.reverse $ mapMaybe parseRecord headers) []
+    writeHSTS $ seq (L.length db) db -- Ensure the file is fully read before being written.
+    return db
+  where
+    parseRecord ('*':domain, value) | Just expires <- readMaybe value = Just (domain, True, expires)
+    parseRecord (domain, value) | Just expires <- readMaybe value = Just (domain, False, expires)
+    parseRecord _ = Nothing
+appendHSTS :: (String, Bool, UTCTime) -> IO ()
+appendHSTS = void . openKV ".HSTS" AppendMode . flip appendHSTS'
+appendHSTS' h (domain, True, expires) = IO.hPutStrLn h ('*':domain ++ ' ':show expires)
+appendHSTS' h (domain, False, expires) = IO.hPutStrLn h (domain ++ ' ':show expires)
+writeHSTS :: [(String, Bool, UTCTime)] -> IO ()
+writeHSTS domains = void . openKV ".HSTS" WriteMode $ \h -> forM domains (appendHSTS' h)
+
+-- Directly disregards IETF RFC6797 section 12.1
+-- I prefer not to give up on designing a proper consent UI.
+removeHSTS :: [(String, Bool, UTCTime)] -> String -> IO [(String, Bool, UTCTime)]
+removeHSTS db badDomain = do
+    now <- getCurrentTime -- Clear out expired records while we're at it...
+    let ret = nubHSTS now db [badDomain]
+    writeHSTS ret
+    return ret
+
+nubHSTS now (x@(domain, _, expires):db) filter
+    | domain `L.elem` filter = nubHSTS now db (domain:filter)
+    -- Filter out expired entries while we're at it.
+    | now >= expires = nubHSTS now db (domain:filter)
+    | otherwise = x:nubHSTS now db (domain:filter)
+nubHSTS _ [] _ = []
+
+appendHSTSFromHeader :: String -> Strict.ByteString -> IO (Maybe (String, Bool, UTCTime))
+appendHSTSFromHeader domain header =
+    let dirs = parseDirectives $ C.split ';' header
+    in if validateHSTS dirs then do
+        expiry <- secondsFromNow $ fromMaybe 0 (readMaybe =<< lookup "max-age" dirs)
+        -- FIXME: Is it right I'm ignoring if this has a value.
+        let subdomains = isJust $ lookup "includesubdomains" dirs
+        appendHSTS (domain, subdomains, expiry)
+        return $ Just (domain, subdomains, expiry)
+    else return Nothing
+
+parseDirectives (dir:dirs) = case L.break (== '=') $ C.unpack dir of
+    (key, '=':'"':quoted) | Just (value, dirs') <- parseString quoted dirs
+        -> (lowercase $ strip key, value):parseDirectives dirs'
+    (_, '=':'"':_) -> [("", "")] -- Represents error...
+    (key, '=':value) -> (lowercase $ strip key, strip value):parseDirectives dirs
+    (key, _) -> (lowercase $ strip key, ""):parseDirectives dirs
+  where
+    parseString ('\\':c:str) tail = appendC c $ parseString str tail
+    parseString ("\"") tail = Just ("", tail)
+    parseString ('"':_) _ = Nothing -- Disallow trailing text
+    parseString (c:str) tail = appendC c $ parseString str tail
+    -- Handle the naive split-by-semicolon above.
+    parseString "" (extra:tail) = appendC ';' $ parseString (C.unpack extra) tail
+    parseString "" [] = Nothing
+    appendC c (Just (str, tail)) = Just (c:str, tail)
+    appendC _ Nothing = Nothing
+
+    strip = L.dropWhile isSpace . L.dropWhileEnd isSpace
+    lowercase = L.map toLower
+parseDirectives [] = []
+
+validateHSTS directives
+    | Just _ <- lookup "" directives = False -- indicates empty key or malformed string
+    | Nothing <- lookup "max-age" directives = False -- mandatory field
+    | Just val <- lookup "max-age" directives, L.any (not . isDigit) val = False -- invalid value
+    | otherwise = validateHSTS' directives -- check no duplicate keys
+validateHSTS' ((dir, _):dirs) | Just _ <- lookup dir dirs = False
+    | otherwise = validateHSTS' dirs
+validateHSTS' [] = True
+
+testHSTS :: UTCTime -> String -> [(String, Bool, UTCTime)] -> Bool
+testHSTS now key ((_, _, expires):db) | now > expires = testHSTS now key db
+testHSTS _ key ((domain, _, _):db) | key == domain = True
+testHSTS _ key ((domain, True, _):db) | ('.':domain) `L.isSuffixOf` key = True
+testHSTS now key (_:db) = testHSTS now key db
+testHSTS _ _ [] = False

@@ 2,7 2,9 @@
 {-# 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, redirectCount, cachingEnabled), newSession,
+module Network.URI.Fetch(
+    Session(locale, aboutPages, redirectCount, cachingEnabled, validateCertificates),
+    newSession,
     fetchURL, fetchURL', fetchURLs, submitURL, submitURL', mimeERR, htmlERR,
     dispatchByMIME, appsForMIME, Application(..), dispatchByApp,
     saveDownload, downloadToURI,


@@ 49,9 51,10 @@ import Data.List as L
 #ifdef WITH_HTTP_URI
 import qualified Network.HTTP.Client as HTTP
 import qualified Network.HTTP.Client.MultipartFormData as HTTP
-import qualified Network.HTTP.Client.OpenSSL as TLS
-import qualified OpenSSL.Session as TLS
+import qualified Network.HTTP.Client.TLS as TLS
 import           Network.HTTP.Types
+import           Network.PublicSuffixList.Lookup (effectiveTLDPlusOne)
+
 import           Data.List (intercalate)
 import           Control.Concurrent (forkIO)
 


@@ 60,10 63,10 @@ import           Network.URI.CookiesDB
 #endif
 
 #ifdef WITH_RAW_CONNECTIONS
-import qualified OpenSSL as TLS
-import qualified OpenSSL.Session as TLS
-import qualified System.IO.Streams.SSL as TLSConn
-import System.IO.Streams
+import qualified Network.Connection as Conn
+import qualified Network.TLS as TLS
+import qualified Network.TLS.Extra.Cipher as TLS
+import           Data.Default.Class (def)
 #endif
 
 #ifdef WITH_DATA_URI


@@ 80,6 83,9 @@ import Network.URI.XDG
 #ifdef WITH_PLUGIN_REWRITES
 import Network.URI.PlugIns.Rewriters
 #endif
+#ifdef WITH_PLUGIN_EXEC
+import System.Process
+#endif
 
 -- | Data shared accross multiple URI requests.
 data Session = Session {


@@ 88,9 94,10 @@ data Session = Session {
     globalCookieJar :: MVar HTTP.CookieJar,
     cookiesPath :: FilePath,
     retroactiveCookies :: Maybe (MVar HTTP.CookieJar),
+    hstsDomains :: MVar [(String, Bool, UTCTime)],
 #endif
 #ifdef WITH_RAW_CONNECTIONS
-    connCtxt :: TLS.SSLContext,
+    connCtxt :: Conn.ConnectionContext,
 #endif
 #ifdef WITH_XDG
     apps :: XDGConfig,


@@ 109,7 116,9 @@ data Session = Session {
     -- | Whether to cache network responses, avoiding sending requests
     cachingEnabled :: Bool,
     -- | App-specific config subdirectory to check
-    appName :: String
+    appName :: String,
+    -- | Whether to validate the server is who they say they are on secured protocols.
+    validateCertificates :: Bool
 }
 
 data LogRecord = LogRecord {


@@ 132,11 141,7 @@ newSession' :: String -> IO Session
 newSession' appname = do
     (ietfLocale, unixLocale) <- rfc2616Locale
 #ifdef WITH_HTTP_URI
-    httpsCtxt <- TLS.context
-    TLS.contextSetDefaultCiphers httpsCtxt
-    TLS.contextSetCADirectory httpsCtxt "/etc/ssl/certs"
-    TLS.contextSetVerificationMode httpsCtxt $ TLS.VerifyPeer True True Nothing
-    managerHTTP' <- HTTP.newManager $ TLS.opensslManagerSettings $ return httpsCtxt
+    managerHTTP' <- HTTP.newManager $ TLS.tlsManagerSettings
 
     cookiesDir <- getXdgDirectory XdgData "nz.geek.adrian.hurl.cookies2"
     let cookiesPath' = cookiesDir </> appname


@@ 144,13 149,11 @@ newSession' appname = do
     now <- getCurrentTime
     cookieJar <- newMVar $ HTTP.evictExpiredCookies cookies' now
     cookieJar' <- newMVar $ HTTP.createCookieJar []
+
+    hstsDomains' <- newMVar =<< readHSTS
 #endif
 #ifdef WITH_RAW_CONNECTIONS
-    connCtxt <- TLS.context
-    TLS.contextSetDefaultCiphers connCtxt
-    TLS.contextSetCADirectory connCtxt "/etc/ssl/certs"
-    TLS.contextSetVerificationMode connCtxt $
-        TLS.VerifyPeer True True $ Just $ \valid _ -> return valid -- FIXME: Implement Trust-On-First-Use
+    connCtxt <- Conn.initConnectionContext
 #endif
 #ifdef WITH_XDG
     apps' <- loadXDGConfig unixLocale


@@ 165,6 168,7 @@ newSession' appname = do
         globalCookieJar = cookieJar,
         cookiesPath = cookiesPath',
         retroactiveCookies = Just cookieJar',
+        hstsDomains = hstsDomains',
 #endif
 #ifdef WITH_RAW_CONNECTIONS
         connCtxt = connCtxt,


@@ 180,6 184,7 @@ newSession' appname = do
         requestLog = Nothing,
         redirectCount = 5,
         cachingEnabled = True,
+        validateCertificates = True,
         appName = appname
     }
 


@@ 357,11 362,25 @@ fetchURL' session accept uri | uriScheme uri `elem` ["http:", "https:"] =
 #ifdef WITH_GEMINI_URI
 fetchURL' sess@Session {connCtxt = ctxt, locale = l} mimes uri@URI {
         uriScheme = "gemini:", uriAuthority = Just (URIAuth _ host port)
-    } = TLSConn.withConnection ctxt host (parsePort 1965 port) $ \input output _ -> do
-        writeTo output $ Just $ C8.pack $ uriToString id uri "\r\n"
-        input' <- inputStreamToHandle input
-        header <- hGetLine input'
-        case parseHeader header of
+    } = do
+        let params = TLS.defaultParamsClient host "gmni"
+        conn <- Conn.connectTo ctxt Conn.ConnectionParams {
+            Conn.connectionHostname = host,
+            Conn.connectionPort = parsePort 1965 port,
+            -- FIXME Implement certificate validation that actually common geminispace certs...
+            Conn.connectionUseSecure = Just $ Conn.TLSSettings params {
+                TLS.clientSupported = def { TLS.supportedCiphers = TLS.ciphersuite_default },
+                TLS.clientShared = def {
+                    TLS.sharedValidationCache = TLS.ValidationCache
+                        (\_ _ _ -> return TLS.ValidationCachePass)
+                        (\_ _ _ -> return ())
+                }
+            },
+            Conn.connectionUseSocks = Nothing
+        }
+        Conn.connectionPut conn $ C8.pack $ uriToString id uri "\r\n"
+        header <- Conn.connectionGetLine 1027 conn
+        case parseHeader $ C8.unpack header of
             -- NOTE: This case won't actually do anything until the caller (Rhapsode) implements forms.
             ('1', _, label) -> return (uri, "application/xhtml+xml", Left $ Txt.concat [
                     "<form><label>",


@@ 369,9 388,9 @@ fetchURL' sess@Session {connCtxt = ctxt, locale = l} mimes uri@URI {
                     "<input /></label></form>"
                 ])
             ('2', _, mime) -> do
-                body <- Strict.hGetContents input'
+                body <- B.fromChunks <$> connectionGetChunks conn
                 let mime' = L.map (Txt.unpack . Txt.strip) $ Txt.splitOn ";" mime
-                return $ resolveCharset' uri mime' $ B.fromStrict body
+                return $ resolveCharset' uri mime' body
             ('3', _, redirect) | Just redirect' <- parseURIReference $ Txt.unpack redirect ->
                 fetchURL' sess {
                     redirectCount = redirectCount sess - 1


@@ 385,6 404,9 @@ fetchURL' sess@Session {connCtxt = ctxt, locale = l} mimes uri@URI {
         parseHeader _ = ('4', '1', Txt.pack $ trans l MalformedResponse)
         handleIOErr :: IOError -> IO Strict.ByteString
         handleIOErr _ = return ""
+        connectionGetChunks conn = do
+            chunk <- Conn.connectionGetChunk conn `catch` handleIOErr
+            if Strict.null chunk then return [] else (chunk:) <$> connectionGetChunks conn
 #endif
 
 #ifdef WITH_FILE_URI


@@ 453,8 475,20 @@ dispatchByApp _ _ _ _ = return False
 #endif
 
 #ifdef WITH_HTTP_URI
-fetchHTTPCached session shouldCache accept@(defaultMIME:_) uri cbReq cbResp = do
+fetchHTTPCached session shouldCache accept@(defaultMIME:_) rawUri cbReq cbResp = do
+    now <- getCurrentTime
+    hsts <- readMVar $ hstsDomains session
+    uri <- case (uriScheme rawUri, uriAuthority rawUri) of {
+        (_, Just (URIAuth _ domain _)) | not $ validateCertificates session -> (do
+            modifyMVar_ (hstsDomains session) $ flip removeHSTS domain
+            return rawUri);
+        ("http:", Just (URIAuth _ domain _))
+            | testHSTS now domain hsts -> return rawUri { uriScheme = "https:" };
+        _ -> return rawUri
+    }
+
     cached <- if shouldCache then readCacheHTTP uri else return (Nothing, Nothing)
+
     response <- case cached of
         (Just (mime, body), Nothing) -> return $ Right (mime, body)
         (cached, cachingHeaders) -> do


@@ 471,6 505,18 @@ fetchHTTPCached session shouldCache accept@(defaultMIME:_) uri cbReq cbResp = do
             response <- HTTP.httpLbs request' $ managerHTTP session
             cbResp response
             case (
+                uriScheme uri,
+                uriAuthority uri,
+                "strict-transport-security" `lookup` HTTP.responseHeaders response
+              ) of
+                ("https:", Just (URIAuth _ domain _), Just header)
+                  | Just domain' <- effectiveTLDPlusOne $ Txt.pack domain -> do
+                    record <- appendHSTSFromHeader (Txt.unpack domain') header
+                    case record of
+                        Just x -> modifyMVar_ (hstsDomains session) (return . (x:))
+                        _ -> return ()
+                _ -> return ()
+            case (
                     HTTP.responseStatus response,
                     HTTP.responseBody response,
                     [val | ("content-type", val) <- HTTP.responseHeaders response]


@@ 499,7 545,7 @@ fetchHTTPCached session shouldCache accept@(defaultMIME:_) uri cbReq cbResp = do
         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)
+  `catch` \e -> do return (rawUri, mimeERR, Left $ Txt.pack $ trans (locale session) $ Http e)
 fetchHTTPCached session _ [] uri _ _ =
     return (uri, mimeERR, Left $ Txt.pack $ trans (locale session) $ UnsupportedMIME "")
 #endif

@@ 17,6 17,8 @@ import Data.Maybe (fromMaybe)
 #if WITH_HTTP_URI
 import Network.HTTP.Client (HttpException(..), HttpExceptionContent(..))
 import Control.Exception (displayException)
+import Network.TLS (TLSException(..), TLSError(..), AlertDescription(..))
+import Control.Exception.Base (fromException)
 #endif
 
 trans _ (RawXML markup) = markup


@@ 36,7 38,56 @@ trans ("en":_) (Http (HttpExceptionRequest _ (TooManyRedirects _))) = "Too many 
 trans ("en":_) (Http (HttpExceptionRequest _ ResponseTimeout)) = "The site took too long to respond!"
 trans ("en":_) (Http (HttpExceptionRequest _ ConnectionTimeout)) = "The site took too long to connect!"
 trans ("en":_) (Http (HttpExceptionRequest _ (ConnectionFailure err))) = "Could not connect: " ++ displayException err
-trans ("en":_) (Http (HttpExceptionRequest _ _)) = "The site doesn't appear to speak the same language as me!"
+trans ("en":_) (Http (HttpExceptionRequest _ (InternalException e))) = case fromException e of
+    Just (Terminated _ why _) -> "Secure session disconnected! <em>" ++ why ++ "</em>"
+    Just (HandshakeFailed (Error_Misc msg)) ->
+        "Failed to establish secure connection! <em>" ++ msg ++ "</em>"
+    Just (HandshakeFailed (Error_Protocol (_, _, CloseNotify))) ->
+        "Secure session disconnected!"
+    Just (HandshakeFailed (Error_Protocol (_, _, HandshakeFailure))) ->
+        "Failed to negotiate security parameters!"
+    Just (HandshakeFailed (Error_Protocol (_, _, BadCertificate))) ->
+        "<h1>The site failed to prove it is who it says it is!</h1>"
+    Just (HandshakeFailed (Error_Protocol (_, _, UnsupportedCertificate))) -> unlines [
+        "<h1>The site failed to prove it is who it says it is!</h1>",
+        "<p>It has sent us a cryptographic certificate I failed to make sense of.</p>"
+      ]
+    Just (HandshakeFailed (Error_Protocol (_, _, CertificateExpired))) -> unlines [
+        "<h1>The site failed to prove it is who it says it is!</h1>",
+        "<p>The cryptographic certificate it has sent to us has expired!</p>"
+      ]
+    Just (HandshakeFailed (Error_Protocol (_, _, CertificateRevoked))) -> unlines [
+        "<h1>The site failed to prove it is who it says it is!</h1>",
+        "<p>The cryptographic certificate it has sent us has been revoked!</p>"
+      ]
+    Just (HandshakeFailed (Error_Protocol (_, _, CertificateUnknown))) -> unlines [
+        "<h1>The site failed to prove it is who it says it is!</h1>",
+        "<p>The cryptographic certificate it has sent us belongs to someone else!</p>"
+      ]
+    Just (HandshakeFailed (Error_Protocol (_, _, UnknownCa))) -> unlines [
+        "<h1>The site failed to prove it is who it says it is!</h1>",
+        "<p>The authority vouching for it is unknown to me!</p>"
+      ]
+    Just (HandshakeFailed (Error_Protocol (why, _, _desc))) ->
+        "Failed to establish secure connection! <em>" ++ why ++ "</em>"
+    Just (HandshakeFailed (Error_Certificate why)) -> unlines [
+        "<h1>The site failed to prove it is who it says it is!</h1>",
+        "<p>" ++ why ++ "</p>"
+      ]
+    Just (HandshakeFailed (Error_HandshakePolicy why)) ->
+        "Invalid handshake policy: <em>" ++ why ++ "</em>"
+    Just (HandshakeFailed Error_EOF) -> "Secure session disconnected!"
+    Just (HandshakeFailed (Error_Packet why)) ->
+        "Invalid security packet: <em>" ++ why ++ "</em>"
+    Just (HandshakeFailed (Error_Packet_unexpected a b)) -> unlines [
+        "<p>Invalid security packet: <em>" ++ a ++ "</em></p>",
+        "<p>" ++ b ++ "</p>"
+      ]
+    Just (HandshakeFailed (Error_Packet_Parsing why)) ->
+        "Invalid security packet: <em>" ++ why ++ "</em>"
+    Just ConnectionNotEstablished ->
+        "Attempted to send or recieve data before establishing secure connection!"
+    Nothing -> "Internal error: " ++ displayException e
 #endif
 --- END LOCALIZATION