summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAdrian Cochrane <adrian@openwork.nz>2020-10-08 20:24:25 +1300
committerAdrian Cochrane <adrian@openwork.nz>2020-10-08 20:24:25 +1300
commitce8562b4fa89c09d4eccba73773e51b62d2dd7aa (patch)
tree749e303a058923ecb5c4afb578c19752f952a190
parent96f09fdcd64b6a6673e0efbddebd465e84ccd629 (diff)
downloadhurl-ce8562b4fa89c09d4eccba73773e51b62d2dd7aa.tar.gz
hurl-ce8562b4fa89c09d4eccba73773e51b62d2dd7aa.tar.bz2
hurl-ce8562b4fa89c09d4eccba73773e51b62d2dd7aa.zip
Switch over to OpenSSL for encryption.
-rw-r--r--hurl.cabal6
-rw-r--r--src/Network/URI/Fetch.hs93
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 [
- "<form><label for='input'>",
+ "<form><label>",
Txt.replace "<" "&lt;" $ Txt.replace "&" "&amp;" label,
- "</label><input id='input' /></form>"
+ "<input /></label></form>"
])
('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