{-# 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 -> FilePath
cookiesPath :: FilePath,
    Session -> Maybe (MVar CookieJar)
retroactiveCookies :: Maybe (MVar HTTP.CookieJar),
    Session -> MVar [(FilePath, 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 -> [FilePath]
locale :: [String],
    -- | Callback function for localizing error messages, or throwing exceptions
    Session -> Errors -> FilePath
trans' :: Errors -> String,
    -- | Additional files to serve from about: URIs.
    Session -> [(FilePath, 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 -> FilePath
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 (FilePath, FilePath) (ByteString, ByteString))
credentials :: Maybe (Either (FilePath, FilePath) (C8.ByteString, C8.ByteString)),
    Session
-> MVar
     (Maybe (Either (FilePath, FilePath) (ByteString, ByteString)))
credentials' :: MVar (Maybe (Either (FilePath, FilePath) (C8.ByteString, C8.ByteString)))
}

data LogRecord = LogRecord {
    LogRecord -> URI
url :: URI,
    LogRecord -> [FilePath]
accept :: [String],
    LogRecord -> URI
redirected :: URI,
    LogRecord -> FilePath
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 = FilePath -> IO Session
newSession' FilePath
""

-- | Variant of `newSession` which loads plugins for the named app.
newSession' :: String -> IO Session
newSession' :: FilePath -> IO Session
newSession' FilePath
appname = do
    ([FilePath]
ietfLocale, [FilePath]
unixLocale) <- IO ([FilePath], [FilePath])
rfc2616Locale
    MVar (Maybe (Either (FilePath, FilePath) (ByteString, ByteString)))
credentialsMVar <- Maybe (Either (FilePath, FilePath) (ByteString, ByteString))
-> IO
     (MVar
        (Maybe (Either (FilePath, FilePath) (ByteString, ByteString))))
forall a. a -> IO (MVar a)
newMVar Maybe (Either (FilePath, FilePath) (ByteString, ByteString))
forall a. Maybe a
Nothing
#ifdef WITH_HTTP_URI
    let httpsSettings :: ClientParams
httpsSettings = (FilePath -> ByteString -> ClientParams
TLS.defaultParamsClient FilePath
"example.com" ByteString
"https") {
        clientSupported :: Supported
TLS.clientSupported = Supported
forall a. Default a => a
def { supportedCiphers :: [Cipher]
TLS.supportedCiphers = [Cipher]
TLS.ciphersuite_default },
        clientHooks :: ClientHooks
TLS.clientHooks = ClientHooks
forall a. Default a => a
def {
            onCertificateRequest :: OnCertificateRequest
TLS.onCertificateRequest = MVar (Maybe (Either (FilePath, FilePath) (ByteString, ByteString)))
-> OnCertificateRequest
forall p.
MVar (Maybe (Either (FilePath, FilePath) (ByteString, ByteString)))
-> p -> IO (Maybe Credential)
deliverCredentials MVar (Maybe (Either (FilePath, FilePath) (ByteString, ByteString)))
credentialsMVar
        }
    }
    let httpsSettingsNoValidate :: ClientParams
httpsSettingsNoValidate = ClientParams
httpsSettings {
        clientShared :: Shared
TLS.clientShared = Shared
forall a. Default a => a
def {
            sharedValidationCache :: ValidationCache
TLS.sharedValidationCache = ValidationCacheQueryCallback
-> ValidationCacheAddCallback -> ValidationCache
TLS.ValidationCache
                (\ServiceID
_ Fingerprint
_ Certificate
_ -> ValidationCacheResult -> IO ValidationCacheResult
forall (m :: * -> *) a. Monad m => a -> m a
return ValidationCacheResult
TLS.ValidationCachePass)
                (\ServiceID
_ Fingerprint
_ Certificate
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
        }
    }
    Manager
managerHTTP' <- ManagerSettings -> IO Manager
HTTP.newManager (ManagerSettings -> IO Manager) -> ManagerSettings -> IO Manager
forall a b. (a -> b) -> a -> b
$ TLSSettings -> Maybe SockSettings -> ManagerSettings
TLS.mkManagerSettings (ClientParams -> TLSSettings
Conn.TLSSettings ClientParams
httpsSettings) Maybe SockSettings
forall a. Maybe a
Nothing
    Manager
managerHTTPnovalidate' <- ManagerSettings -> IO Manager
HTTP.newManager (ManagerSettings -> IO Manager) -> ManagerSettings -> IO Manager
forall a b. (a -> b) -> a -> b
$ TLSSettings -> Maybe SockSettings -> ManagerSettings
TLS.mkManagerSettings
        (ClientParams -> TLSSettings
Conn.TLSSettings ClientParams
httpsSettingsNoValidate) Maybe SockSettings
forall a. Maybe a
Nothing 

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

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

    Session -> IO Session
forall (m :: * -> *) a. Monad m => a -> m a
return Session :: Manager
-> Manager
-> MVar CookieJar
-> FilePath
-> Maybe (MVar CookieJar)
-> MVar [(FilePath, Bool, UTCTime)]
-> ConnectionContext
-> XDGConfig
-> Rewriter
-> [FilePath]
-> (Errors -> FilePath)
-> [(FilePath, ByteString)]
-> Maybe (MVar [LogRecord])
-> Int
-> Bool
-> FilePath
-> Bool
-> Maybe (Either (FilePath, FilePath) (ByteString, ByteString))
-> MVar
     (Maybe (Either (FilePath, FilePath) (ByteString, ByteString)))
-> Session
Session {
#ifdef WITH_HTTP_URI
        managerHTTP :: Manager
managerHTTP = Manager
managerHTTP',
        managerHTTPNoValidate :: Manager
managerHTTPNoValidate = Manager
managerHTTPnovalidate',
        globalCookieJar :: MVar CookieJar
globalCookieJar = MVar CookieJar
cookieJar,
        cookiesPath :: FilePath
cookiesPath = FilePath
cookiesPath',
        retroactiveCookies :: Maybe (MVar CookieJar)
retroactiveCookies = MVar CookieJar -> Maybe (MVar CookieJar)
forall a. a -> Maybe a
Just MVar CookieJar
cookieJar',
        hstsDomains :: MVar [(FilePath, Bool, UTCTime)]
hstsDomains = MVar [(FilePath, 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 :: [FilePath]
locale = [FilePath]
ietfLocale,
        trans' :: Errors -> FilePath
trans' = [FilePath] -> Errors -> FilePath
trans [FilePath]
ietfLocale,
        aboutPages :: [(FilePath, ByteString)]
aboutPages = [],
        requestLog :: Maybe (MVar [LogRecord])
requestLog = Maybe (MVar [LogRecord])
forall a. Maybe a
Nothing,
        redirectCount :: Int
redirectCount = Int
5,
        cachingEnabled :: Bool
cachingEnabled = Bool
True,
        validateCertificates :: Bool
validateCertificates = Bool
True,
        appName :: FilePath
appName = FilePath
appname,
        credentials :: Maybe (Either (FilePath, FilePath) (ByteString, ByteString))
credentials = Maybe (Either (FilePath, FilePath) (ByteString, ByteString))
forall a. Maybe a
Nothing,
        credentials' :: MVar (Maybe (Either (FilePath, FilePath) (ByteString, ByteString)))
credentials' = MVar (Maybe (Either (FilePath, FilePath) (ByteString, ByteString)))
credentialsMVar
    }

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

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

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

-- | Internal MIMEtypes for error reporting
mimeERR, htmlERR :: String
mimeERR :: FilePath
mimeERR = FilePath
"txt/x-error\t"
htmlERR :: FilePath
htmlERR = FilePath
"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
-> [FilePath]
-> URI
-> Text
-> FilePath
-> IO (URI, FilePath, Either Text ByteString)
submitURL Session
s [FilePath]
a URI
u Text
m FilePath
q =
    Session
-> [FilePath]
-> URI
-> ByteString
-> ByteString
-> [(FilePath, Either FilePath FilePath)]
-> IO (URI, FilePath, Either Text ByteString)
submitURL' Session
s [FilePath]
a URI
u (Text -> ByteString
Txt.encodeUtf8 Text
m) ByteString
"application/x-www-form-urlencoded" ([(FilePath, Either FilePath FilePath)]
 -> IO (URI, FilePath, Either Text ByteString))
-> [(FilePath, Either FilePath FilePath)]
-> IO (URI, FilePath, Either Text ByteString)
forall a b. (a -> b) -> a -> b
$
        (Text -> (FilePath, Either FilePath FilePath))
-> [Text] -> [(FilePath, Either FilePath FilePath)]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map Text -> (FilePath, Either FilePath FilePath)
forall b. Text -> (FilePath, Either FilePath b)
parseQuery ([Text] -> [(FilePath, Either FilePath FilePath)])
-> [Text] -> [(FilePath, Either FilePath FilePath)]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
Txt.splitOn Text
"&" (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
Txt.pack FilePath
q
  where
    parseQuery :: Text -> (FilePath, Either FilePath 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 -> FilePath
decode Text
key, FilePath -> Either FilePath b
forall a b. a -> Either a b
Left FilePath
"")
        else (Text -> FilePath
decode Text
key, FilePath -> Either FilePath b
forall a b. a -> Either a b
Left (FilePath -> Either FilePath b) -> FilePath -> Either FilePath b
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
decode (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Text -> Text
Txt.tail Text
value)
    decode :: Text -> FilePath
decode = FilePath -> FilePath
unEscapeString (FilePath -> FilePath) -> (Text -> FilePath) -> Text -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
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 -> FilePath -> Request -> m Request
addHTTPBody ByteString
mime FilePath
body Request
req = Request -> m Request
forall (m :: * -> *) a. Monad m => a -> m a
return Request
req {
    requestHeaders :: RequestHeaders
HTTP.requestHeaders = (HeaderName
hContentType, ByteString
mime) (HeaderName, ByteString) -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
:
        ((HeaderName, ByteString) -> Bool)
-> RequestHeaders -> RequestHeaders
forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter (\(HeaderName
x, ByteString
_) -> HeaderName
x HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderName
hContentType) (Request -> RequestHeaders
HTTP.requestHeaders Request
req),
    requestBody :: RequestBody
HTTP.requestBody = ByteString -> RequestBody
HTTP.RequestBodyBS (ByteString -> RequestBody) -> ByteString -> RequestBody
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
C8.pack FilePath
body
  }
packQuery :: [(String, Either String FilePath)] -> C8.ByteString -> HTTP.Request -> IO HTTP.Request
packQuery :: [(FilePath, Either FilePath FilePath)]
-> ByteString -> Request -> IO Request
packQuery [(FilePath, Either FilePath FilePath)]
query mime :: ByteString
mime@ByteString
"application/x-www-form-urlencoded" =
    ByteString -> FilePath -> Request -> IO Request
forall (m :: * -> *).
Monad m =>
ByteString -> FilePath -> Request -> m Request
addHTTPBody ByteString
mime (FilePath -> Request -> IO Request)
-> FilePath -> Request -> IO Request
forall a b. (a -> b) -> a -> b
$ [(FilePath, Either FilePath FilePath)] -> FilePath
encodeQuery [(FilePath, Either FilePath FilePath)]
query
packQuery [(FilePath, Either FilePath FilePath)]
query mime :: ByteString
mime@ByteString
"text/plain" = ByteString -> FilePath -> Request -> IO Request
forall (m :: * -> *).
Monad m =>
ByteString -> FilePath -> Request -> m Request
addHTTPBody ByteString
mime (FilePath -> Request -> IO Request)
-> FilePath -> Request -> IO Request
forall a b. (a -> b) -> a -> b
$
    [FilePath] -> FilePath
Prelude.unlines [FilePath
value | (FilePath
key, Left FilePath
value) <- [(FilePath, Either FilePath FilePath)]
query, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
value]
packQuery [(FilePath, Either FilePath FilePath)]
q ByteString
"multipart/form-data" = [Part] -> Request -> IO Request
forall (m :: * -> *). MonadIO m => [Part] -> Request -> m Request
HTTP.formDataBody ([Part] -> Request -> IO Request)
-> [Part] -> Request -> IO Request
forall a b. (a -> b) -> a -> b
$ ((FilePath, Either FilePath FilePath) -> Part)
-> [(FilePath, Either FilePath FilePath)] -> [Part]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map (FilePath, Either FilePath FilePath) -> Part
encodePart [(FilePath, Either FilePath FilePath)]
q
  where
    encodePart :: (FilePath, Either FilePath FilePath) -> Part
encodePart (FilePath
key, Left FilePath
value) = Text -> ByteString -> Part
forall (m :: * -> *).
Applicative m =>
Text -> ByteString -> PartM m
HTTP.partBS (FilePath -> Text
Txt.pack FilePath
key) (FilePath -> ByteString
C8.pack FilePath
value)
    encodePart (FilePath
key, Right FilePath
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.
        Text -> FilePath -> IO RequestBody -> Part
forall (m :: * -> *). Text -> FilePath -> m RequestBody -> PartM m
HTTP.partFileRequestBodyM (FilePath -> Text
Txt.pack FilePath
key) (FilePath
"C:\\fakepath\\" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
takeFileName FilePath
value) (IO RequestBody -> Part) -> IO RequestBody -> Part
forall a b. (a -> b) -> a -> b
$ do
            Int64
size <- Integer -> Int64
forall a. Num a => Integer -> a
fromInteger (Integer -> Int64) -> IO Integer -> IO Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IOMode -> (Handle -> IO Integer) -> IO Integer
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
value IOMode
ReadMode Handle -> IO Integer
hFileSize
            ByteString
body <- FilePath -> IO ByteString
B.readFile FilePath
value
            RequestBody -> IO RequestBody
forall (m :: * -> *) a. Monad m => a -> m a
return (RequestBody -> IO RequestBody) -> RequestBody -> IO RequestBody
forall a b. (a -> b) -> a -> b
$ Int64 -> Builder -> RequestBody
HTTP.RequestBodyBuilder Int64
size (Builder -> RequestBody) -> Builder -> RequestBody
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
Builder.lazyByteString ByteString
body
packQuery [(FilePath, Either FilePath FilePath)]
_ ByteString
_ = Request -> IO Request
forall (m :: * -> *) a. Monad m => a -> m a
return -- Do not upload data if requested to do so in an invalid format.
submitURL' :: Session
-> [FilePath]
-> URI
-> ByteString
-> ByteString
-> [(FilePath, Either FilePath FilePath)]
-> IO (URI, FilePath, Either Text ByteString)
submitURL' Session
session [FilePath]
mimes URI
uri ByteString
method ByteString
"GET" [(FilePath, Either FilePath FilePath)]
query = Session
-> [FilePath] -> URI -> IO (URI, FilePath, Either Text ByteString)
fetchURL' Session
session [FilePath]
mimes URI
uri {
    uriQuery :: FilePath
uriQuery = Char
'?'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: [(FilePath, Either FilePath FilePath)] -> FilePath
encodeQuery [(FilePath, Either FilePath FilePath)]
query } -- Specialcase GET!
submitURL' Session
session [FilePath]
accept URI
uri ByteString
method ByteString
encoding [(FilePath, Either FilePath FilePath)]
query | URI -> FilePath
uriScheme URI
uri FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath
"http:", FilePath
"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 -> CookieJar -> Maybe CookieJar
forall a. a -> Maybe a
Just (CookieJar -> Maybe CookieJar)
-> IO CookieJar -> IO (Maybe CookieJar)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar CookieJar -> IO CookieJar
forall a. MVar a -> IO a
readMVar MVar CookieJar
cookies;
        Maybe (MVar CookieJar)
Nothing -> Maybe CookieJar -> IO (Maybe CookieJar)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe CookieJar
forall a. Maybe a
Nothing
    }
    Session
-> Bool
-> [FilePath]
-> URI
-> (Request -> IO Request)
-> (Response ByteString -> IO ())
-> IO (URI, FilePath, Either Text ByteString)
forall a.
Session
-> Bool
-> [FilePath]
-> URI
-> (Request -> IO Request)
-> (Response ByteString -> IO a)
-> IO (URI, FilePath, Either Text ByteString)
fetchHTTPCached Session
session Bool
False [FilePath]
accept URI
uri (\Request
req -> do
        Request
ret <- [(FilePath, Either FilePath FilePath)]
-> ByteString -> Request -> IO Request
packQuery [(FilePath, Either FilePath FilePath)]
query ByteString
encoding Request
req
        Request -> IO Request
forall (m :: * -> *) a. Monad m => a -> m a
return Request
ret {
            cookieJar :: Maybe CookieJar
HTTP.cookieJar = Maybe CookieJar -> Maybe CookieJar -> Maybe CookieJar
forall a. Maybe a -> Maybe a -> Maybe a
firstJust Maybe CookieJar
csrfCookies (Maybe CookieJar -> Maybe CookieJar)
-> Maybe CookieJar -> Maybe CookieJar
forall a b. (a -> b) -> a -> b
$ Request -> Maybe CookieJar
HTTP.cookieJar Request
req,
            method :: ByteString
HTTP.method = ByteString
method
        }) ((Response ByteString -> IO ())
 -> IO (URI, FilePath, Either Text ByteString))
-> (Response ByteString -> IO ())
-> IO (URI, FilePath, Either Text ByteString)
forall a b. (a -> b) -> a -> b
$ \Response ByteString
resp -> do
            let cookies :: CookieJar
cookies = Response ByteString -> CookieJar
forall body. Response body -> CookieJar
HTTP.responseCookieJar Response ByteString
resp
            MVar CookieJar -> CookieJar -> IO CookieJar
forall a. MVar a -> a -> IO a
swapMVar (Session -> MVar CookieJar
globalCookieJar Session
session) CookieJar
cookies
            FilePath -> CookieJar -> Bool -> IO ()
writeCookies (Session -> FilePath
cookiesPath Session
session) CookieJar
cookies Bool
False
#endif
submitURL' Session
session [FilePath]
mimes URI
uri ByteString
_method ByteString
_encoding [(FilePath, Either FilePath FilePath)]
query = Session
-> [FilePath] -> URI -> IO (URI, FilePath, Either Text ByteString)
fetchURL' Session
session [FilePath]
mimes URI
uri {
    uriQuery :: FilePath
uriQuery = Char
'?'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:[(FilePath, Either FilePath FilePath)] -> FilePath
encodeQuery [(FilePath, Either FilePath FilePath)]
query }
encodeQuery :: [(String, Either String FilePath)] -> String
encodeQuery :: [(FilePath, Either FilePath FilePath)] -> FilePath
encodeQuery [(FilePath
"", Left FilePath
query)] = FilePath
query -- Mostly for the sake of Gemini...
encodeQuery [(FilePath, Either FilePath FilePath)]
query = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"&" ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ ((FilePath, Either FilePath FilePath) -> Maybe FilePath)
-> [(FilePath, Either FilePath FilePath)] -> [FilePath]
forall a b. (a -> Maybe b) -> [a] -> [b]
M.mapMaybe (FilePath, Either FilePath FilePath) -> Maybe FilePath
forall b. (FilePath, Either FilePath b) -> Maybe FilePath
encodePart [(FilePath, Either FilePath FilePath)]
query
  where
    encodePart :: (FilePath, Either FilePath b) -> Maybe FilePath
encodePart (FilePath
key, Left FilePath
"") = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
escape FilePath
key
    encodePart (FilePath
key, Left FilePath
value) = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> FilePath
escape FilePath
key FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Char
'='Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath -> FilePath
escape FilePath
value)
    encodePart (FilePath, Either FilePath b)
_ = Maybe FilePath
forall a. Maybe a
Nothing
    escape :: FilePath -> FilePath
escape = (Char -> Bool) -> FilePath -> FilePath
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
-> [FilePath] -> URI -> IO (URI, FilePath, Either Text ByteString)
fetchURL' sess :: Session
sess@Session {redirectCount :: Session -> Int
redirectCount = Int
0 } [FilePath]
_ URI
uri =
    (URI, FilePath, Either Text ByteString)
-> IO (URI, FilePath, Either Text ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (URI
uri, FilePath
mimeERR, Text -> Either Text ByteString
forall a b. a -> Either a b
Left (Text -> Either Text ByteString) -> Text -> Either Text ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
Txt.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Session -> Errors -> FilePath
trans' Session
sess Errors
ExcessiveRedirects)

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

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

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

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

#ifdef WITH_XDG
fetchURL' sess :: Session
sess@Session { apps :: Session -> XDGConfig
apps = XDGConfig
a } [FilePath]
_ uri :: URI
uri@(URI {uriScheme :: URI -> FilePath
uriScheme = FilePath
s}) = do
        Errors
app <- XDGConfig -> URI -> FilePath -> IO Errors
dispatchURIByMIME XDGConfig
a URI
uri (FilePath
"x-scheme-handler/" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. [a] -> [a]
init FilePath
s)
        (URI, FilePath, Either Text ByteString)
-> IO (URI, FilePath, Either Text ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (URI
uri, FilePath
htmlERR, Text -> Either Text ByteString
forall a b. a -> Either a b
Left (Text -> Either Text ByteString) -> Text -> Either Text ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
Txt.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Session -> Errors -> FilePath
trans' Session
sess (Errors -> FilePath) -> Errors -> FilePath
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 -> FilePath -> URI -> IO (Maybe FilePath)
dispatchByMIME sess :: Session
sess@Session { apps :: Session -> XDGConfig
apps = XDGConfig
a } FilePath
mime URI
uri = do
    Errors
err <- XDGConfig -> URI -> FilePath -> IO Errors
dispatchURIByMIME XDGConfig
a URI
uri FilePath
mime
    Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ case Errors
err of
        UnsupportedMIME FilePath
_ -> Maybe FilePath
forall a. Maybe a
Nothing
        Errors
_ -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ Session -> Errors -> FilePath
trans' Session
sess Errors
err
#else
dispatchByMIME _ _ _ = return Nothing
#endif

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

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

#ifdef WITH_HTTP_URI
fetchHTTPCached :: Session
-> Bool
-> [FilePath]
-> URI
-> (Request -> IO Request)
-> (Response ByteString -> IO a)
-> IO (URI, FilePath, Either Text ByteString)
fetchHTTPCached session :: Session
session @ Session { trans' :: Session -> Errors -> FilePath
trans' = Errors -> FilePath
t} Bool
shouldCache
        accept :: [FilePath]
accept@(FilePath
defaultMIME:[FilePath]
_) URI
rawUri Request -> IO Request
cbReq Response ByteString -> IO a
cbResp = do
    UTCTime
now <- IO UTCTime
getCurrentTime
    [(FilePath, Bool, UTCTime)]
hsts <- MVar [(FilePath, Bool, UTCTime)] -> IO [(FilePath, Bool, UTCTime)]
forall a. MVar a -> IO a
readMVar (MVar [(FilePath, Bool, UTCTime)]
 -> IO [(FilePath, Bool, UTCTime)])
-> MVar [(FilePath, Bool, UTCTime)]
-> IO [(FilePath, Bool, UTCTime)]
forall a b. (a -> b) -> a -> b
$ Session -> MVar [(FilePath, Bool, UTCTime)]
hstsDomains Session
session
    URI
uri <- case (URI -> FilePath
uriScheme URI
rawUri, URI -> Maybe URIAuth
uriAuthority URI
rawUri) of {
        (FilePath
_, Just (URIAuth FilePath
_ FilePath
domain FilePath
_)) | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Session -> Bool
validateCertificates Session
session -> (do
            MVar [(FilePath, Bool, UTCTime)]
-> ([(FilePath, Bool, UTCTime)] -> IO [(FilePath, Bool, UTCTime)])
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (Session -> MVar [(FilePath, Bool, UTCTime)]
hstsDomains Session
session) (([(FilePath, Bool, UTCTime)] -> IO [(FilePath, Bool, UTCTime)])
 -> IO ())
-> ([(FilePath, Bool, UTCTime)] -> IO [(FilePath, Bool, UTCTime)])
-> IO ()
forall a b. (a -> b) -> a -> b
$ ([(FilePath, Bool, UTCTime)]
 -> FilePath -> IO [(FilePath, Bool, UTCTime)])
-> FilePath
-> [(FilePath, Bool, UTCTime)]
-> IO [(FilePath, Bool, UTCTime)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [(FilePath, Bool, UTCTime)]
-> FilePath -> IO [(FilePath, Bool, UTCTime)]
removeHSTS FilePath
domain
            URI -> IO URI
forall (m :: * -> *) a. Monad m => a -> m a
return URI
rawUri);
        (FilePath
"http:", Just (URIAuth FilePath
_ FilePath
domain FilePath
_))
            | UTCTime -> FilePath -> [(FilePath, Bool, UTCTime)] -> Bool
testHSTS UTCTime
now FilePath
domain [(FilePath, Bool, UTCTime)]
hsts -> URI -> IO URI
forall (m :: * -> *) a. Monad m => a -> m a
return URI
rawUri { uriScheme :: FilePath
uriScheme = FilePath
"https:" };
        (FilePath, Maybe URIAuth)
_ -> URI -> IO URI
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
    MVar (Maybe (Either (FilePath, FilePath) (ByteString, ByteString)))
-> Maybe (Either (FilePath, FilePath) (ByteString, ByteString))
-> IO
     (Maybe (Either (FilePath, FilePath) (ByteString, ByteString)))
forall a. MVar a -> a -> IO a
swapMVar (Session
-> MVar
     (Maybe (Either (FilePath, FilePath) (ByteString, ByteString)))
credentials' Session
session) (Session
-> Maybe (Either (FilePath, FilePath) (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 (Maybe (Text, ByteString), Maybe RequestHeaders)
-> IO (Maybe (Text, ByteString), Maybe RequestHeaders)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Text, ByteString)
forall a. Maybe a
Nothing, Maybe RequestHeaders
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) -> Either URI (Text, ByteString) -> IO (Either URI (Text, ByteString))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either URI (Text, ByteString)
 -> IO (Either URI (Text, ByteString)))
-> Either URI (Text, ByteString)
-> IO (Either URI (Text, ByteString))
forall a b. (a -> b) -> a -> b
$ (Text, ByteString) -> Either URI (Text, ByteString)
forall a b. b -> Either a b
Right (Text
mime, ByteString
body)
        (Maybe (Text, ByteString)
cached, Maybe RequestHeaders
cachingHeaders) -> do
            Request
request <- URI -> IO Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
HTTP.requestFromURI URI
uri
            CookieJar
cookieJar <- MVar CookieJar -> IO CookieJar
forall a. MVar a -> IO a
readMVar (MVar CookieJar -> IO CookieJar) -> MVar CookieJar -> IO CookieJar
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 = CookieJar -> Maybe CookieJar
forall a. a -> Maybe a
Just (CookieJar -> Maybe CookieJar) -> CookieJar -> Maybe CookieJar
forall a b. (a -> b) -> a -> b
$ CookieJar
cookieJar,
                requestHeaders :: RequestHeaders
HTTP.requestHeaders = [
                    (HeaderName
"Accept", FilePath -> ByteString
C8.pack (FilePath -> ByteString) -> FilePath -> ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " [FilePath]
accept),
                    (HeaderName
"Accept-Language", FilePath -> ByteString
C8.pack (FilePath -> ByteString) -> FilePath -> ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ Session -> [FilePath]
locale Session
session)
                ] RequestHeaders -> RequestHeaders -> RequestHeaders
forall a. [a] -> [a] -> [a]
++ RequestHeaders -> Maybe RequestHeaders -> RequestHeaders
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 -> FilePath
uriScheme URI
uri,
                URI -> Maybe URIAuth
uriAuthority URI
uri,
                HeaderName
"strict-transport-security" HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` Response ByteString -> RequestHeaders
forall body. Response body -> RequestHeaders
HTTP.responseHeaders Response ByteString
response
              ) of
                (FilePath
"https:", Just (URIAuth FilePath
_ FilePath
domain FilePath
_), Just ByteString
header)
                  | Just Text
domain' <- Text -> Maybe Text
effectiveTLDPlusOne (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
Txt.pack FilePath
domain -> do
                    Maybe (FilePath, Bool, UTCTime)
record <- FilePath -> ByteString -> IO (Maybe (FilePath, Bool, UTCTime))
appendHSTSFromHeader (Text -> FilePath
Txt.unpack Text
domain') ByteString
header
                    case Maybe (FilePath, Bool, UTCTime)
record of
                        Just (FilePath, Bool, UTCTime)
x -> MVar [(FilePath, Bool, UTCTime)]
-> ([(FilePath, Bool, UTCTime)] -> IO [(FilePath, Bool, UTCTime)])
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (Session -> MVar [(FilePath, Bool, UTCTime)]
hstsDomains Session
session) ([(FilePath, Bool, UTCTime)] -> IO [(FilePath, Bool, UTCTime)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(FilePath, Bool, UTCTime)] -> IO [(FilePath, Bool, UTCTime)])
-> ([(FilePath, Bool, UTCTime)] -> [(FilePath, Bool, UTCTime)])
-> [(FilePath, Bool, UTCTime)]
-> IO [(FilePath, Bool, UTCTime)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FilePath, Bool, UTCTime)
x(FilePath, Bool, UTCTime)
-> [(FilePath, Bool, UTCTime)] -> [(FilePath, Bool, UTCTime)]
forall a. a -> [a] -> [a]
:))
                        Maybe (FilePath, Bool, UTCTime)
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                (FilePath, Maybe URIAuth, Maybe ByteString)
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            case (
                    Response ByteString -> Status
forall body. Response body -> Status
HTTP.responseStatus Response ByteString
response,
                    Response ByteString -> ByteString
forall body. Response body -> body
HTTP.responseBody Response ByteString
response,
                    [ByteString
val | (HeaderName
"content-type", ByteString
val) <- Response ByteString -> RequestHeaders
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 (Response ByteString -> IO ()) -> Response ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Response ByteString
response { responseBody :: ByteString
HTTP.responseBody = ByteString
body }
                    Either URI (Text, ByteString) -> IO (Either URI (Text, ByteString))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either URI (Text, ByteString)
 -> IO (Either URI (Text, ByteString)))
-> Either URI (Text, ByteString)
-> IO (Either URI (Text, ByteString))
forall a b. (a -> b) -> a -> b
$ (Text, ByteString) -> Either URI (Text, ByteString)
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
300 Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
400,
                        Just ByteString
location <- HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"location" (RequestHeaders -> Maybe ByteString)
-> RequestHeaders -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Response ByteString -> RequestHeaders
forall body. Response body -> RequestHeaders
HTTP.responseHeaders Response ByteString
response,
                        Just URI
uri' <- FilePath -> Maybe URI
parseURIReference (FilePath -> Maybe URI) -> FilePath -> Maybe URI
forall a b. (a -> b) -> a -> b
$ ByteString -> FilePath
C8.unpack ByteString
location ->
                    Either URI (Text, ByteString) -> IO (Either URI (Text, ByteString))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either URI (Text, ByteString)
 -> IO (Either URI (Text, ByteString)))
-> Either URI (Text, ByteString)
-> IO (Either URI (Text, ByteString))
forall a b. (a -> b) -> a -> b
$ URI -> Either URI (Text, ByteString)
forall a b. a -> Either a b
Left (URI -> Either URI (Text, ByteString))
-> URI -> Either URI (Text, ByteString)
forall a b. (a -> b) -> a -> b
$ URI -> URI -> URI
relativeTo URI
uri' URI
uri
                (Status Int
code ByteString
msg, ByteString
"", [ByteString]
_) -> Either URI (Text, ByteString) -> IO (Either URI (Text, ByteString))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either URI (Text, ByteString)
 -> IO (Either URI (Text, ByteString)))
-> Either URI (Text, ByteString)
-> IO (Either URI (Text, ByteString))
forall a b. (a -> b) -> a -> b
$ (Text, ByteString) -> Either URI (Text, ByteString)
forall a b. b -> Either a b
Right (FilePath -> Text
Txt.pack FilePath
mimeERR,
                    ByteString -> ByteString
B.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
C8.pack (FilePath -> ByteString) -> FilePath -> ByteString
forall a b. (a -> b) -> a -> b
$
                        Session -> Errors -> FilePath
trans' Session
session (Errors -> FilePath) -> Errors -> FilePath
forall a b. (a -> b) -> a -> b
$ Int -> FilePath -> Errors
HTTPStatus Int
code (FilePath -> Errors) -> FilePath -> Errors
forall a b. (a -> b) -> a -> b
$ ByteString -> FilePath
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 (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> Text
convertCharset FilePath
"utf-8" ByteString
mimetype
                    Either URI (Text, ByteString) -> IO (Either URI (Text, ByteString))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either URI (Text, ByteString)
 -> IO (Either URI (Text, ByteString)))
-> Either URI (Text, ByteString)
-> IO (Either URI (Text, ByteString))
forall a b. (a -> b) -> a -> b
$ (Text, ByteString) -> Either URI (Text, ByteString)
forall a b. b -> Either a b
Right (Text
mime, ByteString
body)
                (Status
_, ByteString
response, []) -> Either URI (Text, ByteString) -> IO (Either URI (Text, ByteString))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either URI (Text, ByteString)
 -> IO (Either URI (Text, ByteString)))
-> Either URI (Text, ByteString)
-> IO (Either URI (Text, ByteString))
forall a b. (a -> b) -> a -> b
$ (Text, ByteString) -> Either URI (Text, ByteString)
forall a b. b -> Either a b
Right (FilePath -> Text
Txt.pack FilePath
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 }
            in Session
-> [FilePath] -> URI -> IO (URI, FilePath, Either Text ByteString)
fetchURL' Session
session' [FilePath]
accept URI
redirect
        Right (Text
mime, ByteString
body) ->
            let mime' :: [FilePath]
mime' = (Text -> FilePath) -> [Text] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
L.map (Text -> FilePath
Txt.unpack (Text -> FilePath) -> (Text -> Text) -> Text -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Txt.strip) ([Text] -> [FilePath]) -> [Text] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
Txt.splitOn Text
";" Text
mime
            in (URI, FilePath, Either Text ByteString)
-> IO (URI, FilePath, Either Text ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return ((URI, FilePath, Either Text ByteString)
 -> IO (URI, FilePath, Either Text ByteString))
-> (URI, FilePath, Either Text ByteString)
-> IO (URI, FilePath, Either Text ByteString)
forall a b. (a -> b) -> a -> b
$ URI
-> [FilePath]
-> ByteString
-> (URI, FilePath, Either Text ByteString)
forall a.
a
-> [FilePath]
-> ByteString
-> (a, FilePath, Either Text ByteString)
resolveCharset' URI
uri [FilePath]
mime' ByteString
body
  IO (URI, FilePath, Either Text ByteString)
-> (HttpException -> IO (URI, FilePath, Either Text ByteString))
-> IO (URI, FilePath, Either Text ByteString)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \HttpException
e -> do (URI, FilePath, Either Text ByteString)
-> IO (URI, FilePath, Either Text ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (URI
rawUri, FilePath
mimeERR, Text -> Either Text ByteString
forall a b. a -> Either a b
Left (Text -> Either Text ByteString) -> Text -> Either Text ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
Txt.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ (Errors -> FilePath) -> HttpException -> FilePath
transHttp Errors -> FilePath
t HttpException
e)
fetchHTTPCached Session
session Bool
_ [] URI
uri Request -> IO Request
_ Response ByteString -> IO a
_ =
    (URI, FilePath, Either Text ByteString)
-> IO (URI, FilePath, Either Text ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (URI
uri, FilePath
mimeERR, Text -> Either Text ByteString
forall a b. a -> Either a b
Left (Text -> Either Text ByteString) -> Text -> Either Text ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
Txt.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Session -> Errors -> FilePath
trans' Session
session (Errors -> FilePath) -> Errors -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> Errors
UnsupportedMIME FilePath
"")
#endif

#if WITH_HTTP_URI || WITH_GEMINI_URI
deliverCredentials :: MVar (Maybe (Either (FilePath, FilePath) (ByteString, ByteString)))
-> p -> IO (Maybe Credential)
deliverCredentials MVar (Maybe (Either (FilePath, FilePath) (ByteString, ByteString)))
credentialsMVar p
_ = do
    Maybe (Either (FilePath, FilePath) (ByteString, ByteString))
credentials' <- MVar (Maybe (Either (FilePath, FilePath) (ByteString, ByteString)))
-> IO
     (Maybe (Either (FilePath, FilePath) (ByteString, ByteString)))
forall a. MVar a -> IO a
readMVar MVar (Maybe (Either (FilePath, FilePath) (ByteString, ByteString)))
credentialsMVar -- workaround for HTTP-Client-TLS
    case Maybe (Either (FilePath, FilePath) (ByteString, ByteString))
credentials' of
        Just (Left (FilePath
public, FilePath
private)) -> Either FilePath Credential -> Maybe Credential
forall a a. Either a a -> Maybe a
right (Either FilePath Credential -> Maybe Credential)
-> IO (Either FilePath Credential) -> IO (Maybe Credential)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> FilePath -> IO (Either FilePath Credential)
TLS.credentialLoadX509 FilePath
public FilePath
private
        Just (Right (ByteString
public, ByteString
private)) ->
            Maybe Credential -> IO (Maybe Credential)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Credential -> IO (Maybe Credential))
-> Maybe Credential -> IO (Maybe Credential)
forall a b. (a -> b) -> a -> b
$ Either FilePath Credential -> Maybe Credential
forall a a. Either a a -> Maybe a
right (Either FilePath Credential -> Maybe Credential)
-> Either FilePath Credential -> Maybe Credential
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> Either FilePath Credential
TLS.credentialLoadX509FromMemory ByteString
public ByteString
private
        Maybe (Either (FilePath, FilePath) (ByteString, ByteString))
Nothing -> Maybe Credential -> IO (Maybe Credential)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Credential
forall a. Maybe a
Nothing
  where
    right :: Either a a -> Maybe a
right (Left a
_) = Maybe a
forall a. Maybe a
Nothing
    right (Right a
x) = a -> Maybe a
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
-> FilePath -> (URI, FilePath, Either Text ByteString) -> IO URI
saveDownload URI
baseURI FilePath
dir (URI {uriPath :: URI -> FilePath
uriPath = FilePath
path}, FilePath
mime, Either Text ByteString
resp) = do
    FilePath
dest <- FilePath -> IO FilePath
unusedFilename (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath -> FilePath
takeFileName' FilePath
path)
    case Either Text ByteString
resp of
        Left Text
txt -> FilePath -> FilePath -> IO ()
writeFile FilePath
dest (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
Txt.unpack Text
txt
        Right ByteString
bytes -> FilePath -> ByteString -> IO ()
B.writeFile FilePath
dest ByteString
bytes
    -- TODO set user.mime file attribute.
    URI -> IO URI
forall (m :: * -> *) a. Monad m => a -> m a
return (URI -> IO URI) -> URI -> IO URI
forall a b. (a -> b) -> a -> b
$ URI
baseURI {uriPath :: FilePath
uriPath = FilePath
dest}
  where
    takeFileName' :: FilePath -> FilePath
takeFileName' FilePath
s = case FilePath -> FilePath
takeFileName FilePath
s of { FilePath
"" -> FilePath
"index";  FilePath
f -> FilePath
f}

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

-- | Convert a download into a data: URI
downloadToURI :: (URI, String, Either Text ByteString) -> URI
downloadToURI :: (URI, FilePath, Either Text ByteString) -> URI
downloadToURI (URI
_, FilePath
mime, Left Text
txt) = URI
nullURI {
        uriScheme :: FilePath
uriScheme = FilePath
"data:",
        uriPath :: FilePath
uriPath = FilePath
mime FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"," FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Char -> Bool) -> FilePath -> FilePath
escapeURIString Char -> Bool
isReserved (Text -> FilePath
Txt.unpack Text
txt)
    }
downloadToURI (URI
_, FilePath
mime, Right ByteString
bytes) = URI
nullURI {
        uriScheme :: FilePath
uriScheme = FilePath
"data:",
        uriPath :: FilePath
uriPath = FilePath
mime FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
";base64," FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ByteString -> FilePath
C8.unpack (ByteString -> ByteString
B.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
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 <- [LogRecord] -> IO (MVar [LogRecord])
forall a. a -> IO (MVar a)
newMVar []
    Session -> IO Session
forall (m :: * -> *) a. Monad m => a -> m a
return Session
session { requestLog :: Maybe (MVar [LogRecord])
requestLog = MVar [LogRecord] -> Maybe (MVar [LogRecord])
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 } = MVar [LogRecord] -> [LogRecord] -> IO [LogRecord]
forall a. MVar a -> a -> IO a
swapMVar MVar [LogRecord]
log []
retrieveLog Session
_ = [LogRecord] -> IO [LogRecord]
forall (m :: * -> *) a. Monad m => a -> m a
return []

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

-- Utils

breakOn :: a -> [a] -> ([a], [a])
breakOn a
c (a
a:[a]
as) | a
c a -> a -> Bool
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
aa -> [a] -> [a]
forall 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