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