acme-http (empty) → 0.1
raw patch · 8 files changed
+514/−0 lines, 8 filesdep +basedep +bytestringdep +extensible-exceptionssetup-changed
Dependencies added: base, bytestring, extensible-exceptions, mtl, network, pretty
Files
- Acme/Request.hs +164/−0
- Acme/Response.hs +39/−0
- Acme/Serve.hs +94/−0
- Acme/Types.hs +143/−0
- LICENSE +30/−0
- Pong.hs +11/−0
- Setup.hs +2/−0
- acme-http.cabal +31/−0
+ Acme/Request.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}+module Acme.Request where++import Control.Monad.Trans (lift, liftIO)+import Control.Exception.Extensible+import Data.ByteString (ByteString, elemIndex, empty, split, uncons)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as C+import Data.ByteString.Unsafe (unsafeDrop, unsafeIndex, unsafeTake)+import Data.Monoid (mappend)+import Data.Typeable (Typeable)+import Acme.Types ( ConnectionClosed(..), HTTPVersion(..), Method(..)+ , Request(..), cr, colon, nl, space+ )++------------------------------------------------------------------------------+-- Parse Exception+------------------------------------------------------------------------------++data ParseError+ = Unexpected+ | MalformedRequestLine ByteString+ | MalformedHeader ByteString+ | UnknownHTTPVersion ByteString+ deriving (Typeable, Show, Eq)++instance Exception ParseError++------------------------------------------------------------------------------+-- Request Parser+------------------------------------------------------------------------------+++{-+ Request = Request-Line ; Section 5.1+ *(( general-header ; Section 4.5+ | request-header ; Section 5.3+ | entity-header ) CRLF) ; Section 7.1+ CRLF+ [ message-body ] ; Section 4.3+-}+parseRequest :: IO ByteString -> ByteString -> Bool -> IO (Request, ByteString)+parseRequest getChunk bs secure =+ do (line, bs') <- takeLine getChunk bs+ let (method, requestURI, httpVersion) = parseRequestLine line+ (headers, bs'') <- parseHeaders getChunk bs'+ let request = Request { rqMethod = method+ , rqURIbs = requestURI+ , rqHTTPVersion = httpVersion+ , rqHeaders = headers+ , rqSecure = secure+ , rqBody = empty+ }+-- liftIO $ print request+ return (request, bs'')++{-+The Request-Line begins with a method token, followed by the Request-URI and the protocol version, and ending with CRLF. The elements are separated by SP characters. No CR or LF is allowed except in the final CRLF sequence.++ Request-Line = Method SP Request-URI SP HTTP-Version CRLF+-}+parseRequestLine :: ByteString -> (Method, ByteString, HTTPVersion)+parseRequestLine bs =+ case split space bs of+ [method, requestURI, httpVersion] ->+ (parseMethod method, requestURI, parseHTTPVersion httpVersion)+ _ -> throw (MalformedRequestLine bs)+++{-++The Method token indicates the method to be performed on the resource identified by the Request-URI. The method is case-sensitive.++ Method = "OPTIONS" ; Section 9.2+ | "GET" ; Section 9.3+ | "HEAD" ; Section 9.4+ | "POST" ; Section 9.5+ | "PUT" ; Section 9.6+ | "DELETE" ; Section 9.7+ | "TRACE" ; Section 9.8+ | "CONNECT" ; Section 9.9+ | extension-method+ extension-method = token+-}+parseMethod :: ByteString -> Method+parseMethod bs+ | bs == "OPTIONS" = OPTIONS+ | bs == "GET" = GET+ | bs == "HEAD" = HEAD+ | bs == "POST" = POST+ | bs == "PUT" = PUT+ | bs == "DELETE" = DELETE+ | bs == "TRACE" = TRACE+ | bs == "CONNECT" = CONNECT+ | otherwise = EXTENSION bs+++-- HTTP-Version = "HTTP" "/" 1*DIGIT "." 1*DIGIT+parseHTTPVersion :: ByteString -> HTTPVersion+parseHTTPVersion bs+ | bs == "HTTP/1.1" = HTTP11+ | bs == "HTTP/1.0" = HTTP10+ | otherwise = throw (UnknownHTTPVersion bs)++parseHeaders :: IO ByteString -> ByteString -> IO ([(ByteString, ByteString)], ByteString)+parseHeaders getChunk remainder =+ do (line, bs) <- takeLine getChunk remainder+ if B.null line+ then do return ([], bs)+ else do (headers, bs') <- parseHeaders getChunk bs+ return ((parseHeader line : headers), bs')+++{-+ message-header = field-name ":" [ field-value ]+ field-name = token+ field-value = *( field-content | LWS )+ field-content = <the OCTETs making up the field-value+ and consisting of either *TEXT or combinations+ of token, separators, and quoted-string>+-}+parseHeader :: ByteString -> (ByteString, ByteString)+parseHeader bs =+ let (fieldName, remaining) = parseToken bs+ in case uncons remaining of+ (Just (c, fieldValue))+ | c == colon -> (fieldName, fieldValue)+ _ -> throw (MalformedHeader bs)++{-+ token = 1*<any CHAR except CTLs or separators>+ separators = "(" | ")" | "<" | ">" | "@"+ | "," | ";" | ":" | "\" | <">+ | "/" | "[" | "]" | "?" | "="+ | "{" | "}" | SP | HT+ CTL = <any US-ASCII control character+ (octets 0 - 31) and DEL (127)>+-}+-- FIXME: follow the spec+parseToken :: ByteString -> (ByteString, ByteString)+parseToken bs = B.span (/= colon) bs++-- | find a line terminated by a '\r\n'+takeLine :: IO ByteString -> ByteString -> IO (ByteString, ByteString)+takeLine getChunk bs =+ -- find the index of the next '\n'+ case elemIndex nl bs of+ Nothing ->+ do x <- getChunk+ if (B.null x)+ then throw ConnectionClosed+ else takeLine getChunk (bs `mappend` x)+ (Just 0) -> throw Unexpected+ (Just i) ->+ -- check that the '\n' was preceded by '\r'+ if unsafeIndex bs (i - 1) /= cr+ then throw Unexpected+ else return $ (unsafeTake (i - 1) bs, unsafeDrop (i + 1) bs)+{-+parse :: String -> Pipe ByteString ByteString (ResourceT IO) a -> IO (Maybe a)+parse str parser =+ runResourceT $ runPipe $+ (yield (C.pack str) >> return Nothing) >+> (fmap Just parser) >+> discard+-}
+ Acme/Response.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE RecordWildCards, OverloadedStrings #-}+module Acme.Response where++import Data.ByteString (ByteString, append)+import Data.ByteString.Char8 () -- instance IsString ByteString+++------------------------------------------------------------------------------+-- send a response+------------------------------------------------------------------------------++pong :: (ByteString -> IO ()) -> IO ()+pong send =+ do send "HTTP/1.1 200 OK\r\nContent-Length: 4\r\n\r\nPONG"++{-+sendResponse :: Response -> (ByteString -> IO+sendResponse _ =+ do -- lift $ liftIO $ putStrLn "responding..."+ yield $ statusLine rsCode `append` "Content-Length: 4\r\n\r\nPONG"+ return ()+-}++------------------------------------------------------------------------------+-- Status Lines+------------------------------------------------------------------------------++{-+ Status-Line = HTTP-Version SP Status-Code SP Reason-Phrase CRLF+-}++-- FIXME: can the http version always be 1.1 or do we need to match the caller?+statusLine :: Int -> ByteString+statusLine 200 = ok_status++ok_status :: ByteString+ok_status = "HTTP/1.1 200 OK\r\n"++
+ Acme/Serve.hs view
@@ -0,0 +1,94 @@+module Acme.Serve where++import Acme.Request+import Acme.Response+import Acme.Types+import Control.Concurrent (killThread, forkIO)+import Control.Exception.Extensible as E+import Control.Monad (forever)+import Control.Monad.Trans+import Data.ByteString (ByteString, empty)+import Data.ByteString.Char8 (pack)+import Network.BSD (getProtocolNumber)+import Network.Socket (Socket, SockAddr(..), SocketOption(..), SocketType(Stream), Family(AF_INET), accept, bindSocket, iNADDR_ANY, sClose, listen, maxListenQueue, setSocketOption, socket)+import Network.Socket.ByteString (recv, sendAll)+import System.IO++++-- | start TCP listening on a port+listenOn :: Int -- ^ port number+ -> IO Socket+listenOn portm = do+ proto <- getProtocolNumber "tcp"+ E.bracketOnError+ (socket AF_INET Stream proto)+ (sClose)+ (\sock -> do+ setSocketOption sock ReuseAddr 1+ setSocketOption sock NoDelay 1+ bindSocket sock (SockAddrInet (fromIntegral portm) iNADDR_ANY)+ listen sock (max 1024 maxListenQueue)+ return sock+ )++-- | listen on a port and handle 'Requests'+serve :: Int -- ^ port to listen on+ -> (Request -> IO Response) -- ^ request handler+ -> IO ()+serve port app =+ bracket (listenOn port) sClose $ \listenSocket ->+ serveSocket listenSocket app++-- | handle 'Requests' from an already listening 'Socket'+serveSocket :: Socket -- ^ 'Socket' in listen mode+ -> (Request -> IO Response) -- ^ request handler+ -> IO ()+serveSocket listenSocket app =+ forever $+ do (sock, addr) <- accept listenSocket+ let reader = recv sock 4096+ writer = sendAll sock+ forkIO $ do requestLoop False addr reader writer app `E.catch` (\ConnectionClosed -> return ())+ sClose sock++requestLoop :: Bool+ -> SockAddr+ -> IO ByteString+ -> (ByteString -> IO ())+ -> (Request -> IO Response)+ -> IO ()+requestLoop secure addr reader writer app =+ go empty+ where+ go bs =+ do (request, bs') <- parseRequest reader bs secure+ pong writer+ go bs'+{-+ runPipe $ reader >+> httpPipe empty >+> writer+ where+ httpPipe :: ByteString -> Pipe ByteString ByteString (ResourceT IO) ()+ httpPipe bs =+ do (request, bs') <- parseRequest bs secure+ response <- appPipe request+ responsePipe response+-- _remaining <- discardBody request+ httpPipe bs'++ discardBody :: Request -> Pipe ByteString ByteString (ResourceT IO) ByteString+ discardBody request = rqBody request >> discard++ appPipe :: Request -> Pipe ByteString ByteString (ResourceT IO) Response+ appPipe req = lift $ app req+++hello :: Request -> ResourceT IO Response+hello req = + do lift $ print (ppRequest req)+ let res = Response { rsCode = 200+ , rsBody = ResponsePipe $ return ()+ }+ lift $ print (ppResponse res)+ return $ res+-}
+ Acme/Types.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE DeriveDataTypeable, RankNTypes, RecordWildCards #-}+module Acme.Types where++import Control.Exception.Extensible (Exception)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as C+import Data.ByteString.Internal (c2w)+import Data.Data (Data, Typeable)+import Text.PrettyPrint.HughesPJ (Doc, ($$), (<+>), ($+$), (<>), char, nest, text, vcat)+import Data.Word (Word8)++------------------------------------------------------------------------------+-- HTTPVersion+------------------------------------------------------------------------------++data HTTPVersion+ = HTTP10+ | HTTP11+ deriving (Eq, Ord, Read, Show, Data, Typeable)++ppHTTPVersion :: HTTPVersion -> Doc+ppHTTPVersion HTTP10 = text "HTTP/1.0"+ppHTTPVersion HTTP11 = text "HTTP/1.1"++------------------------------------------------------------------------------+-- Method+------------------------------------------------------------------------------++data Method+ = OPTIONS+ | GET+ | GETONLY+ | HEAD+ | POST+ | PUT+ | DELETE+ | TRACE+ | CONNECT+ | EXTENSION ByteString+ deriving (Eq, Ord, Read, Show, Data, Typeable)++ppMethod :: Method -> Doc+ppMethod OPTIONS = text "OPTIONS"+ppMethod GET = text "GET"+ppMethod GETONLY = text "GETONLY"+ppMethod HEAD = text "HEAD"+ppMethod POST = text "POST"+ppMethod PUT = text "PUT"+ppMethod DELETE = text "DELETE"+ppMethod TRACE = text "TRACE"+ppMethod CONNECT = text "CONNECT"+ppMethod (EXTENSION ext) = text (C.unpack ext)++------------------------------------------------------------------------------+-- Request+------------------------------------------------------------------------------++data Request = Request+ { rqMethod :: !Method+ , rqURIbs :: !ByteString+ , rqHTTPVersion :: !HTTPVersion+ , rqHeaders :: ![(ByteString, ByteString)]+ , rqSecure :: !Bool+ , rqBody :: !ByteString+ }+ deriving Typeable++instance Show Request where+ show = show . ppRequest++ppRequest :: Request -> Doc+ppRequest Request{..} =+ text "Request {" $+$+ nest 2 (+ vcat [ field " rqMethod" (ppMethod rqMethod)+ , field ", rqURIbs" (bytestring rqURIbs)+ , field ", rqHTTPVersion" (ppHTTPVersion rqHTTPVersion)+ , field ", rqHeaders" (vcat $ map ppHeader rqHeaders)+ , field ", rqSecure" (text $ show rqSecure)+ ]) $+$+ text "}"++------------------------------------------------------------------------------+-- Response+------------------------------------------------------------------------------++data Response+ = PongResponse -- ^ return PONG in the request body+ | ByteStringResponse+ { rsCode :: !Int+ , rsBody :: !ByteString+ }++ppResponse :: Response -> Doc+ppResponse PongResponse = text "PongResponse"+ppResponse ByteStringResponse{..} =+ text "Response {" $+$+ nest 2 (vcat [ field "rsCode" (text $ show rsCode)+ , field "rsBody" (text $ show rsBody)+ ]) $+$+ text "}"++------------------------------------------------------------------------------+-- Exceptions+------------------------------------------------------------------------------++-- | thrown when the remote-side closes the connection+data ConnectionClosed+ = ConnectionClosed+ deriving (Typeable, Show)++instance Exception ConnectionClosed++------------------------------------------------------------------------------+-- pretty-print helpers+------------------------------------------------------------------------------++-- | render a 'ByteString' to 'Doc'+bytestring :: ByteString -> Doc+bytestring = text . C.unpack++-- | render, field = value+field :: String -- ^ field name+ -> Doc -- ^ field value+ -> Doc+field name doc = text name $$ nest 15 (char '=' <+> doc)++-- | pretty-print an HTTP header+ppHeader :: (ByteString, ByteString) -> Doc+ppHeader (fieldName, fieldValue) =+ bytestring fieldName <> char ':' <> bytestring fieldValue+++------------------------------------------------------------------------------+-- 'Word8' constants for popular characters+------------------------------------------------------------------------------++colon, cr, nl, space :: Word8+colon = c2w ':'+cr = c2w '\r'+nl = c2w '\n'+space = c2w ' '+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2012, Jeremy Shaw, SeeReason Partners LLC++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 Jeremy Shaw nor the names of other+ 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.
+ Pong.hs view
@@ -0,0 +1,11 @@+module Main where++import Acme.Serve+import Acme.Types++main :: IO ()+main = serve 8000 pong++pong :: Request -> IO Response+pong r =+ return $ PongResponse
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ acme-http.cabal view
@@ -0,0 +1,31 @@+Name: acme-http+Version: 0.1+Synopsis: fastest Haskell PONG server in the world+Description: winning the PONG benchmark at all costs+License: BSD3+License-file: LICENSE+Author: Jeremy Shaw+Maintainer: jeremy@n-heptane.com+Copyright: 2012 Jeremy Shaw, SeeReason Partners LLC+Category: Web+Build-type: Simple+Cabal-version: >=1.6++Library+ Exposed-modules: Acme.Response+ Acme.Request+ Acme.Serve+ Acme.Types++ Build-depends: base < 5,+ bytestring == 0.9.*,+ extensible-exceptions == 0.1.*,+ mtl == 2.0.*,+ network >= 2.3 && <2.5,+ pretty >= 1.0 && <1.2++ GHC-Options: -O2++Executable pong+ Main-Is: Pong.hs+ GHC-Options: -threaded -O2