2 files changed, 66 insertions(+), 33 deletions(-)

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

@@ 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

@@ 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