hyperdrive (empty) → 0.1
raw patch · 9 files changed
+646/−0 lines, 9 filesdep +basedep +bytestringdep +bytestring-lexingsetup-changed
Dependencies added: base, bytestring, bytestring-lexing, extensible-exceptions, mtl, network, pipes, pretty
Files
- LICENSE +30/−0
- Network.hs +50/−0
- Pong.hs +28/−0
- Request.hs +236/−0
- Response.hs +54/−0
- Serve.hs +73/−0
- Setup.hs +2/−0
- Types.hs +127/−0
- hyperdrive.cabal +46/−0
+ LICENSE view
@@ -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.
+ Network.hs view
@@ -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)
+ Pong.hs view
@@ -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
+ Request.hs view
@@ -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 = <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 :: (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+-}
+ Response.hs view
@@ -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"]+
+ Serve.hs view
@@ -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 ()
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Types.hs view
@@ -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)
+ hyperdrive.cabal view
@@ -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