direct-http 0.5.3 → 0.6
raw patch · 2 files changed
+281/−235 lines, 2 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Network.HTTP: instance Show ResponseContentParameters
Files
- Network/HTTP.hs +277/−234
- direct-http.cabal +4/−1
Network/HTTP.hs view
@@ -216,6 +216,7 @@ | ResponseContentBufferedIdentity | ResponseContentUnbufferedIdentity Int | ResponseContentChunked+ deriving (Show) -- | An object representing a cookie (a small piece of information, mostly@@ -290,18 +291,17 @@ state <- getHTTPState let mvar = httpStateThreadSetMVar state msem = httpStateThreadTerminationMSem state- threadSet <- takeMVar mvar- childThread <- liftBaseDiscard (httpStateForkPrimitive state)- $ finally action- (do- threadSet <- takeMVar mvar- self <- myThreadId- let threadSet' = Set.delete self threadSet'- putMVar mvar threadSet'- liftBase $ MSem.signal msem)- let threadSet' = Set.insert childThread threadSet- putMVar mvar threadSet'- return childThread+ modifyMVar mvar $ \threadSet -> do+ childThread <- liftBaseDiscard (httpStateForkPrimitive state)+ $ finally action+ (do+ modifyMVar_ mvar $ \threadSet -> do+ self <- myThreadId+ let threadSet' = Set.delete self threadSet'+ return threadSet'+ liftBase $ MSem.signal msem)+ let threadSet' = Set.insert childThread threadSet+ return (threadSet', childThread) -- | A record used to configure the server. Broken informally into the four@@ -641,13 +641,31 @@ let getHeadersValid = do connection <- getHTTPConnection headerMap <- readMVar $ httpConnectionRequestHeaderMap connection- return $ all (\header -> (isValidInRequest header)- && (hasContent- || (not $ isValidOnlyWithEntity header)))- $ Map.keys headerMap+ foldM (\result header -> do+ if isValidInRequest header+ then return result+ else do+ if hasContent+ then return result+ else if not $ isValidOnlyWithEntity header+ then return result+ else do+ httpLog $ "Header " ++ (show header)+ ++ " is valid only with an entity."+ return False)+ True+ (Map.keys headerMap) getContentValid = do contentAllowed <- getRequestContentAllowed- return $ contentAllowed || not hasContent+ if contentAllowed+ then return True+ else if not hasContent+ then return True+ else do+ method <- getRequestMethod+ httpLog $ "Content provided but not allowed with "+ ++ method ++ "."+ return False httpVersion <- getRequestProtocol case httpVersion of "HTTP/1.0" -> do@@ -660,8 +678,10 @@ mandatoryHeadersIncluded <- do maybeHost <- getRequestHeader HttpHost case maybeHost of- Nothing -> return False- Just host -> return True+ Just _ -> return True+ Nothing -> do+ httpLog $ "Host header not provided and HTTP/1.1 used."+ return False return $ and [headersValid, mandatoryHeadersIncluded, contentValid] _ -> return False @@ -882,57 +902,56 @@ recvHeaders = do HTTPConnection { httpConnectionInputBufferMVar = inputBufferMVar } <- getHTTPConnection- inputBuffer <- takeMVar inputBufferMVar- (inputBuffer, maybeLine) <- recvLine inputBuffer- (inputBuffer, result) <- case maybeLine of- Nothing -> return (inputBuffer, Nothing)- Just line -> do- let computeWords input =- let (before, after) = BS.breakSubstring (UTF8.fromString " ") input- in if BS.null after- then [before]- else let rest = computeWords $ BS.drop 1 after- in before : rest- words = computeWords line- case words of- [method, url, protocol]- | (isValidMethod method)- && (isValidURL url)- && (isValidProtocol protocol)- -> do- let loop inputBuffer headersSoFar = do- (inputBuffer, maybeLine) <- recvLine inputBuffer- case maybeLine of- Nothing -> return (inputBuffer, Nothing)- Just line- | BS.null line -> do- return (inputBuffer,- Just (method, url, protocol, headersSoFar))- | otherwise -> do- case parseHeader line of- Nothing -> do- logInvalidRequest- return (inputBuffer, Nothing)- Just (header, value) -> do- let headersSoFar'- = case Map.lookup header headersSoFar of- Nothing -> Map.insert header- value- headersSoFar- Just oldValue- -> Map.insert- header- (BS.concat [oldValue,- (UTF8.fromString ","),- value])- headersSoFar- loop inputBuffer headersSoFar'- loop inputBuffer Map.empty- _ -> do- logInvalidRequest- return (inputBuffer, Nothing)- putMVar inputBufferMVar inputBuffer- return result+ modifyMVar inputBufferMVar $ \inputBuffer -> do+ (inputBuffer, maybeLine) <- recvLine inputBuffer+ (inputBuffer, result) <- case maybeLine of+ Nothing -> return (inputBuffer, Nothing)+ Just line -> do+ let computeWords input =+ let (before, after) = BS.breakSubstring (UTF8.fromString " ") input+ in if BS.null after+ then [before]+ else let rest = computeWords $ BS.drop 1 after+ in before : rest+ words = computeWords line+ case words of+ [method, url, protocol]+ | (isValidMethod method)+ && (isValidURL url)+ && (isValidProtocol protocol)+ -> do+ let loop inputBuffer headersSoFar = do+ (inputBuffer, maybeLine) <- recvLine inputBuffer+ case maybeLine of+ Nothing -> return (inputBuffer, Nothing)+ Just line+ | BS.null line -> do+ return (inputBuffer,+ Just (method, url, protocol, headersSoFar))+ | otherwise -> do+ case parseHeader line of+ Nothing -> do+ logInvalidRequest+ return (inputBuffer, Nothing)+ Just (header, value) -> do+ let headersSoFar'+ = case Map.lookup header headersSoFar of+ Nothing -> Map.insert header+ value+ headersSoFar+ Just oldValue+ -> Map.insert+ header+ (BS.concat [oldValue,+ (UTF8.fromString ","),+ value])+ headersSoFar+ loop inputBuffer headersSoFar'+ loop inputBuffer Map.empty+ _ -> do+ logInvalidRequest+ return (inputBuffer, Nothing)+ return (inputBuffer, result) parseHeader :: ByteString -> Maybe (Header, ByteString)@@ -996,13 +1015,12 @@ recvBlock :: (MonadHTTP m) => Int -> m ByteString recvBlock length = do- HTTPConnection { httpConnectionInputBufferMVar = inputBufferMVar } <- getHTTPConnection- inputBuffer <- takeMVar inputBufferMVar- (inputBuffer, endOfInput)- <- extendInputBuffer inputBuffer length True- (result, inputBuffer) <- return $ BS.splitAt length inputBuffer- putMVar inputBufferMVar inputBuffer- return result+ HTTPConnection { httpConnectionInputBufferMVar = inputBufferMVar } <-+ getHTTPConnection+ modifyMVar inputBufferMVar $ \inputBuffer -> do+ (inputBuffer, endOfInput) <- extendInputBuffer inputBuffer length True+ (result, inputBuffer) <- return $ BS.splitAt length inputBuffer+ return (inputBuffer, result) extendInputBuffer :: (MonadHTTP m)@@ -1384,21 +1402,19 @@ getRequestCookieMap = do connection <- getHTTPConnection let mvar = httpConnectionRequestCookieMap connection- maybeCookieMap <- takeMVar mvar- case maybeCookieMap of- Just cookieMap -> do- putMVar mvar maybeCookieMap- return cookieMap- Nothing -> do- maybeCookieString <- getRequestHeader HttpCookie- let cookieMap =- case maybeCookieString of- Nothing -> Map.empty- Just cookieString ->- Map.fromList (map (\cookie -> (cookieName cookie, cookie))- (parseCookies cookieString))- putMVar mvar (Just cookieMap)- return cookieMap+ modifyMVar mvar $ \maybeCookieMap -> do+ case maybeCookieMap of+ Just cookieMap -> do+ return (maybeCookieMap, cookieMap)+ Nothing -> do+ maybeCookieString <- getRequestHeader HttpCookie+ let cookieMap =+ case maybeCookieString of+ Nothing -> Map.empty+ Just cookieString ->+ Map.fromList (map (\cookie -> (cookieName cookie, cookie))+ (parseCookies cookieString))+ return (Just cookieMap, cookieMap) -- | Return the remote address, which includes both host and port information.@@ -1491,12 +1507,12 @@ getRequestHasContent = do HTTPConnection { httpConnectionRequestContentParameters = parametersMVar } <- getHTTPConnection- parameters <- takeMVar parametersMVar- parameters <- ensureRequestContentParametersInitialized parameters- putMVar parametersMVar parameters- return $ case parameters of- RequestContentNone -> False- _ -> True+ modifyMVar parametersMVar $ \parameters -> do+ parameters <- ensureRequestContentParametersInitialized parameters+ let result = case parameters of+ RequestContentNone -> False+ _ -> True+ return (parameters, result) getRequestContentAllowed :: (MonadHTTP m) => m Bool@@ -1547,13 +1563,13 @@ httpIsReadable = do HTTPConnection { httpConnectionRequestContentParameters = parametersMVar } <- getHTTPConnection- parameters <- takeMVar parametersMVar- parameters <- ensureRequestContentParametersInitialized parameters- putMVar parametersMVar parameters- return $ case parameters of- RequestContentNone -> False- RequestContentClosed -> False- _ -> True+ modifyMVar parametersMVar $ \parameters -> do+ parameters <- ensureRequestContentParametersInitialized parameters+ let result = case parameters of+ RequestContentNone -> False+ RequestContentClosed -> False+ _ -> True+ return (parameters, result) httpGet' :: (MonadHTTP m) => (Maybe Int) -> Bool -> Bool -> m BS.ByteString@@ -1561,21 +1577,14 @@ if not discarding then requireOutputNotYetClosed else return ()- HTTPConnection {- httpConnectionRequestContentBuffer = bufferMVar,- httpConnectionRequestContentParameters = parametersMVar- } <- getHTTPConnection- buffer <- takeMVar bufferMVar- parameters <- takeMVar parametersMVar- parameters <- ensureRequestContentParametersInitialized parameters- (buffer, parameters)- <- extendRequestContentBuffer buffer parameters maybeSize blocking- (result, buffer) <- return $ case maybeSize of- Nothing -> (buffer, BS.empty)- Just size -> BS.splitAt size buffer- putMVar parametersMVar parameters- putMVar bufferMVar buffer- return result+ modifyRequest $ \buffer parameters -> do+ parameters <- ensureRequestContentParametersInitialized parameters+ (buffer, parameters)+ <- extendRequestContentBuffer buffer parameters maybeSize blocking+ (result, buffer) <- return $ case maybeSize of+ Nothing -> (buffer, BS.empty)+ Just size -> BS.splitAt size buffer+ return (buffer, parameters, result) ensureRequestContentParametersInitialized@@ -1653,11 +1662,10 @@ -- TODO IAK HTTPConnection { httpConnectionInputBufferMVar = lowLevelBufferMVar } <- getHTTPConnection- lowLevelBuffer <- takeMVar lowLevelBufferMVar- (highLevelBuffer, lowLevelBuffer, parameters)- <- loop highLevelBuffer lowLevelBuffer parameters- putMVar lowLevelBufferMVar lowLevelBuffer- return (highLevelBuffer, parameters)+ modifyMVar lowLevelBufferMVar $ \lowLevelBuffer -> do+ (highLevelBuffer, lowLevelBuffer, parameters)+ <- loop highLevelBuffer lowLevelBuffer parameters+ return (lowLevelBuffer, (highLevelBuffer, parameters)) -- | Sets the response status which will be sent with the response headers. If@@ -1718,9 +1726,9 @@ then do connection <- getHTTPConnection let mvar = httpConnectionResponseHeaderMap connection- headerMap <- takeMVar mvar- let headerMap' = Map.insert header (UTF8.fromString value) headerMap- putMVar mvar headerMap'+ modifyMVar_ mvar $ \headerMap -> do+ let headerMap' = Map.insert header (UTF8.fromString value) headerMap+ return headerMap' else throwIO $ NotAResponseHeader header @@ -1745,9 +1753,9 @@ if isValidInResponse header then do HTTPConnection { httpConnectionResponseHeaderMap = mvar } <- getHTTPConnection- headerMap <- takeMVar mvar- headerMap <- return $ Map.delete header headerMap- putMVar mvar headerMap+ modifyMVar_ mvar $ \headerMap -> do+ headerMap <- return $ Map.delete header headerMap+ return headerMap else throwIO $ NotAResponseHeader header @@ -1789,10 +1797,10 @@ requireValidCookieName $ cookieName cookie connection <- getHTTPConnection let mvar = httpConnectionResponseCookieMap connection- responseCookieMap <- takeMVar mvar- let responseCookieMap' =- Map.insert (cookieName cookie) cookie responseCookieMap- putMVar mvar responseCookieMap'+ modifyMVar_ mvar $ \responseCookieMap -> do+ let responseCookieMap' =+ Map.insert (cookieName cookie) cookie responseCookieMap+ return responseCookieMap' -- | Causes the user agent to unset any cookie applicable to this page with the@@ -1814,10 +1822,10 @@ requireValidCookieName name connection <- getHTTPConnection let mvar = httpConnectionResponseCookieMap connection- responseCookieMap <- takeMVar mvar- let responseCookieMap' =- Map.insert name (mkUnsetCookie name) responseCookieMap- putMVar mvar responseCookieMap'+ modifyMVar_ mvar $ \responseCookieMap -> do+ let responseCookieMap' =+ Map.insert name (mkUnsetCookie name) responseCookieMap+ return responseCookieMap' -- | Constructs a cookie with the given name and value. Version is set to 1;@@ -1968,22 +1976,23 @@ modifiableMVar = httpConnectionResponseHeadersModifiable connection parametersMVar = httpConnectionResponseContentParameters connection bufferMVar = httpConnectionResponseContentBuffer connection- parameters <- takeMVar parametersMVar- parameters <- ensureResponseContentParametersInitialized parameters- putMVar parametersMVar parameters- alreadySent <- takeMVar alreadySentMVar- if not alreadySent- then do- _ <- swapMVar modifiableMVar False- case parameters of- ResponseContentBufferedIdentity -> do- buffer <- readMVar bufferMVar- setResponseHeader' HttpContentLength (show $ BS.length buffer)- _ -> do- headersBuffer <- getHeadersBuffer- send headersBuffer- else return ()- putMVar alreadySentMVar True+ parameters <-+ modifyMVar parametersMVar $ \parameters -> do+ parameters <- ensureResponseContentParametersInitialized parameters+ return (parameters, parameters)+ modifyMVar_ alreadySentMVar $ \alreadySent -> do+ if not alreadySent+ then do+ _ <- swapMVar modifiableMVar False+ case parameters of+ ResponseContentBufferedIdentity -> do+ buffer <- readMVar bufferMVar+ setResponseHeader' HttpContentLength (show $ BS.length buffer)+ _ -> do+ headersBuffer <- getHeadersBuffer+ send headersBuffer+ else return ()+ return True getHeadersBuffer :: (MonadHTTP m) => m ByteString@@ -2138,53 +2147,54 @@ requireOutputNotYetClosed markResponseHeadersUnmodifiable connection <- getHTTPConnection- let bufferMVar = httpConnectionResponseContentBuffer connection- parametersMVar = httpConnectionResponseContentParameters connection- alreadySentMVar = httpConnectionResponseHeadersSent connection- buffer <- takeMVar bufferMVar- parameters <- takeMVar parametersMVar- parameters <- ensureResponseContentParametersInitialized parameters- (buffer, parameters) <- case parameters of- ResponseContentClosed -> throwIO OutputAlreadyClosed- ResponseContentBufferedIdentity -> do- return (BS.append buffer bytestring, ResponseContentBufferedIdentity)- ResponseContentUnbufferedIdentity lengthRemaining -> do- alreadySent <- takeMVar alreadySentMVar- if alreadySent- then return ()- else do- headersBuffer <- getHeadersBuffer- send headersBuffer- putMVar alreadySentMVar True- let lengthThisPut = BS.length bytestring- if lengthThisPut > lengthRemaining- then do- putMVar parametersMVar ResponseContentClosed- putMVar bufferMVar BS.empty- throwIO OutputAlreadyClosed- else do- let parameters' = ResponseContentUnbufferedIdentity- $ lengthRemaining - lengthThisPut- send bytestring- return (buffer, parameters')- ResponseContentChunked -> do- alreadySent <- takeMVar alreadySentMVar- if alreadySent- then return ()- else do- headersBuffer <- getHeadersBuffer- send headersBuffer- putMVar alreadySentMVar True- if BS.length bytestring > 0- then do- let lengthBuffer =- UTF8.fromString $ showHex (BS.length bytestring) "" ++ "\r\n"- crlfBuffer = UTF8.fromString "\r\n"- send $ BS.concat [lengthBuffer, bytestring, crlfBuffer]- else return ()- return (buffer, parameters)- putMVar parametersMVar parameters- putMVar bufferMVar buffer+ let alreadySentMVar = httpConnectionResponseHeadersSent connection+ maybeException <- do+ modifyResponse $ \buffer parameters -> do+ parameters <- ensureResponseContentParametersInitialized parameters+ case parameters of+ ResponseContentClosed -> do+ return (buffer, parameters, Just OutputAlreadyClosed)+ ResponseContentBufferedIdentity -> do+ return (BS.append buffer bytestring, parameters, Nothing)+ ResponseContentUnbufferedIdentity lengthRemaining -> do+ modifyMVar_ alreadySentMVar $ \alreadySent -> do+ if alreadySent+ then return ()+ else do+ headersBuffer <- getHeadersBuffer+ send headersBuffer+ return True+ let lengthThisPut = BS.length bytestring+ if lengthThisPut > lengthRemaining+ then do+ return (BS.empty,+ ResponseContentClosed,+ Just OutputAlreadyClosed)+ else do+ let parameters' = ResponseContentUnbufferedIdentity+ $ lengthRemaining - lengthThisPut+ send bytestring+ return (buffer, parameters', Nothing)+ ResponseContentChunked -> do+ modifyMVar_ alreadySentMVar $ \alreadySent -> do+ if alreadySent+ then return ()+ else do+ headersBuffer <- getHeadersBuffer+ send headersBuffer+ return True+ if BS.length bytestring > 0+ then do+ let lengthBuffer =+ UTF8.fromString $ showHex (BS.length bytestring) ""+ ++ "\r\n"+ crlfBuffer = UTF8.fromString "\r\n"+ send $ BS.concat [lengthBuffer, bytestring, crlfBuffer]+ else return ()+ return (buffer, parameters, Nothing)+ case maybeException of+ Nothing -> return ()+ Just exception -> throwIO exception ensureResponseContentParametersInitialized@@ -2216,34 +2226,34 @@ ensureResponseContentParametersInitialized parameters = return parameters -flushResponseContent :: (MonadHTTP m) => m ()-flushResponseContent = do+finishResponseContent :: (MonadHTTP m) => m ()+finishResponseContent = do connection <- getHTTPConnection let bufferMVar = httpConnectionResponseContentBuffer connection parametersMVar = httpConnectionResponseContentParameters connection- buffer <- takeMVar bufferMVar- parameters <- takeMVar parametersMVar- parameters <- ensureResponseContentParametersInitialized parameters- case parameters of- ResponseContentClosed -> throwIO OutputAlreadyClosed- ResponseContentBufferedIdentity -> do- headersBuffer <- getHeadersBuffer- send $ BS.concat [headersBuffer, buffer]- return ()- ResponseContentUnbufferedIdentity lengthRemaining -> do- if lengthRemaining > 0- then do- putMVar parametersMVar ResponseContentClosed- putMVar bufferMVar BS.empty- throwIO OutputIncomplete- else return ()- ResponseContentChunked -> do- let emptyChunkBuffer = UTF8.fromString $ "0\r\n\r\n\r\n"- send emptyChunkBuffer- putMVar parametersMVar parameters- putMVar bufferMVar buffer- putMVar parametersMVar ResponseContentClosed- putMVar bufferMVar BS.empty+ maybeException <-+ modifyResponse $ \buffer parameters -> do+ parameters <- ensureResponseContentParametersInitialized parameters+ result <-+ case parameters of+ ResponseContentClosed -> do+ return $ Just OutputAlreadyClosed+ ResponseContentBufferedIdentity -> do+ headersBuffer <- getHeadersBuffer+ send $ BS.concat [headersBuffer, buffer]+ return Nothing+ ResponseContentUnbufferedIdentity lengthRemaining -> do+ if lengthRemaining > 0+ then return $ Just OutputIncomplete+ else return Nothing+ ResponseContentChunked -> do+ let emptyChunkBuffer = UTF8.fromString $ "0\r\n\r\n\r\n"+ send emptyChunkBuffer+ return Nothing+ return (BS.empty, ResponseContentClosed, result)+ case maybeException of+ Nothing -> return ()+ Just exception -> throwIO exception send :: (MonadHTTP m) => ByteString -> m ()@@ -2273,7 +2283,7 @@ httpCloseOutput = do requireOutputNotYetClosed sendResponseHeaders- flushResponseContent+ finishResponseContent httpGet' Nothing True True return () @@ -2284,12 +2294,12 @@ httpIsWritable = do connection <- getHTTPConnection let parametersMVar = httpConnectionResponseContentParameters connection- parameters <- takeMVar parametersMVar- parameters <- ensureResponseContentParametersInitialized parameters- putMVar parametersMVar parameters- return $ case parameters of- ResponseContentClosed -> False- _ -> True+ modifyMVar parametersMVar $ \parameters -> do+ parameters <- ensureResponseContentParametersInitialized parameters+ let result = case parameters of+ ResponseContentClosed -> False+ _ -> True+ return (parameters, result) requireResponseHeadersNotYetSent :: (MonadHTTP m) => m ()@@ -2315,3 +2325,36 @@ False -> throwIO OutputAlreadyClosed True -> return () ++modifyRequest+ :: (MonadHTTP m)+ => (ByteString+ -> RequestContentParameters+ -> m (ByteString, RequestContentParameters, a))+ -> m a+modifyRequest action = do+ HTTPConnection {+ httpConnectionRequestContentBuffer = bufferMVar,+ httpConnectionRequestContentParameters = parametersMVar+ } <- getHTTPConnection+ modifyMVar bufferMVar $ \buffer -> do+ modifyMVar parametersMVar $ \parameters -> do+ (buffer, parameters, result) <- action buffer parameters+ return (parameters, (buffer, result))+++modifyResponse+ :: (MonadHTTP m)+ => (ByteString+ -> ResponseContentParameters+ -> m (ByteString, ResponseContentParameters, a))+ -> m a+modifyResponse action = do+ HTTPConnection {+ httpConnectionResponseContentBuffer = bufferMVar,+ httpConnectionResponseContentParameters = parametersMVar+ } <- getHTTPConnection+ modifyMVar bufferMVar $ \buffer -> do+ modifyMVar parametersMVar $ \parameters -> do+ (buffer, parameters, result) <- action buffer parameters+ return (parameters, (buffer, result))
direct-http.cabal view
@@ -1,5 +1,5 @@ name: direct-http-version: 0.5.3+version: 0.6 cabal-version: >= 1.10 build-type: Simple license: BSD3@@ -21,6 +21,9 @@ author, but is intended more by way of a replacement for it than a companion to it, and makes several design decisions differently. The biggest is the use of MonadControlBase for exceptions.+ .+ [Version 0.6] Substantial reworking of MVar handling, using safer primitives+ to be much more robust in the face of exceptions in pure code. . [Version 0.5.3] Actually works with extension headers, by admitting the reality that they can occur anytime and not just with an entity.