{-# LANGUAGE CPP #-}
{-# 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, redirectCount, cachingEnabled, validateCertificates, credentials),
    newSession,
    fetchURL, fetchURL', fetchURLs, submitURL, submitURL', mimeERR, htmlERR,
    dispatchByMIME, appsForMIME, Application(..), dispatchByApp,
    saveDownload, downloadToURI,
    -- logging API
    LogRecord(..), enableLogging, retrieveLog, writeLog) where

import Network.URI.Types

import qualified Data.Text as Txt
import           Data.Text (Text)
import qualified Data.Text.Encoding as Txt
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 qualified Data.ByteString.Builder as Builder
import           Network.URI.Charset
import           Control.Exception
import           System.IO.Error (isEOFError)
import           Control.Concurrent.Async (forConcurrently)

import qualified Data.Maybe as M

-- for about: URIs & port parsing, all standard lib
import Data.Maybe (fromMaybe, listToMaybe, isJust)
import Data.Either (isLeft)
import Text.Read (readMaybe)
-- for executable extensions, all standard lib
import Data.Char (isSpace)
import System.Exit (ExitCode(..))

-- for saveDownload
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.MultipartFormData as HTTP
import qualified Network.HTTP.Client.TLS as TLS
import           Network.HTTP.Types
import           Network.PublicSuffixList.Lookup (effectiveTLDPlusOne)

import           Data.List (intercalate)
import           Control.Concurrent (forkIO)

import           Network.URI.Cache
import           Network.URI.CookiesDB
#endif

#if WITH_HTTP_URI || WITH_RAW_CONNECTIONS
import qualified Network.Connection as Conn
import qualified Network.TLS as TLS
import qualified Network.TLS.Extra.Cipher as TLS
import           Data.Default.Class (def)
#endif

#ifdef WITH_DATA_URI
import qualified Data.ByteString.Base64.URL.Lazy as B64
#endif

import Network.URI.Locale
import Network.URI.Messages

#ifdef WITH_XDG
import Network.URI.XDG
#endif

#ifdef WITH_PLUGIN_REWRITES
import Network.URI.PlugIns.Rewriters
#endif
#ifdef WITH_PLUGIN_EXEC
import System.Process
#endif

-- | Data shared accross multiple URI requests.
data Session = Session {
#ifdef WITH_HTTP_URI
    Session -> Manager
managerHTTP :: HTTP.Manager,
    Session -> Manager
managerHTTPNoValidate :: HTTP.Manager,
    Session -> MVar CookieJar
globalCookieJar :: MVar HTTP.CookieJar,
    Session -> String
cookiesPath :: FilePath,
    Session -> Maybe (MVar CookieJar)
retroactiveCookies :: Maybe (MVar HTTP.CookieJar),
    Session -> MVar [(String, Bool, UTCTime)]
hstsDomains :: MVar [(String, Bool, UTCTime)],
#endif
#ifdef WITH_RAW_CONNECTIONS
    Session -> ConnectionContext
connCtxt :: Conn.ConnectionContext,
#endif
#ifdef WITH_XDG
    Session -> XDGConfig
apps :: XDGConfig,
#endif
#ifdef WITH_PLUGIN_REWRITES
    Session -> Rewriter
rewriter :: Rewriter,
#endif
    -- | The languages (RFC2616-encoded) to which responses should be localized.
    Session -> [String]
locale :: [String],
    -- | Callback function for localizing error messages, or throwing exceptions
    Session -> Errors -> String
trans' :: Errors -> String,
    -- | Additional files to serve from about: URIs.
    Session -> [(String, ByteString)]
aboutPages :: [(FilePath, ByteString)],
    -- | Log of timestamped/profiled URL requests
    Session -> Maybe (MVar [LogRecord])
requestLog :: Maybe (MVar [LogRecord]),
    -- | How many redirects to follow for Gemini or HTTP(S) requests
    Session -> Int
redirectCount :: Int,
    -- | Whether to cache network responses, avoiding sending requests
    Session -> Bool
cachingEnabled :: Bool,
    -- | App-specific config subdirectory to check
    Session -> String
appName :: String,
    -- | Whether to validate the server is who they say they are on secured protocols.
    Session -> Bool
validateCertificates :: Bool,
    -- | Bytestrings or files containing the client certificate to use for logging into the server.
    Session -> Maybe (Either (String, String) (ByteString, ByteString))
credentials :: Maybe (Either (FilePath, FilePath) (C8.ByteString, C8.ByteString)),
    Session
-> MVar (Maybe (Either (String, String) (ByteString, ByteString)))
credentials' :: MVar (Maybe (Either (FilePath, FilePath) (C8.ByteString, C8.ByteString)))
}

data LogRecord = LogRecord {
    LogRecord -> URI
url :: URI,
    LogRecord -> [String]
accept :: [String],
    LogRecord -> URI
redirected :: URI,
    LogRecord -> String
mimetype :: String,
    LogRecord -> Either Text ByteString
response :: Either Text ByteString,
    LogRecord -> UTCTime
begin :: UTCTime,
    LogRecord -> UTCTime
end :: UTCTime
  }

-- | Initializes a default Session object to support HTTPS & Accept-Language
-- if HTTP is enabled.
newSession :: IO Session
newSession :: IO Session
newSession = String -> IO Session
newSession' String
""

-- | Variant of `newSession` which loads plugins for the named app.
newSession' :: String -> IO Session
newSession' :: String -> IO Session
newSession' String
appname = do
    ([String]
ietfLocale, [String]
unixLocale) <- IO ([String], [String])
rfc2616Locale
    MVar (Maybe (Either (String, String) (ByteString, ByteString)))
credentialsMVar <- forall a. a -> IO (MVar a)
newMVar forall a. Maybe a
Nothing
#ifdef WITH_HTTP_URI
    {- let httpsSettings = (TLS.defaultParamsClient "example.com" "https") {
        TLS.clientSupported = def { TLS.supportedCiphers = TLS.ciphersuite_default },
        TLS.clientHooks = def {
            TLS.onCertificateRequest = deliverCredentials credentialsMVar
        }
    }
    let httpsSettingsNoValidate = httpsSettings {
        TLS.clientShared = def {
            TLS.sharedValidationCache = TLS.ValidationCache
                (\_ _ _ -> return TLS.ValidationCachePass)
                (\_ _ _ -> return ())
        }
    } -} -- FIXME: Be nice to support clientside certs... Those are far too strict!
    Manager
managerHTTP' <- ManagerSettings -> IO Manager
HTTP.newManager forall a b. (a -> b) -> a -> b
$ TLSSettings -> Maybe SockSettings -> ManagerSettings
TLS.mkManagerSettings
        (Bool -> Bool -> Bool -> TLSSettings
Conn.TLSSettingsSimple Bool
False Bool
False Bool
False) forall a. Maybe a
Nothing
    Manager
managerHTTPnovalidate' <- ManagerSettings -> IO Manager
HTTP.newManager forall a b. (a -> b) -> a -> b
$ TLSSettings -> Maybe SockSettings -> ManagerSettings
TLS.mkManagerSettings
        (Bool -> Bool -> Bool -> TLSSettings
Conn.TLSSettingsSimple Bool
True Bool
False Bool
False) forall a. Maybe a
Nothing

    String
cookiesDir <- XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgData String
"nz.geek.adrian.hurl.cookies2"
    let cookiesPath' :: String
cookiesPath' = String
cookiesDir String -> String -> String
</> String
appname
    CookieJar
cookies' <- String -> IO CookieJar
readCookies String
cookiesPath'
    UTCTime
now <- IO UTCTime
getCurrentTime
    MVar CookieJar
cookieJar <- forall a. a -> IO (MVar a)
newMVar forall a b. (a -> b) -> a -> b
$ CookieJar -> UTCTime -> CookieJar
HTTP.evictExpiredCookies CookieJar
cookies' UTCTime
now
    MVar CookieJar
cookieJar' <- forall a. a -> IO (MVar a)
newMVar forall a b. (a -> b) -> a -> b
$ [Cookie] -> CookieJar
HTTP.createCookieJar []

    MVar [(String, Bool, UTCTime)]
hstsDomains' <- forall a. a -> IO (MVar a)
newMVar forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [(String, Bool, UTCTime)]
readHSTS
#endif
#ifdef WITH_RAW_CONNECTIONS
    ConnectionContext
connCtxt <- IO ConnectionContext
Conn.initConnectionContext
#endif
#ifdef WITH_XDG
    XDGConfig
apps' <- [String] -> IO XDGConfig
loadXDGConfig [String]
unixLocale
#endif
#ifdef WITH_PLUGIN_REWRITES
    Rewriter
rewriters <- String -> IO Rewriter
parseRewriters String
appname
#endif

    forall (m :: * -> *) a. Monad m => a -> m a
return Session {
#ifdef WITH_HTTP_URI
        managerHTTP :: Manager
managerHTTP = Manager
managerHTTP',
        managerHTTPNoValidate :: Manager
managerHTTPNoValidate = Manager
managerHTTPnovalidate',
        globalCookieJar :: MVar CookieJar
globalCookieJar = MVar CookieJar
cookieJar,
        cookiesPath :: String
cookiesPath = String
cookiesPath',
        retroactiveCookies :: Maybe (MVar CookieJar)
retroactiveCookies = forall a. a -> Maybe a
Just MVar CookieJar
cookieJar',
        hstsDomains :: MVar [(String, Bool, UTCTime)]
hstsDomains = MVar [(String, Bool, UTCTime)]
hstsDomains',
#endif
#ifdef WITH_RAW_CONNECTIONS
        connCtxt :: ConnectionContext
connCtxt = ConnectionContext
connCtxt,
#endif
#ifdef WITH_XDG
        apps :: XDGConfig
apps = XDGConfig
apps',
#endif
#ifdef WITH_PLUGIN_REWRITES
        rewriter :: Rewriter
rewriter = Rewriter
rewriters,
#endif
        locale :: [String]
locale = [String]
ietfLocale,
        trans' :: Errors -> String
trans' = [String] -> Errors -> String
trans [String]
ietfLocale,
        aboutPages :: [(String, ByteString)]
aboutPages = [],
        requestLog :: Maybe (MVar [LogRecord])
requestLog = forall a. Maybe a
Nothing,
        redirectCount :: Int
redirectCount = Int
5,
        cachingEnabled :: Bool
cachingEnabled = Bool
True,
        validateCertificates :: Bool
validateCertificates = Bool
True,
        appName :: String
appName = String
appname,
        credentials :: Maybe (Either (String, String) (ByteString, ByteString))
credentials = forall a. Maybe a
Nothing,
        credentials' :: MVar (Maybe (Either (String, String) (ByteString, ByteString)))
credentials' = MVar (Maybe (Either (String, String) (ByteString, ByteString)))
credentialsMVar
    }

llookup :: a -> a -> [(a, a)] -> a
llookup a
key a
fallback [(a, a)]
map = a
fallback forall a. a -> Maybe a -> a
`fromMaybe` forall a. [a] -> Maybe a
listToMaybe [a
v | (a
k, a
v) <- [(a, a)]
map, a
k forall a. Eq a => a -> a -> Bool
== a
key]
parsePort :: a -> String -> a
parsePort a
fallback (Char
':':String
port) = a
fallback forall a. a -> Maybe a -> a
`fromMaybe` forall a. Read a => String -> Maybe a
readMaybe String
port
parsePort a
fallback String
_ = a
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 :: Session -> [String] -> URI -> IO (String, Either Text ByteString)
fetchURL Session
sess [String]
mimes URI
uri = do
    (URI
_, String
mime, Either Text ByteString
resp) <- Session
-> [String] -> URI -> IO (URI, String, Either Text ByteString)
fetchURL' Session
sess [String]
mimes URI
uri
    forall (m :: * -> *) a. Monad m => a -> m a
return (String
mime, Either Text ByteString
resp)

fetchURLLogged :: MVar [LogRecord]
-> Session
-> [String]
-> URI
-> IO (URI, String, Either Text ByteString)
fetchURLLogged MVar [LogRecord]
log Session
sess [String]
mimes URI
uri = do
    UTCTime
begin' <- IO UTCTime
getCurrentTime
    res :: (URI, String, Either Text ByteString)
res@(URI
redirected', String
mimetype', Either Text ByteString
response') <- Session
-> [String] -> URI -> IO (URI, String, Either Text ByteString)
fetchURL' Session
sess [String]
mimes URI
uri
    UTCTime
end' <- IO UTCTime
getCurrentTime
    forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar [LogRecord]
log forall a b. (a -> b) -> a -> b
$ \[LogRecord]
log' -> forall (m :: * -> *) a. Monad m => a -> m a
return (
        URI
-> [String]
-> URI
-> String
-> Either Text ByteString
-> UTCTime
-> UTCTime
-> LogRecord
LogRecord URI
uri [String]
mimes URI
redirected' String
mimetype' Either Text ByteString
response' UTCTime
begin' UTCTime
end' forall a. a -> [a] -> [a]
: [LogRecord]
log')
    forall (m :: * -> *) a. Monad m => a -> m a
return (URI, String, Either Text ByteString)
res

-- | Concurrently fetch given URLs.
fetchURLs :: Session -> [String] -> [URI] -> ((URI, String, Either Text ByteString) -> IO a) -> IO [(URI, a)]
fetchURLs :: forall a.
Session
-> [String]
-> [URI]
-> ((URI, String, Either Text ByteString) -> IO a)
-> IO [(URI, a)]
fetchURLs Session
sess [String]
mimes [URI]
uris (URI, String, Either Text ByteString) -> IO a
cb = do
    let fetch :: Session
-> [String] -> URI -> IO (URI, String, Either Text ByteString)
fetch = case Session -> Maybe (MVar [LogRecord])
requestLog Session
sess of {Maybe (MVar [LogRecord])
Nothing -> Session
-> [String] -> URI -> IO (URI, String, Either Text ByteString)
fetchURL'; Just MVar [LogRecord]
log -> MVar [LogRecord]
-> Session
-> [String]
-> URI
-> IO (URI, String, Either Text ByteString)
fetchURLLogged MVar [LogRecord]
log}
    let sess' :: Session
sess' = Session
sess {
#ifdef WITH_HTTP_URI
        retroactiveCookies :: Maybe (MVar CookieJar)
retroactiveCookies = forall a. Maybe a
Nothing
#endif
      }
    forall (t :: * -> *) a b.
Traversable t =>
t a -> (a -> IO b) -> IO (t b)
forConcurrently [URI]
uris (\URI
u -> Session
-> [String] -> URI -> IO (URI, String, Either Text ByteString)
fetch Session
sess' [String]
mimes URI
u forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (URI, String, Either Text ByteString) -> IO a
cb) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
L.zip [URI]
uris

-- | Internal MIMEtypes for error reporting
mimeERR, htmlERR :: String
mimeERR :: String
mimeERR = String
"txt/x-error\t"
htmlERR :: String
htmlERR = String
"html/x-error\t"

submitURL :: Session -> [String] -> URI -> Text -> String -> IO (URI, String, Either Text ByteString)
-- | See submitURL', preserved for backwards compatability.
-- This is a little more cumbersome to use, & doesn't support file uploads.
-- Was designed naively based on convenience of initial caller.
submitURL :: Session
-> [String]
-> URI
-> Text
-> String
-> IO (URI, String, Either Text ByteString)
submitURL Session
s [String]
a URI
u Text
m String
q =
    Session
-> [String]
-> URI
-> ByteString
-> ByteString
-> [(String, Either String String)]
-> IO (URI, String, Either Text ByteString)
submitURL' Session
s [String]
a URI
u (Text -> ByteString
Txt.encodeUtf8 Text
m) ByteString
"application/x-www-form-urlencoded" forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
Prelude.map forall {b}. Text -> (String, Either String b)
parseQuery forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
Txt.splitOn Text
"&" forall a b. (a -> b) -> a -> b
$ String -> Text
Txt.pack String
q
  where
    parseQuery :: Text -> (String, Either String b)
parseQuery Text
q = let (Text
key, Text
value) = Text -> Text -> (Text, Text)
Txt.breakOn Text
"=" Text
q in if Text -> Bool
Txt.null Text
value
        then (Text -> String
decode Text
key, forall a b. a -> Either a b
Left String
"")
        else (Text -> String
decode Text
key, forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> String
decode forall a b. (a -> b) -> a -> b
$ Text -> Text
Txt.tail Text
value)
    decode :: Text -> String
decode = String -> String
unEscapeString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Txt.unpack
-- | Uploads given key-value pairs to the specified URL using the specified HTTP method & encoding.
-- The key-value pairs may specify filepaths, in which case the method must be "POST"
-- and the encoding must be "multipart/form-data" for that data to get sent.
--
-- Unsupported encodings (values other than "application/x-www-form-urlencoded",
-- "text/plain", or "multipart/form-data") omits the key-value pairs from the request.
submitURL' :: Session -> [String] -> URI -> Strict.ByteString -> Strict.ByteString ->
    [(String, Either String FilePath)] -> IO (URI, String, Either Text ByteString)
#ifdef WITH_HTTP_URI
addHTTPBody :: ByteString -> String -> Request -> m Request
addHTTPBody ByteString
mime String
body Request
req = forall (m :: * -> *) a. Monad m => a -> m a
return Request
req {
    requestHeaders :: RequestHeaders
HTTP.requestHeaders = (HeaderName
hContentType, ByteString
mime) forall a. a -> [a] -> [a]
:
        forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter (\(HeaderName
x, ByteString
_) -> HeaderName
x forall a. Eq a => a -> a -> Bool
/= HeaderName
hContentType) (Request -> RequestHeaders
HTTP.requestHeaders Request
req),
    requestBody :: RequestBody
HTTP.requestBody = ByteString -> RequestBody
HTTP.RequestBodyBS forall a b. (a -> b) -> a -> b
$ String -> ByteString
C8.pack String
body
  }
packQuery :: [(String, Either String FilePath)] -> C8.ByteString -> HTTP.Request -> IO HTTP.Request
packQuery :: [(String, Either String String)]
-> ByteString -> Request -> IO Request
packQuery [(String, Either String String)]
query mime :: ByteString
mime@ByteString
"application/x-www-form-urlencoded" =
    forall {m :: * -> *}.
Monad m =>
ByteString -> String -> Request -> m Request
addHTTPBody ByteString
mime forall a b. (a -> b) -> a -> b
$ [(String, Either String String)] -> String
encodeQuery [(String, Either String String)]
query
packQuery [(String, Either String String)]
query mime :: ByteString
mime@ByteString
"text/plain" = forall {m :: * -> *}.
Monad m =>
ByteString -> String -> Request -> m Request
addHTTPBody ByteString
mime forall a b. (a -> b) -> a -> b
$
    [String] -> String
Prelude.unlines [String
value | (String
key, Left String
value) <- [(String, Either String String)]
query, Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
value]
packQuery [(String, Either String String)]
q ByteString
"multipart/form-data" = forall (m :: * -> *). MonadIO m => [Part] -> Request -> m Request
HTTP.formDataBody forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
Prelude.map (String, Either String String) -> Part
encodePart [(String, Either String String)]
q
  where
    encodePart :: (String, Either String String) -> Part
encodePart (String
key, Left String
value) = forall (m :: * -> *).
Applicative m =>
Text -> ByteString -> PartM m
HTTP.partBS (String -> Text
Txt.pack String
key) (String -> ByteString
C8.pack String
value)
    encodePart (String
key, Right String
value) =
        -- C:\fakepath\ is part of the webstandards now & I might as well use it.
        -- Ancient browsers exposed the full filepath which was a security vulnerability.
        -- Now to avoid breaking servers relying on this behaviour we send
        -- a fake Windows filepath.
        forall (m :: * -> *). Text -> String -> m RequestBody -> PartM m
HTTP.partFileRequestBodyM (String -> Text
Txt.pack String
key) (String
"C:\\fakepath\\" forall a. [a] -> [a] -> [a]
++ String -> String
takeFileName String
value) forall a b. (a -> b) -> a -> b
$ do
            Int64
size <- forall a. Num a => Integer -> a
fromInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
value IOMode
ReadMode Handle -> IO Integer
hFileSize
            ByteString
body <- String -> IO ByteString
B.readFile String
value
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int64 -> Builder -> RequestBody
HTTP.RequestBodyBuilder Int64
size forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
Builder.lazyByteString ByteString
body
packQuery [(String, Either String String)]
_ ByteString
_ = forall (m :: * -> *) a. Monad m => a -> m a
return -- Do not upload data if requested to do so in an invalid format.
submitURL' :: Session
-> [String]
-> URI
-> ByteString
-> ByteString
-> [(String, Either String String)]
-> IO (URI, String, Either Text ByteString)
submitURL' Session
session [String]
mimes URI
uri ByteString
method ByteString
"GET" [(String, Either String String)]
query = Session
-> [String] -> URI -> IO (URI, String, Either Text ByteString)
fetchURL' Session
session [String]
mimes URI
uri {
    uriQuery :: String
uriQuery = Char
'?'forall a. a -> [a] -> [a]
: [(String, Either String String)] -> String
encodeQuery [(String, Either String String)]
query } -- Specialcase GET!
submitURL' Session
session [String]
accept URI
uri ByteString
method ByteString
encoding [(String, Either String String)]
query | URI -> String
uriScheme URI
uri forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"http:", String
"https:"] = do
    -- HURL is very strict on when it allows cookies to be set: Only POST HTTP requests are considered consent.
    -- For the sake of most webframeworks' CSRF protection, cookies from retrieving the form are retroactively set.
    Maybe CookieJar
csrfCookies <- case Session -> Maybe (MVar CookieJar)
retroactiveCookies Session
session of {
        Just MVar CookieJar
cookies -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. MVar a -> IO a
readMVar MVar CookieJar
cookies;
        Maybe (MVar CookieJar)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    }
    forall {a}.
Session
-> Bool
-> [String]
-> URI
-> (Request -> IO Request)
-> (Response ByteString -> IO a)
-> IO (URI, String, Either Text ByteString)
fetchHTTPCached Session
session Bool
False [String]
accept URI
uri (\Request
req -> do
        Request
ret <- [(String, Either String String)]
-> ByteString -> Request -> IO Request
packQuery [(String, Either String String)]
query ByteString
encoding Request
req
        forall (m :: * -> *) a. Monad m => a -> m a
return Request
ret {
            cookieJar :: Maybe CookieJar
HTTP.cookieJar = forall {a}. Maybe a -> Maybe a -> Maybe a
firstJust Maybe CookieJar
csrfCookies forall a b. (a -> b) -> a -> b
$ Request -> Maybe CookieJar
HTTP.cookieJar Request
req,
            method :: ByteString
HTTP.method = ByteString
method
        }) forall a b. (a -> b) -> a -> b
$ \Response ByteString
resp -> do
            let cookies :: CookieJar
cookies = forall body. Response body -> CookieJar
HTTP.responseCookieJar Response ByteString
resp
            forall a. MVar a -> a -> IO a
swapMVar (Session -> MVar CookieJar
globalCookieJar Session
session) CookieJar
cookies
            String -> CookieJar -> Bool -> IO ()
writeCookies (Session -> String
cookiesPath Session
session) CookieJar
cookies Bool
False
#endif
submitURL' Session
session [String]
mimes URI
uri ByteString
_method ByteString
_encoding [(String, Either String String)]
query = Session
-> [String] -> URI -> IO (URI, String, Either Text ByteString)
fetchURL' Session
session [String]
mimes URI
uri {
    uriQuery :: String
uriQuery = Char
'?'forall a. a -> [a] -> [a]
:[(String, Either String String)] -> String
encodeQuery [(String, Either String String)]
query }
encodeQuery :: [(String, Either String FilePath)] -> String
encodeQuery :: [(String, Either String String)] -> String
encodeQuery [(String
"", Left String
query)] = String
query -- Mostly for the sake of Gemini...
encodeQuery [(String, Either String String)]
query = forall a. [a] -> [[a]] -> [a]
intercalate String
"&" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
M.mapMaybe forall {b}. (String, Either String b) -> Maybe String
encodePart [(String, Either String String)]
query
  where
    encodePart :: (String, Either String b) -> Maybe String
encodePart (String
key, Left String
"") = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> String
escape String
key
    encodePart (String
key, Left String
value) = forall a. a -> Maybe a
Just (String -> String
escape String
key forall a. [a] -> [a] -> [a]
++ Char
'='forall a. a -> [a] -> [a]
:String -> String
escape String
value)
    encodePart (String, Either String b)
_ = forall a. Maybe a
Nothing
    escape :: String -> String
escape = (Char -> Bool) -> String -> String
escapeURIString Char -> Bool
isUnescapedInURIComponent

-- | As per `fetchURL`, but also returns the redirected URI.
fetchURL' :: Session -> [String] -> URI -> IO (URI, String, Either Text ByteString)
fetchURL' :: Session
-> [String] -> URI -> IO (URI, String, Either Text ByteString)
fetchURL' sess :: Session
sess@Session {redirectCount :: Session -> Int
redirectCount = Int
0 } [String]
_ URI
uri =
    forall (m :: * -> *) a. Monad m => a -> m a
return (URI
uri, String
mimeERR, forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Text
Txt.pack forall a b. (a -> b) -> a -> b
$ Session -> Errors -> String
trans' Session
sess Errors
ExcessiveRedirects)

#ifdef WITH_PLUGIN_REWRITES
fetchURL' Session
session [String]
mimes URI
uri
    | Just URI
uri' <- Rewriter -> URI -> Maybe URI
applyRewriter (Session -> Rewriter
rewriter Session
session) URI
uri = Session
-> [String] -> URI -> IO (URI, String, Either Text ByteString)
fetchURL' Session
session [String]
mimes URI
uri'
#endif

#ifdef WITH_PLUGIN_EXEC
fetchURL' session :: Session
session@Session { appName :: Session -> String
appName = String
appname } [String]
mimes uri :: URI
uri@(URI String
"ext:" Maybe URIAuth
Nothing String
path String
query String
_) = do
    String
dir <- XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgData String
"nz.geek.adrian.hurl"
    [String]
sysdirs <- XdgDirectoryList -> IO [String]
getXdgDirectoryList XdgDirectoryList
XdgDataDirs
    let dirs :: [String]
dirs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String
dir' String -> String -> String
</> String
appname, String
dir'] | String
dir' <- String
dir forall a. a -> [a] -> [a]
: [String]
sysdirs]
    [String]
programs <- [String] -> String -> IO [String]
findExecutablesInDirectories [String]
dirs (String
"bin" String -> String -> String
</> String
path)
    case [String]
programs of
      [] -> forall (m :: * -> *) a. Monad m => a -> m a
return (URI
uri, String
mimeERR, forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Text
Txt.pack forall a b. (a -> b) -> a -> b
$ Session -> Errors -> String
trans' Session
session forall a b. (a -> b) -> a -> b
$ String -> Errors
ReadFailed String
"404")
      String
program:[String]
_ -> do
        let args :: [String]
args = case String
query of {
            Char
'?':String
rest -> (Char -> Bool) -> String -> [String]
split (forall a. Eq a => a -> a -> Bool
== Char
'&') String
rest;
            String
_ -> []
        }
        (ExitCode
exitcode, String
stdout, String
stderr) <- String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
program [String]
args String
""
        let response :: String
response = if ExitCode -> Bool
isSuccess ExitCode
exitcode then String
stdout else String
stderr
        let (String
header, String
body) = forall {a}. Eq a => a -> [a] -> ([a], [a])
breakOn Char
'\n' String
response
        case String -> String
strip String
header of
            Char
'm':Char
'i':Char
'm':Char
'e':String
mimetype -> forall (m :: * -> *) a. Monad m => a -> m a
return (URI
uri, String -> String
strip String
mimetype, forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Text
Txt.pack String
body)
            Char
'u':Char
'r':Char
'l':String
header' | Just URI
uri' <- String -> Maybe URI
parseURIReference forall a b. (a -> b) -> a -> b
$ String -> String
strip String
header' ->
                Session
-> [String] -> URI -> IO (URI, String, Either Text ByteString)
fetchURL' (Session
session {redirectCount :: Int
redirectCount = Session -> Int
redirectCount Session
session forall a. Num a => a -> a -> a
- Int
1}) [String]
mimes forall a b. (a -> b) -> a -> b
$
                    URI -> URI -> URI
