diff --git a/hurl.cabal b/hurl.cabal --- a/hurl.cabal +++ b/hurl.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 1.4.1.1 +version: 1.4.2.0 -- A short (one-line) description of the package. synopsis: Haskell URL resolver @@ -78,6 +78,11 @@ Default: True Manual: True +Flag rewriters + Description: Support regexp-based URI rewriting/blocking plugins + Default: True + Manual: True + source-repository head type: git location: https://git.adrian.geek.nz/hurl.git @@ -95,7 +100,8 @@ -- Other library packages from which modules are imported. build-depends: base >=4.9 && <=4.12, text >= 1.2 && <1.3, network-uri >=2.6 && <2.7, bytestring >= 0.10 && < 0.11, - async >= 2.1 && < 2.3, filepath, directory + async >= 2.1 && < 2.3, filepath, directory, + time >= 1.6 && < 1.7 -- Directories containing source files. hs-source-dirs: src @@ -106,10 +112,10 @@ 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) @@ -123,6 +129,10 @@ CPP-options: -DWITH_APPSTREAM build-depends: xml-conduit >=1.8 && < 1.9, zlib >= 0.6 && < 0.7, containers other-modules: Network.URI.XDG.AppStream, Network.URI.XDG.AppStreamOutput + if flag(rewriters) + CPP-options: -DWITH_PLUGIN_REWRITES + build-depends: regex >= 1.1 && < 1.2, regex-tdfa >= 1.2 && < 1.4 + other-modules: Network.URI.PlugIns.Rewriters executable hurl -- .hs file containing the Main module @@ -136,3 +146,5 @@ -- Base language which the package is written in. default-language: Haskell2010 + + ghc-options: -threaded diff --git a/src/Network/URI/Charset.hs b/src/Network/URI/Charset.hs --- a/src/Network/URI/Charset.hs +++ b/src/Network/URI/Charset.hs @@ -7,18 +7,22 @@ import qualified Data.ByteString.Lazy as B import Data.Text.Encoding import Debug.Trace (trace) +import Data.List (intercalate) -- | If the MIMEtype specifies a charset parameter, apply it. resolveCharset :: [String] -- ^ The MIMEtype, split by ';' -> ByteString -- ^ The bytes received from the server -> (String, Either Text ByteString) -- ^ The MIMEtype (minus parameters) & possibly decoded text, to be returned from protocol handlers. -resolveCharset (mime:('c':'h':'a':'r':'s':'e':'t':'=':charset):_) response = - (mime, Left $ convertCharset charset $ B.toStrict response) -resolveCharset (mime:_:params) response = resolveCharset (mime:params) response +resolveCharset (mime:('c':'h':'a':'r':'s':'e':'t':'=':charset):params) response = + (parameterizedMIME mime params, Left $ convertCharset charset $ B.toStrict response) +resolveCharset (mime:param:params) response = + resolveCharset (parameterizedMIME mime [param]:params) response resolveCharset [mime] response = (mime, Right $ response) -- NOTE I can't localize this error string because resolveCharset doesn't know the locale. -- I don't think this is worth fixing, because hitting this indicates the server is badly misbehaving. resolveCharset [] response = ("text/x-error\t", Left "Filetype unspecified") + +parameterizedMIME mime params = mime ++ ";" ++ intercalate ";" params -- | As per `resolveCharset`, but also returns given URI (or other type). resolveCharset' :: a -> [String] -> ByteString -> (a, String, Either Text ByteString) diff --git a/src/Network/URI/Fetch.hs b/src/Network/URI/Fetch.hs --- a/src/Network/URI/Fetch.hs +++ b/src/Network/URI/Fetch.hs @@ -2,9 +2,11 @@ {-# 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), newSession, +module Network.URI.Fetch(Session(locale, aboutPages, redirectCount), 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) @@ -26,15 +28,26 @@ import System.Directory 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 @@ -48,37 +61,74 @@ import Network.URI.XDG #endif +#ifdef WITH_PLUGIN_REWRITES +import Network.URI.PlugIns.Rewriters +#endif + -- | Data shared accross multiple URI requests. data Session = Session { #ifdef WITH_HTTP_URI managerHTTP :: HTTP.Manager, #endif #ifdef WITH_RAW_CONNECTIONS - connCtxt :: ConnectionContext, + connCtxt :: TLS.SSLContext, #endif #ifdef WITH_XDG apps :: XDGConfig, #endif +#ifdef WITH_PLUGIN_REWRITES + rewriter :: Rewriter, +#endif -- | The languages (RFC2616-encoded) to which responses should be localized. locale :: [String], -- | Additional files to serve from about: URIs. - aboutPages :: [(FilePath, ByteString)] + aboutPages :: [(FilePath, ByteString)], + -- | Log of timestamped/profiled URL requests + requestLog :: MVar [LogRecord], + -- | How many redirects to follow for Gemini or HTTP(S) requests + redirectCount :: Int } +data LogRecord = LogRecord { + url :: URI, + accept :: [String], + redirected :: URI, + mimetype :: String, + response :: Either Text ByteString, + begin :: UTCTime, + end :: UTCTime + } + -- | Initializes a default Session object to support HTTPS & Accept-Language -- if HTTP is enabled. newSession :: IO Session -newSession = do +newSession = newSession' "" + +-- | Variant of `newSession` which loads plugins for the named app. +newSession' :: String -> IO Session +newSession' appname = do (ietfLocale, unixLocale) <- rfc2616Locale #ifdef WITH_HTTP_URI - managerHTTP' <- HTTP.newManager TLS.tlsManagerSettings + 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 #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 $ Just $ \valid _ -> return valid -- FIXME: Implement Trust-On-First-Use #endif #ifdef WITH_XDG apps' <- loadXDGConfig unixLocale #endif +#ifdef WITH_PLUGIN_REWRITES + rewriters <- parseRewriters appname +#endif + log <- newEmptyMVar return Session { #ifdef WITH_HTTP_URI @@ -90,8 +140,13 @@ #ifdef WITH_XDG apps = apps', #endif +#ifdef WITH_PLUGIN_REWRITES + rewriter = rewriters, +#endif locale = ietfLocale, - aboutPages = [] + aboutPages = [], + requestLog = log, + redirectCount = 5 } llookup key fallback map = fallback `fromMaybe` listToMaybe [v | (k, v) <- map, k == key] @@ -107,10 +162,20 @@ (_, mime, resp) <- fetchURL' sess mimes uri return (mime, resp) +fetchURLLogged sess mimes uri = do + begin' <- getCurrentTime + res@(redirected', mimetype', response') <- fetchURL' sess mimes uri + end' <- getCurrentTime + modifyMVar_ (requestLog sess) $ \log -> return ( + LogRecord uri mimes redirected' mimetype' response' begin' end' : log) + return res + -- | Concurrently fetch given URLs. fetchURLs :: Session -> [String] -> [URI] -> ((URI, String, Either Text ByteString) -> IO a) -> IO [(URI, a)] -fetchURLs sess mimes uris cb = - forConcurrently uris (\u -> fetchURL' sess mimes u >>= cb) >>= return . zip uris +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 . L.zip uris -- | Internal MIMEtypes for error reporting mimeERR, htmlERR :: String @@ -119,6 +184,14 @@ -- | As per `fetchURL`, but also returns the redirected URI. fetchURL' :: Session -> [String] -> URI -> IO (URI, String, Either Text ByteString) +fetchURL' Session {redirectCount = 0, locale = locale'} _ uri = + return (uri, mimeERR, Left $ Txt.pack $ trans locale' ExcessiveRedirects) + +#ifdef WITH_PLUGIN_REWRITES +fetchURL' session mimes uri + | Just uri' <- applyRewriter (rewriter session) uri = fetchURL' session mimes uri' +#endif + fetchURL' session mimes uri@(URI {uriScheme = "about:", uriPath = ""}) = fetchURL' session mimes $ uri {uriPath = "version"} fetchURL' Session {aboutPages = pages} _ url@URI {uriScheme = "about:", uriPath = path} = @@ -135,7 +208,8 @@ HTTP.requestHeaders = [ ("Accept", C8.pack $ intercalate ", " accept), ("Accept-Language", C8.pack $ intercalate ", " $ locale session) - ] + ], + HTTP.redirectCount = redirectCount session } $ managerHTTP session return $ case ( HTTP.responseBody response, @@ -143,7 +217,7 @@ ) 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), @@ -154,40 +228,32 @@ #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 <- Strict.hGetContents input' + let mime' = L.map (Txt.unpack . Txt.strip) $ Txt.splitOn ";" mime + return $ resolveCharset' uri mime' $ B.fromStrict body ('3', _, redirect) | Just redirect' <- parseURIReference $ Txt.unpack redirect -> - fetchURL' sess mimes $ relativeTo redirect' uri + fetchURL' sess { + redirectCount = redirectCount sess - 1 + } 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 @@ -266,20 +332,38 @@ 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 breakOn c (a:as) | c == a = ([], as) | otherwise = let (x, y) = breakOn c as in (a:x, y) breakOn _ [] = ([], []) -#endif - -#ifdef WITH_GEMINI_URI -mWhile test body = do - cond <- test - if cond then do - x <- body - xs <- mWhile test body - return (x:xs) - else return [] #endif diff --git a/src/Network/URI/Messages.hs b/src/Network/URI/Messages.hs --- a/src/Network/URI/Messages.hs +++ b/src/Network/URI/Messages.hs @@ -29,6 +29,7 @@ trans ("en":_) (OpenedWith app) = "Opened in " ++ app trans ("en":_) (ReadFailed msg) = "Failed to read file: " ++ msg trans ("en":_) MalformedResponse = "Invalid response!" +trans ("en":_) ExcessiveRedirects = "Too many redirects!" #if WITH_HTTP_URI trans ("en":_) (Http (InvalidUrlException url msg)) = "Invalid URL " ++ url ++ ": " ++ msg trans ("en":_) (Http (HttpExceptionRequest _ (TooManyRedirects _))) = "Too many redirects!" @@ -44,6 +45,7 @@ data Errors = UnsupportedScheme String | UnsupportedMIME String | RequiresInstall String String | OpenedWith String | ReadFailed String | RawXML String | MalformedResponse + | ExcessiveRedirects #if WITH_HTTP_URI | Http HttpException #endif diff --git a/src/Network/URI/PlugIns/Rewriters.hs b/src/Network/URI/PlugIns/Rewriters.hs new file mode 100644 --- /dev/null +++ b/src/Network/URI/PlugIns/Rewriters.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE FlexibleContexts #-} +module Network.URI.PlugIns.Rewriters(parseRewriter, parseRewriters, Rewriter, applyRewriter) where + +import Text.RE.Tools.Edit +import Text.RE.TDFA.String +import Network.URI (URI, uriToString, parseAbsoluteURI) +import Data.Maybe (catMaybes, fromMaybe) + +import System.Directory as Dir +import System.FilePath (()) +import Control.Concurrent.Async (forConcurrently) + +type Rewriter = Edits Maybe RE String +parseRewriter :: FilePath -> IO Rewriter +parseRewriter filepath = do + source <- readFile filepath + let parseLine line | [pattern, template] <- words line = compileSearchReplace pattern template + | [pattern] <- words line = compileSearchReplace pattern "about:blank" + | otherwise = Nothing + let edits = catMaybes $ map parseLine $ lines source + return $ Select $ map Template edits + +parseRewriters :: String -> IO Rewriter +parseRewriters app = do + dir <- Dir.getXdgDirectory Dir.XdgConfig "nz.geek.adrian.hurl" + exists <- Dir.doesDirectoryExist dir + if exists then do + rewriters <- loadRewriters dir + + let inner = dir app + innerExists <- Dir.doesDirectoryExist dir + if innerExists then do + appRewriters <- loadRewriters inner + return $ Select (appRewriters ++ rewriters) + else return $ Select rewriters + else return $ Select [] + where + loadRewriters dir = do + files <- Dir.listDirectory dir + raw <- forConcurrently files $ \file -> do + rewriter <- parseRewriter file + return $ case rewriter of + Select x -> x + Pipe x -> x + return $ concat raw + +applyRewriter :: Rewriter -> URI -> Maybe URI +applyRewriter rewriter uri = parseAbsoluteURI =<< + applyEdits firstLine rewriter (uriToString id uri "")