@@ -0,0 +1,180 @@
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)
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+run :: Port -> Application -> IO ()
41+run port = withSocketsDo .
42+ bracket
43+ (listenOn $ PortNumber $ fromIntegral port)
44+ sClose .
45+ serveConnections port
46+type Port = Int
47+
48+serveConnections :: Port -> Application -> Socket -> IO ()
49+serveConnections port app socket = do
50+ (conn, remoteHost', _) <- accept socket
51+ _ <- forkIO $ serveConnection port app conn remoteHost'
52+ serveConnections port app socket
53+
54+serveConnection :: Port -> Application -> Handle -> String -> IO ()
55+serveConnection port app conn remoteHost' =
56+ finally
57+ serveConnection'
58+ (hClose conn)
59+ where
60+ serveConnection' = do
61+ env <- hParseRequest port conn remoteHost'
62+ res <- app env
63+ sendResponse conn res
64+
65+hParseRequest :: Port -> Handle -> String -> IO Request
66+hParseRequest port conn remoteHost' = do
67+ headers' <- takeUntilBlank conn id
68+ parseRequest port headers' conn remoteHost'
69+
70+takeUntilBlank :: Handle
71+ -> ([BS.ByteString] -> [BS.ByteString])
72+ -> IO [BS.ByteString]
73+takeUntilBlank h front = do
74+ l <- stripCR `fmap` BS.hGetLine h
75+ if BS.null l
76+ then return $ front []
77+ else takeUntilBlank h $ front . (:) l
78+
79+stripCR :: BS.ByteString -> BS.ByteString
80+stripCR bs
81+ | BS.null bs = bs
82+ | B8.last bs == '\r' = BS.init bs
83+ | otherwise = bs
84+
85+safeRead :: Read a => a -> String -> a
86+safeRead d s =
87+ case reads s of
88+ ((x, _):_) -> x
89+ [] -> d
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 :: (MonadFailure InvalidRequest m)
101+ => Port
102+ -> [BS.ByteString]
103+ -> Handle
104+ -> String
105+ -> m Request
106+parseRequest port lines' handle remoteHost' = do
107+ case lines' of
108+ (_:_:_) -> return ()
109+ _ -> failure $ NotEnoughLines $ map SL.unpack lines'
110+ (method', rpath', gets) <- parseFirst $ head lines'
111+ let method = safeRead GET (SL.unpack method')
112+ let rpath = '/' : case SL.unpack rpath' of
113+ ('/':x) -> x
114+ _ -> SL.unpack rpath'
115+ let heads = map parseHeaderNoAttr $ tail lines'
116+ let host' = lookup (SL.pack "Host") heads
117+ unless (isJust host') $ failure HostNotIncluded
118+ let host = fromJust host'
119+ {- FIXME use length somewhere?
120+ let len = maybe "0" SL.unpack
121+ $ lookup (SL.pack "Content-Length") heads
122+ -}
123+ let (serverName', _) = SL.breakChar ':' host
124+ return $ Request
125+ { requestMethod = method
126+ , pathInfo = SL.pack rpath
127+ , queryString = gets
128+ , serverName = serverName'
129+ , serverPort = port
130+ , httpHeaders = heads
131+ , urlScheme = HTTP
132+ , requestBody = RequestBody $ SSRequestBody handle
133+ , errorHandler = System.IO.hPutStr System.IO.stderr
134+ , remoteHost = remoteHost'
135+ }
136+
137+newtype SSRequestBody = SSRequestBody Handle
138+instance RequestBodyClass SSRequestBody where
139+ receiveByteString (SSRequestBody h) = do
140+ bs <- BS.hGet h 1024 -- FIXME find a good chunk size
141+ if BS.null bs
142+ then return Nothing
143+ else return $ Just bs
144+
145+parseFirst :: (StringLike s, MonadFailure 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 $ status res
162+ BS.hPut h $ SL.pack "\r\n"
163+ mapM_ putHeader $ headers res
164+ BS.hPut h $ SL.pack "\r\n"
165+ body res $ ResponseBody $ SSResponseBody h
166+ where
167+ putHeader (x, y) = do
168+ BS.hPut h x
169+ BS.hPut h $ SL.pack ": "
170+ BS.hPut h y
171+ BS.hPut h $ SL.pack "\r\n"
172+
173+newtype SSResponseBody = SSResponseBody Handle
174+instance ResponseBodyClass SSResponseBody where
175+ sendByteString (SSResponseBody h) = BS.hPut h
176+
177+parseHeaderNoAttr :: StringLike a => a -> (a, a)
178+parseHeaderNoAttr s =
179+ let (k, rest) = SL.span (/= ':') s
180+ in (k, SL.dropPrefix' (SL.pack ": ") rest)