ihttp 0.2.2 → 0.3.0
raw patch · 8 files changed
+159/−45 lines, 8 filesdep +networkdep ~contstuffdep ~netlinesnew-component:exe:ihttp-test
Dependencies added: network
Dependency ranges changed: contstuff, netlines
Files
- Network/IHttp/Header.hs +13/−13
- Network/IHttp/Parsers.hs +3/−4
- Network/IHttp/Request.hs +4/−1
- Network/IHttp/Simple.hs +15/−1
- Network/IHttp/Tools.hs +1/−13
- Network/IHttp/Types.hs +77/−4
- Test.hs +37/−0
- ihttp.cabal +9/−9
Network/IHttp/Header.hs view
@@ -21,7 +21,6 @@ import qualified Data.ByteString as B import qualified Data.Map as M-import Control.Applicative import Data.ByteString (ByteString) import Data.ByteString.Char8 () import Data.Enumerator as E@@ -51,8 +50,9 @@ enumHeaders :: forall b m. Monad m => HeaderMap -> Enumerator ByteString m b enumHeaders headers = enum where- format :: ByteString -> ByteString -> [ByteString] -> [ByteString]- format header content rest = header : ": " : content : "\r\n" : rest+ format :: HeaderKey -> ByteString -> [ByteString] -> [ByteString]+ format (HeaderKey headerStr) content rest =+ headerStr : ": " : content : "\r\n" : rest enum :: Enumerator ByteString m b enum (Continue k) = k (Chunks . M.foldrWithKey format [] $ headers)@@ -68,27 +68,27 @@ httpHeader :: forall m. Monad m =>- Int -> Iteratee ByteString m (Maybe (ByteString, ByteString))+ Int -> Iteratee ByteString m (Maybe (HeaderKey, ByteString)) httpHeader n = do line <- EL.head >>= maybe (throwError $ InvalidHeaderError "Premature end of stream") return if B.null line then return Nothing else do- (hdrName, hdrTxt) <- parseIter httpFirstHeaderP InvalidHeaderError line- Just <$> continue (loop hdrName (B.take n hdrTxt))+ (hdrName, hdrTxt') <- parseIter httpFirstHeaderP InvalidHeaderError line+ hdrTxt <- continue (loop (B.take n hdrTxt'))+ return $ Just (hdrName, hdrTxt) where- loop :: ByteString -> ByteString -> Stream ByteString ->- Iteratee ByteString m (ByteString, ByteString)- loop hdrName hdrTxt EOF = yield (hdrName, hdrTxt) EOF- loop hdrName hdrTxt (Chunks []) = continue (loop hdrName hdrTxt)- loop hdrName hdrTxt' ch@(Chunks (line:lines)) =+ loop :: ByteString -> Stream ByteString -> Iteratee ByteString m ByteString+ loop hdrTxt EOF = yield hdrTxt EOF+ loop hdrTxt (Chunks []) = continue (loop hdrTxt)+ loop hdrTxt' ch@(Chunks (line:lines)) = let (pfx, sfx) = B.span (\c -> c == 32 || c == 9) line hdrTxt = B.take n $ B.append (B.snoc hdrTxt' 32) sfx in if B.null pfx- then yield (hdrName, hdrTxt') ch- else hdrTxt `seq` loop hdrName hdrTxt (Chunks lines)+ then yield hdrTxt' ch+ else hdrTxt `seq` loop hdrTxt (Chunks lines) -- | Get the headers of an HTTP request from a 'netLinesEmpty'-splitted
Network/IHttp/Parsers.hs view
@@ -28,7 +28,6 @@ import Control.ContStuff import Data.Attoparsec.Char8 as P import Data.ByteString (ByteString)-import Network.IHttp.Tools import Network.IHttp.Types @@ -55,12 +54,12 @@ _ -> empty <?> "Invalid response code" --- | Parse first HTTP header line.+-- | Parse initial HTTP header line. -httpFirstHeaderP :: Parser (ByteString, ByteString)+httpFirstHeaderP :: Parser (HeaderKey, ByteString) httpFirstHeaderP = do (,)- <$> (BC.map asciiToUpper <$> httpTokenP) <* string ": "+ <$> (headerKey <$> httpTokenP) <* string ": " <*> messageP <?> "initial header line"
Network/IHttp/Request.hs view
@@ -76,7 +76,10 @@ mkGetRequest :: ByteString -> ByteString -> Request mkGetRequest domain uri =- Request { requestHeaders = M.singleton "Host" domain,+ Request { requestHeaders =+ M.insert "CONNECTION" "CLOSE" .+ M.insert "HOST" domain $+ M.empty, requestMethod = GetMethod, requestUri = uri, requestVersion = Http1_1 }
Network/IHttp/Simple.hs view
@@ -15,7 +15,8 @@ -- * Iteratees getRequest, getResponse,- httpRequest+ httpRequest,+ okRequest ) where @@ -75,3 +76,16 @@ httpRequest cfg h req = do tryIO . run_ $ enumRequest req $$ iterHandleTimeout (httpTimeout cfg) h getResponse cfg+++-- | Send a request to the given output handle and return its response.+-- If the response code is anything other than 200, throw a+-- 'ResponseNotOkError' iteratee exception.++okRequest ::+ MonadIO m =>+ HttpConfig -> Handle -> Request -> Iteratee ByteString m Response+okRequest cfg h req = do+ resp <- httpRequest cfg h req+ when (responseCode resp /= 200) (throwError $ ResponseNotOkError resp)+ return resp
Network/IHttp/Tools.hs view
@@ -20,10 +20,7 @@ -- * Printing tools showMethod,- showVersion,-- -- * Character tools- asciiToUpper+ showVersion ) where @@ -32,19 +29,10 @@ import Data.Attoparsec.Char8 as P import Data.ByteString as B import Data.ByteString.Char8 ()-import Data.Char import Data.Enumerator as E import Data.List as L import Network.IHttp.Types import Text.Printf----- | Fast ASCII version of 'toUpper'.--asciiToUpper :: Char -> Char-asciiToUpper c- | c >= 'a' && c <= 'z' = chr $ ord c - 0x20- | otherwise = c -- | Runs the first computation and then the second, even if the first
Network/IHttp/Types.hs view
@@ -7,7 +7,7 @@ -- -- Types for ihttp. -{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} module Network.IHttp.Types ( -- * Protocol data@@ -17,15 +17,26 @@ Request(..), Response(..), + -- * Header keys+ HeaderKey(..),+ headerKey,+ recaseHeaderKey,+ -- * Miscellaneous types HttpError(..) ) where +import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import Control.Arrow import Control.Exception as Ex import Data.ByteString.Char8 (ByteString)+import Data.Data import Data.Map (Map)-import Data.Typeable+import Data.Monoid+import Data.String+import Text.Printf -- TODO: Common HTTP headers with correct types.@@ -38,16 +49,44 @@ -- } +-- | A HTTP header key. This is just a 'ByteString', but with+-- case-insensitive ordering and a pretty 'IsString' instance.++newtype HeaderKey = HeaderKey { getHeaderKey :: ByteString }+ deriving (Data, Monoid, Read, Typeable)++instance Eq HeaderKey where+ HeaderKey str1 == HeaderKey str2 =+ B.map wordToUpper str1 == B.map wordToUpper str2++instance IsString HeaderKey where+ fromString = HeaderKey . recaseHeaderKey . BC.pack++instance Ord HeaderKey where+ compare (HeaderKey str1) (HeaderKey str2) =+ compare (caseConvert str1) (caseConvert str2)++ where+ caseConvert :: ByteString -> ByteString+ caseConvert = B.map wordToUpper++instance Show HeaderKey where+ show = ("HeaderKey " ++) . show . getHeaderKey++ -- | Map of HTTP headers. -type HeaderMap = Map ByteString ByteString+type HeaderMap = Map HeaderKey ByteString -- | HTTP error. data HttpError+ -- | Non-OK response.+ = ResponseNotOkError { httpErrorResponse :: Response }+ -- | Invalid headers from client/server.- = InvalidHeaderError { httpErrorMessage :: String }+ | InvalidHeaderError { httpErrorMessage :: String } -- | Invalid requests from client. | InvalidRequestError { httpErrorMessage :: String }@@ -62,6 +101,10 @@ instance Exception HttpError instance Show HttpError where+ show (ResponseNotOkError resp) =+ let code = responseCode resp+ msg = responseMessage resp+ in printf "Non-OK response: %i %s" code (BC.unpack msg) show (InvalidHeaderError msg) = "Invalid HTTP header: " ++ msg show (InvalidRequestError msg) = "Invalid HTTP request: " ++ msg show (InvalidResponseError msg) = "Invalid HTTP response: " ++ msg@@ -114,3 +157,33 @@ responseVersion :: HttpVersion -- ^ Protocol version of response. } deriving (Eq, Read, Show)+++-- | Turn a 'ByteString' with 'recaseHeaderKey' case conversion to a+-- 'HeaderKey'.++headerKey :: ByteString -> HeaderKey+headerKey = HeaderKey . recaseHeaderKey+++-- | Convert an arbitrary case header key to dashed camel case+-- ("content-type" -> "Content-Type").++recaseHeaderKey :: ByteString -> ByteString+recaseHeaderKey =+ B.intercalate (BC.singleton '-') .+ map (maybe B.empty (uncurry B.cons . (wordToUpper *** B.map wordToLower)) .+ B.uncons) .+ BC.split '-'+++-- | Convert upper case characters to lower case (ASCII).++wordToLower :: (Num a, Ord a) => a -> a+wordToLower c = if c >= 65 && c <= 90 then c + 32 else c+++-- | Convert lower case characters to upper case (ASCII).++wordToUpper :: (Num a, Ord a) => a -> a+wordToUpper c = if c >= 97 && c <= 122 then c - 32 else c
+ Test.hs view
@@ -0,0 +1,37 @@+-- |+-- Module: Main+-- Copyright: (c) 2010 Ertugrul Soeylemez+-- License: BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>+-- Stability: experimental+--+-- ihttp test program.++{-# LANGUAGE OverloadedStrings #-}++module Main where++import qualified Data.ByteString.Char8 as BC+import qualified Data.Map as M+import Control.ContStuff+import Data.Enumerator as E+import Data.Enumerator.Binary as EB+import Data.Enumerator.NetLines+import Network+import Network.IHttp+import System.IO+++main :: IO ()+main = do+ h <- connectTo "127.0.0.1" (PortNumber 80)+ hSetBuffering h NoBuffering+ run_ $ enumHandleSession 4096 60000 60000 h $$ do+ resp <- okRequest defHttpConfig h (mkGetRequest "ertes.de" "/")+ liftIO (print resp)+ cnt <- maybe EB.consume EB.take $ do+ lenStr <- M.lookup "CONTENT-LENGTH" (responseHeaders resp)+ (len, _) <- BC.readInteger lenStr+ return len+ liftIO (print cnt)+ hClose h
ihttp.cabal view
@@ -1,5 +1,5 @@ Name: ihttp-Version: 0.2.2+Version: 0.3.0 Category: Network Synopsis: Incremental HTTP iteratee Maintainer: Ertugrul Söylemez <es@ertes.de>@@ -21,9 +21,9 @@ base >= 4 && <= 5, bytestring >= 0.9.1.7, containers >= 0.4.0.0,- contstuff >= 1.2.4,+ contstuff >= 1.2.6, enumerator >= 0.4.7,- netlines >= 0.4.3+ netlines >= 1.0.0 GHC-Options: -W Exposed-modules: Network.IHttp@@ -35,9 +35,9 @@ Network.IHttp.Tools Network.IHttp.Types --- Executable ihttp-test--- Build-depends:--- base >= 4 && <= 5,--- network >= 2.2.1.10--- Main-is: Test.hs--- GHC-Options: -W+Executable ihttp-test+ Build-depends:+ base >= 4 && <= 5,+ network >= 2.2.1.10+ Main-is: Test.hs+ GHC-Options: -W