diff --git a/Acme/Request.hs b/Acme/Request.hs new file mode 100644 --- /dev/null +++ b/Acme/Request.hs @@ -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 = +-} +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* + separators = "(" | ")" | "<" | ">" | "@" + | "," | ";" | ":" | "\" | <"> + | "/" | "[" | "]" | "?" | "=" + | "{" | "}" | SP | HT + CTL = +-} +-- 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 +-} diff --git a/Acme/Response.hs b/Acme/Response.hs new file mode 100644 --- /dev/null +++ b/Acme/Response.hs @@ -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" + + diff --git a/Acme/Serve.hs b/Acme/Serve.hs new file mode 100644 --- /dev/null +++ b/Acme/Serve.hs @@ -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 +-} diff --git a/Acme/Types.hs b/Acme/Types.hs new file mode 100644 --- /dev/null +++ b/Acme/Types.hs @@ -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 ' ' + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Pong.hs b/Pong.hs new file mode 100644 --- /dev/null +++ b/Pong.hs @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/acme-http.cabal b/acme-http.cabal new file mode 100644 --- /dev/null +++ b/acme-http.cabal @@ -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