relativeTo URI
uri' URI
uri
            String
_ | ExitCode -> Bool
isSuccess ExitCode
exitcode -> forall (m :: * -> *) a. Monad m => a -> m a
return (URI
uri, String
"text/html", forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Text
Txt.pack String
response)
            String
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (URI
uri, String
mimeERR, forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Text
Txt.pack String
response)
  where
    split :: (Char -> Bool) -> String -> [String]
split Char -> Bool
p String
s = case forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
p String
s of
        String
"" -> []
        String
s' -> let (String
w, String
s'') = forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
p String
s' in String
w forall a. a -> [a] -> [a]
: (Char -> Bool) -> String -> [String]
split Char -> Bool
p String
s''
    strip :: String -> String
strip = forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace
    isSuccess :: ExitCode -> Bool
isSuccess ExitCode
ExitSuccess = Bool
True
    isSuccess ExitCode
_ = Bool
False
#endif

fetchURL' Session
session [String]
mimes uri :: URI
uri@(URI {uriScheme :: URI -> String
uriScheme = String
"about:", uriPath :: URI -> String
uriPath = String
""}) =
    Session
-> [String] -> URI -> IO (URI, String, Either Text ByteString)
fetchURL' Session
session [String]
mimes forall a b. (a -> b) -> a -> b
$ URI
uri {uriPath :: String
uriPath = String
"version"}
fetchURL' Session {aboutPages :: Session -> [(String, ByteString)]
aboutPages = [(String, ByteString)]
pages} [String]
_ url :: URI
url@URI {uriScheme :: URI -> String
uriScheme = String
"about:", uriPath :: URI -> String
uriPath = String
path} =
    forall (m :: * -> *) a. Monad m => a -> m a
