~alcinnz/hurl

ref: 6370ab8a13697df679fb756e7906a4a6a400337e hurl/src/Network/URI/Fetch.hs -rw-r--r-- 5.0 KiB
6370ab8a — Adrian Cochrane Draft AppStream loading code. 4 years ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
{-# 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, newSession, fetchURL, dispatchByMIME) where

import qualified Data.Text as Txt
import           Data.Text (Text)
import           Network.URI
import           Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as B
import           Control.Exception

#ifdef WITH_HTTP_URI
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Client.TLS as TLS
import           Network.HTTP.Types
import           Network.URI.Charset
import           Data.List (intercalate)
#endif

#ifdef WITH_DATA_URI
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Base64 as B64
#endif

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

#ifdef WITH_XDG
import Network.URI.XDG
#endif

-- | Data shared accross multiple URI requests.
data Session = Session {
#ifdef WITH_HTTP_URI
    managerHTTP :: HTTP.Manager,
#endif
#ifdef WITH_XDG
    apps :: HandlersConfig,
#endif
    -- | The languages (RFC2616-encoded) to which responses should be localized.
    locale :: [String]
}

-- | Initializes a default Session object to support HTTPS & Accept-Language
-- if HTTP is enabled.
newSession :: IO Session
newSession = do
    locale' <- rfc2616Locale
#ifdef WITH_HTTP_URI
    managerHTTP' <- HTTP.newManager TLS.tlsManagerSettings
#endif
#ifdef WITH_XDG
    apps' <- loadHandlers
#endif

    return Session {
#ifdef WITH_HTTP_URI
        managerHTTP = managerHTTP',
#endif
#ifdef WITH_XDG
        apps = apps',
#endif
        locale = locale'
    }

-- | 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.
#ifdef WITH_HTTP_URI
fetchURL session accept@(defaultMIME:_) uri | uriScheme uri `elem` ["http:", "https:"] = do
    request <- HTTP.requestFromURI uri
    response <- HTTP.httpLbs request {
            HTTP.cookieJar = Nothing, -- Will only be supported by Rhapsode when submitting a form.
            HTTP.requestHeaders = [
                ("Accept", C8.pack $ intercalate ", " accept),
                ("Accept-Language", C8.pack $ intercalate ", " $ locale session)
            ]
        } $ managerHTTP session
    return $ case (
            HTTP.responseBody response,
            [val | ("content-type", val) <- HTTP.responseHeaders response]
      ) of
        ("", _) -> ("text/plain", Right $ B.fromStrict $ statusMessage $ HTTP.responseStatus response)
        (response, (mimetype:_)) -> let mime = Txt.toLower $ convertCharset "utf-8" mimetype
            in resolveCharset (map (Txt.unpack . Txt.strip) $ Txt.splitOn ";" $ mime) response
        (response, []) -> (defaultMIME, Right response)
  `catches` [
    Handler $ \e -> do return ("text/plain", Left $ Txt.pack $ trans (locale session) $ Http e),
    Handler $ \(ErrorCall msg) -> do return ("text/plain", Left $ Txt.pack msg)
  ]
#endif

#ifdef WITH_FILE_URI
fetchURL Session {locale = l} (defaultMIME:_) uri@URI {uriScheme = "file:"} = do
    response <- B.readFile $ uriPath uri
    return (defaultMIME, Right response)
  `catch` \e -> do
    return (
        "text/plain",
        Left $ Txt.pack $ trans l $ ReadFailed $ displayException (e :: IOException))
#endif

#ifdef WITH_DATA_URI
fetchURL _ (defaultMIME:_) uri@URI {uriScheme = "data:"} =
    let request = uriPath uri ++ uriQuery uri ++ uriFragment uri
    in case breakOn ',' $ unEscapeString request of
        ("", response) -> return (defaultMIME, Left $ Txt.pack response)
        (mime', response) | '4':'6':'e':'s':'a':'b':';':mime <- reverse mime' ->
            return $ case B64.decode $ C8.pack response of
                Left str -> ("text/plain", Left $ Txt.pack str)
                Right bytes -> (reverse mime, Right $ B.fromStrict bytes)
        (mime, response) -> return (mime, Left $ Txt.pack response)
#endif

#ifdef WITH_XDG
fetchURL Session {locale = l, apps = a} _ uri@(URI {uriScheme = s})
    | canDispatchMIME a ("x-scheme-handler/" ++ init s) = do
        app <- dispatchURIByMIME l a uri ("x-scheme-handler/" ++ init s)
        return (
            "text/plain",
            Left $ Txt.pack $ trans l $ case app of
                Just name -> OpenedWith name
                Nothing -> UnsupportedScheme s)
#endif

fetchURL Session {locale = l} _ URI {uriScheme = scheme} =
    return ("text/plain", Left $ Txt.pack $ trans l $ UnsupportedScheme scheme)

dispatchByMIME :: Session -> String -> URI -> IO (Maybe String)
#if WITH_XDG
dispatchByMIME Session {locale = l, apps = a} mime uri = dispatchURIByMIME l a uri mime
#else
dispatchByMIME _ _ _ = return Nothing
#endif

#ifdef WITH_DATA_URI
breakOn c (a:as) | c == a = ([], as)
    | otherwise = let (x, y) = breakOn c as in (a:x, y)
breakOn _ [] = ([], [])
#endif