From ce8562b4fa89c09d4eccba73773e51b62d2dd7aa Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Thu, 8 Oct 2020 20:24:25 +1300 Subject: [PATCH] Switch over to OpenSSL for encryption. --- hurl.cabal | 6 ++- src/Network/URI/Fetch.hs | 93 ++++++++++++++++++++++++++-------------- 2 files changed, 66 insertions(+), 33 deletions(-) diff --git a/hurl.cabal b/hurl.cabal index cce58ca..3740b32 100644 --- a/hurl.cabal +++ b/hurl.cabal @@ -112,10 +112,10 @@ library if flag(http) CPP-options: -DWITH_HTTP_URI build-depends: http-client >= 0.6 && <0.7, http-types >= 0.12 && <0.13, - http-client-tls >= 0.3 && <0.4 + http-client-openssl >= 0.3 && <0.4, HsOpenSSL >= 0.11.4.19 && < 0.12 if flag(gemini) CPP-options: -DWITH_GEMINI_URI -DWITH_RAW_CONNECTIONS - build-depends: connection == 0.3.0 + build-depends: HsOpenSSL >= 0.11.4.19 && < 0.12, openssl-streams >= 1.2 && < 1.3, io-streams >= 1.5 && < 1.6 if flag(file) CPP-options: -DWITH_FILE_URI if flag(data) @@ -146,3 +146,5 @@ executable hurl -- Base language which the package is written in. default-language: Haskell2010 + + ghc-options: -threaded diff --git a/src/Network/URI/Fetch.hs b/src/Network/URI/Fetch.hs index 73866e6..062dda6 100644 --- a/src/Network/URI/Fetch.hs +++ b/src/Network/URI/Fetch.hs @@ -4,7 +4,9 @@ -- disabled at build-time for reduced dependencies. module Network.URI.Fetch(Session(locale, aboutPages), newSession, fetchURL, fetchURL', fetchURLs, mimeERR, htmlERR, - dispatchByMIME, saveDownload, downloadToURI) where + dispatchByMIME, saveDownload, downloadToURI, + -- logging API + LogRecord(..), enableLogging, retrieveLog, writeLog) where import qualified Data.Text as Txt import Data.Text (Text) @@ -29,16 +31,23 @@ import System.FilePath -- for logging import Control.Concurrent.MVar import Data.Time.Clock +import System.IO +import Control.Monad +import Data.List as L #ifdef WITH_HTTP_URI import qualified Network.HTTP.Client as HTTP -import qualified Network.HTTP.Client.TLS as TLS +import qualified Network.HTTP.Client.OpenSSL as TLS +import qualified OpenSSL.Session as TLS import Network.HTTP.Types import Data.List (intercalate) #endif #ifdef WITH_RAW_CONNECTIONS -import Network.Connection +import qualified OpenSSL as TLS +import qualified OpenSSL.Session as TLS +import qualified System.IO.Streams.SSL as TLSConn +import System.IO.Streams #endif #ifdef WITH_DATA_URI @@ -62,7 +71,7 @@ data Session = Session { managerHTTP :: HTTP.Manager, #endif #ifdef WITH_RAW_CONNECTIONS - connCtxt :: ConnectionContext, + connCtxt :: TLS.SSLContext, #endif #ifdef WITH_XDG apps :: XDGConfig, @@ -98,10 +107,14 @@ newSession' :: String -> IO Session newSession' appname = do (ietfLocale, unixLocale) <- rfc2616Locale #ifdef WITH_HTTP_URI - managerHTTP' <- HTTP.newManager TLS.tlsManagerSettings + managerHTTP' <- HTTP.newManager $ TLS.opensslManagerSettings TLS.context #endif #ifdef WITH_RAW_CONNECTIONS - connCtxt <- initConnectionContext + connCtxt <- TLS.context + TLS.contextSetDefaultCiphers connCtxt + TLS.contextSetCADirectory connCtxt "/etc/ssl/certs" + TLS.contextSetVerificationMode connCtxt $ + TLS.VerifyPeer True True Nothing #endif #ifdef WITH_XDG apps' <- loadXDGConfig unixLocale @@ -155,7 +168,7 @@ fetchURLs :: Session -> [String] -> [URI] -> ((URI, String, Either Text ByteStri fetchURLs sess mimes uris cb = do shouldntLog <- isEmptyMVar $ requestLog sess let fetch = if shouldntLog then fetchURL' else fetchURLLogged - forConcurrently uris (\u -> fetch sess mimes u >>= cb) >>= return . zip uris + forConcurrently uris (\u -> fetch sess mimes u >>= cb) >>= return . L.zip uris -- | Internal MIMEtypes for error reporting mimeERR, htmlERR :: String @@ -193,7 +206,7 @@ fetchURL' session accept@(defaultMIME:_) uri | uriScheme uri `elem` ["http:", "h ) of ("", _) -> (uri, mimeERR, Right $ B.fromStrict $ statusMessage $ HTTP.responseStatus response) (response, (mimetype:_)) -> let mime = Txt.toLower $ convertCharset "utf-8" mimetype - in resolveCharset' uri (map (Txt.unpack . Txt.strip) $ Txt.splitOn ";" mime) response + in resolveCharset' uri (L.map (Txt.unpack . Txt.strip) $ Txt.splitOn ";" mime) response (response, []) -> (uri, defaultMIME, Right response) `catches` [ Handler $ \e -> do return (uri, mimeERR, Left $ Txt.pack $ trans (locale session) $ Http e), @@ -204,40 +217,30 @@ fetchURL' session accept@(defaultMIME:_) uri | uriScheme uri `elem` ["http:", "h #ifdef WITH_GEMINI_URI fetchURL' sess@Session {connCtxt = ctxt, locale = l} mimes uri@URI { uriScheme = "gemini:", uriAuthority = Just (URIAuth _ host port) - } = do - conn <- connectTo ctxt $ ConnectionParams { - connectionHostname = host, - connectionPort = parsePort 1965 port, - -- TODO implement Trust-On-First-Use, client certificates - connectionUseSecure = Just $ TLSSettingsSimple False False False, - connectionUseSocks = Nothing - } - connectionPut conn $ C8.pack $ uriToString id uri "\r\n" - header <- connectionGetLine 1024 conn - ret <- case parseHeader header of + } = 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 -- NOTE: This case won't actually do anything until the caller (Rhapsode) implements forms. ('1', _, label) -> return (uri, "application/xhtml+xml", Left $ Txt.concat [ - "
" ]) ('2', _, mime) -> do - chunks <- mWhile (connectionWaitForInput conn 60000 `catch` (return . not . isEOFError)) $ - (connectionGetChunk conn `catch` handleIOErr) - let mime' = map (Txt.unpack . Txt.strip) $ Txt.splitOn ";" mime - return $ resolveCharset' uri mime' $ B.fromChunks chunks + body <- B.hGetContents input' + let mime' = L.map (Txt.unpack . Txt.strip) $ Txt.splitOn ";" mime + return $ resolveCharset' uri mime' body ('3', _, redirect) | Just redirect' <- parseURIReference $ Txt.unpack redirect -> fetchURL' sess 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) - connectionClose conn - return ret where - parseHeader header - | Just (major, header') <- Txt.uncons $ convertCharset "utf-8" header, - Just (minor, meta) <- Txt.uncons header' = (major, minor, Txt.strip meta) - | otherwise = ('4', '1', Txt.pack $ trans l MalformedResponse) + parseHeader :: String -> (Char, Char, Text) + parseHeader (major:minor:meta) = (major, minor, Txt.strip $ Txt.pack meta) + parseHeader _ = ('4', '1', Txt.pack $ trans l MalformedResponse) handleIOErr :: IOError -> IO Strict.ByteString handleIOErr _ = return "" #endif @@ -316,6 +319,34 @@ downloadToURI (_, mime, Right bytes) = nullURI { uriPath = mime ++ ";base64," ++ C8.unpack (B.toStrict $ B64.encode bytes) } +-- Logging API +enableLogging :: Session -> IO () +enableLogging session = do + logInactive <- isEmptyMVar $ requestLog session + if logInactive then putMVar (requestLog session) [] else return () + +retrieveLog :: Session -> IO [LogRecord] +retrieveLog session = do + logInactive <- isEmptyMVar $ requestLog session + if logInactive then return [] else takeMVar $ requestLog session + +writeLog :: Handle -> Session -> IO () +writeLog out session = do + writeRow ["URL", "Redirected", "Accept", "MIMEtype", "Size", "Begin", "End", "Duration"] + log <- retrieveLog session + forM log $ \record -> writeRow [ + show $ url record, show $ redirected record, + show $ accept record, show $ mimetype record, + case response record of + Left txt -> show $ Txt.length txt + Right bs -> show $ B.length bs, + show $ begin record, show $ end record, + show (end record `diffUTCTime` end record) + ] + return () + where + writeRow = hPutStrLn out . L.intercalate "\t" + -- Utils #ifdef WITH_DATA_URI -- 2.30.2