return (URI
url,
        Text -> String
Txt.unpack forall a b. (a -> b) -> a -> b
$ Text -> Text
Txt.strip forall a b. (a -> b) -> a -> b
$ String -> ByteString -> Text
convertCharset String
"utf-8" forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B.toStrict forall a b. (a -> b) -> a -> b
$
            forall {a} {a}. Eq a => a -> a -> [(a, a)] -> a
llookup (String
path forall a. [a] -> [a] -> [a]
++ String
".mime") ByteString
"text/html" [(String, ByteString)]
pages,
        forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall {a} {a}. Eq a => a -> a -> [(a, a)] -> a
llookup String
path ByteString
"" [(String, ByteString)]
pages)

#ifdef WITH_HTTP_URI
fetchURL' Session
session [String]
accept URI
uri | URI -> String
uriScheme URI
uri forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"http:", String
"https:"] =
    forall {a}.
Session
-> Bool
-> [String]
-> URI
-> (Request -> IO Request)
-> (Response ByteString -> IO a)
-> IO (URI, String, Either Text ByteString)
fetchHTTPCached Session
session (Session -> Bool
cachingEnabled Session
session) [String]
accept URI
uri forall (m :: * -> *) a. Monad m => a -> m a
return forall {body}. Response body -> IO ()
saveCookies
  where
    saveCookies :: Response body -> IO ()
