diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,32 @@ +ihttp license +Copyright (c) 2010, Ertugrul Soeylemez + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + + * Neither the name of the author nor the names of any contributors + may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Network/IHttp.hs b/Network/IHttp.hs new file mode 100644 --- /dev/null +++ b/Network/IHttp.hs @@ -0,0 +1,24 @@ +-- | +-- Module: Network.IHttp +-- Copyright: (c) 2010 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- Stability: experimental +-- +-- Convenience module for the ihttp library. + +module Network.IHttp + ( -- * Reexported modules + module Network.IHttp.Header, + module Network.IHttp.Request, + module Network.IHttp.Response, + module Network.IHttp.Simple, + module Network.IHttp.Types + ) + where + +import Network.IHttp.Header +import Network.IHttp.Request +import Network.IHttp.Response +import Network.IHttp.Simple +import Network.IHttp.Types diff --git a/Network/IHttp/Header.hs b/Network/IHttp/Header.hs new file mode 100644 --- /dev/null +++ b/Network/IHttp/Header.hs @@ -0,0 +1,86 @@ +-- | +-- Module: Network.IHttp.Header +-- Copyright: (c) 2010 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- Stability: experimental +-- +-- Iteratees for header parsing. + +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} + +module Network.IHttp.Header + ( -- * Iteratees + httpHeader, + httpHeaders + ) + where + +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 +import Data.Enumerator.List as EL +import Network.IHttp.Parsers +import Network.IHttp.Tools +import Network.IHttp.Types + + +-- | Get the next header from the 'netLinesEmpty'-splitted stream. The +-- header's content is length-limited by the given argument. If it's +-- longer, it's safely truncated in constant space. This iteratee +-- throws an iteratee error, if the next lines are not a valid HTTP +-- header or the stream ends prematurely. If the next line is an empty +-- line, this iteratee returns 'Nothing'. + +httpHeader :: + forall m. Monad m => + Int -> Iteratee ByteString m (Maybe (ByteString, 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)) + + 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)) = + 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) + + +-- | Get the headers of an HTTP request from a 'netLinesEmpty'-splitted +-- byte stream. The first 'Int' specifies the maximum length of +-- individual headers. The second 'Int' specifies the maximum number of +-- headers. This iteratee throws an iteratee error on invalid input, of +-- if the stream ends prematurely. +-- +-- Excess data is truncated safely in constant space. + +httpHeaders :: forall m. Monad m => Int -> Int -> Iteratee ByteString m HeaderMap +httpHeaders maxLine maxHeaders = + loop M.empty + + where + loop :: HeaderMap -> Iteratee ByteString m HeaderMap + loop m' = do + mHeader <- httpHeader maxLine + case mHeader of + Just (hdrName, hdrSfx) -> do + let accum hdrPfx = B.take maxLine $ B.concat [hdrPfx, ", ", hdrSfx] + hdrTxt = maybe hdrSfx accum (M.lookup hdrName m') + if M.size m' < maxHeaders + then hdrTxt `seq` loop (M.insert hdrName hdrTxt m') + else loop m' + Nothing -> return m' diff --git a/Network/IHttp/Parsers.hs b/Network/IHttp/Parsers.hs new file mode 100644 --- /dev/null +++ b/Network/IHttp/Parsers.hs @@ -0,0 +1,149 @@ +-- | +-- Module: Network.IHttp.Parsers +-- Copyright: (c) 2010 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- Stability: experimental +-- +-- HTTP parsers. + +{-# LANGUAGE OverloadedStrings #-} + +module Network.IHttp.Parsers + ( -- * Protocol parsers + httpCodeP, + httpFirstHeaderP, + httpMethodP, + httpMethodP', + httpVersionP, + messageP, + requestLineP, + responseLineP + ) + where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import qualified Data.Map as M +import Control.ContStuff +import Data.Attoparsec.Char8 as P +import Data.ByteString (ByteString) +import Network.IHttp.Tools +import Network.IHttp.Types + + +-- | Parse an HTTP status code. + +httpCodeP :: Parser Int +httpCodeP = + ( "HTTP response code") $ do + code <- P.take 3 + case BC.readInt code of + Just (n, rest) | B.null rest -> return n + _ -> empty "Invalid response code" + + +-- | Parse first HTTP header line. + +httpFirstHeaderP :: Parser (ByteString, ByteString) +httpFirstHeaderP = do + (,) + <$> (BC.map asciiToUpper <$> httpTokenP) <* string ": " + <*> messageP + "initial header line" + + +-- | Parse a known HTTP method. + +httpMethodP :: Parser HttpMethod +httpMethodP = + ( "HTTP request method") $ + P.choice . map (P.try . httpMethodP') $ methods + + where + methods :: [HttpMethod] + methods = [ ConnectMethod, DeleteMethod, GetMethod, HeadMethod, + OptionsMethod, PatchMethod, PostMethod, PutMethod, + TraceMethod ] + + +-- | Parse the given HTTP method. + +httpMethodP' :: HttpMethod -> Parser HttpMethod +httpMethodP' method = + let parser = + case method of + ConnectMethod -> string "CONNECT" "CONNECT method" + DeleteMethod -> string "DELETE" "DELETE method" + GetMethod -> string "GET" "GET method" + HeadMethod -> string "HEAD" "HEAD method" + OptionsMethod -> string "OPTIONS" "OPTIONS method" + PatchMethod -> string "PATCH" "PATCH method" + PostMethod -> string "POST" "POST method" + PutMethod -> string "PUT" "PUT method" + TraceMethod -> string "TRACE" "TRACE method" + XMethod str -> return str BC.unpack str ++ " method" + in method <$ parser + + +-- | Parse an HTTP token as specified by RFC 1945. + +httpTokenP :: Parser ByteString +httpTokenP = + P.takeWhile1 isTokenChar "HTTP token" + + where + tspecials' :: [Char] + tspecials' = "()<>@,;:\\\"/[]?={}" + + isTokenChar :: Char -> Bool + isTokenChar c = c > ' ' && c < '\DEL' && notInClass tspecials' c + + +-- | Parse an HTTP version in the format @HTTP/major.minor@. + +httpVersionP :: Parser HttpVersion +httpVersionP = + ( "version string") $ do + string "HTTP/" "\"HTTP/\" version prefix" + major <- decimal "major version" + char '.' + minor <- decimal "minor version" + case (major, minor) of + (1, 0) -> return Http1_0 + (1, 1) -> return Http1_1 + _ -> empty "unsupported version" + + +-- | Parse the rest of input as a status message. + +messageP :: Parser ByteString +messageP = + P.takeWhile (const True) <* endOfInput "status message" + + +-- | Parse an HTTP request line. + +requestLineP :: Parser Request +requestLineP = + Request M.empty + <$> httpMethodP <* char ' ' + <*> uriP <* char ' ' + <*> httpVersionP <* endOfInput + + +-- | Parse an HTTP response line. + +responseLineP :: Parser Response +responseLineP = + (\ver code msg -> Response code M.empty msg ver) + <$> httpVersionP <* char ' ' + <*> httpCodeP <* char ' ' + <*> messageP + + +-- | Parse a URI (which is right now just a nonempty string token +-- without whitespace). + +uriP :: Parser ByteString +uriP = P.takeWhile1 (/= ' ') "URI string" diff --git a/Network/IHttp/Request.hs b/Network/IHttp/Request.hs new file mode 100644 --- /dev/null +++ b/Network/IHttp/Request.hs @@ -0,0 +1,47 @@ +-- | +-- Module: Network.IHttp.Request +-- Copyright: (c) 2010 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- Stability: experimental +-- +-- Iteratees for requests. + +module Network.IHttp.Request + ( -- * Iteratees + request, + requestLine + ) + where + +import Data.ByteString (ByteString) +import Data.Enumerator as E +import Data.Enumerator.List as EL +import Network.IHttp.Header +import Network.IHttp.Parsers +import Network.IHttp.Tools +import Network.IHttp.Types + + +-- | Get the next full request from a 'netLinesEmpty'-splitted byte +-- stream. If the request is invalid or the stream ends prematurely an +-- iteratee error is thrown. The first 'Int' specifies the maximum +-- header content length. The second 'Int' specifies the maximum number +-- of headers. Excess data is truncated safely in constant space. + +request :: Monad m => Int -> Int -> Iteratee ByteString m Request +request maxHeadLine maxHeaders = do + req <- requestLine + headers <- httpHeaders maxHeadLine maxHeaders + return req { requestHeaders = headers } + + +-- | Get the next request line from a 'netLinesEmpty'-splitted byte +-- stream. If the request is invalid or the stream ends prematurely an +-- iteratee error is thrown. + +requestLine :: Monad m => Iteratee ByteString m Request +requestLine = + EL.head + >>= maybe (throwError $ InvalidRequestError "Premature end of stream") return + >>= parseIter requestLineP InvalidRequestError diff --git a/Network/IHttp/Response.hs b/Network/IHttp/Response.hs new file mode 100644 --- /dev/null +++ b/Network/IHttp/Response.hs @@ -0,0 +1,47 @@ +-- | +-- Module: Network.IHttp.Response +-- Copyright: (c) 2010 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- Stability: experimental +-- +-- Iteratees for response. + +module Network.IHttp.Response + ( -- * Iteratees + response, + responseLine + ) + where + +import Data.ByteString (ByteString) +import Data.Enumerator as E +import Data.Enumerator.List as EL +import Network.IHttp.Header +import Network.IHttp.Parsers +import Network.IHttp.Tools +import Network.IHttp.Types + + +-- | Get the next full response from a 'netLinesEmpty'-splitted byte +-- stream. If the response is invalid or the stream ends prematurely an +-- iteratee error is thrown. The first 'Int' specifies the maximum +-- header content length. The second 'Int' specifies the maximum number +-- of headers. Excess data is truncated safely in constant space. + +response :: Monad m => Int -> Int -> Iteratee ByteString m Response +response maxHeadLine maxHeaders = do + req <- responseLine + headers <- httpHeaders maxHeadLine maxHeaders + return req { responseHeaders = headers } + + +-- | Get the next response line form 'netLinesEmpty'-splitted stream. +-- If the response line is invalid or the stream ended prematurely, then +-- an iteratee error is thrown. + +responseLine :: Monad m => Iteratee ByteString m Response +responseLine = + EL.head + >>= maybe (throwError $ InvalidResponseError "Premature end of stream") return + >>= parseIter responseLineP InvalidResponseError diff --git a/Network/IHttp/Simple.hs b/Network/IHttp/Simple.hs new file mode 100644 --- /dev/null +++ b/Network/IHttp/Simple.hs @@ -0,0 +1,62 @@ +-- | +-- Module: Network.IHttp.Simple +-- Copyright: (c) 2010 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- Stability: experimental +-- +-- Simple interface to the HTTP iteratees. + +module Network.IHttp.Simple + ( -- * Types + HttpConfig(..), + defHttpConfig, + + -- * Iteratees + getRequest, + getResponse + ) + where + +import Data.ByteString (ByteString) +import Data.Enumerator as E +import Data.Enumerator.NetLines +import Network.IHttp.Request +import Network.IHttp.Response +import Network.IHttp.Types + + +-- | HTTP iteratees configuration. + +data HttpConfig = + HttpConfig { + httpMaxLine :: Int, -- ^ Maximum protocol line length. + httpMaxHeaderContent :: Int, -- ^ Maximum header content length. + httpMaxHeaders :: Int -- ^ Maximum number of headers. + } + + +-- | Default HTTP iteratee configuration. Other than in very special +-- applications you should never need to change these defaults. + +defHttpConfig :: HttpConfig +defHttpConfig = + HttpConfig { httpMaxLine = 1024, + httpMaxHeaderContent = 8192, + httpMaxHeaders = 128 } + + +-- | Get the next full request from the given raw byte stream. + +getRequest :: Monad m => HttpConfig -> Iteratee ByteString m Request +getRequest cfg = + joinI $ netLinesEmpty (httpMaxLine cfg) $$ + request (httpMaxHeaderContent cfg) (httpMaxHeaders cfg) + + +-- | Get the next full response from the given raw byte stream. + +getResponse :: Monad m => HttpConfig -> Iteratee ByteString m Response +getResponse cfg = + joinI $ netLinesEmpty (httpMaxLine cfg) $$ + response (httpMaxHeaderContent cfg) (httpMaxHeaders cfg) diff --git a/Network/IHttp/Tools.hs b/Network/IHttp/Tools.hs new file mode 100644 --- /dev/null +++ b/Network/IHttp/Tools.hs @@ -0,0 +1,61 @@ +-- | +-- Module: Network.IHttp.Tools +-- Copyright: (c) 2010 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- Stability: experimental +-- +-- Enumeratees and other tools. + +{-# LANGUAGE ScopedTypeVariables #-} + +module Network.IHttp.Tools + ( -- * Character tools + asciiToUpper, + + -- * Parser tools + parseIter, + parseFull + ) + where + +import Control.Exception as Ex +import Data.Attoparsec.Char8 as P +import Data.ByteString as B +import Data.Char +import Data.Enumerator as E +import Data.List as L +import Text.Printf + + +-- | Fast ASCII version of 'toUpper'. + +asciiToUpper :: Char -> Char +asciiToUpper c + | c >= 'a' && c <= 'z' = chr $ ord c - 0x20 + | otherwise = c + + +-- | Fully parse a string with the given parser. Throw an iteratee +-- error with the given error constructor, if it fails. + +parseIter :: + (Exception ex, Monad m) => + Parser b -> (String -> ex) -> ByteString -> Iteratee a m b +parseIter parser ex str = + case parseFull parser str of + Left err -> throwError (ex err) + Right res -> return res + + +-- | Fully parse a string with the given parser. + +parseFull :: forall a. Parser a -> ByteString -> Either String a +parseFull parser str = + loop (parse parser str) + + where + loop :: Result a -> Either String a + loop (Fail _ ctxs msg) = Left (printf "%s (%s)" (L.intercalate ": " ctxs) msg) + loop (Partial k) = loop (k B.empty) + loop (Done _ res) = Right res diff --git a/Network/IHttp/Types.hs b/Network/IHttp/Types.hs new file mode 100644 --- /dev/null +++ b/Network/IHttp/Types.hs @@ -0,0 +1,106 @@ +-- | +-- Module: Network.IHttp.Types +-- Copyright: (c) 2010 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- Stability: experimental +-- +-- Types for ihttp. + +{-# LANGUAGE DeriveDataTypeable #-} + +module Network.IHttp.Types + ( -- * Protocol data + HeaderMap, + HttpMethod(..), + HttpVersion(..), + Request(..), + Response(..), + + -- * Miscellaneous types + HttpError(..) + ) + where + +import Control.Exception as Ex +import Data.ByteString (ByteString) +import Data.Map (Map) +import Data.Typeable + + +-- | Map of HTTP headers. + +type HeaderMap = Map ByteString ByteString + + +-- | HTTP error. + +data HttpError + -- | Invalid headers from client/server. + = InvalidHeaderError { httpErrorMessage :: String } + + -- | Invalid requests from client. + | InvalidRequestError { httpErrorMessage :: String } + + -- | Invalid responses from server. + | InvalidResponseError { httpErrorMessage :: String } + + -- | Unsupported HTTP version. + | UnsupportedVersionError { httpErrorMessage :: String } + deriving (Eq, Typeable) + +instance Exception HttpError + +instance Show HttpError where + show (InvalidHeaderError msg) = "Invalid HTTP header: " ++ msg + show (InvalidRequestError msg) = "Invalid HTTP request: " ++ msg + show (InvalidResponseError msg) = "Invalid HTTP response: " ++ msg + show (UnsupportedVersionError msg) = "Unsupported HTTP version: " ++ msg + + +-- | HTTP request method. + +data HttpMethod + = ConnectMethod -- ^ CONNECT + | DeleteMethod -- ^ DELETE + | GetMethod -- ^ GET + | HeadMethod -- ^ HEAD + | OptionsMethod -- ^ OPTIONS + | PatchMethod -- ^ PATCH + | PostMethod -- ^ POST + | PutMethod -- ^ PUT + | TraceMethod -- ^ TRACE + | XMethod ByteString -- ^ Methods this library doesn't know. + deriving (Eq, Read, Show) + + +-- | HTTP protocol version. + +data HttpVersion + = Http1_0 -- ^ Version 1.0 of HTTP. + | Http1_1 -- ^ Version 1.1 of HTTP. + deriving (Eq, Ord, Read, Show) + + +-- | HTTP request line with status code. + +data Request = + Request { + requestHeaders :: HeaderMap, -- ^ Request headers. + requestMethod :: HttpMethod, -- ^ Request method. + requestUri :: ByteString, -- ^ Request URI. + requestVersion :: HttpVersion -- ^ HTTP version of request. + } + deriving (Eq, Read, Show) + + +-- | HTTP response line with the status code. + +data Response = + Response { + responseCode :: Int, -- ^ HTTP response code. + responseHeaders :: HeaderMap, -- ^ Response headers. + responseMessage :: ByteString, -- ^ Response message. + responseVersion :: HttpVersion -- ^ Protocol version of response. + } + deriving (Eq, Read, Show) diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,12 @@ +ihttp setup script +Copyright (C) 2010, Ertugrul Soeylemez + +Please see the LICENSE file for terms and conditions of use, +modification and distribution of this package, including this file. + +> module Main where +> +> import Distribution.Simple +> +> main :: IO () +> main = defaultMain diff --git a/ihttp.cabal b/ihttp.cabal new file mode 100644 --- /dev/null +++ b/ihttp.cabal @@ -0,0 +1,42 @@ +Name: ihttp +Version: 0.1.0 +Category: Network +Synopsis: Incremental HTTP iteratee +Maintainer: Ertugrul Söylemez +Author: Ertugrul Söylemez +Copyright: (c) 2010 Ertugrul Söylemez +License: BSD3 +License-file: LICENSE +Build-type: Simple +Stability: experimental +Cabal-version: >= 1.6 +Description: + + Incremental iteratee-based HTTP library using the 'enumerator' + package. + +Library + Build-depends: + attoparsec >= 0.8.4.0, + base >= 4 && <= 5, + bytestring >= 0.9.1.7, + containers >= 0.4.0.0, + contstuff >= 1.2.4, + enumerator >= 0.4.7, + netlines >= 0.3.0 + GHC-Options: -W + Exposed-modules: + Network.IHttp + Network.IHttp.Header + Network.IHttp.Parsers + Network.IHttp.Response + Network.IHttp.Request + Network.IHttp.Simple + Network.IHttp.Tools + Network.IHttp.Types + +-- Executable ihttp-test +-- Build-depends: +-- base >= 4 && <= 5 +-- Main-is: Test.hs +-- GHC-Options: -W