hurl 1.4.1.1 → 1.4.2.0
raw patch · 5 files changed
+206/−55 lines, 5 filesdep +HsOpenSSLdep +http-client-openssldep +io-streamsdep −connectiondep −http-client-tls
Dependencies added: HsOpenSSL, http-client-openssl, io-streams, openssl-streams, regex, regex-tdfa, time
Dependencies removed: connection, http-client-tls
Files
- hurl.cabal +16/−4
- src/Network/URI/Charset.hs +7/−3
- src/Network/URI/Fetch.hs +132/−48
- src/Network/URI/Messages.hs +2/−0
- src/Network/URI/PlugIns/Rewriters.hs +49/−0
hurl.cabal view
@@ -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
src/Network/URI/Charset.hs view
@@ -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)
src/Network/URI/Fetch.hs view
@@ -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 [- "<form><label for='input'>",+ "<form><label>", Txt.replace "<" "<" $ Txt.replace "&" "&" 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 <- 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
src/Network/URI/Messages.hs view
@@ -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
+ src/Network/URI/PlugIns/Rewriters.hs view
@@ -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 "")