saveCookies Response body
resp
        | Just MVar CookieJar
cookies <- Session -> Maybe (MVar CookieJar)
retroactiveCookies Session
session =
            forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$forall a. MVar a -> a -> IO a
swapMVar MVar CookieJar
cookies forall a b. (a -> b) -> a -> b
$forall body. Response body -> CookieJar
HTTP.responseCookieJar Response body
resp
        | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif

#ifdef WITH_GEMINI_URI
fetchURL' sess :: Session
sess@Session { connCtxt :: Session -> ConnectionContext
connCtxt = ConnectionContext
ctxt } [String]
mimes uri :: URI
uri@URI {
        uriScheme :: URI -> String
uriScheme = String
"gemini:", uriAuthority :: URI -> Maybe URIAuth
uriAuthority = Just (URIAuth String
_ String
host String
port)
    } = do
        let params :: ClientParams
params = String -> ByteString -> ClientParams
TLS.defaultParamsClient String
host ByteString
"gmni"
        forall a. MVar a -> a -> IO a
swapMVar (Session
-> MVar (Maybe (Either (String, String) (ByteString, ByteString)))
credentials' Session
sess) (Session -> Maybe (Either (String, String) (ByteString, ByteString))
credentials Session
sess)
        Connection
conn <- ConnectionContext -> ConnectionParams -> IO Connection
Conn.connectTo ConnectionContext
ctxt Conn.ConnectionParams {
            connectionHostname :: String
Conn.connectionHostname = String
host,
            connectionPort :: PortNumber
Conn.connectionPort = forall {a}. Read a => a -> String -> a
parsePort PortNumber
1965 String
port,
            -- FIXME Implement certificate validation that actually common geminispace certs...
            connectionUseSecure :: Maybe TLSSettings
Conn.connectionUseSecure = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ClientParams -> TLSSettings
Conn.TLSSettings ClientParams
params {
                clientSupported :: Supported
TLS.clientSupported = forall a. Default a => a
def { supportedCiphers :: [Cipher]
TLS.supportedCiphers = [Cipher]
TLS.ciphersuite_default },
                clientShared :: Shared
TLS.clientShared = forall a. Default a => a
def {
                    sharedValidationCache :: ValidationCache
TLS.sharedValidationCache = ValidationCacheQueryCallback
-> ValidationCacheAddCallback -> ValidationCache
TLS.ValidationCache
                        (\ServiceID
_ Fingerprint
_ Certificate
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ValidationCacheResult
TLS.ValidationCachePass)
                        (\ServiceID
_ Fingerprint
_ Certificate
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ())
                },
                clientHooks :: ClientHooks
TLS.clientHooks = forall a. Default a => a
def {
                    onCertificateRequest :: OnCertificateRequest
TLS.onCertificateRequest = forall {p}.
MVar (Maybe (Either (String, String) (ByteString, ByteString)))
-> p -> IO (Maybe Credential)
deliverCredentials forall a b. (a -> b) -> a -> b
$ Session
-> MVar (Maybe (Either (String, String) (ByteString, ByteString)))
credentials' Session
sess
                }
            },
            connectionUseSocks :: Maybe SockSettings
Conn.connectionUseSocks = forall a. Maybe a
Nothing
        }
        Connection -> ByteString -> IO ()
