Permalink
Browse files

A simple static HTTP server.

  • Loading branch information...
1 parent cee5f4e commit a8048235acf213cd95e9e9e0a4f8016c513c357e @bos bos committed Feb 17, 2010
View
@@ -30,3 +30,5 @@ benchmarks/simple
benchmarks/thread-delay
benchmarks/timers
tests/tests
+benchmarks/static-http
+benchmarks/NoPush.hs
View
@@ -6,6 +6,7 @@ autom4te.cache
benchmarks/IntMap
benchmarks/PSQ
benchmarks/Simple
+benchmarks/static-http
config.log
config.mk
config.status
@@ -31,3 +32,4 @@ benchmarks/simple
benchmarks/thread-delay
benchmarks/timers
tests/tests
+benchmarks/NoPush.hs
View
@@ -61,7 +61,7 @@ main = withSocketsDo $ do
putStrLn $ show numConns ++ " threads looping"
-- Block process forever.
- threadDelay maxBound
+ --threadDelay maxBound
request = "GET / HTTP/1.1\r\nHost: www.test.com\r\n\r\n"
View
@@ -0,0 +1,80 @@
+{-# LANGUAGE CPP, ForeignFunctionInterface #-}
+
+-- | File functions using System.Event instead of GHC's I/O manager.
+module EventFile
+ (
+ read
+ ) where
+
+import Control.Concurrent (modifyMVar_, newMVar)
+import Control.Monad (liftM, when)
+import Data.ByteString (ByteString)
+import Data.ByteString.Internal (createAndTrim)
+import Data.Word (Word8)
+import qualified Data.ByteString as B
+import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
+import Foreign.C.Types (CChar, CInt, CSize)
+import Foreign.Marshal.Alloc (allocaBytes)
+import Foreign.Marshal.Utils (with)
+import Foreign.Ptr (Ptr, castPtr)
+import Foreign.C.Error (Errno(..), eINPROGRESS, eINTR, eWOULDBLOCK, eAGAIN,
+ errnoToIOError, getErrno, throwErrno)
+#if __GLASGOW_HASKELL__ < 612
+import GHC.IOBase (IOErrorType(..))
+#else
+import GHC.IO.Exception (IOErrorType(..))
+#endif
+import Network.Socket hiding (accept, connect, recv, send)
+#if defined(USE_GHC_IO_MANAGER)
+import GHC.Conc (threadWaitRead)
+#else
+import System.Event.Thread (threadWaitRead)
+#endif
+import System.IO.Error (ioeSetErrorString, mkIOError)
+import System.Posix.Internals (c_read)
+import System.Posix.Types (Fd)
+import Prelude hiding (read)
+
+read :: Fd -> Int -> IO ByteString
+read fd nbytes
+ | nbytes <= 0 = ioError (mkInvalidReadArgError "read")
+ | otherwise = createAndTrim nbytes $ readInner fd nbytes
+
+readInner :: Fd -> Int -> Ptr Word8 -> IO Int
+readInner fd nbytes ptr = do
+ len <- throwErrnoIfMinus1Retry_repeatOnBlock "read"
+ (threadWaitRead (fromIntegral fd)) $
+ c_read (fromIntegral fd) (castPtr ptr) (fromIntegral nbytes)
+ case fromIntegral len of
+ (-1) -> do errno <- getErrno
+ if errno == eINTR
+ then readInner fd nbytes ptr
+ else throwErrno "read"
+ n -> return n
+
+{-# SPECIALISE
+ throwErrnoIfMinus1Retry_mayBlock
+ :: String -> IO CInt -> IO CInt -> IO CInt #-}
+throwErrnoIfMinus1Retry_mayBlock :: Num a => String -> IO a -> IO a -> IO a
+throwErrnoIfMinus1Retry_mayBlock name on_block act = do
+ res <- act
+ if res == -1
+ then do
+ err <- getErrno
+ if err == eINTR
+ then throwErrnoIfMinus1Retry_mayBlock name on_block act
+ else if err == eWOULDBLOCK || err == eAGAIN
+ then on_block
+ else throwErrno name
+ else return res
+
+throwErrnoIfMinus1Retry_repeatOnBlock :: Num a => String -> IO b -> IO a -> IO a
+throwErrnoIfMinus1Retry_repeatOnBlock name on_block act = do
+ throwErrnoIfMinus1Retry_mayBlock name (on_block >> repeat) act
+ where repeat = throwErrnoIfMinus1Retry_repeatOnBlock name on_block act
+
+mkInvalidReadArgError :: String -> IOError
+mkInvalidReadArgError loc = ioeSetErrorString (mkIOError
+ InvalidArgument
+ loc Nothing Nothing)
+ "non-positive length"
@@ -23,7 +23,11 @@ import Foreign.Marshal.Utils (with)
import Foreign.Ptr (Ptr, castPtr)
import Foreign.C.Error (Errno(..), eINPROGRESS, eINTR, eWOULDBLOCK, eAGAIN,
errnoToIOError, getErrno, throwErrno)
+#if __GLASGOW_HASKELL__ < 612
import GHC.IOBase (IOErrorType(..))
+#else
+import GHC.IO.Exception (IOErrorType(..))
+#endif
import Network.Socket hiding (accept, connect, recv, send)
import Network.Socket.Internal
import Prelude hiding (repeat)
View
@@ -4,7 +4,8 @@ cc-opt-flags = -O2
include ../tests/common.mk
-ghc-bench-flags := -package network -package network-bytestring
+ghc-bench-flags := -package network -package network-bytestring \
+ -package attoparsec -package bytestring-show
ifdef USE_GHC_IO_MANAGER
ghc-bench-flags += -DUSE_GHC_IO_MANAGER
@@ -14,7 +15,7 @@ ifdef USE_EVENTLOG
ghc-bench-flags += -eventlog
endif
-programs := dead-conn deadconn pong-server signal simple thread-delay timers
+programs := dead-conn deadconn pong-server signal simple static-http thread-delay timers
.PHONY: all
all: $(programs)
@@ -33,6 +34,11 @@ pong-server: $(lib) Args.o EventSocket.o PongServer.o
ranlib $(lib)
$(ghc) $(ghc-flags) -threaded -o $@ $(filter %.o,$^) $(lib)
+static-http: ghc-flags += $(ghc-bench-flags)
+static-http: $(lib) EventFile.o EventSocket.o NoPush.o RFC2616.o StaticHttp.o
+ ranlib $(lib)
+ $(ghc) $(ghc-flags) -threaded -o $@ $(filter %.o,$^) $(lib)
+
signal: $(lib) Signal.o
ranlib $(lib)
$(ghc) $(ghc-flags) -threaded -o $@ $(filter %.o,$^) $(lib)
@@ -56,6 +62,9 @@ timers: $(lib) Args.o Timers.o
%.o: %.c
$(cc) $(cc-opt-flags) -c -o $@ $<
+%.hs: %.hsc
+ hsc2hs $<
+
.PHONY: clean
clean:
-find . \( -name '*.o' -o -name '*.hi' \) -exec rm {} \;
View
@@ -0,0 +1,34 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module NoPush (setNoPush) where
+
+#include <sys/socket.h>
+#include <netinet/tcp.h>
+#include <netinet/in.h>
+
+import Foreign.C.Error (throwErrnoIfMinus1_)
+import Foreign.C.Types (CInt)
+import Foreign.Marshal.Utils (with)
+import Foreign.Ptr (Ptr)
+import Foreign.Storable (sizeOf)
+import Network.Socket (Socket(..))
+
+noPush :: CInt
+#if defined(TCP_NOPUSH)
+noPush = #const TCP_NOPUSH
+#elif defined(TCP_CORK)
+noPush = #const TCP_CORK
+#else
+noPush = 0
+#endif
+
+setNoPush :: Socket -> Bool -> IO ()
+setNoPush _ _ | noPush == 0 = return ()
+setNoPush (MkSocket fd _ _ _ _) onOff = do
+ let v = if onOff then 1 else 0
+ with v $ \ptr ->
+ throwErrnoIfMinus1_ "setNoPush" $
+ c_setsockopt fd (#const IPPROTO_TCP) noPush ptr (fromIntegral (sizeOf v))
+
+foreign import stdcall unsafe "setsockopt"
+ c_setsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> CInt -> IO CInt
View
@@ -8,7 +8,7 @@
-- ab -n 10000 -c 100 http://localhost:5002/
import Args (ljust, parseArgs, positive, theLast)
-import Control.Concurrent (forkIO)
+import Control.Concurrent (forkIO, runInUnboundThread)
import Data.ByteString.Char8 ()
import Data.Function (on)
import Data.Monoid (Monoid(..), Last(..))
@@ -20,10 +20,10 @@ import Network.Socket (accept)
import Network.Socket.ByteString (recv, sendAll)
#else
import EventSocket (accept, recv, sendAll)
+import System.Event.Thread (ensureIOManagerIsRunning)
#endif
import System.Console.GetOpt (ArgDescr(ReqArg), OptDescr(..))
import System.Environment (getArgs)
-import System.Event.Thread (ensureIOManagerIsRunning)
import System.Posix.Resource (ResourceLimit(..), ResourceLimits(..),
Resource(..), setResourceLimit)
@@ -43,7 +43,7 @@ main = do
setSocketOption sock ReuseAddr 1
bindSocket sock (addrAddress ai)
listen sock maxListenQueue
- acceptConnections sock
+ runInUnboundThread $ acceptConnections sock
acceptConnections :: Socket -> IO ()
acceptConnections sock = loop
View
@@ -0,0 +1,58 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module RFC2616
+ (
+ Request(..)
+ , Header(..)
+ , isToken
+ , requestLine
+ , messageHeader
+ , request
+ ) where
+
+import Control.Applicative hiding (many)
+import Data.Attoparsec as P
+import Data.Attoparsec.Char8 (char8, endOfLine)
+import Data.Word (Word8)
+import qualified Data.ByteString.Char8 as B
+
+isToken :: Word8 -> Bool
+isToken w = w <= 127 && notInClass "\0-\31()<>@,;:\\\"/[]?={} \t" w
+
+skipSpaces :: Parser ()
+skipSpaces = satisfy spc *> skipWhile spc
+ where spc = inClass " \t"
+
+data Request = Request {
+ requestMethod :: !B.ByteString
+ , requestUri :: !B.ByteString
+ , requestProtocol :: !B.ByteString
+ } deriving (Eq, Ord, Show)
+
+requestLine :: Parser Request
+requestLine = do
+ method <- P.takeWhile isToken
+ skipSpaces
+ uri <- P.takeWhile (notInClass " \t")
+ skipSpaces >> string "HTTP/"
+ proto <- P.takeWhile (inClass "0-9.")
+ endOfLine
+ return $! Request method uri proto
+
+data Header = Header {
+ headerName :: !B.ByteString
+ , headerValue :: [B.ByteString]
+ } deriving (Eq, Ord, Show)
+
+messageHeader :: Parser Header
+messageHeader = do
+ header <- P.takeWhile isToken
+ char8 ':' *> skipSpaces
+ body <- takeTill (inClass "\r\n")
+ endOfLine
+ bodies <- many $ satisfy (inClass " \t") *> skipSpaces *>
+ takeTill (inClass "\r\n") <* endOfLine
+ return $! Header header (body:bodies)
+
+request :: Parser (Request, [Header])
+request = (,) <$> requestLine <*> many messageHeader
View
@@ -0,0 +1,80 @@
+{-# LANGUAGE CPP, OverloadedStrings #-}
+
+import Control.Concurrent (forkIO, runInUnboundThread)
+import Control.Exception (bracket, finally)
+import Control.Monad (unless)
+import qualified Data.Attoparsec as A
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy as L
+import Network.Socket hiding (accept, recv)
+#ifdef USE_GHC_IO_MANAGER
+import Network.Socket (accept)
+import Network.Socket.ByteString (recv, sendAll)
+#else
+import EventSocket (accept, recv, sendAll)
+import System.Event.Thread (ensureIOManagerIsRunning)
+#endif
+import qualified EventFile as F
+import System.Posix.Files
+import System.Posix.IO
+import qualified Text.Show.ByteString as S
+import NoPush
+import RFC2616
+
+strict :: L.ByteString -> B.ByteString
+strict = B.concat . L.toChunks
+
+main = do
+ let port = "5002"
+ myHints = defaultHints { addrFlags = [AI_PASSIVE]
+ , addrSocketType = Stream }
+ (ai:_) <- getAddrInfo (Just myHints) Nothing (Just port)
+#ifndef USE_GHC_IO_MANAGER
+ ensureIOManagerIsRunning
+#endif
+ sock <- socket (addrFamily ai) (addrSocketType ai) (addrProtocol ai)
+ setSocketOption sock ReuseAddr 1
+ bindSocket sock (addrAddress ai)
+ listen sock maxListenQueue
+ runInUnboundThread $ acceptConnections sock
+
+acceptConnections :: Socket -> IO ()
+acceptConnections sock = loop
+ where
+ loop = do
+ (c,_) <- accept sock
+ forkIO $ client c
+ loop
+
+parseM :: Monad m => (m B.ByteString) -> A.Parser a -> m (B.ByteString, Either String a)
+parseM refill p = (step . A.parse p) =<< refill
+ where step (A.Fail bs _stk msg) = return (bs, Left msg)
+ step (A.Partial k) = (step . k) =<< refill
+ step (A.Done bs r) = return (bs, Right r)
+
+asInt :: Integral a => a -> Int
+asInt = fromIntegral
+
+client :: Socket -> IO ()
+client sock = (`finally` sClose sock) $ do
+ -- setNoPush sock True
+ (_bs, ereq) <- parseM (recv sock 4096) request
+ case ereq of
+ Right (req,hdrs) | requestMethod req == "GET" ->
+ bracket (openFd (B.unpack (requestUri req)) ReadOnly Nothing
+ defaultFileFlags{nonBlock=True}) closeFd $ \fd -> do
+ st <- getFdStatus fd
+ let fixedHeaders = B.intercalate "\r\n" [
+ "HTTP/1.1 200 OK"
+ , "Content-type: application/octet-stream"
+ , "Connection: close"
+ ]
+ sendAll sock $! (`B.append` "\r\n\r\n") $ B.intercalate "\r\n" [
+ fixedHeaders
+ , B.append "Content-length: " . strict . S.show . asInt . fileSize $ st
+ ]
+ let go = do
+ s <- F.read fd 16384
+ unless (B.null s) $ sendAll sock s >> go
+ go
+ _ -> sendAll sock "HTTP/1.1 400 Bad Request\r\nConnection: close\r\n\r\n"
@@ -4,7 +4,7 @@
-- number of milliseconds and wait for them all to finish.
import Args (ljust, parseArgs, positive, theLast)
-import Control.Concurrent (forkIO)
+import Control.Concurrent (forkIO, runInUnboundThread)
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
import Control.Monad (when)
import Data.Function (on)
@@ -36,8 +36,7 @@ main = do
let !b = a+1 in (b,b)
when (a == numThreads) $ putMVar done ()
loop (i + 1)
- loop 0
- takeMVar done
+ runInUnboundThread $ loop 0 >> takeMVar done
------------------------------------------------------------------------
-- Configuration

0 comments on commit a804823

Please sign in to comment.