@@ -1,212 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE OverloadedStrings #-}
4−---------------------------------------------------------
6−-- Module : Network.Wai.Handler.SimpleServer
7−-- Copyright : Michael Snoyman
10−-- Maintainer : Michael Snoyman <michael@snoyman.com>
12−-- Portability : portable
14−-- A simplistic HTTP server handler for Wai.
16−---------------------------------------------------------
17−module Network.Wai.Handler.SimpleServer
24−import Network.Wai.Handler.Helper
25−import qualified System.IO
27−import Data.ByteString (ByteString)
28−import qualified Data.ByteString.Char8 as B
30− ( listenOn, accept, sClose, PortID(PortNumber), Socket
32−import Control.Exception (bracket, finally, Exception, throwIO)
33−import System.IO (Handle, hClose, hFlush)
34−import System.IO.Error (isEOFError, ioeGetHandle)
35−import Control.Concurrent (forkIO)
36−import Control.Monad (unless)
37−import Data.Maybe (fromMaybe)
39−import Data.Typeable (Typeable)
41−import Control.Arrow (first)
43−import Data.Enumerator (($$), (>>==))
44−import qualified Data.Enumerator as E
45−import Data.Enumerator.IO (iterHandle)
46−import Blaze.ByteString.Builder.Enumerator (builderToByteString)
47−import Blaze.ByteString.Builder.HTTP
48− (chunkedTransferEncoding, chunkedTransferTerminator)
49−import Blaze.ByteString.Builder (fromByteString, Builder)
50−import Blaze.ByteString.Builder.Char8 (fromChar, fromString)
51−import Data.Monoid (mconcat)
53−run :: Port -> Application -> IO ()
54−run port = withSocketsDo .
56− (listenOn $ PortNumber $ fromIntegral port)
58− serveConnections port
61−serveConnections :: Port -> Application -> Socket -> IO ()
62−serveConnections port app socket = do
63− (conn, remoteHost', _) <- accept socket
64− _ <- forkIO $ serveConnection port app conn remoteHost'
65− serveConnections port app socket
67−serveConnection :: Port -> Application -> Handle -> String -> IO ()
68−serveConnection port app conn remoteHost' = do
74− where serveConnection' = do
75− env <- parseRequest port conn remoteHost'
77− sendResponse (httpVersion env) conn res
78− -- FIXME drain request body
82− catchEOFError :: IOError -> IO ()
83− catchEOFError e | isEOFError e = case ioeGetHandle e of
84− Just h -> unless (h == conn) (ioError e)
86− | otherwise = ioError e
88−parseRequest :: Port -> Handle -> String -> IO Request
89−parseRequest port conn remoteHost' = do
90− headers' <- takeUntilBlank conn id
91− parseRequest' port headers' conn remoteHost'
93−takeUntilBlank :: Handle
94− -> ([ByteString] -> [ByteString])
96−takeUntilBlank h front = do
97− l <- stripCR `fmap` B.hGetLine h
99− then return $ front []
100− else takeUntilBlank h $ front . (:) l
102−stripCR :: ByteString -> ByteString
105− | B.last bs == '\r' = B.init bs
108−data InvalidRequest =
109− NotEnoughLines [String]
110− | BadFirstLine String
112− deriving (Show, Typeable)
113−instance Exception InvalidRequest
115−-- | Parse a set of header lines and body into a 'Request'.
116−parseRequest' :: Port
121−parseRequest' port lines' handle remoteHost' = do
122− (firstLine, otherLines) <-
124− x:xs -> return (x, xs)
125− [] -> throwIO $ NotEnoughLines $ map B.unpack lines'
126− (method, rpath', gets, httpversion) <- parseFirst firstLine
127− let rpath = '/' : case B.unpack rpath' of
129− _ -> B.unpack rpath'
130− let heads = map (first mkCIByteString . parseHeaderNoAttr) otherLines
131− let host = fromMaybe "" $ lookup "host" heads
132− let len = fromMaybe 0 $ do
133− bs <- lookup "Content-Length" heads
134− let str = B.unpack bs
138− let (serverName', _) = B.break (== ':') host
140− { requestMethod = method
141− , httpVersion = httpversion
142− , pathInfo = B.pack rpath
143− , queryString = gets
144− , serverName = serverName'
146− , requestHeaders = heads
148− , requestBody = requestBodyHandle handle len
149− , errorHandler = System.IO.hPutStr System.IO.stderr
150− , remoteHost = B.pack remoteHost'
153−parseFirst :: ByteString
154− -> IO (ByteString, ByteString, ByteString, HttpVersion)
156− let pieces = B.words s
157− (method, query, http') <-
159− [x, y, z] -> return (x, y, z)
160− _ -> throwIO $ BadFirstLine $ B.unpack s
161− let (hfirst, hsecond) = B.splitAt 5 http'
162− unless (hfirst == B.pack "HTTP/") $ throwIO NonHttp
163− let (rpath, qstring) = B.break (== '?') query
164− return (method, rpath, qstring, hsecond)
166−headers :: HttpVersion -> Status -> ResponseHeaders -> Builder
167−headers httpversion status responseHeaders = mconcat
168− [ fromByteString "HTTP/"
169− , fromByteString httpversion
171− , fromString $ show $ statusCode status
173− , fromByteString $ statusMessage status
174− , fromByteString "\r\n"
175− , mconcat $ map go responseHeaders
176− , fromByteString "Transfer-Encoding: chunked\r\n\r\n" -- FIXME perhaps put in non-chunked for HTTP 1.0 clients?
180− [ fromByteString $ ciOriginal x
181− , fromByteString ": "
183− , fromByteString "\r\n"
186−sendResponse :: HttpVersion -> Handle -> Response -> IO ()
187−sendResponse hv handle res = do
188− responseEnumerator res $ \s hs ->
190− $$ E.enumList 1 [headers hv s hs]
191− $$ E.joinI $ builderToByteString
192− $$ iterHandle handle
194− chunk :: E.Enumeratee Builder Builder IO ()
195− chunk = E.checkDone $ E.continue . step
196− step k E.EOF = k (E.Chunks [chunkedTransferTerminator]) >>== return
197− step k (E.Chunks []) = E.continue $ step k
198− step k (E.Chunks builders) =
199− k (E.Chunks [chunked]) >>== chunk
201− chunked = chunkedTransferEncoding $ mconcat builders
203−parseHeaderNoAttr :: ByteString -> (ByteString, ByteString)
204−parseHeaderNoAttr s =
205− let (k, rest) = B.span (/= ':') s
206− rest' = if not (B.null rest) &&
207− B.head rest == ':' &&
208− not (B.null $ B.tail rest) &&
209− B.head (B.tail rest) == ' '