Conn.connectionPut Connection
conn forall a b. (a -> b) -> a -> b
$ String -> ByteString
C8.pack forall a b. (a -> b) -> a -> b
$ (String -> String) -> URI -> String -> String
uriToString forall a. a -> a
id URI
uri String
"\r\n"
        ByteString
header <- Int -> Connection -> IO ByteString
Conn.connectionGetLine Int
1027 Connection
conn
        case String -> (Char, Char, Text)
parseHeader forall a b. (a -> b) -> a -> b
$ ByteString -> String
C8.unpack ByteString
header of
            (Char
'2', Char
_, Text
mime) -> do
                ByteString
body <- [ByteString] -> ByteString
B.fromChunks forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO [ByteString]
connectionGetChunks Connection
conn
                let mime' :: [String]
mime' = forall a b. (a -> b) -> [a] -> [b]
L.map (Text -> String
Txt.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Txt.strip) forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
Txt.splitOn Text
";" Text
mime
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
a -> [String] -> ByteString -> (a, String, Either Text ByteString)
resolveCharset' URI
uri [String]
mime' ByteString
body
            (Char
'3', Char
_, Text
redirect) | Just URI
redirect' <- String -> Maybe URI
parseURIReference forall a b. (a -> b) -> a -> b
$ Text -> String
Txt.unpack Text
redirect ->
                Session
-> [String] -> URI -> IO (URI, String, Either Text ByteString)
fetchURL' Session
sess {
                    redirectCount :: Int
redirectCount = Session -> Int
redirectCount Session
sess forall a. Num a => a -> a -> a
- Int
1
                } [String]
mimes forall a b. (a -> b) -> a -> b
$ URI -> URI -> URI
relativeTo URI
redirect' URI
uri
            (Char
x, Char
y, Text
err) -> forall (m :: * -> *) a. Monad m => a -> m a
return (URI
uri, String
htmlERR, forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Text
Txt.pack forall a b. (a -> b) -> a -> b
$
                Session -> Errors -> String
trans' Session
sess forall a b. (a -> b) -> a -> b
$ Char -> Char -> String -> Errors
GeminiError Char
x Char
y forall a b. (a -> b) -> a -> b
$ Text -> String
Txt.unpack forall a b. (a -> b) -> a -> b
$
                    Text -> Text -> Text -> Text
Txt.replace Text
"<" Text
"&lt;" forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Text
Txt.replace Text
"&" Text
"&amp;" Text
err)
    where
        parseHeader :: String -> (Char, Char, Text)
        parseHeader :: String -> (Char, Char, Text)
parseHeader (Char
major:Char
minor:String
meta) = (Char
major, Char
minor, Text -> Text
Txt.strip forall a b. (a -> b) -> a -> b
$ String -> Text
Txt.pack String
meta)
        parseHeader String
header = (Char
'4', Char
'1', String -> Text
Txt.pack forall a b. (a -> b) -> a -> b
$ Session -> Errors -> String
trans' Session
sess forall a b. (a -> b) -> a -> b
$ String -> Errors
MalformedResponse String
header)
        handleIOErr :: IOError -> IO Strict.ByteString
        handleIOErr :: IOException -> IO ByteString
handleIOErr IOException
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
""
        connectionGetChunks :: Connection -> IO [ByteString]
connectionGetChunks Connection
conn = do
            ByteString
