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