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