chunk <- Connection -> IO ByteString
Conn.connectionGetChunk Connection
conn forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` IOException -> IO ByteString
handleIOErr
            if ByteString -> Bool
Strict.null ByteString
chunk then forall (m :: * -> *) a. Monad m => a -> m a
return [] else (ByteString
chunkforall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO [ByteString]
connectionGetChunks Connection
conn
#endif

#ifdef WITH_FILE_URI
fetchURL' Session
sess (String
defaultMIME:[String]
_) uri :: URI
uri@URI {uriScheme :: URI -> String
uriScheme = String
"file:"} = do
    ByteString
response <- String -> IO ByteString
B.readFile forall a b. (a -> b) -> a -> b
$ URI -> String
uriPath URI
uri
    forall (m :: * -> *) a. Monad m => a -> m a
return (URI
uri, String
defaultMIME, forall a b. b -> Either a b
Right ByteString
response)
  forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \IOException
e -> do
    forall (m :: * -> *) a. Monad m => a -> m a
return (URI
uri, String
mimeERR,
        forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Text
Txt.pack forall a b. (a -> b) -> a -> b
$ Session -> Errors -> String
trans' Session
sess forall a b. (a -> b) -> a -> b
$ String -> Errors
ReadFailed forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> String
displayException (IOException
e :: IOException))
#endif

#ifdef WITH_DATA_URI
fetchURL' Session
_ (String
defaultMIME:[String]
_) uri :: URI
uri@URI {uriScheme :: URI -> String
uriScheme = String
"data:"} =
    let request :: String
request = URI -> String
uriPath URI
uri forall a. [a] -> [a] -> [a]
++ URI -> String
uriQuery URI
uri forall a. [a] -> [a] -> [a]
++ URI -> String
uriFragment URI
uri
    in case forall {a}. Eq a => a -> [a] -> ([a], [a])
breakOn Char
',' forall a b. (a -> b) -> a -> b
$ String -> String
unEscapeString String
request of
        (String
"", String
response) -> forall (m :: * -> *) a. Monad m => a -> m a
return (URI
uri, String
defaultMIME, forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Text
Txt.pack String
response)
        (String
mime', String
response) | Char
'4':Char
'6':Char
'e':Char
's':Char
'a':Char
'b':Char
';':String
mime <- forall a. [a] -> [a]
reverse String
mime' ->
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case ByteString -> Either String ByteString
B64.decode forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B.fromStrict forall a b. (a -> b) -> a -> b
$ String -> ByteString
C8.pack String
response of
                Left String
str -> (URI
uri, String
mimeERR, forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Text
Txt.pack forall a b. (a -> b) -> a -> b
$ String -> String
unEscapeString String
str)
                Right ByteString
bytes -> (URI
uri, forall a. [a] -> [a]
reverse String
mime, forall a b. b -> Either a b
Right ByteString
bytes)
        (String
mime, String
response) -> forall (m :: * -> *) a. Monad m => a -> m a
return (URI
uri, String
mime, forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Text
Txt.pack String
response)
#endif

#ifdef WITH_XDG
fetchURL' sess :: Session
sess@Session { apps :: Session -> XDGConfig
apps = XDGConfig
a } [String]
_ uri :: URI
uri@(URI {uriScheme :: URI -> String
uriScheme = String
s}) = do
        Errors
app <- XDGConfig -> URI -> String -> IO Errors
dispatchURIByMIME XDGConfig
a URI
uri (String
"x-scheme-handler/" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [a]
init String
s)
        forall (m :: * -> *) a. Monad m => a -> m a
return (URI
uri, String
htmlERR, forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Text
Txt.pack forall a b. (a -> b) -> a -> b
$ Session -> Errors -> String
trans' Session
sess forall a b. (a -> b) -> a -> b
$ Errors
app)
#else
fetchURL' sess _ URI {uriScheme = scheme} =
    return (uri, mimeERR, Left $ Txt.pack $ trans' sess $ UnsupportedScheme scheme)
#endif

dispatchByMIME :: Session -> String -> URI -> IO (Maybe String)
#if WITH_XDG
dispatchByMIME :: Session -> String -> URI -> IO (Maybe String)
dispatchByMIME sess :: Session
sess@Session { apps :: Session -> XDGConfig
apps = XDGConfig
a } String
mime URI
uri = do
    Errors
err <- XDGConfig -> URI -> String -> IO Errors
dispatchURIByMIME XDGConfig
a URI
uri String
mime
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Errors
err of
        UnsupportedMIME String
_ -> forall a. Maybe a
Nothing
        Errors
_ -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Session -> Errors -> String
trans' Session
sess Errors
err
#else
dispatchByMIME _ _ _ = return Nothing
#endif

appsForMIME :: Session -> String -> IO [Application]
#if WITH_XDG
appsForMIME :: Session -> String -> IO [Application]
appsForMIME Session { apps :: Session -> XDGConfig
apps = XDGConfig
a, locale :: Session -> [String]
locale = [String]
l } = XDGConfig -> [String] -> String -> IO [Application]
queryHandlers' XDGConfig
a [String]
l
#else
appsForMIME _ _ = []
#endif

dispatchByApp :: Session -> Application -> String -> URI -> IO Bool
#if WITH_XDG
dispatchByApp :: Session -> Application -> String -> URI -> IO Bool
dispatchByApp session :: Session
session@Session { locale :: Session -> [String]
locale = [String]
l } Application { appId :: Application -> String
appId = String
app} String
mime URI
uri = do
    Either String Bool
try1 <- [String] -> URI -> String -> IO (Either String Bool)
launchApp' [String]
l URI
uri String
app -- First try handing off the URL, feedreaders need this!
    case Either String Bool
try1 of
        Left String
app -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Right Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Right Bool
True -> do
            -- Download as temp file to open locally, the app requires it...
            String
temp <- String -> IO String
canonicalizePath forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO String
getTemporaryDirectory
            (URI, String, Either Text ByteString)
resp <- Session
-> [String] -> URI -> IO (URI, String, Either Text ByteString)
fetchURL' Session
session [String
mime] URI
uri
            URI
uri' <- URI -> String -> (URI, String, Either Text ByteString) -> IO URI
saveDownload (String -> Maybe URIAuth -> String -> String -> String -> URI
URI String
"file:" forall a. Maybe a
Nothing String
"" String
"" String
"") String
temp (URI, String, Either Text ByteString)
resp
            forall a b. Either a b -> Bool
isLeft forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> URI -> String -> IO (Either String Bool)
launchApp' [String]
l URI
uri' String
app
#else
dispatchByApp _ _ _ _ = return False
#endif

#ifdef WITH_HTTP_URI
fetchHTTPCached :: Session
-> Bool
-> [String]
-> URI
-> (Request -> IO Request)
-> (Response ByteString -> IO a)
-> IO (URI, String, Either Text ByteString)
fetchHTTPCached session :: Session
session@Session { trans' :: Session -> Errors -> String
trans' = Errors -> String
t} Bool
shouldCache
        accept :: [String]
accept@(String
defaultMIME:[String]
_) URI
rawUri Request -> IO Request
cbReq Response ByteString -> IO a
cbResp = do
    UTCTime
now <- IO UTCTime
getCurrentTime
    [(String, Bool, UTCTime)]
hsts <- forall a. MVar a -> IO a
readMVar forall a b. (a -> b) -> a -> b
$ Session -> MVar [(String, Bool, UTCTime)]
hstsDomains Session
session
    URI
uri <- case (URI -> String
uriScheme URI
rawUri, URI -> Maybe URIAuth
uriAuthority URI
rawUri) of {
        (String
_, Just (URIAuth String
_ String
domain String
_)) | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Session -> Bool
validateCertificates Session
session -> (do
            forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (Session -> MVar [(String, Bool, UTCTime)]
hstsDomains Session
session) forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip [(String, Bool, UTCTime)] -> String -> IO [(String, Bool, UTCTime)]
removeHSTS String
domain
            forall (m :: * -> *) a. Monad m => a -> m a
return URI
rawUri);
        (String
"http:", Just (URIAuth String
_ String
domain String
_))
            | UTCTime -> String -> [(String, Bool, UTCTime)] -> Bool
testHSTS UTCTime
now String
domain [(String, Bool, UTCTime)]
hsts -> forall (m :: * -> *) a. Monad m => a -> m a
return URI
rawUri { uriScheme :: String
uriScheme = String
"https:" };
        (String, Maybe URIAuth)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return URI
rawUri
    }
    let manager :: Manager
manager = (if Session -> Bool
validateCertificates Session
session
        then Session -> Manager
managerHTTP else Session -> Manager
managerHTTPNoValidate) Session
session
    forall a. MVar a -> a -> IO a
swapMVar (Session
-> MVar (Maybe (Either (String, String) (ByteString, ByteString)))
credentials' Session
session) (Session -> Maybe (Either (String, String) (ByteString, ByteString))
credentials Session
session)

    (Maybe (Text, ByteString), Maybe RequestHeaders)
cached <- if Bool
shouldCache then URI -> IO (Maybe (Text, ByteString), Maybe RequestHeaders)
readCacheHTTP URI
uri else forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)

    Either URI (Text, ByteString)
response <- case (Maybe (Text, ByteString), Maybe RequestHeaders)
cached of
        (Just (Text
mime, ByteString
body), Maybe RequestHeaders
Nothing) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (Text
mime, ByteString
body)
        (Maybe (Text, ByteString)
cached, Maybe RequestHeaders
cachingHeaders) -> do
            Request
request <- forall (m :: * -> *). MonadThrow m => URI -> m Request
HTTP.requestFromURI URI
uri
            CookieJar
cookieJar <- forall a. MVar a -> IO a
readMVar forall a b. (a -> b) -> a -> b
$ Session -> MVar CookieJar
globalCookieJar Session
session
            Request
request'<- Request -> IO Request
cbReq Request
request {
                cookieJar :: Maybe CookieJar
HTTP.cookieJar = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ CookieJar
cookieJar,
                requestHeaders :: RequestHeaders
HTTP.requestHeaders = [
                    (HeaderName
"Accept", String -> ByteString
C8.pack forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
accept),
                    (HeaderName
"Accept-Language", String -> ByteString
C8.pack forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate String
", " forall a b. (a -> b) -> a -> b
$ Session -> [String]
locale Session
session)
                ] forall a. [a] -> [a] -> [a]
++ forall a. a -> Maybe a -> a
fromMaybe [] Maybe RequestHeaders
cachingHeaders,
                redirectCount :: Int
HTTP.redirectCount = Int
0
            }
            Response ByteString
response <- Request -> Manager -> IO (Response ByteString)
HTTP.httpLbs Request
request' Manager
manager
            Response ByteString -> IO a
cbResp Response ByteString
response
            case (
                URI -> String
uriScheme URI
uri,
                URI -> Maybe URIAuth
uriAuthority URI
uri,
                HeaderName
"strict-transport-security" forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` forall body. Response body -> RequestHeaders
HTTP.responseHeaders Response ByteString
response
              ) of
                (String
"https:", Just (URIAuth String
_ String
domain String
_), Just ByteString
header)
                  | Just Text
