{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
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,
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
import Data.Maybe (fromMaybe, listToMaybe, isJust)
import Data.Either (isLeft)
import Text.Read (readMaybe)
import Data.Char (isSpace)
import System.Exit (ExitCode(..))
import System.Directory
import System.FilePath
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 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
Session -> [String]
locale :: [String],
Session -> Errors -> String
trans' :: Errors -> String,
Session -> [(String, ByteString)]
aboutPages :: [(FilePath, ByteString)],
Session -> Maybe (MVar [LogRecord])
requestLog :: Maybe (MVar [LogRecord]),
Session -> Int
redirectCount :: Int,
Session -> Bool
cachingEnabled :: Bool,
Session -> String
appName :: String,
Session -> Bool
validateCertificates :: Bool,
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
}
newSession :: IO Session
newSession :: IO Session
newSession = String -> IO Session
newSession' String
""
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 <- Maybe (Either (String, String) (ByteString, ByteString))
-> IO
(MVar (Maybe (Either (String, String) (ByteString, ByteString))))
forall a. a -> IO (MVar a)
newMVar Maybe (Either (String, String) (ByteString, ByteString))
forall a. Maybe a
Nothing
#ifdef WITH_HTTP_URI
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
(Bool -> Bool -> Bool -> TLSSettings
Conn.TLSSettingsSimple Bool
False Bool
False Bool
False) 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
(Bool -> Bool -> Bool -> TLSSettings
Conn.TLSSettingsSimple Bool
True Bool
False Bool
False) Maybe SockSettings
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 <- 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 [(String, Bool, UTCTime)]
hstsDomains' <- [(String, Bool, UTCTime)] -> IO (MVar [(String, Bool, UTCTime)])
forall a. a -> IO (MVar a)
newMVar ([(String, Bool, UTCTime)] -> IO (MVar [(String, Bool, UTCTime)]))
-> IO [(String, Bool, UTCTime)]
-> IO (MVar [(String, Bool, UTCTime)])
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
Session -> IO Session
forall (m :: * -> *) a. Monad m => a -> m a
return Session :: Manager
-> Manager
-> MVar CookieJar
-> String
-> Maybe (MVar CookieJar)
-> MVar [(String, Bool, UTCTime)]
-> ConnectionContext
-> XDGConfig
-> Rewriter
-> [String]
-> (Errors -> String)
-> [(String, ByteString)]
-> Maybe (MVar [LogRecord])
-> Int
-> Bool
-> String
-> Bool
-> Maybe (Either (String, String) (ByteString, ByteString))
-> MVar (Maybe (Either (String, String) (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 :: String
cookiesPath = String
cookiesPath',
retroactiveCookies :: Maybe (MVar CookieJar)
retroactiveCookies = MVar CookieJar -> Maybe (MVar CookieJar)
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 = Maybe (MVar [LogRecord])
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 = Maybe (Either (String, String) (ByteString, ByteString))
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 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 :: a -> String -> a
parsePort a
fallback (Char
':':String
port) = a
fallback a -> Maybe a -> a
forall a. a -> Maybe a -> a
`fromMaybe` String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe String
port
parsePort a
fallback String
_ = a
fallback
fetchURL :: Session
-> [String]
-> URI
-> IO (String, Either Text ByteString)
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
(String, Either Text ByteString)
-> IO (String, Either Text ByteString)
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
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
-> [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' LogRecord -> [LogRecord] -> [LogRecord]
forall a. a -> [a] -> [a]
: [LogRecord]
log')
(URI, String, Either Text ByteString)
-> IO (URI, String, Either Text ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (URI, String, Either Text ByteString)
res
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 = 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
-> [String] -> URI -> IO (URI, String, Either Text ByteString)
fetch Session
sess' [String]
mimes URI
u IO (URI, String, Either Text ByteString)
-> ((URI, String, Either Text ByteString) -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (URI, String, 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
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)
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" ([(String, Either String String)]
-> IO (URI, String, Either Text ByteString))
-> [(String, Either String String)]
-> IO (URI, String, Either Text ByteString)
forall a b. (a -> b) -> a -> b
$
(Text -> (String, Either String String))
-> [Text] -> [(String, Either String String)]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map Text -> (String, Either String String)
forall {b}. Text -> (String, Either String b)
parseQuery ([Text] -> [(String, Either String String)])
-> [Text] -> [(String, Either String String)]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
Txt.splitOn Text
"&" (Text -> [Text]) -> Text -> [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, String -> Either String b
forall a b. a -> Either a b
Left String
"")
else (Text -> String
decode Text
key, String -> Either String b
forall a b. a -> Either a b
Left (String -> Either String b) -> String -> Either String b
forall a b. (a -> b) -> a -> b
$ Text -> String
decode (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> Text
Txt.tail Text
value)
decode :: Text -> String
decode = String -> String
unEscapeString (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Txt.unpack
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 = 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
$ 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" =
ByteString -> String -> Request -> IO Request
forall {m :: * -> *}.
Monad m =>
ByteString -> String -> Request -> m Request
addHTTPBody ByteString
mime (String -> Request -> IO Request)
-> String -> Request -> IO Request
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" = ByteString -> String -> Request -> IO Request
forall {m :: * -> *}.
Monad m =>
ByteString -> String -> Request -> m Request
addHTTPBody ByteString
mime (String -> Request -> IO Request)
-> String -> Request -> IO Request
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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
value]
packQuery [(String, Either String String)]
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
$ ((String, Either String String) -> Part)
-> [(String, Either String String)] -> [Part]
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) = Text -> ByteString -> Part
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) =
Text -> String -> IO RequestBody -> Part
forall (m :: * -> *). Text -> String -> m RequestBody -> PartM m
HTTP.partFileRequestBodyM (String -> Text
Txt.pack String
key) (String
"C:\\fakepath\\" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
takeFileName String
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
<$> String -> IOMode -> (Handle -> IO Integer) -> IO Integer
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
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 [(String, Either String String)]
_ ByteString
_ = Request -> IO Request
forall (m :: * -> *) a. Monad m => a -> m a
return
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
'?'Char -> String -> String
forall a. a -> [a] -> [a]
: [(String, Either String String)] -> String
encodeQuery [(String, Either String String)]
query }
submitURL' Session
session [String]
accept URI
uri ByteString
method ByteString
encoding [(String, Either String String)]
query | URI -> String
uriScheme URI
uri String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"http:", String
"https:"] = do
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
-> [String]
-> URI
-> (Request -> IO Request)
-> (Response ByteString -> IO ())
-> IO (URI, String, Either Text ByteString)
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
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, String, Either Text ByteString))
-> (Response ByteString -> IO ())
-> IO (URI, String, 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
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
'?'Char -> String -> String
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
encodeQuery [(String, Either String String)]
query = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"&" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((String, Either String String) -> Maybe String)
-> [(String, Either String String)] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
M.mapMaybe (String, Either String String) -> Maybe String
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
"") = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String -> String
escape String
key
encodePart (String
key, Left String
value) = String -> Maybe String
forall a. a -> Maybe a
Just (String -> String
escape String
key String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'='Char -> String -> String
forall a. a -> [a] -> [a]
:String -> String
escape String
value)
encodePart (String, Either String b)
_ = Maybe String
forall a. Maybe a
Nothing
escape :: String -> String
escape = (Char -> Bool) -> String -> String
escapeURIString Char -> Bool
isUnescapedInURIComponent
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 =
(URI, String, Either Text ByteString)
-> IO (URI, String, Either Text ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (URI
uri, String
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
$ String -> Text
Txt.pack (String -> Text) -> String -> Text
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 = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String
dir' String -> String -> String
</> String
appname, String
dir'] | String
dir' <- String
dir String -> [String] -> [String]
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
[] -> (URI, String, Either Text ByteString)
-> IO (URI, String, Either Text ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (URI
uri, String
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
$ String -> Text
Txt.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Session -> Errors -> String
trans' Session
session (Errors -> String) -> Errors -> String
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 (Char -> Char -> Bool
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) = Char -> String -> (String, String)
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 -> (URI, String, Either Text ByteString)
-> IO (URI, String, Either Text ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (URI
uri, String -> String
strip String
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
$ String -> Text
Txt.pack String
body)
Char
'u':Char
'r':Char
'l':String
header' | Just URI
uri' <- String -> Maybe URI
parseURIReference (String -> Maybe URI) -> String -> Maybe URI
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1}) [String]
mimes (URI -> IO (URI, String, Either Text ByteString))
-> URI -> IO (URI, String, Either Text ByteString)
forall a b. (a -> b) -> a -> b
$
URI -> URI -> URI
relativeTo URI
uri' URI
uri
String
_ | ExitCode -> Bool
isSuccess ExitCode
exitcode -> (URI, String, Either Text ByteString)
-> IO (URI, String, Either Text ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (URI
uri, String
"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
$ String -> Text
Txt.pack String
response)
String
_ -> (URI, String, Either Text ByteString)
-> IO (URI, String, Either Text ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (URI
uri, String
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
$ String -> Text
Txt.pack String
response)
where
split :: (Char -> Bool) -> String -> [String]
split Char -> Bool
p String
s = case (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
p String
s of
String
"" -> []
String
s' -> let (String
w, String
s'') = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
p String
s' in String
w String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Char -> Bool) -> String -> [String]
split Char -> Bool
p String
s''
strip :: String -> String
strip = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
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 (URI -> IO (URI, String, Either Text ByteString))
-> URI -> IO (URI, String, Either Text ByteString)
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} =
(URI, String, Either Text ByteString)
-> IO (URI, String, Either Text ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (URI
url,
Text -> String
Txt.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> Text
Txt.strip (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> Text
convertCharset String
"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
$
String -> ByteString -> [(String, ByteString)] -> ByteString
forall {a} {a}. Eq a => a -> a -> [(a, a)] -> a
llookup (String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".mime") ByteString
"text/html" [(String, 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
$ String -> ByteString -> [(String, ByteString)] -> ByteString
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 String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"http:", String
"https:"] =
Session
-> Bool
-> [String]
-> URI
-> (Request -> IO Request)
-> (Response ByteString -> IO ())
-> IO (URI, String, Either Text ByteString)
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 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 } [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"
MVar (Maybe (Either (String, String) (ByteString, ByteString)))
-> Maybe (Either (String, String) (ByteString, ByteString))
-> IO (Maybe (Either (String, String) (ByteString, ByteString)))
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 ConnectionParams :: String
-> PortNumber
-> Maybe TLSSettings
-> Maybe SockSettings
-> ConnectionParams
Conn.ConnectionParams {
connectionHostname :: String
Conn.connectionHostname = String
host,
connectionPort :: PortNumber
Conn.connectionPort = PortNumber -> String -> PortNumber
forall {a}. Read a => a -> String -> a
parsePort PortNumber
1965 String
port,
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 (String, String) (ByteString, ByteString)))
-> OnCertificateRequest
forall {p}.
MVar (Maybe (Either (String, String) (ByteString, ByteString)))
-> p -> IO (Maybe Credential)
deliverCredentials (MVar (Maybe (Either (String, String) (ByteString, ByteString)))
-> OnCertificateRequest)
-> MVar (Maybe (Either (String, String) (ByteString, ByteString)))
-> OnCertificateRequest
forall a b. (a -> b) -> a -> b
$ Session
-> MVar (Maybe (Either (String, String) (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
$ String -> ByteString
C8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ (String -> String) -> URI -> String -> String
uriToString String -> String
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 (String -> (Char, Char, Text)) -> String -> (Char, Char, Text)
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 ([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' :: [String]
mime' = (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
L.map (Text -> String
Txt.unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Txt.strip) ([Text] -> [String]) -> [Text] -> [String]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
Txt.splitOn Text
";" Text
mime
(URI, String, Either Text ByteString)
-> IO (URI, String, Either Text ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return ((URI, String, Either Text ByteString)
-> IO (URI, String, Either Text ByteString))
-> (URI, String, Either Text ByteString)
-> IO (URI, String, Either Text ByteString)
forall a b. (a -> b) -> a -> b
$ URI
-> [String] -> ByteString -> (URI, String, Either Text ByteString)
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 (String -> Maybe URI) -> String -> Maybe URI
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
} [String]
mimes (URI -> IO (URI, String, Either Text ByteString))
-> URI -> IO (URI, String, 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, String, Either Text ByteString)
-> IO (URI, String, Either Text ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (URI
uri, String
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
$ String -> Text
Txt.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
Session -> Errors -> String
trans' Session
sess (Errors -> String) -> Errors -> String
forall a b. (a -> b) -> a -> b
$ Char -> Char -> String -> Errors
GeminiError Char
x Char
y (String -> Errors) -> String -> Errors
forall a b. (a -> b) -> a -> b
$ Text -> String
Txt.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
Text -> Text -> Text -> Text
Txt.replace Text
"<" Text
"<" (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Text
Txt.replace Text
"&" Text
"&" 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 (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Txt.pack String
meta)
parseHeader String
header = (Char
'4', Char
'1', String -> Text
Txt.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Session -> Errors -> String
trans' Session
sess (Errors -> String) -> Errors -> String
forall a b. (a -> b) -> a -> b
$ String -> Errors
MalformedResponse String
header)
handleIOErr :: IOError -> IO Strict.ByteString
handleIOErr :: IOException -> IO ByteString
handleIOErr IOException
_ = 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 -> (IOException -> IO ByteString) -> IO ByteString
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 [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 (String
defaultMIME:[String]
_) uri :: URI
uri@URI {uriScheme :: URI -> String
uriScheme = String
"file:"} = do
ByteString
response <- String -> IO ByteString
B.readFile (String -> IO ByteString) -> String -> IO ByteString
forall a b. (a -> b) -> a -> b
$ URI -> String
uriPath URI
uri
(URI, String, Either Text ByteString)
-> IO (URI, String, Either Text ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (URI
uri, String
defaultMIME, ByteString -> Either Text ByteString
forall a b. b -> Either a b
Right ByteString
response)
IO (URI, String, Either Text ByteString)
-> (IOException -> IO (URI, String, Either Text ByteString))
-> IO (URI, String, Either Text ByteString)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \IOException
e -> do
(URI, String, Either Text ByteString)
-> IO (URI, String, Either Text ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (URI
uri, String
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
$ String -> Text
Txt.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Session -> Errors -> String
trans' Session
sess (Errors -> String) -> Errors -> String
forall a b. (a -> b) -> a -> b
$ String -> Errors
ReadFailed (String -> Errors) -> String -> Errors
forall a b. (a -> b) -> a -> b
$ IOException -> String
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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ URI -> String
uriQuery URI
uri String -> String -> String
forall a. [a] -> [a] -> [a]
++ URI -> String
uriFragment URI
uri
in case Char -> String -> (String, String)
forall {a}. Eq a => a -> [a] -> ([a], [a])
breakOn Char
',' (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ String -> String
unEscapeString String
request of
(String
"", String
response) -> (URI, String, Either Text ByteString)
-> IO (URI, String, Either Text ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (URI
uri, String
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
$ 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 <- String -> String
forall a. [a] -> [a]
reverse String
mime' ->
(URI, String, Either Text ByteString)
-> IO (URI, String, Either Text ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return ((URI, String, Either Text ByteString)
-> IO (URI, String, Either Text ByteString))
-> (URI, String, Either Text ByteString)
-> IO (URI, String, Either Text ByteString)
forall a b. (a -> b) -> a -> b
$ case ByteString -> Either String ByteString
B64.decode (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
C8.pack String
response of
Left String
str -> (URI
uri, String
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
$ String -> Text
Txt.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> String
unEscapeString String
str)
Right ByteString
bytes -> (URI
uri, String -> String
forall a. [a] -> [a]
reverse String
mime, ByteString -> Either Text ByteString
forall a b. b -> Either a b
Right ByteString
bytes)
(String
mime, String
response) -> (URI, String, Either Text ByteString)
-> IO (URI, String, Either Text ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (URI
uri, String
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
$ 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/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. [a] -> [a]
init String
s)
(URI, String, Either Text ByteString)
-> IO (URI, String, Either Text ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (URI
uri, String
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
$ String -> Text
Txt.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Session -> Errors -> String
trans' Session
sess (Errors -> String) -> Errors -> String
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
Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ case Errors
err of
UnsupportedMIME String
_ -> Maybe String
forall a. Maybe a
Nothing
Errors
_ -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
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
case Either String Bool
try1 of
Left String
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
String
temp <- String -> IO String
canonicalizePath (String -> IO String) -> IO String -> IO String
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:" Maybe URIAuth
forall a. Maybe a
Nothing String
"" String
"" String
"") String
temp (URI, String, Either Text ByteString)
resp
Either String Bool -> Bool
forall a b. Either a b -> Bool
isLeft (Either String Bool -> Bool) -> IO (Either String Bool) -> IO Bool
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 <- MVar [(String, Bool, UTCTime)] -> IO [(String, Bool, UTCTime)]
forall a. MVar a -> IO a
readMVar (MVar [(String, Bool, UTCTime)] -> IO [(String, Bool, UTCTime)])
-> MVar [(String, Bool, UTCTime)] -> IO [(String, Bool, UTCTime)]
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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Session -> Bool
validateCertificates Session
session -> (do
MVar [(String, Bool, UTCTime)]
-> ([(String, Bool, UTCTime)] -> IO [(String, Bool, UTCTime)])
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (Session -> MVar [(String, Bool, UTCTime)]
hstsDomains Session
session) (([(String, Bool, UTCTime)] -> IO [(String, Bool, UTCTime)])
-> IO ())
-> ([(String, Bool, UTCTime)] -> IO [(String, Bool, UTCTime)])
-> IO ()
forall a b. (a -> b) -> a -> b
$ ([(String, Bool, UTCTime)]
-> String -> IO [(String, Bool, UTCTime)])
-> String
-> [(String, Bool, UTCTime)]
-> IO [(String, Bool, UTCTime)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [(String, Bool, UTCTime)] -> String -> IO [(String, Bool, UTCTime)]
removeHSTS String
domain
URI -> IO URI
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 -> URI -> IO URI
forall (m :: * -> *) a. Monad m => a -> m a
return URI
rawUri { uriScheme :: String
uriScheme = String
"https:" };
(String, 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 (String, String) (ByteString, ByteString)))
-> Maybe (Either (String, String) (ByteString, ByteString))
-> IO (Maybe (Either (String, String) (ByteString, ByteString)))
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 (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", String -> ByteString
C8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
accept),
(HeaderName
"Accept-Language", String -> ByteString
C8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Session -> [String]
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 -> String
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
(String
"https:", Just (URIAuth String
_ String
domain String
_), Just ByteString
header)
| Just Text
domain' <- Text -> Maybe Text
effectiveTLDPlusOne (Text -> Maybe Text) -> Text -> Maybe Text
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 -> MVar [(String, Bool, UTCTime)]
-> ([(String, Bool, UTCTime)] -> IO [(String, Bool, UTCTime)])
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (Session -> MVar [(String, Bool, UTCTime)]
hstsDomains Session
session) ([(String, Bool, UTCTime)] -> IO [(String, Bool, UTCTime)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, Bool, UTCTime)] -> IO [(String, Bool, UTCTime)])
-> ([(String, Bool, UTCTime)] -> [(String, Bool, UTCTime)])
-> [(String, Bool, UTCTime)]
-> IO [(String, Bool, UTCTime)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, Bool, UTCTime)
x(String, Bool, UTCTime)
-> [(String, Bool, UTCTime)] -> [(String, Bool, UTCTime)]
forall a. a -> [a] -> [a]
:))
Maybe (String, Bool, UTCTime)
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(String, 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'
(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' <- String -> Maybe URI
parseURIReference (String -> Maybe URI) -> String -> Maybe URI
forall a b. (a -> b) -> a -> b
$ ByteString -> String
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 (String -> Text
Txt.pack String
htmlERR,
ByteString -> ByteString
B.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
C8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$
Session -> Errors -> String
trans' Session
session (Errors -> String) -> Errors -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> Errors
HTTPStatus Int
code (String -> Errors) -> String -> Errors
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
let mime :: Text
mime = Text -> Text
Txt.toLower (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> Text
convertCharset String
"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 (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 Int -> Int -> Int
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' = (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
L.map (Text -> String
Txt.unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Txt.strip) ([Text] -> [String]) -> [Text] -> [String]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
Txt.splitOn Text
";" Text
mime
in (URI, String, Either Text ByteString)
-> IO (URI, String, Either Text ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return ((URI, String, Either Text ByteString)
-> IO (URI, String, Either Text ByteString))
-> (URI, String, Either Text ByteString)
-> IO (URI, String, Either Text ByteString)
forall a b. (a -> b) -> a -> b
$ URI
-> [String] -> ByteString -> (URI, String, Either Text ByteString)
forall a.
a -> [String] -> ByteString -> (a, String, Either Text ByteString)
resolveCharset' URI
uri [String]
mime' ByteString
body
IO (URI, String, Either Text ByteString)
-> (HttpException -> IO (URI, String, Either Text ByteString))
-> IO (URI, String, Either Text ByteString)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \HttpException
e -> do (URI, String, Either Text ByteString)
-> IO (URI, String, Either Text ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (URI
rawUri, String
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
$ String -> Text
Txt.pack (String -> Text) -> String -> Text
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
_ =
(URI, String, Either Text ByteString)
-> IO (URI, String, Either Text ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (URI
uri, String
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
$ String -> Text
Txt.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Session -> Errors -> String
trans' Session
session (Errors -> String) -> Errors -> String
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' <- MVar (Maybe (Either (String, String) (ByteString, ByteString)))
-> IO (Maybe (Either (String, String) (ByteString, ByteString)))
forall a. MVar a -> IO a
readMVar MVar (Maybe (Either (String, String) (ByteString, ByteString)))
credentialsMVar
case Maybe (Either (String, String) (ByteString, ByteString))
credentials' of
Just (Left (String
public, String
private)) -> Either String Credential -> Maybe Credential
forall {a} {a}. Either a a -> Maybe a
right (Either String Credential -> Maybe Credential)
-> IO (Either String Credential) -> IO (Maybe Credential)
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)) ->
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 String Credential -> Maybe Credential
forall {a} {a}. Either a a -> Maybe a
right (Either String Credential -> Maybe Credential)
-> Either String Credential -> Maybe Credential
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 -> 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
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 (String -> IO ()) -> String -> IO ()
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
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 :: 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 Integer -> IO String
forall {t}. (Num t, Show t) => t -> IO String
go Integer
0 else String -> IO String
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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ t -> String
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
nt -> t -> t
forall a. Num a => a -> a -> a
+t
1) else String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
path'
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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"," String -> String -> 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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";base64," String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
C8.unpack (ByteString -> ByteString
B.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B64.encode ByteString
bytes)
}
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
[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
[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 -> [String] -> IO ()
writeRow [
URI -> String
forall a. Show a => a -> String
show (URI -> String) -> URI -> String
forall a b. (a -> b) -> a -> b
$ LogRecord -> URI
url LogRecord
record, URI -> String
forall a. Show a => a -> String
show (URI -> String) -> URI -> String
forall a b. (a -> b) -> a -> b
$ LogRecord -> URI
redirected LogRecord
record,
[String] -> String
forall a. Show a => a -> String
show ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ LogRecord -> [String]
accept LogRecord
record, String -> String
forall a. Show a => a -> String
show (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ LogRecord -> String
mimetype LogRecord
record,
case LogRecord -> Either Text ByteString
response LogRecord
record of
Left Text
txt -> Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Text -> Int
Txt.length Text
txt
Right ByteString
bs -> Int64 -> String
forall a. Show a => a -> String
show (Int64 -> String) -> Int64 -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
B.length ByteString
bs,
UTCTime -> String
forall a. Show a => a -> String
show (UTCTime -> String) -> UTCTime -> String
forall a b. (a -> b) -> a -> b
$ LogRecord -> UTCTime
begin LogRecord
record, UTCTime -> String
forall a. Show a => a -> String
show (UTCTime -> String) -> UTCTime -> String
forall a b. (a -> b) -> a -> b
$ LogRecord -> UTCTime
end LogRecord
record,
NominalDiffTime -> String
forall a. Show a => a -> String
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 :: [String] -> IO ()
writeRow = Handle -> String -> IO ()
hPutStrLn Handle
out (String -> IO ()) -> ([String] -> String) -> [String] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
"\t"
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