1{-# LANGUAGE ScopedTypeVariables #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE ViewPatterns #-}
4module Network.HTTP.Client.Connection
5    ( connectionReadLine
6    , connectionReadLineWith
7    , connectionDropTillBlankLine
8    , dummyConnection
9    , openSocketConnection
10    , openSocketConnectionSize
11    , makeConnection
12    , socketConnection
13    ) where
14
15import Data.ByteString (ByteString, empty)
16import Data.IORef
17import Control.Monad
18import Network.HTTP.Client.Types
19import Network.Socket (Socket, HostAddress)
20import qualified Network.Socket as NS
21import Network.Socket.ByteString (sendAll, recv)
22import qualified Control.Exception as E
23import qualified Data.ByteString as S
24import Data.Word (Word8)
25import Data.Function (fix)
26
27connectionReadLine :: Connection -> IO ByteString
28connectionReadLine conn = do
29    bs <- connectionRead conn
30    when (S.null bs) $ throwHttp IncompleteHeaders
31    connectionReadLineWith conn bs
32
33-- | Keep dropping input until a blank line is found.
34connectionDropTillBlankLine :: Connection -> IO ()
35connectionDropTillBlankLine conn = fix $ \loop -> do
36    bs <- connectionReadLine conn
37    unless (S.null bs) loop
38
39connectionReadLineWith :: Connection -> ByteString -> IO ByteString
40connectionReadLineWith conn bs0 =
41    go bs0 id 0
42  where
43    go bs front total =
44        case S.break (== charLF) bs of
45            (_, "") -> do
46                let total' = total + S.length bs
47                when (total' > 4096) $ throwHttp OverlongHeaders
48                bs' <- connectionRead conn
49                when (S.null bs') $ throwHttp IncompleteHeaders
50                go bs' (front . (bs:)) total'
51            (x, S.drop 1 -> y) -> do
52                unless (S.null y) $! connectionUnread conn y
53                return $! killCR $! S.concat $! front [x]
54
55charLF, charCR :: Word8
56charLF = 10
57charCR = 13
58
59killCR :: ByteString -> ByteString
60killCR bs
61    | S.null bs = bs
62    | S.last bs == charCR = S.init bs
63    | otherwise = bs
64
65-- | For testing
66dummyConnection :: [ByteString] -- ^ input
67                -> IO (Connection, IO [ByteString], IO [ByteString]) -- ^ conn, output, input
68dummyConnection input0 = do
69    iinput <- newIORef input0
70    ioutput <- newIORef []
71    return (Connection
72        { connectionRead = atomicModifyIORef iinput $ \input ->
73            case input of
74                [] -> ([], empty)
75                x:xs -> (xs, x)
76        , connectionUnread = \x -> atomicModifyIORef iinput $ \input -> (x:input, ())
77        , connectionWrite = \x -> atomicModifyIORef ioutput $ \output -> (output ++ [x], ())
78        , connectionClose = return ()
79        }, atomicModifyIORef ioutput $ \output -> ([], output), readIORef iinput)
80
81-- | Create a new 'Connection' from a read, write, and close function.
82--
83-- @since 0.5.3
84makeConnection :: IO ByteString -- ^ read
85               -> (ByteString -> IO ()) -- ^ write
86               -> IO () -- ^ close
87               -> IO Connection
88makeConnection r w c = do
89    istack <- newIORef []
90
91    -- it is necessary to make sure we never read from or write to
92    -- already closed connection.
93    closedVar <- newIORef False
94
95    let close = do
96          closed <- atomicModifyIORef closedVar (\closed -> (True, closed))
97          unless closed $
98            c
99
100    _ <- mkWeakIORef istack close
101    return $! Connection
102        { connectionRead = do
103            closed <- readIORef closedVar
104            when closed $ throwHttp ConnectionClosed
105            join $ atomicModifyIORef istack $ \stack ->
106              case stack of
107                  x:xs -> (xs, return x)
108                  [] -> ([], r)
109
110        , connectionUnread = \x -> do
111            closed <- readIORef closedVar
112            when closed $ throwHttp ConnectionClosed
113            atomicModifyIORef istack $ \stack -> (x:stack, ())
114
115        , connectionWrite = \x -> do
116            closed <- readIORef closedVar
117            when closed $ throwHttp ConnectionClosed
118            w x
119
120        , connectionClose = close
121        }
122
123-- | Create a new 'Connection' from a 'Socket'.
124--
125-- @since 0.5.3
126socketConnection :: Socket
127                 -> Int -- ^ chunk size
128                 -> IO Connection
129socketConnection socket chunksize = makeConnection
130    (recv socket chunksize)
131    (sendAll socket)
132    (NS.close socket)
133
134openSocketConnection :: (Socket -> IO ())
135                     -> Maybe HostAddress
136                     -> String -- ^ host
137                     -> Int -- ^ port
138                     -> IO Connection
139openSocketConnection f = openSocketConnectionSize f 8192
140
141openSocketConnectionSize :: (Socket -> IO ())
142                         -> Int -- ^ chunk size
143                         -> Maybe HostAddress
144                         -> String -- ^ host
145                         -> Int -- ^ port
146                         -> IO Connection
147openSocketConnectionSize tweakSocket chunksize hostAddress' host' port' = do
148    let hints = NS.defaultHints {
149                          NS.addrFlags = [NS.AI_ADDRCONFIG]
150                        , NS.addrSocketType = NS.Stream
151                        }
152    addrs <- case hostAddress' of
153        Nothing ->
154            NS.getAddrInfo (Just hints) (Just host') (Just $ show port')
155        Just ha ->
156            return
157                [NS.AddrInfo
158                 { NS.addrFlags = []
159                 , NS.addrFamily = NS.AF_INET
160                 , NS.addrSocketType = NS.Stream
161                 , NS.addrProtocol = 6 -- tcp
162                 , NS.addrAddress = NS.SockAddrInet (toEnum port') ha
163                 , NS.addrCanonName = Nothing
164                 }]
165
166    firstSuccessful addrs $ \addr ->
167        E.bracketOnError
168            (NS.socket (NS.addrFamily addr) (NS.addrSocketType addr)
169                       (NS.addrProtocol addr))
170            NS.close
171            (\sock -> do
172                NS.setSocketOption sock NS.NoDelay 1
173                tweakSocket sock
174                NS.connect sock (NS.addrAddress addr)
175                socketConnection sock chunksize)
176
177firstSuccessful :: [NS.AddrInfo] -> (NS.AddrInfo -> IO a) -> IO a
178firstSuccessful []     _  = error "getAddrInfo returned empty list"
179firstSuccessful (a:as) cb =
180    cb a `E.catch` \(e :: E.IOException) ->
181        case as of
182            [] -> E.throwIO e
183            _  -> firstSuccessful as cb
184