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