@@ -1,184 +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− ) where
20−
21−import Network.Wai
22−import qualified System.IO
23−
24−import qualified Data.ByteString as BS
25−import qualified Data.ByteString.Lazy as L
26−import qualified Data.ByteString.Char8 as B8
27−import Network
28− ( listenOn, accept, sClose, PortID(PortNumber), Socket
29− , withSocketsDo)
30−import Control.Exception (bracket, finally, Exception)
31−import System.IO (Handle, hClose)
32−import Control.Concurrent (forkIO)
33−import Control.Monad (unless)
34−import Data.Maybe (isJust, fromJust, fromMaybe)
35−
36−import Control.Failure
37−import Data.Typeable (Typeable)
38−
39−import Web.Encodings.StringLike (StringLike)
40−import qualified Web.Encodings.StringLike as SL
41−
42−import qualified Safe
43−import Network.Socket.SendFile
44−import Control.Arrow (first)
45−
46−run :: Port -> Application -> IO ()
47−run port = withSocketsDo .
48− bracket
49− (listenOn $ PortNumber $ fromIntegral port)
50− sClose .
51− serveConnections port
52−type Port = Int
53−
54−serveConnections :: Port -> Application -> Socket -> IO ()
55−serveConnections port app socket = do
56− (conn, remoteHost', _) <- accept socket
57− _ <- forkIO $ serveConnection port app conn remoteHost'
58− serveConnections port app socket
59−
60−serveConnection :: Port -> Application -> Handle -> String -> IO ()
61−serveConnection port app conn remoteHost' =
62− finally
63− serveConnection'
64− (hClose conn)
65− where
66− serveConnection' = do
67− env <- hParseRequest port conn remoteHost'
68− res <- app env
69− sendResponse conn res
70−
71−hParseRequest :: Port -> Handle -> String -> IO Request
72−hParseRequest port conn remoteHost' = do
73− headers' <- takeUntilBlank conn id
74− parseRequest port headers' conn remoteHost'
75−
76−takeUntilBlank :: Handle
77− -> ([BS.ByteString] -> [BS.ByteString])
78− -> IO [BS.ByteString]
79−takeUntilBlank h front = do
80− l <- stripCR `fmap` BS.hGetLine h
81− if BS.null l
82− then return $ front []
83− else takeUntilBlank h $ front . (:) l
84−
85−stripCR :: BS.ByteString -> BS.ByteString
86−stripCR bs
87− | BS.null bs = bs
88− | B8.last bs == '\r' = BS.init bs
89− | otherwise = bs
90−
91−data InvalidRequest =
92− NotEnoughLines [String]
93− | HostNotIncluded
94− | BadFirstLine String
95− | NonHttp11
96− deriving (Show, Typeable)
97−instance Exception InvalidRequest
98−
99−-- | Parse a set of header lines and body into a 'Request'.
100−parseRequest :: Port
101− -> [BS.ByteString]
102− -> Handle
103− -> String
104− -> IO Request
105−parseRequest port lines' handle remoteHost' = do
106− case lines' of
107− (_:_:_) -> return ()
108− _ -> failure $ NotEnoughLines $ map SL.unpack lines'
109− (method, rpath', gets) <- parseFirst $ head lines'
110− let rpath = '/' : case SL.unpack rpath' of
111− ('/':x) -> x
112− _ -> SL.unpack rpath'
113− let heads = map (first mkCIByteString . parseHeaderNoAttr) $ tail lines'
114− let host' = lookup "Host" heads
115− unless (isJust host') $ failure HostNotIncluded
116− let host = fromJust host'
117− let len = fromMaybe 0 $ do
118− bs <- lookup "Content-Length" heads
119− let str = SL.unpack bs
120− Safe.readMay str
121− let (serverName', _) = SL.breakChar ':' host
122− return $ Request
123− { requestMethod = method
124− , httpVersion = http11
125− , pathInfo = SL.pack rpath
126− , queryString = gets
127− , serverName = serverName'
128− , serverPort = port
129− , requestHeaders = heads
130− , isSecure = False
131− , requestBody = requestBodyHandle handle len
132− , errorHandler = System.IO.hPutStr System.IO.stderr
133− , remoteHost = B8.pack remoteHost'
134− }
135−
136−requestBodyHandle :: Handle -> Int -> Source
137−requestBodyHandle _ 0 = Source $ return Nothing
138−requestBodyHandle h len = Source $ do
139− let maxChunkSize = 1024
140− bs <- BS.hGet h $ min len maxChunkSize
141− let newLen = len - BS.length bs
142− putStrLn $ "reading a chunk of size " ++ show (BS.length bs)
143− return $ Just (bs, requestBodyHandle h newLen)
144−
145−parseFirst :: (StringLike s, Failure InvalidRequest m) =>
146− s
147− -> m (s, s, s)
148−parseFirst s = do
149− let pieces = SL.split ' ' s
150− (method, query, http') <-
151− case pieces of
152− [x, y, z] -> return (x, y, z)
153− _ -> failure $ BadFirstLine $ SL.unpack s
154− unless (http' == SL.pack "HTTP/1.1") $ failure NonHttp11
155− let (rpath, qstring) = SL.breakChar '?' query
156− return (method, rpath, qstring)
157−
158−sendResponse :: Handle -> Response -> IO ()
159−sendResponse h res = do
160− BS.hPut h $ SL.pack "HTTP/1.1 "
161− BS.hPut h $ SL.pack $ show $ statusCode $ status res
162− BS.hPut h $ statusMessage $ status res
163− BS.hPut h $ SL.pack "\r\n"
164− mapM_ putHeader $ map (first ciOriginal) $ responseHeaders res
165− BS.hPut h $ SL.pack "\r\n"
166− case responseBody res of
167− ResponseFile fp -> unsafeSendFile h fp
168− ResponseEnumerator (Enumerator enum) -> enum myPut h >> return ()
169− ResponseLBS lbs -> L.hPutStr h lbs
170− where
171− myPut _ bs = do
172− putStrLn $ "sending a chunk of size " ++ show (BS.length bs)
173− BS.hPut h bs
174− return (Right h)
175− putHeader (x, y) = do
176− BS.hPut h x
177− BS.hPut h $ SL.pack ": "
178− BS.hPut h y
179− BS.hPut h $ SL.pack "\r\n"
180−
181−parseHeaderNoAttr :: StringLike a => a -> (a, a)
182−parseHeaderNoAttr s =
183− let (k, rest) = SL.span (/= ':') s
184− in (k, SL.dropPrefix' (SL.pack ": ") rest)