{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Retrieves documents for a URL, supporting multiple URL schemes that can be
-- disabled at build-time for reduced dependencies.
module Network.URI.Fetch(Session(locale, aboutPages, redirectCount), newSession,
    fetchURL, fetchURL', fetchURLs, mimeERR, htmlERR,
    dispatchByMIME, saveDownload, downloadToURI,
    -- logging API
    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)

-- for about: URIs & port parsing, all standard lib
import Data.Maybe (fromMaybe, listToMaybe)
import Text.Read (readMaybe)

-- for saveDownload
import System.Directory
import System.FilePath

-- for logging
import Control.Concurrent.MVar
import Data.Time.Clock
import System.IO
import Control.Monad
import Data.List as L

#ifdef WITH_HTTP_URI
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Client.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 shared accross multiple URI requests.
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
    -- | The languages (RFC2616-encoded) to which responses should be localized.
    Session -> [String]
locale :: [String],
    -- | Additional files to serve from about: URIs.
    Session -> [(String, ByteString)]
aboutPages :: [(FilePath, ByteString)],
    -- | Log of timestamped/profiled URL requests
    Session -> MVar [LogRecord]
requestLog :: MVar [LogRecord],
    -- | How many redirects to follow for Gemini or HTTP(S) requests
    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
  }

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

-- | Variant of `newSession` which loads plugins for the named app.
newSession' :: String -> IO Session
newSession' :: String -> IO Session
newSession' String
appname = do
    ([String]
ietfLocale, [String]
unixLocale) <- IO ([String], [String])
rfc2616Locale
#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 -- FIXME: Implement Trust-On-First-Use
#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

-- | Retrieves a URL-identified resource & it's MIMEtype, possibly decoding it's text.
fetchURL :: Session -- ^ The session of which this request is a part.
    -> [String] -- ^ The expected MIMEtypes in priority order.
    -> URI -- ^ The URL to retrieve
    -> IO (String, Either Text ByteString) -- ^ The MIMEtype & possibly text-decoded response.
fetchURL :: Session -> [String] -> URI -> IO (String, Either Text ByteString)
fetchURL Session
sess [String]
mimes URI
uri = do
    (URI
_, String
mime, Either Text ByteString
resp) <- Session
-> [String] -> URI -> IO (URI, String, Either Text ByteString)
fetchURL' Session
sess [String]
mimes URI
uri
    (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

-- | Concurrently fetch given URLs.
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

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

-- | As per `fetchURL`, but also returns the redirected URI.
fetchURL' :: Session -> [String] -> URI -> IO (URI, String, Either Text ByteString)
fetchURL' :: Session
-> [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, -- Will only be supported by Rhapsode when submitting a form.
            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
            -- NOTE: This case won't actually do anything until the caller (Rhapsode) implements forms.
            (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
"&lt;" (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Text
Txt.replace Text
"&" Text
"&amp;" 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
            -- TODO Implement client certificates, once I have a way for the user/caller to select one.
            --      And once I figure out how to configure the TLS cryptography.
            (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

-- Downloads utilities
-- | write download to a file in the given directory.
saveDownload :: URI -> FilePath -> (URI, String, Either Text ByteString) -> IO URI
saveDownload :: URI -> String -> (URI, String, Either Text ByteString) -> IO URI
saveDownload URI
baseURI String
dir (URI {uriPath :: URI -> String
uriPath = String
path}, String
mime, Either Text ByteString
resp) = do
    String
dest <- String -> IO String
unusedFilename (String
dir String -> String -> String
</> String -> String
takeFileName' String
path)
    case Either Text ByteString
resp of
        Left Text
txt -> String -> String -> IO ()
writeFile String
dest (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
    -- TODO set user.mime file attribute.
    URI -> IO URI
forall (m :: * -> *) a. Monad m => a -> m a
return (URI -> IO URI) -> URI -> IO URI
forall a b. (a -> b) -> a -> b
$ URI
baseURI {uriPath :: 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'

-- | Convert a download into a data: URI
downloadToURI :: (URI, String, Either Text ByteString) -> URI
downloadToURI :: (URI, String, Either Text ByteString) -> URI
downloadToURI (URI
_, String
mime, Left Text
txt) = URI
nullURI {
        uriScheme :: String
uriScheme = String
"data:",
        uriPath :: String
uriPath = String
mime 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)
    }

-- Logging API
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"

-- Utils

#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