@@ -1,212 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE OverloadedStrings #-}
4−---------------------------------------------------------
5−-- |
6−-- Module : Network.Wai.Handler.SimpleServer
7−-- Copyright : Michael Snoyman
8−-- License : BSD3
9−--
10−-- Maintainer : Michael Snoyman <michael@snoyman.com>
11−-- Stability : Stable
12−-- Portability : portable
13−--
14−-- A simplistic HTTP server handler for Wai.
15−--
16−---------------------------------------------------------
17−module Network.Wai.Handler.SimpleServer
18− ( run
19− , sendResponse
20− , parseRequest
21− ) where
22−
23−import Network.Wai
24−import Network.Wai.Handler.Helper
25−import qualified System.IO
26−
27−import Data.ByteString (ByteString)
28−import qualified Data.ByteString.Char8 as B
29−import Network
30− ( listenOn, accept, sClose, PortID(PortNumber), Socket
31− , withSocketsDo)
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)
38−
39−import Data.Typeable (Typeable)
40−
41−import Control.Arrow (first)
42−
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)
52−
53−run :: Port -> Application -> IO ()
54−run port = withSocketsDo .
55− bracket
56− (listenOn $ PortNumber $ fromIntegral port)
57− sClose .
58− serveConnections port
59−type Port = Int
60−
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
66−
67−serveConnection :: Port -> Application -> Handle -> String -> IO ()
68−serveConnection port app conn remoteHost' = do
69− catch
70− (finally
71− serveConnection'
72− (hClose conn))
73− catchEOFError
74− where serveConnection' = do
75− env <- parseRequest port conn remoteHost'
76− res <- app env
77− sendResponse (httpVersion env) conn res
78− -- FIXME drain request body
79− hFlush conn
80− serveConnection'
81−
82− catchEOFError :: IOError -> IO ()
83− catchEOFError e | isEOFError e = case ioeGetHandle e of
84− Just h -> unless (h == conn) (ioError e)
85− Nothing -> ioError e
86− | otherwise = ioError e
87−
88−parseRequest :: Port -> Handle -> String -> IO Request
89−parseRequest port conn remoteHost' = do
90− headers' <- takeUntilBlank conn id
91− parseRequest' port headers' conn remoteHost'
92−
93−takeUntilBlank :: Handle
94− -> ([ByteString] -> [ByteString])
95− -> IO [ByteString]
96−takeUntilBlank h front = do
97− l <- stripCR `fmap` B.hGetLine h
98− if B.null l
99− then return $ front []
100− else takeUntilBlank h $ front . (:) l
101−
102−stripCR :: ByteString -> ByteString
103−stripCR bs
104− | B.null bs = bs
105− | B.last bs == '\r' = B.init bs
106− | otherwise = bs
107−
108−data InvalidRequest =
109− NotEnoughLines [String]
110− | BadFirstLine String
111− | NonHttp
112− deriving (Show, Typeable)
113−instance Exception InvalidRequest
114−
115−-- | Parse a set of header lines and body into a 'Request'.
116−parseRequest' :: Port
117− -> [ByteString]
118− -> Handle
119− -> String
120− -> IO Request
121−parseRequest' port lines' handle remoteHost' = do
122− (firstLine, otherLines) <-
123− case lines' of
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
128− ('/':x) -> x
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
135− case reads str of
136− (x, _):_ -> Just x
137− _ -> Nothing
138− let (serverName', _) = B.break (== ':') host
139− return $ Request
140− { requestMethod = method
141− , httpVersion = httpversion
142− , pathInfo = B.pack rpath
143− , queryString = gets
144− , serverName = serverName'
145− , serverPort = port
146− , requestHeaders = heads
147− , isSecure = False
148− , requestBody = requestBodyHandle handle len
149− , errorHandler = System.IO.hPutStr System.IO.stderr
150− , remoteHost = B.pack remoteHost'
151− }
152−
153−parseFirst :: ByteString
154− -> IO (ByteString, ByteString, ByteString, HttpVersion)
155−parseFirst s = do
156− let pieces = B.words s
157− (method, query, http') <-
158− case pieces of
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)
165−
166−headers :: HttpVersion -> Status -> ResponseHeaders -> Builder
167−headers httpversion status responseHeaders = mconcat
168− [ fromByteString "HTTP/"
169− , fromByteString httpversion
170− , fromChar ' '
171− , fromString $ show $ statusCode status
172− , fromChar ' '
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?
177− ]
178− where
179− go (x, y) = mconcat
180− [ fromByteString $ ciOriginal x
181− , fromByteString ": "
182− , fromByteString y
183− , fromByteString "\r\n"
184− ]
185−
186−sendResponse :: HttpVersion -> Handle -> Response -> IO ()
187−sendResponse hv handle res = do
188− responseEnumerator res $ \s hs ->
189− E.joinI $ chunk
190− $$ E.enumList 1 [headers hv s hs]
191− $$ E.joinI $ builderToByteString
192− $$ iterHandle handle
193− where
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
200− where
201− chunked = chunkedTransferEncoding $ mconcat builders
202−
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) == ' '
210− then B.drop 2 rest
211− else rest
212− in (k, rest')