@@ -0,0 +1,186 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+---------------------------------------------------------
4+-- |
5+-- Module : Network.Wai.Handler.SimpleServer
6+-- Copyright : Michael Snoyman
7+-- License : BSD3
8+--
9+-- Maintainer : Michael Snoyman <michael@snoyman.com>
10+-- Stability : Stable
11+-- Portability : portable
12+--
13+-- A simplistic HTTP server handler for Wai.
14+--
15+---------------------------------------------------------
16+module Network.Wai.Handler.SimpleServer
17+ ( run
18+ ) where
19+
20+import Network.Wai
21+import qualified System.IO
22+
23+import qualified Data.ByteString as BS
24+import qualified Data.ByteString.Char8 as B8
25+import Network
26+ ( listenOn, accept, sClose, PortID(PortNumber), Socket
27+ , withSocketsDo)
28+import Control.Exception (bracket, finally, Exception)
29+import System.IO (Handle, hClose)
30+import Control.Concurrent
31+import Control.Monad (unless)
32+import Data.Maybe (isJust, fromJust, fromMaybe)
33+
34+import Control.Failure
35+import Data.Typeable (Typeable)
36+
37+import Web.Encodings.StringLike (StringLike)
38+import qualified Web.Encodings.StringLike as SL
39+
40+import qualified Safe
41+import Network.Socket.SendFile
42+import Control.Arrow (first)
43+
44+run :: Port -> Application -> IO ()
45+run port = withSocketsDo .
46+ bracket
47+ (listenOn $ PortNumber $ fromIntegral port)
48+ sClose .
49+ serveConnections port
50+type Port = Int
51+
52+serveConnections :: Port -> Application -> Socket -> IO ()
53+serveConnections port app socket = do
54+ (conn, remoteHost', _) <- accept socket
55+ _ <- forkIO $ serveConnection port app conn remoteHost'
56+ serveConnections port app socket
57+
58+serveConnection :: Port -> Application -> Handle -> String -> IO ()
59+serveConnection port app conn remoteHost' =
60+ finally
61+ serveConnection'
62+ (hClose conn)
63+ where
64+ serveConnection' = do
65+ env <- hParseRequest port conn remoteHost'
66+ res <- app env
67+ sendResponse conn res
68+
69+hParseRequest :: Port -> Handle -> String -> IO Request
70+hParseRequest port conn remoteHost' = do
71+ headers' <- takeUntilBlank conn id
72+ parseRequest port headers' conn remoteHost'
73+
74+takeUntilBlank :: Handle
75+ -> ([BS.ByteString] -> [BS.ByteString])
76+ -> IO [BS.ByteString]
77+takeUntilBlank h front = do
78+ l <- stripCR `fmap` BS.hGetLine h
79+ if BS.null l
80+ then return $ front []
81+ else takeUntilBlank h $ front . (:) l
82+
83+stripCR :: BS.ByteString -> BS.ByteString
84+stripCR bs
85+ | BS.null bs = bs
86+ | B8.last bs == '\r' = BS.init bs
87+ | otherwise = bs
88+
89+data InvalidRequest =
90+ NotEnoughLines [String]
91+ | HostNotIncluded
92+ | BadFirstLine String
93+ | NonHttp11
94+ deriving (Show, Typeable)
95+instance Exception InvalidRequest
96+
97+-- | Parse a set of header lines and body into a 'Request'.
98+parseRequest :: Port
99+ -> [BS.ByteString]
100+ -> Handle
101+ -> String
102+ -> IO Request
103+parseRequest port lines' handle remoteHost' = do
104+ case lines' of
105+ (_:_:_) -> return ()
106+ _ -> failure $ NotEnoughLines $ map SL.unpack lines'
107+ (method', rpath', gets) <- parseFirst $ head lines'
108+ let method = methodFromBS method'
109+ let rpath = '/' : case SL.unpack rpath' of
110+ ('/':x) -> x
111+ _ -> SL.unpack rpath'
112+ let heads = map (first requestHeaderFromBS . parseHeaderNoAttr)
113+ $ 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 ReqContentLength heads
119+ let str = SL.unpack bs
120+ Safe.readMay str
121+ mlen <- newMVar len
122+ let (serverName', _) = SL.breakChar ':' host
123+ return $ Request
124+ { requestMethod = method
125+ , httpVersion = Http11
126+ , pathInfo = SL.pack rpath
127+ , queryString = gets
128+ , serverName = serverName'
129+ , serverPort = port
130+ , httpHeaders = heads
131+ , urlScheme = HTTP
132+ , requestBody = requestBodyHandle handle mlen
133+ , errorHandler = System.IO.hPutStr System.IO.stderr
134+ , remoteHost = B8.pack remoteHost'
135+ }
136+
137+requestBodyHandle :: Handle -> MVar Int -> Enumerator a
138+requestBodyHandle h mlen iter accum = modifyMVar mlen (helper accum) where
139+ helper a 0 = return (0, Right a)
140+ helper a len = do
141+ let maxChunkSize = 1024
142+ bs <- BS.hGet h $ min len maxChunkSize
143+ let newLen = len - BS.length bs
144+ ea' <- iter a bs
145+ case ea' of
146+ Left a' -> return (newLen, Left a')
147+ Right a' -> helper a' newLen
148+
149+parseFirst :: (StringLike s, MonadFailure InvalidRequest m) =>
150+ s
151+ -> m (s, s, s)
152+parseFirst s = do
153+ let pieces = SL.split ' ' s
154+ (method, query, http') <-
155+ case pieces of
156+ [x, y, z] -> return (x, y, z)
157+ _ -> failure $ BadFirstLine $ SL.unpack s
158+ unless (http' == SL.pack "HTTP/1.1") $ failure NonHttp11
159+ let (rpath, qstring) = SL.breakChar '?' query
160+ return (method, rpath, qstring)
161+
162+sendResponse :: Handle -> Response -> IO ()
163+sendResponse h res = do
164+ BS.hPut h $ SL.pack "HTTP/1.1 "
165+ BS.hPut h $ SL.pack $ show $ statusCode $ status res
166+ BS.hPut h $ statusMessage $ status res
167+ BS.hPut h $ SL.pack "\r\n"
168+ mapM_ putHeader $ headers res
169+ BS.hPut h $ SL.pack "\r\n"
170+ case body res of
171+ Left fp -> unsafeSendFile h fp
172+ Right enum -> enum myPut h >> return ()
173+ where
174+ myPut _ bs = do
175+ BS.hPut h bs
176+ return (Right h)
177+ putHeader (x, y) = do
178+ BS.hPut h $ responseHeaderToBS x
179+ BS.hPut h $ SL.pack ": "
180+ BS.hPut h y
181+ BS.hPut h $ SL.pack "\r\n"
182+
183+parseHeaderNoAttr :: StringLike a => a -> (a, a)
184+parseHeaderNoAttr s =
185+ let (k, rest) = SL.span (/= ':') s
186+ in (k, SL.dropPrefix' (SL.pack ": ") rest)