domain' <- Text -> Maybe Text
effectiveTLDPlusOne forall a b. (a -> b) -> a -> b
$ String -> Text
Txt.pack String
domain -> do
                    Maybe (String, Bool, UTCTime)
record <- String -> ByteString -> IO (Maybe (String, Bool, UTCTime))
appendHSTSFromHeader (Text -> String
Txt.unpack Text
domain') ByteString
header
                    case Maybe (String, Bool, UTCTime)
record of
                        Just (String, Bool, UTCTime)
x -> forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (Session -> MVar [(String, Bool, UTCTime)]
hstsDomains Session
session) (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, Bool, UTCTime)
xforall a. a -> [a] -> [a]
:))
                        Maybe (String, Bool, UTCTime)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                (String, Maybe URIAuth, Maybe ByteString)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            case (
                    forall body. Response body -> Status
HTTP.responseStatus Response ByteString
response,
                    forall body. Response body -> body
HTTP.responseBody Response ByteString
response,
                    [ByteString
val | (HeaderName
"content-type", ByteString
val) <- forall body. Response body -> RequestHeaders
HTTP.responseHeaders Response ByteString
response]
              ) of
                (Status Int
304 ByteString
_, ByteString
_, [ByteString]
_) | Just cached' :: (Text, ByteString)
cached'@(Text
_, ByteString
body) <- Maybe (Text, ByteString)
cached -> do
                    URI -> Response ByteString -> IO ()
cacheHTTP URI
uri forall a b. (a -> b) -> a -> b
$ Response ByteString
response { responseBody :: ByteString
HTTP.responseBody = ByteString
body }
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (Text, ByteString)
cached'
                -- Manually handle redirects so the caller & HTTP cache gets the correct URI.
                (Status Int
code ByteString
_, ByteString
_, [ByteString]
_) | Int
code forall a. Ord a => a -> a -> Bool
> Int
300 Bool -> Bool -> Bool
&& Int
code forall a. Ord a => a -> a -> Bool
< Int
400,
                        Just ByteString
location <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"location" forall a b. (a -> b) -> a -> b
$ forall body. Response body -> RequestHeaders
HTTP.responseHeaders Response ByteString
response,
                        Just URI
