1{-# LANGUAGE OverloadedStrings #-} 2{-# LANGUAGE RankNTypes #-} 3{-# LANGUAGE ScopedTypeVariables #-} 4module Network.HTTP.Client.Manager 5 ( ManagerSettings (..) 6 , newManager 7 , closeManager 8 , withManager 9 , getConn 10 , defaultManagerSettings 11 , rawConnectionModifySocket 12 , rawConnectionModifySocketSize 13 , proxyFromRequest 14 , noProxy 15 , useProxy 16 , proxyEnvironment 17 , proxyEnvironmentNamed 18 , defaultProxy 19 , dropProxyAuthSecure 20 ) where 21 22import qualified Data.ByteString.Char8 as S8 23 24import Data.Text (Text) 25 26import Control.Monad (unless) 27import Control.Exception (throwIO, fromException, IOException, Exception (..), handle) 28 29import qualified Network.Socket as NS 30 31import Network.HTTP.Types (status200) 32import Network.HTTP.Client.Types 33import Network.HTTP.Client.Connection 34import Network.HTTP.Client.Headers (parseStatusHeaders) 35import Network.HTTP.Proxy 36import Data.KeyedPool 37import Data.Maybe (isJust) 38 39-- | A value for the @managerRawConnection@ setting, but also allows you to 40-- modify the underlying @Socket@ to set additional settings. For a motivating 41-- use case, see: <https://github.com/snoyberg/http-client/issues/71>. 42-- 43-- Since 0.3.8 44rawConnectionModifySocket :: (NS.Socket -> IO ()) 45 -> IO (Maybe NS.HostAddress -> String -> Int -> IO Connection) 46rawConnectionModifySocket = return . openSocketConnection 47 48-- | Same as @rawConnectionModifySocket@, but also takes in a chunk size. 49-- 50-- @since 0.5.2 51rawConnectionModifySocketSize :: (NS.Socket -> IO ()) 52 -> IO (Int -> Maybe NS.HostAddress -> String -> Int -> IO Connection) 53rawConnectionModifySocketSize = return . openSocketConnectionSize 54 55 56-- | Default value for @ManagerSettings@. 57-- 58-- Note that this value does /not/ have support for SSL/TLS. If you need to 59-- make any https connections, please use the http-client-tls package, which 60-- provides a @tlsManagerSettings@ value. 61-- 62-- Since 0.1.0 63defaultManagerSettings :: ManagerSettings 64defaultManagerSettings = ManagerSettings 65 { managerConnCount = 10 66 , managerRawConnection = return $ openSocketConnection (const $ return ()) 67 , managerTlsConnection = return $ \_ _ _ -> throwHttp TlsNotSupported 68 , managerTlsProxyConnection = return $ \_ _ _ _ _ _ -> throwHttp TlsNotSupported 69 , managerResponseTimeout = ResponseTimeoutDefault 70 , managerRetryableException = \e -> 71 case fromException e of 72 Just (_ :: IOException) -> True 73 _ -> 74 case fmap unHttpExceptionContentWrapper $ fromException e of 75 -- Note: Some servers will timeout connections by accepting 76 -- the incoming packets for the new request, but closing 77 -- the connection as soon as we try to read. To make sure 78 -- we open a new connection under these circumstances, we 79 -- check for the NoResponseDataReceived exception. 80 Just NoResponseDataReceived -> True 81 Just IncompleteHeaders -> True 82 _ -> False 83 , managerWrapException = \_req -> 84 let wrapper se = 85 case fromException se of 86 Just (_ :: IOException) -> throwHttp $ InternalException se 87 Nothing -> throwIO se 88 in handle wrapper 89 , managerIdleConnectionCount = 512 90 , managerModifyRequest = return 91 , managerModifyResponse = return 92 , managerProxyInsecure = defaultProxy 93 , managerProxySecure = defaultProxy 94 } 95 96-- | Create a 'Manager'. The @Manager@ will be shut down automatically via 97-- garbage collection. 98-- 99-- Creating a new 'Manager' is a relatively expensive operation, you are 100-- advised to share a single 'Manager' between requests instead. 101-- 102-- The first argument to this function is often 'defaultManagerSettings', 103-- though add-on libraries may provide a recommended replacement. 104-- 105-- Since 0.1.0 106newManager :: ManagerSettings -> IO Manager 107newManager ms = do 108 NS.withSocketsDo $ return () 109 110 httpProxy <- runProxyOverride (managerProxyInsecure ms) False 111 httpsProxy <- runProxyOverride (managerProxySecure ms) True 112 113 createConnection <- mkCreateConnection ms 114 115 keyedPool <- createKeyedPool 116 createConnection 117 connectionClose 118 (managerConnCount ms) 119 (managerIdleConnectionCount ms) 120 (const (return ())) -- could allow something in ManagerSettings to handle exceptions more nicely 121 122 let manager = Manager 123 { mConns = keyedPool 124 , mResponseTimeout = managerResponseTimeout ms 125 , mRetryableException = managerRetryableException ms 126 , mWrapException = managerWrapException ms 127 , mModifyRequest = managerModifyRequest ms 128 , mModifyResponse = managerModifyResponse ms 129 , mSetProxy = \req -> 130 if secure req 131 then httpsProxy req 132 else httpProxy req 133 } 134 return manager 135 136 {- FIXME why isn't this being used anymore? 137 flushStaleCerts now = 138 Map.fromList . mapMaybe flushStaleCerts' . Map.toList 139 where 140 flushStaleCerts' (host', inner) = 141 case mapMaybe flushStaleCerts'' $ Map.toList inner of 142 [] -> Nothing 143 pairs -> 144 let x = take 10 pairs 145 in x `seqPairs` Just (host', Map.fromList x) 146 flushStaleCerts'' (certs, expires) 147 | expires > now = Just (certs, expires) 148 | otherwise = Nothing 149 150 seqPairs :: [(L.ByteString, UTCTime)] -> b -> b 151 seqPairs [] b = b 152 seqPairs (p:ps) b = p `seqPair` ps `seqPairs` b 153 154 seqPair :: (L.ByteString, UTCTime) -> b -> b 155 seqPair (lbs, utc) b = lbs `seqLBS` utc `seqUTC` b 156 157 seqLBS :: L.ByteString -> b -> b 158 seqLBS lbs b = L.length lbs `seq` b 159 160 seqUTC :: UTCTime -> b -> b 161 seqUTC (UTCTime day dt) b = day `seqDay` dt `seqDT` b 162 163 seqDay :: Day -> b -> b 164 seqDay (ModifiedJulianDay i) b = i `deepseq` b 165 166 seqDT :: DiffTime -> b -> b 167 seqDT = seq 168 -} 169 170-- | Close all connections in a 'Manager'. 171-- 172-- Note that this doesn't affect currently in-flight connections, 173-- meaning you can safely use it without hurting any queries you may 174-- have concurrently running. 175-- 176-- Since 0.1.0 177closeManager :: Manager -> IO () 178closeManager _ = return () 179{-# DEPRECATED closeManager "Manager will be closed for you automatically when no longer in use" #-} 180 181-- | Create, use and close a 'Manager'. 182-- 183-- Since 0.2.1 184withManager :: ManagerSettings -> (Manager -> IO a) -> IO a 185withManager settings f = newManager settings >>= f 186{-# DEPRECATED withManager "Use newManager instead" #-} 187 188-- | Drop the Proxy-Authorization header from the request if we're using a 189-- secure proxy. 190dropProxyAuthSecure :: Request -> Request 191dropProxyAuthSecure req 192 | secure req && useProxy' = req 193 { requestHeaders = filter (\(k, _) -> k /= "Proxy-Authorization") 194 (requestHeaders req) 195 } 196 | otherwise = req 197 where 198 useProxy' = isJust (proxy req) 199 200getConn :: Request 201 -> Manager 202 -> IO (Managed Connection) 203getConn req m 204 -- Stop Mac OS X from getting high: 205 -- https://github.com/snoyberg/http-client/issues/40#issuecomment-39117909 206 | S8.null h = throwHttp $ InvalidDestinationHost h 207 | otherwise = takeKeyedPool (mConns m) connkey 208 where 209 h = host req 210 connkey = connKey req 211 212connKey :: Request -> ConnKey 213connKey req = 214 case proxy req of 215 Nothing 216 | secure req -> simple CKSecure 217 | otherwise -> simple CKRaw 218 Just p 219 | secure req -> CKProxy 220 (proxyHost p) 221 (proxyPort p) 222 (lookup "Proxy-Authorization" (requestHeaders req)) 223 (host req) 224 (port req) 225 | otherwise -> CKRaw Nothing (proxyHost p) (proxyPort p) 226 where 227 simple con = con (hostAddress req) (host req) (port req) 228 229mkCreateConnection :: ManagerSettings -> IO (ConnKey -> IO Connection) 230mkCreateConnection ms = do 231 rawConnection <- managerRawConnection ms 232 tlsConnection <- managerTlsConnection ms 233 tlsProxyConnection <- managerTlsProxyConnection ms 234 235 return $ \ck -> wrapConnectExc $ case ck of 236 CKRaw connaddr connhost connport -> 237 rawConnection connaddr (S8.unpack connhost) connport 238 CKSecure connaddr connhost connport -> 239 tlsConnection connaddr (S8.unpack connhost) connport 240 CKProxy connhost connport mProxyAuthHeader ultHost ultPort -> 241 let proxyAuthorizationHeader = maybe 242 "" 243 (\h' -> S8.concat ["Proxy-Authorization: ", h', "\r\n"]) 244 mProxyAuthHeader 245 hostHeader = S8.concat ["Host: ", ultHost, ":", (S8.pack $ show ultPort), "\r\n"] 246 connstr = S8.concat 247 [ "CONNECT " 248 , ultHost 249 , ":" 250 , S8.pack $ show ultPort 251 , " HTTP/1.1\r\n" 252 , proxyAuthorizationHeader 253 , hostHeader 254 , "\r\n" 255 ] 256 parse conn = do 257 StatusHeaders status _ _ <- parseStatusHeaders conn Nothing Nothing 258 unless (status == status200) $ 259 throwHttp $ ProxyConnectException ultHost ultPort status 260 in tlsProxyConnection 261 connstr 262 parse 263 (S8.unpack ultHost) 264 Nothing -- we never have a HostAddress we can use 265 (S8.unpack connhost) 266 connport 267 where 268 wrapConnectExc = handle $ \e -> 269 throwHttp $ ConnectionFailure (toException (e :: IOException)) 270 271-- | Get the proxy settings from the @Request@ itself. 272-- 273-- Since 0.4.7 274proxyFromRequest :: ProxyOverride 275proxyFromRequest = ProxyOverride $ const $ return id 276 277-- | Never connect using a proxy, regardless of the proxy value in the @Request@. 278-- 279-- Since 0.4.7 280noProxy :: ProxyOverride 281noProxy = ProxyOverride $ const $ return $ \req -> req { proxy = Nothing } 282 283-- | Use the given proxy settings, regardless of the proxy value in the @Request@. 284-- 285-- Since 0.4.7 286useProxy :: Proxy -> ProxyOverride 287useProxy p = ProxyOverride $ const $ return $ \req -> req { proxy = Just p } 288 289-- | Get the proxy settings from the default environment variable (@http_proxy@ 290-- for insecure, @https_proxy@ for secure). If no variable is set, then fall 291-- back to the given value. @Nothing@ is equivalent to 'noProxy', @Just@ is 292-- equivalent to 'useProxy'. 293-- 294-- Since 0.4.7 295proxyEnvironment :: Maybe Proxy -- ^ fallback if no environment set 296 -> ProxyOverride 297proxyEnvironment mp = ProxyOverride $ \secure' -> 298 systemProxyHelper Nothing (httpProtocol secure') $ maybe EHNoProxy EHUseProxy mp 299 300-- | Same as 'proxyEnvironment', but instead of default environment variable 301-- names, allows you to set your own name. 302-- 303-- Since 0.4.7 304proxyEnvironmentNamed 305 :: Text -- ^ environment variable name 306 -> Maybe Proxy -- ^ fallback if no environment set 307 -> ProxyOverride 308proxyEnvironmentNamed name mp = ProxyOverride $ \secure' -> 309 systemProxyHelper (Just name) (httpProtocol secure') $ maybe EHNoProxy EHUseProxy mp 310 311-- | The default proxy settings for a manager. In particular: if the @http_proxy@ (or @https_proxy@) environment variable is set, use it. Otherwise, use the values in the @Request@. 312-- 313-- Since 0.4.7 314defaultProxy :: ProxyOverride 315defaultProxy = ProxyOverride $ \secure' -> 316 systemProxyHelper Nothing (httpProtocol secure') EHFromRequest 317