1{-# LANGUAGE CPP #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE DeriveDataTypeable #-}
5-- | Support for making connections via the connection package and, in turn,
6-- the tls package suite.
7--
8-- Recommended reading: <https://haskell-lang.org/library/http-client>
9module Network.HTTP.Client.TLS
10    ( -- * Settings
11      tlsManagerSettings
12    , mkManagerSettings
13    , mkManagerSettingsContext
14    , newTlsManager
15    , newTlsManagerWith
16      -- * Digest authentication
17    , applyDigestAuth
18    , DigestAuthException (..)
19    , DigestAuthExceptionDetails (..)
20    , displayDigestAuthException
21      -- * Global manager
22    , getGlobalManager
23    , setGlobalManager
24    ) where
25
26import Control.Applicative ((<|>))
27import Control.Arrow (first)
28import System.Environment (getEnvironment)
29import Data.Default.Class
30import Network.HTTP.Client hiding (host, port)
31import Network.HTTP.Client.Internal hiding (host, port)
32import Control.Exception
33import qualified Network.Connection as NC
34import Network.Socket (HostAddress)
35import qualified Network.TLS as TLS
36import qualified Data.ByteString as S
37import Data.IORef (IORef, newIORef, readIORef, writeIORef)
38import System.IO.Unsafe (unsafePerformIO)
39import Control.Monad.IO.Class (MonadIO, liftIO)
40import Control.Monad (guard, unless)
41import qualified Data.CaseInsensitive as CI
42import Data.Maybe (fromMaybe, isJust)
43import Network.HTTP.Types (status401)
44import Crypto.Hash (hash, Digest, MD5)
45import Control.Arrow ((***))
46import Data.ByteArray.Encoding (convertToBase, Base (Base16))
47import Data.Typeable (Typeable)
48import Control.Monad.Catch (MonadThrow, throwM)
49import qualified Data.Map as Map
50import qualified Data.Text as T
51import Data.Text.Read (decimal)
52import qualified Network.URI as U
53
54-- | Create a TLS-enabled 'ManagerSettings' with the given 'NC.TLSSettings' and
55-- 'NC.SockSettings'
56mkManagerSettings :: NC.TLSSettings
57                  -> Maybe NC.SockSettings
58                  -> ManagerSettings
59mkManagerSettings = mkManagerSettingsContext Nothing
60
61-- | Same as 'mkManagerSettings', but also takes an optional
62-- 'NC.ConnectionContext'. Providing this externally can be an
63-- optimization, though that may change in the future. For more
64-- information, see:
65--
66-- <https://github.com/snoyberg/http-client/pull/227>
67--
68-- @since 0.3.2
69mkManagerSettingsContext
70    :: Maybe NC.ConnectionContext
71    -> NC.TLSSettings
72    -> Maybe NC.SockSettings
73    -> ManagerSettings
74mkManagerSettingsContext mcontext tls sock = mkManagerSettingsContext' defaultManagerSettings mcontext tls sock sock
75
76-- | Internal, allow different SockSettings for HTTP and HTTPS
77mkManagerSettingsContext'
78    :: ManagerSettings
79    -> Maybe NC.ConnectionContext
80    -> NC.TLSSettings
81    -> Maybe NC.SockSettings -- ^ insecure
82    -> Maybe NC.SockSettings -- ^ secure
83    -> ManagerSettings
84mkManagerSettingsContext' set mcontext tls sockHTTP sockHTTPS = set
85    { managerTlsConnection = getTlsConnection mcontext (Just tls) sockHTTPS
86    , managerTlsProxyConnection = getTlsProxyConnection mcontext tls sockHTTPS
87    , managerRawConnection =
88        case sockHTTP of
89            Nothing -> managerRawConnection defaultManagerSettings
90            Just _ -> getTlsConnection mcontext Nothing sockHTTP
91    , managerRetryableException = \e ->
92        case () of
93            ()
94                | ((fromException e)::(Maybe TLS.TLSError))==Just TLS.Error_EOF -> True
95                | otherwise -> managerRetryableException defaultManagerSettings e
96    , managerWrapException = \req ->
97        let wrapper se
98              | Just (_ :: IOException)          <- fromException se = se'
99              | Just (_ :: TLS.TLSException)     <- fromException se = se'
100              | Just (_ :: TLS.TLSError)         <- fromException se = se'
101              | Just (_ :: NC.LineTooLong)       <- fromException se = se'
102#if MIN_VERSION_connection(0,2,7)
103              | Just (_ :: NC.HostNotResolved)   <- fromException se = se'
104              | Just (_ :: NC.HostCannotConnect) <- fromException se = se'
105#endif
106              | otherwise = se
107              where
108                se' = toException $ HttpExceptionRequest req $ InternalException se
109         in handle $ throwIO . wrapper
110    }
111
112-- | Default TLS-enabled manager settings
113tlsManagerSettings :: ManagerSettings
114tlsManagerSettings = mkManagerSettings def Nothing
115
116getTlsConnection :: Maybe NC.ConnectionContext
117                 -> Maybe NC.TLSSettings
118                 -> Maybe NC.SockSettings
119                 -> IO (Maybe HostAddress -> String -> Int -> IO Connection)
120getTlsConnection mcontext tls sock = do
121    context <- maybe NC.initConnectionContext return mcontext
122    return $ \_ha host port -> bracketOnError
123        (NC.connectTo context NC.ConnectionParams
124            { NC.connectionHostname = host
125            , NC.connectionPort = fromIntegral port
126            , NC.connectionUseSecure = tls
127            , NC.connectionUseSocks = sock
128            })
129        NC.connectionClose
130        convertConnection
131
132getTlsProxyConnection
133    :: Maybe NC.ConnectionContext
134    -> NC.TLSSettings
135    -> Maybe NC.SockSettings
136    -> IO (S.ByteString -> (Connection -> IO ()) -> String -> Maybe HostAddress -> String -> Int -> IO Connection)
137getTlsProxyConnection mcontext tls sock = do
138    context <- maybe NC.initConnectionContext return mcontext
139    return $ \connstr checkConn serverName _ha host port -> bracketOnError
140        (NC.connectTo context NC.ConnectionParams
141            { NC.connectionHostname = serverName
142            , NC.connectionPort = fromIntegral port
143            , NC.connectionUseSecure = Nothing
144            , NC.connectionUseSocks =
145                case sock of
146                    Just _ -> error "Cannot use SOCKS and TLS proxying together"
147                    Nothing -> Just $ NC.OtherProxy host $ fromIntegral port
148            })
149        NC.connectionClose
150        $ \conn -> do
151            NC.connectionPut conn connstr
152            conn' <- convertConnection conn
153
154            checkConn conn'
155
156            NC.connectionSetSecure context conn tls
157
158            return conn'
159
160convertConnection :: NC.Connection -> IO Connection
161convertConnection conn = makeConnection
162    (NC.connectionGetChunk conn)
163    (NC.connectionPut conn)
164    -- Closing an SSL connection gracefully involves writing/reading
165    -- on the socket.  But when this is called the socket might be
166    -- already closed, and we get a @ResourceVanished@.
167    (NC.connectionClose conn `Control.Exception.catch` \(_ :: IOException) -> return ())
168
169-- We may decide in the future to just have a global
170-- ConnectionContext and use it directly in tlsManagerSettings, at
171-- which point this can again be a simple (newManager
172-- tlsManagerSettings >>= newIORef). See:
173-- https://github.com/snoyberg/http-client/pull/227.
174globalConnectionContext :: NC.ConnectionContext
175globalConnectionContext = unsafePerformIO NC.initConnectionContext
176{-# NOINLINE globalConnectionContext #-}
177
178-- | Load up a new TLS manager with default settings, respecting proxy
179-- environment variables.
180--
181-- @since 0.3.4
182newTlsManager :: MonadIO m => m Manager
183newTlsManager = liftIO $ do
184    env <- getEnvironment
185    let lenv = Map.fromList $ map (first $ T.toLower . T.pack) env
186        msocksHTTP = parseSocksSettings env lenv "http_proxy"
187        msocksHTTPS = parseSocksSettings env lenv "https_proxy"
188        settings = mkManagerSettingsContext' defaultManagerSettings (Just globalConnectionContext) def msocksHTTP msocksHTTPS
189        settings' = maybe id (const $ managerSetInsecureProxy proxyFromRequest) msocksHTTP
190                  $ maybe id (const $ managerSetSecureProxy proxyFromRequest) msocksHTTPS
191                    settings
192    newManager settings'
193
194-- | Load up a new TLS manager based upon specified settings,
195-- respecting proxy environment variables.
196--
197-- @since 0.3.5
198newTlsManagerWith :: MonadIO m => ManagerSettings -> m Manager
199newTlsManagerWith set = liftIO $ do
200    env <- getEnvironment
201    let lenv = Map.fromList $ map (first $ T.toLower . T.pack) env
202        msocksHTTP = parseSocksSettings env lenv "http_proxy"
203        msocksHTTPS = parseSocksSettings env lenv "https_proxy"
204        settings = mkManagerSettingsContext' set (Just globalConnectionContext) def msocksHTTP msocksHTTPS
205        settings' = maybe id (const $ managerSetInsecureProxy proxyFromRequest) msocksHTTP
206                  $ maybe id (const $ managerSetSecureProxy proxyFromRequest) msocksHTTPS
207                    settings
208                        -- We want to keep the original TLS settings that were
209                        -- passed in. Sadly they aren't available as a record
210                        -- field on `ManagerSettings`. So instead we grab the
211                        -- fields that depend on the TLS settings.
212                        -- https://github.com/snoyberg/http-client/issues/289
213                        { managerTlsConnection = managerTlsConnection set
214                        , managerTlsProxyConnection = managerTlsProxyConnection set
215                        }
216    newManager settings'
217
218parseSocksSettings :: [(String, String)] -- ^ original environment
219                   -> Map.Map T.Text String -- ^ lower-cased keys
220                   -> T.Text -- ^ env name
221                   -> Maybe NC.SockSettings
222parseSocksSettings env lenv n = do
223  str <- lookup (T.unpack n) env <|> Map.lookup n lenv
224  let allowedScheme x = x == "socks5:" || x == "socks5h:"
225  uri <- U.parseURI str
226
227  guard $ allowedScheme $ U.uriScheme uri
228  guard $ null (U.uriPath uri) || U.uriPath uri == "/"
229  guard $ null $ U.uriQuery uri
230  guard $ null $ U.uriFragment uri
231
232  auth <- U.uriAuthority uri
233  port' <-
234      case U.uriPort auth of
235          "" -> Nothing -- should we use some default?
236          ':':rest ->
237              case decimal $ T.pack rest of
238                  Right (p, "") -> Just p
239                  _ -> Nothing
240          _ -> Nothing
241
242  Just $ NC.SockSettingsSimple (U.uriRegName auth) port'
243
244-- | Evil global manager, to make life easier for the common use case
245globalManager :: IORef Manager
246globalManager = unsafePerformIO $ newTlsManager >>= newIORef
247{-# NOINLINE globalManager #-}
248
249-- | Get the current global 'Manager'
250--
251-- @since 0.2.4
252getGlobalManager :: IO Manager
253getGlobalManager = readIORef globalManager
254{-# INLINE getGlobalManager #-}
255
256-- | Set the current global 'Manager'
257--
258-- @since 0.2.4
259setGlobalManager :: Manager -> IO ()
260setGlobalManager = writeIORef globalManager
261
262-- | Generated by 'applyDigestAuth' when it is unable to apply the
263-- digest credentials to the request.
264--
265-- @since 0.3.3
266data DigestAuthException
267    = DigestAuthException Request (Response ()) DigestAuthExceptionDetails
268    deriving (Show, Typeable)
269instance Exception DigestAuthException where
270#if MIN_VERSION_base(4, 8, 0)
271    displayException = displayDigestAuthException
272#endif
273
274-- | User friendly display of a 'DigestAuthException'
275--
276-- @since 0.3.3
277displayDigestAuthException :: DigestAuthException -> String
278displayDigestAuthException (DigestAuthException req res det) = concat
279    [ "Unable to submit digest credentials due to: "
280    , details
281    , ".\n\nRequest: "
282    , show req
283    , ".\n\nResponse: "
284    , show res
285    ]
286  where
287    details =
288        case det of
289            UnexpectedStatusCode -> "received unexpected status code"
290            MissingWWWAuthenticateHeader ->
291                "missing WWW-Authenticate response header"
292            WWWAuthenticateIsNotDigest ->
293                "WWW-Authenticate response header does not indicate Digest"
294            MissingRealm ->
295                "WWW-Authenticate response header does include realm"
296            MissingNonce ->
297                "WWW-Authenticate response header does include nonce"
298
299-- | Detailed explanation for failure for 'DigestAuthException'
300--
301-- @since 0.3.3
302data DigestAuthExceptionDetails
303    = UnexpectedStatusCode
304    | MissingWWWAuthenticateHeader
305    | WWWAuthenticateIsNotDigest
306    | MissingRealm
307    | MissingNonce
308    deriving (Show, Read, Typeable, Eq, Ord)
309
310-- | Apply digest authentication to this request.
311--
312-- Note that this function will need to make an HTTP request to the
313-- server in order to get the nonce, thus the need for a @Manager@ and
314-- to live in @IO@. This also means that the request body will be sent
315-- to the server. If the request body in the supplied @Request@ can
316-- only be read once, you should replace it with a dummy value.
317--
318-- In the event of successfully generating a digest, this will return
319-- a @Just@ value. If there is any problem with generating the digest,
320-- it will return @Nothing@.
321--
322-- @since 0.3.1
323applyDigestAuth :: (MonadIO m, MonadThrow n)
324                => S.ByteString -- ^ username
325                -> S.ByteString -- ^ password
326                -> Request
327                -> Manager
328                -> m (n Request)
329applyDigestAuth user pass req0 man = liftIO $ do
330    res <- httpNoBody req man
331    let throw' = throwM . DigestAuthException req res
332    return $ do
333        unless (responseStatus res == status401)
334            $ throw' UnexpectedStatusCode
335        h1 <- maybe (throw' MissingWWWAuthenticateHeader) return
336            $ lookup "WWW-Authenticate" $ responseHeaders res
337        h2 <- maybe (throw' WWWAuthenticateIsNotDigest) return
338            $ stripCI "Digest " h1
339        let pieces = map (strip *** strip) (toPairs h2)
340        realm <- maybe (throw' MissingRealm) return
341               $ lookup "realm" pieces
342        nonce <- maybe (throw' MissingNonce) return
343               $ lookup "nonce" pieces
344        let qop = isJust $ lookup "qop" pieces
345            digest
346                | qop = md5 $ S.concat
347                    [ ha1
348                    , ":"
349                    , nonce
350                    , ":00000001:deadbeef:auth:"
351                    , ha2
352                    ]
353                | otherwise = md5 $ S.concat [ha1, ":", nonce, ":", ha2]
354              where
355                ha1 = md5 $ S.concat [user, ":", realm, ":", pass]
356
357                -- we always use no qop or qop=auth
358                ha2 = md5 $ S.concat [method req, ":", path req]
359
360                md5 bs = convertToBase Base16 (hash bs :: Digest MD5)
361            key = "Authorization"
362            val = S.concat
363                [ "Digest username=\""
364                , user
365                , "\", realm=\""
366                , realm
367                , "\", nonce=\""
368                , nonce
369                , "\", uri=\""
370                , path req
371                , "\", response=\""
372                , digest
373                , "\""
374                -- FIXME algorithm?
375                , case lookup "opaque" pieces of
376                    Nothing -> ""
377                    Just o -> S.concat [", opaque=\"", o, "\""]
378                , if qop
379                    then ", qop=auth, nc=00000001, cnonce=\"deadbeef\""
380                    else ""
381                ]
382        return req
383            { requestHeaders = (key, val)
384                             : filter
385                                    (\(x, _) -> x /= key)
386                                    (requestHeaders req)
387            , cookieJar = Just $ responseCookieJar res
388            }
389  where
390    -- Since we're expecting a non-200 response, ensure we do not
391    -- throw exceptions for such responses.
392    req = req0 { checkResponse = \_ _ -> return () }
393
394    stripCI x y
395        | CI.mk x == CI.mk (S.take len y) = Just $ S.drop len y
396        | otherwise = Nothing
397      where
398        len = S.length x
399
400    _comma = 44
401    _equal = 61
402    _dquot = 34
403    _space = 32
404
405    strip = fst . S.spanEnd (== _space) . S.dropWhile (== _space)
406
407    toPairs bs0
408        | S.null bs0 = []
409        | otherwise =
410            let bs1 = S.dropWhile (== _space) bs0
411                (key, bs2) = S.break (\w -> w == _equal || w == _comma) bs1
412             in case () of
413                  ()
414                    | S.null bs2 -> [(key, "")]
415                    | S.head bs2 == _equal ->
416                        let (val, rest) = parseVal $ S.tail bs2
417                         in (key, val) : toPairs rest
418                    | otherwise ->
419                        assert (S.head bs2 == _comma) $
420                        (key, "") : toPairs (S.tail bs2)
421
422    parseVal bs0 = fromMaybe (parseUnquoted bs0) $ do
423        guard $ not $ S.null bs0
424        guard $ S.head bs0 == _dquot
425        let (x, y) = S.break (== _dquot) $ S.tail bs0
426        guard $ not $ S.null y
427        Just (x, S.drop 1 $ S.dropWhile (/= _comma) y)
428
429    parseUnquoted bs =
430        let (x, y) = S.break (== _comma) bs
431         in (x, S.drop 1 y)
432