uri' <- String -> Maybe URI
parseURIReference forall a b. (a -> b) -> a -> b
$ ByteString -> String
C8.unpack ByteString
location ->
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ URI -> URI -> URI
relativeTo URI
uri' URI
uri
                (Status Int
code ByteString
msg, ByteString
"", [ByteString]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (String -> Text
Txt.pack String
htmlERR,
                    ByteString -> ByteString
B.fromStrict forall a b. (a -> b) -> a -> b
$ String -> ByteString
C8.pack forall a b. (a -> b) -> a -> b
$
                        Session -> Errors -> String
trans' Session
session forall a b. (a -> b) -> a -> b
$ Int -> String -> Errors
HTTPStatus Int
code forall a b. (a -> b) -> a -> b
$ ByteString -> String
C8.unpack ByteString
msg)
                (Status
_, ByteString
body, (ByteString
mimetype:[ByteString]
_)) -> do
                    URI -> Response ByteString -> IO ()
cacheHTTP URI
uri Response ByteString
response
                    IO () -> IO ThreadId
forkIO IO ()
cleanCacheHTTP -- Try to keep diskspace down...

                    let mime :: Text
mime = Text -> Text
Txt.toLower forall a b. (a -> b) -> a -> b
$ String -> ByteString -> Text
convertCharset String
"utf-8" ByteString
mimetype
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (Text
mime, ByteString
body)
                (Status
_, ByteString
response, []) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (String -> Text
Txt.pack String
defaultMIME, ByteString
response)

    case Either URI (Text, ByteString)
response of
        Left URI
redirect ->
            let session' :: Session
session' = Session
session { redirectCount :: Int
redirectCount = Session -> Int
redirectCount Session
session forall a. Num a => a -> a -> a
- Int
1 }
            in Session
-> [String] -> URI -> IO (URI, String, Either Text ByteString)
fetchURL' Session
session' [String]
accept URI
redirect
        Right (Text
mime, ByteString
body) ->
            let mime' :: [String]
mime' = forall a b. (a -> b) -> [a] -> [b]
L.map (Text -> String
Txt.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Txt.strip) forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
Txt.splitOn Text
";" Text
mime
            in forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
a -> [String] -> ByteString -> (a, String, Either Text ByteString)
resolveCharset' URI
uri [String]
mime' ByteString
body
  forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \HttpException
e -> do forall (m :: * -> *) a. Monad m => a -> m a
return (URI
rawUri, String
htmlERR, forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Text
Txt.pack forall a b. (a -> b) -> a -> b
$ (Errors -> String) -> HttpException -> String
transHttp Errors -> String
t HttpException
e)
fetchHTTPCached Session
session Bool
_ [] URI
uri Request -> IO Request
_ Response ByteString -> IO a
_ =
    forall (m :: * -> *) a. Monad m => a -> m a
return (URI
uri, String
htmlERR, forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Text
Txt.pack forall a b. (a -> b) -> a -> b
$ Session -> Errors -> String
trans' Session
session forall a b. (a -> b) -> a -> b
$ String -> Errors
UnsupportedMIME String
"")
#endif

#if WITH_HTTP_URI || WITH_GEMINI_URI
deliverCredentials :: MVar (Maybe (Either (String, String) (ByteString, ByteString)))
-> p -> IO (Maybe Credential)
deliverCredentials MVar (Maybe (Either (String, String) (ByteString, ByteString)))
credentialsMVar p
_ = do
    Maybe (Either (String, String) (ByteString, ByteString))
credentials' <- forall a. MVar a -> IO a
readMVar MVar (Maybe (Either (String, String) (ByteString, ByteString)))
credentialsMVar -- workaround for HTTP-Client-TLS
    case Maybe (Either (String, String) (ByteString, ByteString))
credentials' of
        Just (Left (String
public, String
private)) -> forall {a} {a}. Either a a -> Maybe a
right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> String -> IO (Either String Credential)
TLS.credentialLoadX509 String
public String
private
        Just (Right (ByteString
public, ByteString
private)) ->
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {a} {a}. Either a a -> Maybe a
right forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> Either String Credential
TLS.credentialLoadX509FromMemory ByteString
public ByteString
private
        Maybe (Either (String, String) (ByteString, ByteString))
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
  where
    right :: Either a a -> Maybe a
right (Left a
_) = forall a. Maybe a
Nothing
    right (Right a
x) = forall a. a -> Maybe a
Just a
x
#endif

-- Downloads utilities
-- | write download to a file in the given directory.
saveDownload :: URI -> FilePath -> (URI, String, Either Text ByteString) -> IO URI
saveDownload :: URI -> String -> (URI, String, Either Text ByteString) -> IO URI
saveDownload URI
baseURI String
dir (URI {uriPath :: URI -> String
uriPath = String
path}, String
mime, Either Text ByteString
resp) = do
    String
dest <- String -> IO String
unusedFilename (String
dir String -> String -> String
</> String -> String
takeFileName' String
path)
    case Either Text ByteString
resp of
        Left Text
txt -> String -> String -> IO ()
writeFile String
dest forall a b. (a -> b) -> a -> b
$ Text -> String
Txt.unpack Text
txt
        Right ByteString
bytes -> String -> ByteString -> IO ()
B.writeFile String
dest ByteString
bytes
    -- TODO set user.mime file attribute.
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ URI
baseURI {uriPath :: String
uriPath = String
dest}
  where
    takeFileName' :: String -> String
takeFileName' String
s = case String -> String
takeFileName String
s of { String
"" -> String
"index";  String
f -> String
f}

unusedFilename :: String -> IO String
unusedFilename String
path = do
        Bool
exists <- String -> IO Bool
doesFileExist String
path
        if Bool
exists then forall {t}. (Num t, Show t) => t -> IO String
go Integer
0 else forall (m :: * -> *) a. Monad m => a -> m a
return String
path
    where
        go :: t -> IO String
go t
n = do
            let path' :: String
path' = String
path forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
n
            Bool
exists <- String -> IO Bool
doesFileExist String
path'
            if Bool
exists then t -> IO String
go (t
nforall a. Num a => a -> a -> a
+t
1) else forall (m :: * -> *) a. Monad m => a -> m a
return String
path'

-- | Convert a download into a data: URI
downloadToURI :: (URI, String, Either Text ByteString) -> URI
downloadToURI :: (URI, String, Either Text ByteString) -> URI
downloadToURI (URI
_, String
mime, Left Text
txt) = URI
nullURI {
        uriScheme :: String
uriScheme = String
"data:",
        uriPath :: String
uriPath = String
mime forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ (Char -> Bool) -> String -> String
escapeURIString Char -> Bool
isReserved (Text -> String
Txt.unpack Text
txt)
    }
downloadToURI (URI
_, String
mime, Right ByteString
bytes) = URI
nullURI {
        uriScheme :: String
uriScheme = String
"data:",
        uriPath :: String
uriPath = String
mime forall a. [a] -> [a] -> [a]
++ String
";base64," forall a. [a] -> [a] -> [a]
++ ByteString -> String
C8.unpack (ByteString -> ByteString
B.toStrict forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B64.encode ByteString
bytes)
    }

-- Logging API
enableLogging :: Session -> IO Session
enableLogging :: Session -> IO Session
enableLogging Session
session = do
    MVar [LogRecord]
log <- forall a. a -> IO (MVar a)
newMVar []
    forall (m :: * -> *) a. Monad m => a -> m a
return Session
session { requestLog :: Maybe (MVar [LogRecord])
requestLog = forall a. a -> Maybe a
Just MVar [LogRecord]
log }

retrieveLog :: Session -> IO [LogRecord]
retrieveLog :: Session -> IO [LogRecord]
retrieveLog session :: Session
session@Session { requestLog :: Session -> Maybe (MVar [LogRecord])
requestLog = Just MVar [LogRecord]
log } = forall a. MVar a -> a -> IO a
swapMVar MVar [LogRecord]
log []
retrieveLog Session
_ = forall (m :: * -> *) a. Monad m => a -> m a
return []

writeLog :: Handle -> Session -> IO ()
writeLog :: Handle -> Session -> IO ()
writeLog Handle
out Session
session = do
    [String] -> IO ()
writeRow [String
"URL", String
"Redirected", String
"Accept", String
"MIMEtype", String
"Size", String
"Begin", String
"End", String
"Duration"]
    [LogRecord]
log <- Session -> IO [LogRecord]
retrieveLog Session
session
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [LogRecord]
log forall a b. (a -> b) -> a -> b
$ \LogRecord
record -> [String] -> IO ()
writeRow [
        forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ LogRecord -> URI
url LogRecord
record, forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ LogRecord -> URI
redirected LogRecord
record,
        forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ LogRecord -> [String]
accept LogRecord
record, forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ LogRecord -> String
mimetype LogRecord
record,
        case LogRecord -> Either Text ByteString
response LogRecord
record of
            Left Text
txt -> forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Text -> Int
Txt.length Text
txt
            Right ByteString
bs -> forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
B.length ByteString
bs,
        forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ LogRecord -> UTCTime
begin LogRecord
record, forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ LogRecord -> UTCTime
end LogRecord
record,
        forall a. Show a => a -> String
show (LogRecord -> UTCTime
end LogRecord
record UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` LogRecord -> UTCTime
end LogRecord
record)
      ]
    forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    writeRow :: [String] -> IO ()
writeRow = Handle -> String -> IO ()
hPutStrLn Handle
out forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [[a]] -> [a]
L.intercalate String
"\t"

-- Utils

breakOn :: a -> [a] -> ([a], [a])
breakOn a
c (a
a:[a]
as) | a
c forall a. Eq a => a -> a -> Bool
== a
a = ([], [a]
as)
    | Bool
otherwise = let ([a]
x, [a]
y) = a -> [a] -> ([a], [a])
breakOn a
c [a]
as in (a
aforall a. a -> [a] -> [a]
:[a]
x, [a]
y)
breakOn a
_ [] = ([], [])

firstJust :: Maybe a -> Maybe a -> Maybe a
firstJust a :: Maybe a
a@(Just a
_) Maybe a
_ = Maybe a
a
firstJust Maybe a
Nothing Maybe a
b = Maybe a
b