{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.URI.Fetch(Session(locale, aboutPages, redirectCount), newSession,
fetchURL, fetchURL', fetchURLs, mimeERR, htmlERR,
dispatchByMIME, saveDownload, downloadToURI,
LogRecord(..), enableLogging, retrieveLog, writeLog) where
import qualified Data.Text as Txt
import Data.Text (Text)
import Network.URI
import qualified Data.ByteString as Strict
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Char8 as C8
import Network.URI.Charset
import Control.Exception
import System.IO.Error (isEOFError)
import Control.Concurrent.Async (forConcurrently)
import Data.Maybe (fromMaybe, listToMaybe)
import Text.Read (readMaybe)
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.OpenSSL as TLS
import qualified OpenSSL.Session as TLS
import Network.HTTP.Types
import Data.List (intercalate)
#endif
#ifdef WITH_RAW_CONNECTIONS
import qualified OpenSSL as TLS
import qualified OpenSSL.Session as TLS
import qualified System.IO.Streams.SSL as TLSConn
import System.IO.Streams
#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
data Session = Session {
#ifdef WITH_HTTP_URI
Session -> Manager
managerHTTP :: HTTP.Manager,
#endif
#ifdef WITH_RAW_CONNECTIONS
Session -> SSLContext
connCtxt :: TLS.SSLContext,
#endif
#ifdef WITH_XDG
Session -> XDGConfig
apps :: XDGConfig,
#endif
#ifdef WITH_PLUGIN_REWRITES
Session -> Rewriter
rewriter :: Rewriter,
#endif
Session -> [String]
locale :: [String],
Session -> [(String, ByteString)]
aboutPages :: [(FilePath, ByteString)],
Session -> MVar [LogRecord]
requestLog :: MVar [LogRecord],
Session -> Int
redirectCount :: Int
}
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
#ifdef WITH_HTTP_URI
SSLContext
httpsCtxt <- IO SSLContext
TLS.context
SSLContext -> IO ()
TLS.contextSetDefaultCiphers SSLContext
httpsCtxt
SSLContext -> String -> IO ()
TLS.contextSetCADirectory SSLContext
httpsCtxt String
"/etc/ssl/certs"
SSLContext -> VerificationMode -> IO ()
TLS.contextSetVerificationMode SSLContext
httpsCtxt (VerificationMode -> IO ()) -> VerificationMode -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Maybe (Bool -> X509StoreCtx -> IO Bool)
-> VerificationMode
TLS.VerifyPeer Bool
True Bool
True Maybe (Bool -> X509StoreCtx -> IO Bool)
forall a. Maybe a
Nothing
Manager
managerHTTP' <- ManagerSettings -> IO Manager
HTTP.newManager (ManagerSettings -> IO Manager) -> ManagerSettings -> IO Manager
forall a b. (a -> b) -> a -> b
$ IO SSLContext -> ManagerSettings
TLS.opensslManagerSettings (IO SSLContext -> ManagerSettings)
-> IO SSLContext -> ManagerSettings
forall a b. (a -> b) -> a -> b
$ SSLContext -> IO SSLContext
forall (m :: * -> *) a. Monad m => a -> m a
return SSLContext
httpsCtxt
#endif
#ifdef WITH_RAW_CONNECTIONS
SSLContext
connCtxt <- IO SSLContext
TLS.context
SSLContext -> IO ()
TLS.contextSetDefaultCiphers SSLContext
connCtxt
SSLContext -> String -> IO ()
TLS.contextSetCADirectory SSLContext
connCtxt String
"/etc/ssl/certs"
SSLContext -> VerificationMode -> IO ()
TLS.contextSetVerificationMode SSLContext
connCtxt (VerificationMode -> IO ()) -> VerificationMode -> IO ()
forall a b. (a -> b) -> a -> b
$
Bool
-> Bool
-> Maybe (Bool -> X509StoreCtx -> IO Bool)
-> VerificationMode
TLS.VerifyPeer Bool
True Bool
True (Maybe (Bool -> X509StoreCtx -> IO Bool) -> VerificationMode)
-> Maybe (Bool -> X509StoreCtx -> IO Bool) -> VerificationMode
forall a b. (a -> b) -> a -> b
$ (Bool -> X509StoreCtx -> IO Bool)
-> Maybe (Bool -> X509StoreCtx -> IO Bool)
forall a. a -> Maybe a
Just ((Bool -> X509StoreCtx -> IO Bool)
-> Maybe (Bool -> X509StoreCtx -> IO Bool))
-> (Bool -> X509StoreCtx -> IO Bool)
-> Maybe (Bool -> X509StoreCtx -> IO Bool)
forall a b. (a -> b) -> a -> b
$ \Bool
valid X509StoreCtx
_ -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
valid
#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
MVar [LogRecord]
log <- IO (MVar [LogRecord])
forall a. IO (MVar a)
newEmptyMVar
Session -> IO Session
forall (m :: * -> *) a. Monad m => a -> m a
return Session :: Manager
-> SSLContext
-> XDGConfig
-> Rewriter
-> [String]
-> [(String, ByteString)]
-> MVar [LogRecord]
-> Int
-> Session
Session {
#ifdef WITH_HTTP_URI
managerHTTP :: Manager
managerHTTP = Manager
managerHTTP',
#endif
#ifdef WITH_RAW_CONNECTIONS
connCtxt :: SSLContext
connCtxt = SSLContext
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,
aboutPages :: [(String, ByteString)]
aboutPages = [],
requestLog :: MVar [LogRecord]
requestLog = MVar [LogRecord]
log,
redirectCount :: Int
redirectCount = Int
5
}
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 -> String -> p
parsePort p
fallback (Char
':':String
port) = p
fallback p -> Maybe p -> p
forall a. a -> Maybe a -> a
`fromMaybe` String -> Maybe p
forall a. Read a => String -> Maybe a
readMaybe String
port
parsePort p
fallback String
_ = p
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 :: Session
-> [String] -> URI -> IO (URI, String, Either Text ByteString)
fetchURLLogged 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_ (Session -> MVar [LogRecord]
requestLog Session
sess) (([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 :: 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
Bool
shouldntLog <- MVar [LogRecord] -> IO Bool
forall a. MVar a -> IO Bool
isEmptyMVar (MVar [LogRecord] -> IO Bool) -> MVar [LogRecord] -> IO Bool
forall a b. (a -> b) -> a -> b
$ Session -> MVar [LogRecord]
requestLog Session
sess
let fetch :: Session
-> [String] -> URI -> IO (URI, String, Either Text ByteString)
fetch = if Bool
shouldntLog then Session
-> [String] -> URI -> IO (URI, String, Either Text ByteString)
fetchURL' else Session
-> [String] -> URI -> IO (URI, String, Either Text ByteString)
fetchURLLogged
[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"
fetchURL' :: Session -> [String] -> URI -> IO (URI, String, Either Text ByteString)
fetchURL' :: Session
-> [String] -> URI -> IO (URI, String, Either Text ByteString)
fetchURL' Session {redirectCount :: Session -> Int
redirectCount = Int
0, locale :: Session -> [String]
locale = [String]
locale'} [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
$ [String] -> Errors -> String
trans [String]
locale' 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
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 accept :: [String]
accept@(String
defaultMIME:[String]
_) 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:"] = do
Request
request <- URI -> IO Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
HTTP.requestFromURI URI
uri
Response ByteString
response <- Request -> Manager -> IO (Response ByteString)
HTTP.httpLbs Request
request {
cookieJar :: Maybe CookieJar
HTTP.cookieJar = Maybe CookieJar
forall a. Maybe a
Nothing,
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)
],
redirectCount :: Int
HTTP.redirectCount = Session -> Int
redirectCount Session
session
} (Manager -> IO (Response ByteString))
-> Manager -> IO (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Session -> Manager
managerHTTP Session
session
(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 (
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
(ByteString
"", [ByteString]
_) -> (URI
uri, String
mimeERR, 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
$ ByteString -> ByteString
B.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Status -> ByteString
statusMessage (Status -> ByteString) -> Status -> ByteString
forall a b. (a -> b) -> a -> b
$ Response ByteString -> Status
forall body. Response body -> Status
HTTP.responseStatus Response ByteString
response)
(ByteString
response, (ByteString
mimetype:[ByteString]
_)) -> 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
in URI
-> [String] -> ByteString -> (URI, String, Either Text ByteString)
forall a.
a -> [String] -> ByteString -> (a, String, Either Text ByteString)
resolveCharset' URI
uri ((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) ByteString
response
(ByteString
response, []) -> (URI
uri, String
defaultMIME, ByteString -> Either Text ByteString
forall a b. b -> Either a b
Right ByteString
response)
IO (URI, String, Either Text ByteString)
-> [Handler (URI, String, Either Text ByteString)]
-> IO (URI, String, Either Text ByteString)
forall a. IO a -> [Handler a] -> IO a
`catches` [
(HttpException -> IO (URI, String, Either Text ByteString))
-> Handler (URI, String, Either Text ByteString)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((HttpException -> IO (URI, String, Either Text ByteString))
-> Handler (URI, String, Either Text ByteString))
-> (HttpException -> IO (URI, String, Either Text ByteString))
-> Handler (URI, String, Either Text ByteString)
forall a b. (a -> b) -> a -> b
$ \HttpException
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
$ [String] -> Errors -> String
trans (Session -> [String]
locale Session
session) (Errors -> String) -> Errors -> String
forall a b. (a -> b) -> a -> b
$ HttpException -> Errors
Http HttpException
e),
(ErrorCall -> IO (URI, String, Either Text ByteString))
-> Handler (URI, String, Either Text ByteString)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((ErrorCall -> IO (URI, String, Either Text ByteString))
-> Handler (URI, String, Either Text ByteString))
-> (ErrorCall -> IO (URI, String, Either Text ByteString))
-> Handler (URI, String, Either Text ByteString)
forall a b. (a -> b) -> a -> b
$ \(ErrorCall String
msg) -> 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
msg)
]
#endif
#ifdef WITH_GEMINI_URI
fetchURL' sess :: Session
sess@Session {connCtxt :: Session -> SSLContext
connCtxt = SSLContext
ctxt, locale :: Session -> [String]
locale = [String]
l} [String]
mimes uri :: URI
uri@URI {
uriScheme :: URI -> String
uriScheme = String
"gemini:", uriAuthority :: URI -> Maybe URIAuth
uriAuthority = Just (URIAuth String
_ String
host String
port)
} = SSLContext
-> String
-> PortNumber
-> (InputStream ByteString
-> OutputStream ByteString
-> SSL
-> IO (URI, String, Either Text ByteString))
-> IO (URI, String, Either Text ByteString)
forall a.
SSLContext
-> String
-> PortNumber
-> (InputStream ByteString
-> OutputStream ByteString -> SSL -> IO a)
-> IO a
TLSConn.withConnection SSLContext
ctxt String
host (PortNumber -> String -> PortNumber
forall p. Read p => p -> String -> p
parsePort PortNumber
1965 String
port) ((InputStream ByteString
-> OutputStream ByteString
-> SSL
-> IO (URI, String, Either Text ByteString))
-> IO (URI, String, Either Text ByteString))
-> (InputStream ByteString
-> OutputStream ByteString
-> SSL
-> IO (URI, String, Either Text ByteString))
-> IO (URI, String, Either Text ByteString)
forall a b. (a -> b) -> a -> b
$ \InputStream ByteString
input OutputStream ByteString
output SSL
_ -> do
OutputStream ByteString -> Maybe ByteString -> IO ()
forall a. OutputStream a -> Maybe a -> IO ()
writeTo OutputStream ByteString
output (Maybe ByteString -> IO ()) -> Maybe ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
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"
Handle
input' <- InputStream ByteString -> IO Handle
inputStreamToHandle InputStream ByteString
input
String
header <- Handle -> IO String
hGetLine Handle
input'
case String -> (Char, Char, Text)
parseHeader String
header of
(Char
'1', Char
_, Text
label) -> (URI, String, Either Text ByteString)
-> IO (URI, String, Either Text ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (URI
uri, String
"application/xhtml+xml", 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
$ [Text] -> Text
Txt.concat [
Text
"<form><label>",
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
label,
Text
"<input /></label></form>"
])
(Char
'2', Char
_, Text
mime) -> do
ByteString
body <- Handle -> IO ByteString
Strict.hGetContents Handle
input'
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 -> (URI, String, Either Text ByteString))
-> ByteString -> (URI, String, Either Text ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B.fromStrict 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
_, Char
_, 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
mimeERR, Text -> Either Text ByteString
forall a b. a -> Either a b
Left 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
_ = (Char
'4', Char
'1', String -> Text
Txt.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [String] -> Errors -> String
trans [String]
l Errors
MalformedResponse)
handleIOErr :: IOError -> IO Strict.ByteString
handleIOErr :: IOError -> IO ByteString
handleIOErr IOError
_ = ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
""
#endif
#ifdef WITH_FILE_URI
fetchURL' Session {locale :: Session -> [String]
locale = [String]
l} (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)
-> (IOError -> 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` \IOError
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
$ [String] -> Errors -> String
trans [String]
l (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
$ IOError -> String
forall e. Exception e => e -> String
displayException (IOError
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' Session {locale :: Session -> [String]
locale = [String]
l, 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
$ [String] -> Errors -> String
trans [String]
l (Errors -> String) -> Errors -> String
forall a b. (a -> b) -> a -> b
$ Errors
app)
#else
fetchURL' Session {locale = l} _ URI {uriScheme = scheme} =
return (uri, mimeERR, Left $ Txt.pack $ trans l $ UnsupportedScheme scheme)
#endif
dispatchByMIME :: Session -> String -> URI -> IO (Maybe String)
#if WITH_XDG
dispatchByMIME :: Session -> String -> URI -> IO (Maybe String)
dispatchByMIME Session {locale :: Session -> [String]
locale = [String]
l, 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
$ [String] -> Errors -> String
trans [String]
l Errors
err
#else
dispatchByMIME _ _ _ = return Nothing
#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 a. (Num a, Show a) => a -> IO String
go Integer
0 else String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
path
where
go :: a -> IO String
go a
n = do
let path' :: String
path' = String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n
Bool
exists <- String -> IO Bool
doesFileExist String
path'
if Bool
exists then a -> IO String
go (a
na -> a -> a
forall a. Num a => a -> a -> a
+a
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 ()
enableLogging :: Session -> IO ()
enableLogging Session
session = do
Bool
logInactive <- MVar [LogRecord] -> IO Bool
forall a. MVar a -> IO Bool
isEmptyMVar (MVar [LogRecord] -> IO Bool) -> MVar [LogRecord] -> IO Bool
forall a b. (a -> b) -> a -> b
$ Session -> MVar [LogRecord]
requestLog Session
session
if Bool
logInactive then MVar [LogRecord] -> [LogRecord] -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (Session -> MVar [LogRecord]
requestLog Session
session) [] else () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
retrieveLog :: Session -> IO [LogRecord]
retrieveLog :: Session -> IO [LogRecord]
retrieveLog Session
session = do
Bool
logInactive <- MVar [LogRecord] -> IO Bool
forall a. MVar a -> IO Bool
isEmptyMVar (MVar [LogRecord] -> IO Bool) -> MVar [LogRecord] -> IO Bool
forall a b. (a -> b) -> a -> b
$ Session -> MVar [LogRecord]
requestLog Session
session
if Bool
logInactive then [LogRecord] -> IO [LogRecord]
forall (m :: * -> *) a. Monad m => a -> m a
return [] else MVar [LogRecord] -> IO [LogRecord]
forall a. MVar a -> IO a
takeMVar (MVar [LogRecord] -> IO [LogRecord])
-> MVar [LogRecord] -> IO [LogRecord]
forall a b. (a -> b) -> a -> b
$ Session -> MVar [LogRecord]
requestLog Session
session
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"
#ifdef WITH_DATA_URI
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
_ [] = ([], [])
#endif