diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2012, Jeremy Shaw + +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/Network.hs b/Network.hs new file mode 100644 --- /dev/null +++ b/Network.hs @@ -0,0 +1,50 @@ +module Network where + +import Control.Exception.Extensible as E +import Control.Monad (forever, unless) +import Control.Monad.Trans (MonadIO(..), lift) +import Control.Proxy (Consumer, Producer, Proxy, request, respond, runIdentityP) +import Data.ByteString as B (ByteString, null) +import Network.BSD (getProtocolNumber) +import Network.Socket (Family(AF_INET), Socket, SockAddr(..), SocketOption(ReuseAddr), SocketType(Stream), bindSocket, iNADDR_ANY, sClose, maxListenQueue, listen, socket, setSocketOption) +import Network.Socket.ByteString (sendAll, recv) + +-- | 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 + bindSocket sock (SockAddrInet (fromIntegral portm) iNADDR_ANY) + listen sock (max 1024 maxListenQueue) + return sock + ) + +-- | Stream data from the socket. +-- +-- FIXME: what should happen if 'recv' raises an exception? +socketReader :: (Proxy p, MonadIO m) => + Socket -- ^ 'Socket' to read data from + -> (() -> Producer p ByteString m ()) +socketReader sock () = runIdentityP go + where + go = do + bs <- lift (liftIO $ recv sock 4096) + unless (B.null bs) $ + respond bs >> go + +-- | Stream data to the socket. +-- +-- FIXME: what should happen if 'sendAll' raises an exception? +socketWriter :: (Proxy p, MonadIO m) => + Socket -- ^ 'Socket' to write data to + -> (() -> Consumer p ByteString m ()) +socketWriter sock () = + runIdentityP $ + forever $ + do bs <- request () + lift $ liftIO (sendAll sock bs) diff --git a/Pong.hs b/Pong.hs new file mode 100644 --- /dev/null +++ b/Pong.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Proxy (respond) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C +import Serve (Handler, serve) +import Types (Response(..)) + +------------------------------------------------------------------------------ +-- pong handler +------------------------------------------------------------------------------ + +pong :: Handler IO +pong r = + do let body = "PONG" + res = Response { rsCode = 200 + , rsHeaders = [("Content-Length", C.pack (show (B.length body)))] + , rsBody = respond body + } + return res + +------------------------------------------------------------------------------ +-- main +------------------------------------------------------------------------------ + +main :: IO () +main = serve 8000 pong diff --git a/Request.hs b/Request.hs new file mode 100644 --- /dev/null +++ b/Request.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} +module Request where + +import Control.Monad (forever) +import Control.Proxy (Proxy, liftP, request, respond) +import Control.Proxy.Trans.State (StateP, get, put) +import Control.Exception.Extensible (Exception, throw) + +import Data.ByteString (ByteString, elemIndex, empty, split, uncons) +import qualified Data.ByteString as B +import Data.ByteString.Lex.Integral (readDecimal) +import Data.ByteString.Internal (c2w) +import Data.ByteString.Unsafe (unsafeDrop, unsafeIndex, unsafeTake) +import Data.Monoid (mappend) +import Data.Typeable (Typeable) +import Data.Word (Word8) +import Network.Socket (SockAddr(..)) +import Types (Method(..), Request(..), HTTPVersion(..)) + +------------------------------------------------------------------------------ +-- 'Word8' constants for popular characters +------------------------------------------------------------------------------ + +colon, cr, nl, space :: Word8 +colon = c2w ':' +cr = c2w '\r' +nl = c2w '\n' +space = c2w ' ' + +------------------------------------------------------------------------------ +-- 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 :: (Proxy p, Monad m) => + Bool -- ^ is this an HTTPS connection? + -> SockAddr + -> StateP ByteString p () ByteString a b m Request +parseRequest secure addr = + do line <- takeLine + let (method, requestURI, httpVersion) = parseRequestLine line + headers <- parseHeaders + let req = + Request { rqMethod = method + , rqURIbs = requestURI + , rqHTTPVersion = httpVersion + , rqHeaders = headers + , rqSecure = secure + , rqClient = addr + } + return $! req + +-- | currently if you consume the entire request body this will +-- terminate and return the 'ret' value that you supplied. But, that +-- seems wrong, because that will tear down the whole pipeline and +-- return that value instead of what you really wanted to return. +-- +-- Perhaps this should return a 'Maybe ByteString' instead so you can +-- detect when the body ends? But that interfers with using +-- 'parseRequest' in 'httpPipe'. For now we will just return 'empty' +-- forever when you get to the end. +-- +-- Perhaps pipes 2.5 will provide a better solution as it is supposed +-- to allow you to catch termination of the upstream pipe. +pipeBody :: (Proxy p, Monad m) => + Request + -> () + -> StateP ByteString p () ByteString a ByteString m r +pipeBody req () = + case lookup "Content-Length" (rqHeaders req) of + Nothing -> + do error "chunked bodies not supported yet" + (Just value) -> + case readDecimal (B.drop 1 value) of + Nothing -> error $ "Failed to read Content-Length" + (Just (n, _)) -> + do unconsumed <- get + go n unconsumed + where + go remaining unconsumed + | remaining == 0 = + do put unconsumed + done + + | remaining >= B.length unconsumed = + do liftP $ respond unconsumed + bs <- liftP $ request () + go (remaining - B.length unconsumed) bs + + | remaining == B.length unconsumed = + do liftP $ respond unconsumed + put empty + done + + | otherwise = + do let (bs', remainder) = B.splitAt remaining unconsumed + liftP $ respond bs' + put remainder + done + + done = forever $ liftP $ respond empty + +{- +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 + +parseHTTPVersion :: ByteString -> HTTPVersion +parseHTTPVersion bs + | bs == "HTTP/1.1" = HTTP11 + | bs == "HTTP/1.0" = HTTP10 + | otherwise = throw (UnknownHTTPVersion bs) + +-- FIXME: add max header size checks +-- parseHeaders :: (Monad m) => ByteString -> Pipe ByteString b m ([(ByteString, ByteString)], ByteString) +parseHeaders :: (Proxy p, Monad m) => StateP ByteString p () ByteString a b m [(ByteString, ByteString)] +parseHeaders = + do line <- takeLine + if B.null line + then do return [] + else do headers <- parseHeaders + return (parseHeader line : headers) + + +{- + 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 :: (Proxy p, Monad m) => + StateP ByteString p () ByteString a b m ByteString +takeLine = + do bs <- get + case elemIndex nl bs of + Nothing -> + do x <- liftP $ request () + put (bs `mappend` x) + takeLine + (Just 0) -> throw Unexpected + (Just i) -> + if unsafeIndex bs (i - 1) /= cr + then throw Unexpected + else do put $ unsafeDrop (i + 1) bs + return $ unsafeTake (i - 1) bs + +{- + +parse :: (Monad m) => Pipe ByteString b m a -> String -> m (Maybe a) +parse parser str = + runPipe $ (yield (C.pack str) >> return Nothing) + >+> (fmap Just parser) + >+> discard +-} diff --git a/Response.hs b/Response.hs new file mode 100644 --- /dev/null +++ b/Response.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE RecordWildCards, OverloadedStrings #-} +module Response where + +import Control.Proxy (Pipe, ProxyFast, respond) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Types (Response(..)) + +-- TODO: How do output the data in sizes that are network friendly? Should we leverage blaze builder? + +------------------------------------------------------------------------------ +-- responseWriter +------------------------------------------------------------------------------ + +responseWriter :: Monad m => + Response m + -> Pipe ProxyFast ByteString ByteString m () +responseWriter Response{..} = + do respond $ B.concat [ statusLine rsCode + , renderHeaders rsHeaders + , "\r\n" + ] + rsBody + +------------------------------------------------------------------------------ +-- 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 +statusLine 404 = not_found_status + +ok_status :: ByteString +ok_status = "HTTP/1.1 200 OK\r\n" + +not_found_status :: ByteString +not_found_status = "HTTP/1.1 404 Not Found\r\n" + +------------------------------------------------------------------------------ +-- Headers +------------------------------------------------------------------------------ + +renderHeaders :: [(ByteString, ByteString)] -> ByteString +renderHeaders = B.concat . map renderHeader + +renderHeader :: (ByteString, ByteString) -> ByteString +renderHeader (fieldName, fieldValue) = + B.concat [fieldName, ": ", fieldValue, "\r\n"] + diff --git a/Serve.hs b/Serve.hs new file mode 100644 --- /dev/null +++ b/Serve.hs @@ -0,0 +1,73 @@ +module Serve where + +import Control.Concurrent (forkIO) +import Control.Exception (bracket, finally) +import Control.Proxy (Pipe, ProxyFast, Server, Client, (>->), (<-<), runProxy) +import Control.Proxy.Trans (liftP) +import Control.Proxy.Trans.State (StateP, evalStateK) +import Control.Monad (forever) +import Data.ByteString (ByteString, empty) +import Network (listenOn, socketReader, socketWriter) +import Network.Socket (Socket, SockAddr, accept, sClose) +import Request (pipeBody, parseRequest) +import Response (responseWriter) +import Types (Request, Response) + + +-- | a 'Handler' essentially a 'Request' and returns a 'Response' +-- +-- The Pipe allows use to incrementally read 'ByteString' chuncks from +-- the Request body and incrementally write 'ByteString' chunks in the +-- 'Response' body. +type Handler m = (Request -> Pipe ProxyFast ByteString ByteString m (Response m)) + +------------------------------------------------------------------------------ +-- serve +------------------------------------------------------------------------------ + +-- | listen on a port and handle 'Requests' +serve :: Int -- ^ port number to listen on + -> Handler IO -- ^ handler + -> IO () +serve port handler = + bracket (listenOn port) sClose $ \listenSocket -> + serveSocket listenSocket handler + +------------------------------------------------------------------------------ +-- internals +------------------------------------------------------------------------------ + +serveSocket :: Socket -- ^ socket to listen on + -> Handler IO -- ^ handler + -> IO () +serveSocket listenSocket handler = + forever $ + do (sock, addr) <- accept listenSocket + let reader = socketReader sock + writer = socketWriter sock + forkIO $ (requestLoop False addr reader writer handler) `finally` (sClose sock) + +-- | this is where we construct the pipe that reads from the socket, +-- processes the request, and sends the response +requestLoop :: Bool -- ^ is this an HTTPS connection + -> SockAddr -- ^ ip of the client + -> (() -> Server ProxyFast () ByteString IO ()) -- ^ Server to read data (Request) from + -> (() -> Client ProxyFast () ByteString IO ()) -- ^ Client to write data (Response) to + -> Handler IO -- ^ handler + -> IO () + +requestLoop secure addr reader writer handler = + runProxy $ reader >-> (evalStateK empty $ httpPipe secure addr handler) >-> writer + +-- | and this is the real heart of things +httpPipe :: Bool -- ^ is this an HTTPS connection + -> SockAddr + -> Handler IO + -> () + -> StateP ByteString ProxyFast () ByteString () ByteString IO b +httpPipe secure addr handler () = + forever $ + do request <- parseRequest secure addr + response <- ((liftP . (const $ handler request)) <-< pipeBody request) () + liftP $ responseWriter (response :: Response IO) + return () 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/Types.hs b/Types.hs new file mode 100644 --- /dev/null +++ b/Types.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE DeriveDataTypeable, RankNTypes, RecordWildCards #-} +module Types where + +import Control.Proxy +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as C +import Data.Data +import Network.Socket (SockAddr) +import Text.PrettyPrint.HughesPJ + +------------------------------------------------------------------------------ +-- 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 -- FIXME: don't use ByteString (use Ascii or something?) + 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) + + +------------------------------------------------------------------------------ +-- MessageBody +------------------------------------------------------------------------------ + +type MessageBody = ByteString + +------------------------------------------------------------------------------ +-- Request +------------------------------------------------------------------------------ + +data Request = Request + { rqMethod :: !Method + , rqURIbs :: !ByteString + , rqHTTPVersion :: !HTTPVersion + , rqHeaders :: ![(ByteString, ByteString)] + , rqSecure :: !Bool + , rqClient :: !SockAddr + } + 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 "}" + +ppHeader :: (ByteString, ByteString) -> Doc +ppHeader (fieldName, fieldValue) = + bytestring fieldName <> char ':' <> bytestring fieldValue + +------------------------------------------------------------------------------ +-- Response +------------------------------------------------------------------------------ + +data Response m = Response + { rsCode :: {-# UNPACK #-} !Int + , rsHeaders :: [(ByteString, ByteString)] + , rsBody :: Pipe ProxyFast ByteString MessageBody m () + } + +instance Show (Response m) where + show = show . ppResponse +{- +data ResponseBody + = SendFile FilePath (Maybe Int) (Maybe Int) + | ResponsePipe (Pipe ByteString MessageBody (ResourceT IO) ()) +-} +ppResponse :: Response m -> Doc +ppResponse Response{..} = + text "Response {" $+$ + nest 2 (vcat [ field "rsCode" (text $ show rsCode) + , field "rsHeaders" (vcat $ map ppHeader rsHeaders) + ]) $+$ + text "}" + + +------------------------------------------------------------------------------ +-- Misc +------------------------------------------------------------------------------ + +bytestring :: ByteString -> Doc +bytestring = text . C.unpack + +field :: String -> Doc -> Doc +field name doc = text name $$ nest 20 (char '=' <+> doc) diff --git a/hyperdrive.cabal b/hyperdrive.cabal new file mode 100644 --- /dev/null +++ b/hyperdrive.cabal @@ -0,0 +1,46 @@ +Name: hyperdrive +Version: 0.1 +Synopsis: a fast, trustworthy HTTP(s) server built +Description: hyperdrive aims to provide an HTTP server which is not only + extremely fast, but also provides a high-level of proof that + its implementation is correct. + . + hyperdrive is still in alpha and not at all suitable for + use. The current implementation is relatively fast, but does + not yet use any of the techniques for proof-of-correctness. It + also does not implement many essential features yet. +License: BSD3 +License-file: LICENSE +Author: Jeremy Shaw +Maintainer: jeremy@n-heptane.com +Copyright: 2012 Jeremy Shaw +Category: Web +Build-type: Simple +Cabal-version: >=1.6 + +source-repository head + type: darcs + subdir: hyperdrive + location: http://hub.darcs.net/stepcut/hyperdrive + +Library + Exposed-modules: Network + Response + Request + Serve + Types + Build-depends: base > 4.2 && <5, + bytestring == 0.10.*, + bytestring-lexing == 0.4.*, + extensible-exceptions == 0.1.*, + mtl == 2.1.*, + network == 2.4.*, + pipes == 3.0.*, + pretty == 1.1.* + GHC-Options: -O2 + +Executable pong + Main-Is: Pong.hs + GHC-Options: -threaded -O2 + Buildable: True +-- Build-depends: resourcet