diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -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 diff --git a/hurl.cabal b/hurl.cabal --- a/hurl.cabal +++ b/hurl.cabal @@ -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 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 @@ -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 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,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 [ + "
" + ]) + ('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 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 @@ -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