hurl 1.3.0.0 → 1.4.0.0
raw patch · 5 files changed
+225/−35 lines, 5 filesdep +asyncdep +connectiondep +hurldep ~network-urinew-component:exe:hurl
Dependencies added: async, connection, hurl
Dependency ranges changed: network-uri
Files
- Main.hs +19/−0
- hurl.cabal +28/−6
- src/Network/URI/Charset.hs +8/−2
- src/Network/URI/Fetch.hs +168/−26
- src/Network/URI/Messages.hs +2/−1
+ Main.hs view
@@ -0,0 +1,19 @@+module Main where++import Network.URI.Fetch+-- Input parsing+import System.Environment (getArgs)+import Network.URI (parseURI, nullURI)+import Data.Maybe (catMaybes)+-- Where to save files+import System.Directory (getCurrentDirectory)++main :: IO ()+main = do+ urls <- getArgs+ let urls' = catMaybes $ map parseURI urls+ session <- newSession+ dir <- getCurrentDirectory++ res <- fetchURLs session ["*/*"] urls' $ saveDownload nullURI dir+ putStrLn $ show res
hurl.cabal view
@@ -10,16 +10,16 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 1.3.0.0+version: 1.4.0.0 -- A short (one-line) description of the package. synopsis: Haskell URL resolver -- A longer description of the package.-description: Retrieves resources for a URI, whether they be HTTP(S), file:, or data:.+description: Retrieves resources for a URI, whether they be HTTP(S), gemini:, file:, or data:. -- URL for the project homepage or repository.-homepage: https://git.nzoss.org.nz/alcinnz/hurl+homepage: https://git.adrian.geek.nz/hurl.git/ -- The license under which the package is released. license: GPL-3@@ -53,6 +53,11 @@ Default: True Manual: True +Flag gemini+ Description: Support gemini: URIs.+ Default: True+ Manual: True+ Flag file Description: Support file: URIs. Default: True@@ -75,7 +80,7 @@ source-repository head type: git- location: https://git.nzoss.org.nz/alcinnz/hurl.git+ location: https://git.adrian.geek.nz/hurl.git library -- Modules exported by the library.@@ -89,7 +94,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+ network-uri >=2.6 && <2.7, bytestring >= 0.10 && < 0.11,+ async >= 2.1 && < 2.3, filepath, directory -- Directories containing source files. hs-source-dirs: src@@ -101,6 +107,9 @@ 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+ if flag(gemini)+ CPP-options: -DWITH_GEMINI_URI -DWITH_RAW_CONNECTIONS+ build-depends: connection == 0.3.0 if flag(file) CPP-options: -DWITH_FILE_URI if flag(data)@@ -108,9 +117,22 @@ build-depends: base64-bytestring >=1.0 && <2.0 if flag(freedesktop) CPP-options: -DWITH_XDG- build-depends: filepath, directory, process >= 1.2 && <2.0+ build-depends: process >= 1.2 && <2.0 other-modules: Network.URI.XDG.Ini, Network.URI.XDG.MimeApps, Network.URI.XDG.DesktopEntry, Network.URI.XDG if flag(freedesktop) && flag(appstream) 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++executable hurl+ -- .hs file containing the Main module+ main-is: Main.hs++ -- Other library packages from which modules are imported+ build-depends: base >=4.9 && <=4.12, hurl, network-uri, directory++ -- Directories containing source files.+ hs-source-dirs: .++ -- Base language which the package is written in.+ default-language: Haskell2010
src/Network/URI/Charset.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -- | Handles server-specified text decoding.-module Network.URI.Charset(resolveCharset, convertCharset, charsets) where+module Network.URI.Charset(resolveCharset, resolveCharset', convertCharset, charsets) where import Data.Text (Text) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as B@@ -16,7 +16,13 @@ (mime, Left $ convertCharset charset $ B.toStrict response) resolveCharset (mime:_:params) response = resolveCharset (mime:params) response resolveCharset [mime] response = (mime, Right $ response)-resolveCharset [] response = ("text/plain", Left "Filetype unspecified")+-- 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")++-- | As per `resolveCharset`, but also returns given URI (or other type).+resolveCharset' :: a -> [String] -> ByteString -> (a, String, Either Text ByteString)+resolveCharset' a mimes resp = let (mime, resp') = resolveCharset mimes resp in (a, mime, resp') -- | Decodes bytes according to a charset identified by it's IANA-assigned name(s). convertCharset "iso-8859-1" = decodeLatin1
src/Network/URI/Fetch.hs view
@@ -2,26 +2,43 @@ {-# 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, newSession, fetchURL, dispatchByMIME) where+module Network.URI.Fetch(Session, locale, newSession,+ fetchURL, fetchURL', fetchURLs, mimeERR, htmlERR,+ dispatchByMIME, saveDownload, downloadToURI) where import qualified Data.Text as Txt import Data.Text (Text) import Network.URI+import qualified Data.ByteString as Strict import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString.Char8 as C8+import Network.URI.Charset import Control.Exception+import System.IO.Error (isEOFError)+import Control.Concurrent.Async (forConcurrently) +-- for about: URIs & port parsing, all standard lib+import Data.Maybe (fromMaybe, listToMaybe)+import Text.Read (readMaybe)++-- for saveDownload+import System.Directory+import System.FilePath+ #ifdef WITH_HTTP_URI import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Client.TLS as TLS import Network.HTTP.Types-import Network.URI.Charset import Data.List (intercalate) #endif +#ifdef WITH_RAW_CONNECTIONS+import Network.Connection+#endif+ #ifdef WITH_DATA_URI-import qualified Data.ByteString.Char8 as C8-import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Base64.URL.Lazy as B64 #endif import Network.URI.Locale@@ -36,11 +53,16 @@ #ifdef WITH_HTTP_URI managerHTTP :: HTTP.Manager, #endif+#ifdef WITH_RAW_CONNECTIONS+ connCtxt :: ConnectionContext,+#endif #ifdef WITH_XDG apps :: XDGConfig, #endif -- | The languages (RFC2616-encoded) to which responses should be localized.- locale :: [String]+ locale :: [String],+ -- | Additional files to serve from about: URIs.+ aboutPages :: [(FilePath, ByteString)] } -- | Initializes a default Session object to support HTTPS & Accept-Language@@ -51,6 +73,9 @@ #ifdef WITH_HTTP_URI managerHTTP' <- HTTP.newManager TLS.tlsManagerSettings #endif+#ifdef WITH_RAW_CONNECTIONS+ connCtxt <- initConnectionContext+#endif #ifdef WITH_XDG apps' <- loadXDGConfig unixLocale #endif@@ -59,19 +84,51 @@ #ifdef WITH_HTTP_URI managerHTTP = managerHTTP', #endif+#ifdef WITH_RAW_CONNECTIONS+ connCtxt = connCtxt,+#endif #ifdef WITH_XDG apps = apps', #endif- locale = ietfLocale+ locale = ietfLocale,+ aboutPages = [] } +llookup key fallback map = fallback `fromMaybe` listToMaybe [v | (k, v) <- map, k == key]+parsePort fallback (':':port) = fallback `fromMaybe` readMaybe port+parsePort fallback _ = fallback+ -- | Retrieves a URL-identified resource & it's MIMEtype, possibly decoding it's text. fetchURL :: Session -- ^ The session of which this request is a part. -> [String] -- ^ The expected MIMEtypes in priority order. -> URI -- ^ The URL to retrieve -> IO (String, Either Text ByteString) -- ^ The MIMEtype & possibly text-decoded response.+fetchURL sess mimes uri = do+ (_, mime, resp) <- fetchURL' sess mimes uri+ return (mime, resp)++-- | 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++-- | Internal MIMEtypes for error reporting+mimeERR, htmlERR :: String+mimeERR = "txt/x-error\t"+htmlERR = "html/x-error\t"++-- | As per `fetchURL`, but also returns the redirected URI.+fetchURL' :: Session -> [String] -> URI -> IO (URI, String, Either Text ByteString)+fetchURL' session mimes uri@(URI {uriScheme = "about:", uriPath = ""}) =+ fetchURL' session mimes $ uri {uriPath = "version"}+fetchURL' Session {aboutPages = pages} _ url@URI {uriScheme = "about:", uriPath = path} =+ return (url,+ Txt.unpack $ convertCharset "utf-8" $ B.toStrict $+ llookup (path ++ ".mime") "text/html" pages,+ Right $ llookup path "" pages)+ #ifdef WITH_HTTP_URI-fetchURL session accept@(defaultMIME:_) uri | uriScheme uri `elem` ["http:", "https:"] = do+fetchURL' session accept@(defaultMIME:_) uri | uriScheme uri `elem` ["http:", "https:"] = do request <- HTTP.requestFromURI uri response <- HTTP.httpLbs request { HTTP.cookieJar = Nothing, -- Will only be supported by Rhapsode when submitting a form.@@ -84,45 +141,85 @@ HTTP.responseBody response, [val | ("content-type", val) <- HTTP.responseHeaders response] ) of- ("", _) -> ("text/plain", Right $ B.fromStrict $ statusMessage $ HTTP.responseStatus response)+ ("", _) -> (uri, mimeERR, Right $ B.fromStrict $ statusMessage $ HTTP.responseStatus response) (response, (mimetype:_)) -> let mime = Txt.toLower $ convertCharset "utf-8" mimetype- in resolveCharset (map (Txt.unpack . Txt.strip) $ Txt.splitOn ";" $ mime) response- (response, []) -> (defaultMIME, Right response)+ in resolveCharset' uri (map (Txt.unpack . Txt.strip) $ Txt.splitOn ";" mime) response+ (response, []) -> (uri, defaultMIME, Right response) `catches` [- Handler $ \e -> do return ("text/plain", Left $ Txt.pack $ trans (locale session) $ Http e),- Handler $ \(ErrorCall msg) -> do return ("text/plain", Left $ Txt.pack msg)+ Handler $ \e -> do return (uri, mimeERR, Left $ Txt.pack $ trans (locale session) $ Http e),+ Handler $ \(ErrorCall msg) -> do return (uri, mimeERR, Left $ Txt.pack msg) ] #endif +#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+ -- 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'>",+ Txt.replace "<" "<" $ Txt.replace "&" "&" label,+ "</label><input id='input' /></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+ ('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)+ handleIOErr :: IOError -> IO Strict.ByteString+ handleIOErr _ = return ""+#endif+ #ifdef WITH_FILE_URI-fetchURL Session {locale = l} (defaultMIME:_) uri@URI {uriScheme = "file:"} = do+fetchURL' Session {locale = l} (defaultMIME:_) uri@URI {uriScheme = "file:"} = do response <- B.readFile $ uriPath uri- return (defaultMIME, Right response)+ return (uri, defaultMIME, Right response) `catch` \e -> do- return (- "text/plain",+ return (uri, mimeERR, Left $ Txt.pack $ trans l $ ReadFailed $ displayException (e :: IOException)) #endif #ifdef WITH_DATA_URI-fetchURL _ (defaultMIME:_) uri@URI {uriScheme = "data:"} =+fetchURL' _ (defaultMIME:_) uri@URI {uriScheme = "data:"} = let request = uriPath uri ++ uriQuery uri ++ uriFragment uri in case breakOn ',' $ unEscapeString request of- ("", response) -> return (defaultMIME, Left $ Txt.pack response)+ ("", response) -> return (uri, defaultMIME, Left $ Txt.pack response) (mime', response) | '4':'6':'e':'s':'a':'b':';':mime <- reverse mime' ->- return $ case B64.decode $ C8.pack response of- Left str -> ("text/plain", Left $ Txt.pack str)- Right bytes -> (reverse mime, Right $ B.fromStrict bytes)- (mime, response) -> return (mime, Left $ Txt.pack response)+ return $ case B64.decode $ B.fromStrict $ C8.pack response of+ Left str -> (uri, mimeERR, Left $ Txt.pack $ unEscapeString str)+ Right bytes -> (uri, reverse mime, Right bytes)+ (mime, response) -> return (uri, mime, Left $ Txt.pack response) #endif #ifdef WITH_XDG-fetchURL Session {locale = l, apps = a} _ uri@(URI {uriScheme = s}) = do+fetchURL' Session {locale = l, apps = a} _ uri@(URI {uriScheme = s}) = do app <- dispatchURIByMIME a uri ("x-scheme-handler/" ++ init s)- return ("text/html", Left $ Txt.pack $ trans l $ app)+ return (uri, htmlERR, Left $ Txt.pack $ trans l $ app) #else-fetchURL Session {locale = l} _ URI {uriScheme = scheme} =- return ("text/plain", Left $ Txt.pack $ trans l $ UnsupportedScheme scheme)+fetchURL' Session {locale = l} _ URI {uriScheme = scheme} =+ return (uri, mimeERR, Left $ Txt.pack $ trans l $ UnsupportedScheme scheme) #endif dispatchByMIME :: Session -> String -> URI -> IO (Maybe String)@@ -136,8 +233,53 @@ dispatchByMIME _ _ _ = return Nothing #endif +-- Downloads utilities+-- | write download to a file in the given directory.+saveDownload :: URI -> FilePath -> (URI, String, Either Text ByteString) -> IO URI+saveDownload baseURI dir (URI {uriPath = path}, mime, resp) = do+ dest <- unusedFilename (dir </> takeFileName' path)+ case resp of+ Left txt -> writeFile dest $ Txt.unpack txt+ Right bytes -> B.writeFile dest bytes+ -- TODO set user.mime file attribute.+ return $ baseURI {uriPath = dest}+ where+ takeFileName' s = case takeFileName s of { "" -> "index"; f -> f}++unusedFilename path = do+ exists <- doesFileExist path+ if exists then go 0 else return path+ where+ go n = do+ let path' = path ++ show n+ exists <- doesFileExist path'+ if exists then go (n+1) else return path'++-- | Convert a download into a data: URI+downloadToURI :: (URI, String, Either Text ByteString) -> URI+downloadToURI (_, mime, Left txt) = nullURI {+ uriScheme = "data:",+ uriPath = mime ++ "," ++ escapeURIString isReserved (Txt.unpack txt)+ }+downloadToURI (_, mime, Right bytes) = nullURI {+ uriScheme = "data:",+ uriPath = mime ++ ";base64," ++ C8.unpack (B.toStrict $ B64.encode bytes)+ }++-- 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
@@ -28,6 +28,7 @@ where linkType = fromMaybe mime $ stripPrefix "x-scheme-handler/" mime trans ("en":_) (OpenedWith app) = "Opened in " ++ app trans ("en":_) (ReadFailed msg) = "Failed to read file: " ++ msg+trans ("en":_) MalformedResponse = "Invalid response!" #if WITH_HTTP_URI trans ("en":_) (Http (InvalidUrlException url msg)) = "Invalid URL " ++ url ++ ": " ++ msg trans ("en":_) (Http (HttpExceptionRequest _ (TooManyRedirects _))) = "Too many redirects!"@@ -42,7 +43,7 @@ trans [] err = trans ["en"] err data Errors = UnsupportedScheme String | UnsupportedMIME String | RequiresInstall String String- | OpenedWith String | ReadFailed String | RawXML String+ | OpenedWith String | ReadFailed String | RawXML String | MalformedResponse #if WITH_HTTP_URI | Http HttpException #endif