ccc4baa · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

Using simpleserver exported functions

ccc4baaMichael Snoyman16 years ago

Network/Wai/Handler/DevelServer.hs+8−148

compare with master

unifiedsplit

@@ -5,30 +5,22 @@ module Network.Wai.Handler.DevelServer (run) where

6import Language.Haskell.Interpreter

7import Network.Wai

8−import qualified System.IO

10−import Data.ByteString (ByteString)

11−import Data.ByteString.Lazy.Internal (defaultChunkSize)

12−import qualified Data.ByteString.Char8 as B

13−import qualified Data.ByteString.Lazy as L

14import qualified Data.ByteString.Lazy.Char8 as L8

9import qualified Data.ByteString.Lazy.Char8 as L8

15import Network

10import Network

16 ( listenOn, accept, sClose, PortID(PortNumber), Socket

11 ( listenOn, accept, sClose, PortID(PortNumber), Socket

17 , withSocketsDo)

12 , withSocketsDo)

18−import Control.Exception (bracket, finally, Exception, throwIO,

13+import Control.Exception (bracket, finally, Exception,

19− handle, SomeException, toException)

14+ SomeException, toException)

15+import qualified Control.Exception as E

20import System.IO (Handle, hClose)

16import System.IO (Handle, hClose)

21import Control.Concurrent (forkIO, threadDelay)

17import Control.Concurrent (forkIO, threadDelay)

22−import Control.Monad (unless, forM)

18+import Control.Monad (forM)

23−import Data.Maybe (isJust, fromJust, fromMaybe)

25−import Data.Typeable (Typeable)

26−

27−import Network.Socket.SendFile

28−import Control.Arrow (first)

29import qualified Control.Concurrent.MVar as M

20import qualified Control.Concurrent.MVar as M

30import qualified Control.Concurrent.Chan as C

21import qualified Control.Concurrent.Chan as C

31import System.Directory (getModificationTime)

22import System.Directory (getModificationTime)

23+import Network.Wai.Handler.SimpleServer (parseRequest, sendResponse)

33type FunctionName = String

25type FunctionName = String

@@ -82,7 +74,7 @@ fillApp modu func mqueue =

82 return (Just $ toException err, [])

74 return (Just $ toException err, [])

83 Right (app, files) -> do

75 Right (app, files) -> do

84 putStrLn "Interpreting success, new app loaded"

76 putStrLn "Interpreting success, new app loaded"

85− handle onInitErr $ do

77+ E.handle onInitErr $ do

86 swapApp app mqueue

78 swapApp app mqueue

87 files' <- forM files $ \f -> do

79 files' <- forM files $ \f -> do

88 t <- getModificationTime f

80 t <- getModificationTime f

@@ -96,6 +88,7 @@ fillApp modu func mqueue =

96loadingApp' :: Maybe SomeException -> M.MVar Queue -> IO ()

88loadingApp' :: Maybe SomeException -> M.MVar Queue -> IO ()

97loadingApp' err mqueue = swapApp (loadingApp err) mqueue

89loadingApp' err mqueue = swapApp (loadingApp err) mqueue

91+swapApp :: Handler -> M.MVar Queue -> IO ()

99swapApp app mqueue = do

92swapApp app mqueue = do

100 oldqueue <- M.takeMVar mqueue

93 oldqueue <- M.takeMVar mqueue

101 C.writeChan oldqueue Nothing

94 C.writeChan oldqueue Nothing

@@ -114,7 +107,6 @@ loadingApp err f =

114 toMessage (Just err') = "Error loading code: " ++ show err'

107 toMessage (Just err') = "Error loading code: " ++ show err'

115

108

116type Handler = (Application -> IO ()) -> IO ()

109type Handler = (Application -> IO ()) -> IO ()

117−type MHandler = M.MVar Application

118

110

119theapp :: String -> String -> IO (Either InterpreterError (Handler, [FilePath]))

111theapp :: String -> String -> IO (Either InterpreterError (Handler, [FilePath]))

120theapp modu func =

112theapp modu func =

@@ -147,142 +139,10 @@ type Queue = C.Chan (Maybe (Request, Response -> IO ()))

147

139

148serveConnection :: Port -> M.MVar Queue -> Handle -> String -> IO ()

140serveConnection :: Port -> M.MVar Queue -> Handle -> String -> IO ()

149serveConnection port mqueue conn remoteHost' = do

141serveConnection port mqueue conn remoteHost' = do

150− env <- hParseRequest port conn remoteHost'

142+ env <- parseRequest port conn remoteHost'

151 let onRes res =

143 let onRes res =

152 finally

144 finally

153 (sendResponse (httpVersion env) conn res)

145 (sendResponse (httpVersion env) conn res)

154 (hClose conn)

146 (hClose conn)

155 queue <- M.readMVar mqueue

147 queue <- M.readMVar mqueue

156 C.writeChan queue $ Just (env, onRes)

148 C.writeChan queue $ Just (env, onRes)

157−

158−hParseRequest :: Port -> Handle -> String -> IO Request

159−hParseRequest port conn remoteHost' = do

160− headers' <- takeUntilBlank conn id

161− parseRequest port headers' conn remoteHost'

162−

163−takeUntilBlank :: Handle

164− -> ([ByteString] -> [ByteString])

165− -> IO [ByteString]

166−takeUntilBlank h front = do

167− l <- stripCR `fmap` B.hGetLine h

168− if B.null l

169− then return $ front []

170− else takeUntilBlank h $ front . (:) l

171−

172−stripCR :: ByteString -> ByteString

173−stripCR bs

174− | B.null bs = bs

175− | B.last bs == '\r' = B.init bs

176− | otherwise = bs

177−

178−data InvalidRequest =

179− NotEnoughLines [String]

180− | HostNotIncluded

181− | BadFirstLine String

182− | NonHttp

183− deriving (Show, Typeable)

184−instance Exception InvalidRequest

185−

186−-- | Parse a set of header lines and body into a 'Request'.

187−parseRequest :: Port

188− -> [ByteString]

189− -> Handle

190− -> String

191− -> IO Request

192−parseRequest port lines' handle remoteHost' = do

193− case lines' of

194− (_:_:_) -> return ()

195− _ -> throwIO $ NotEnoughLines $ map B.unpack lines'

196− (method, rpath', gets, httpversion) <- parseFirst $ head lines'

197− let rpath = '/' : case B.unpack rpath' of

198− ('/':x) -> x

199− _ -> B.unpack rpath'

200− let heads = map (first mkCIByteString . parseHeaderNoAttr) $ tail lines'

201− let host' = lookup "Host" heads

202− unless (isJust host') $ throwIO HostNotIncluded

203− let host = fromJust host'

204− let len = fromMaybe 0 $ do

205− bs <- lookup "Content-Length" heads

206− let str = B.unpack bs

207− case reads str of

208− (x, _):_ -> Just x

209− _ -> Nothing

210− let (serverName', _) = B.break (== ':') host

211− return $ Request

212− { requestMethod = method

213− , httpVersion = httpversion

214− , pathInfo = B.pack rpath

215− , queryString = gets

216− , serverName = serverName'

217− , serverPort = port

218− , requestHeaders = heads

219− , isSecure = False

220− , requestBody = requestBodyHandle handle len

221− , errorHandler = System.IO.hPutStr System.IO.stderr

222− , remoteHost = B.pack remoteHost'

223− }

224−

225−parseFirst :: ByteString

226− -> IO (ByteString, ByteString, ByteString, HttpVersion)

227−parseFirst s = do

228− let pieces = B.words s

229− (method, query, http') <-

230− case pieces of

231− [x, y, z] -> return (x, y, z)

232− _ -> throwIO $ BadFirstLine $ B.unpack s

233− let (hfirst, hsecond) = B.splitAt 5 http'

234− unless (hfirst == B.pack "HTTP/") $ throwIO NonHttp

235− let (rpath, qstring) = B.break (== '?') query

236− return (method, rpath, qstring, hsecond)

237−

238−sendResponse :: HttpVersion -> Handle -> Response -> IO ()

239−sendResponse httpversion h res = do

240− B.hPut h $ B.pack "HTTP/"

241− B.hPut h $ httpversion

242− B.hPut h $ B.pack " "

243− B.hPut h $ B.pack $ show $ statusCode $ status res

244− B.hPut h $ B.pack " "

245− B.hPut h $ statusMessage $ status res

246− B.hPut h $ B.pack "\r\n"

247− mapM_ putHeader $ responseHeaders res

248− B.hPut h $ B.pack "\r\n"

249− case responseBody res of

250− ResponseFile fp -> unsafeSendFile h fp

251− ResponseEnumerator (Enumerator enum) -> enum myPut h >> return ()

252− ResponseLBS lbs -> L.hPut h lbs

253− where

254− myPut _ bs = do

255− B.hPut h bs

256− return (Right h)

257− putHeader (x, y) = do

258− B.hPut h $ ciOriginal x

259− B.hPut h $ B.pack ": "

260− B.hPut h y

261− B.hPut h $ B.pack "\r\n"

262−

263−parseHeaderNoAttr :: ByteString -> (ByteString, ByteString)

264−parseHeaderNoAttr s =

265− let (k, rest) = B.span (/= ':') s

266− rest' = if not (B.null rest) &&

267− B.head rest == ':' &&

268− not (B.null $ B.tail rest) &&

269− B.head (B.tail rest) == ' '

270− then B.drop 2 rest

271− else rest

272− in (k, rest')

273−

274−requestBodyHandle :: Handle -> Int -> Source

275−requestBodyHandle h =

276− requestBodyFunc go

277− where

278− go i = Just `fmap` B.hGet h (min i defaultChunkSize)

279−

280−requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> Source

281−requestBodyFunc _ 0 = Source $ return Nothing

282−requestBodyFunc h len = Source $ do

283− mbs <- h len

284− case mbs of

285− Nothing -> return Nothing

286− Just bs -> do

287− let newLen = len - B.length bs

288− return $ Just (bs, requestBodyFunc h $ max 0 newLen)

TestApp.hs+1−1

@@ -32,6 +32,6 @@ testApp handler = do

32 insert $ Dummy ""

33 count ([] :: [Filter Dummy])

34 return $ Response status200

35− [("Content-Type", "text/plain")]

35+ [("Content-Type", "text/plain; charset=utf-8")]

36 $ ResponseLBS $ pack $ "Counter: " ++ show x

37 putStrLn "handler completed, this should only happen at the beginning of a reload"

wai-handler-devel.cabal+2−2

@@ -1,5 +1,5 @@

1Name: wai-handler-devel

2−Version: 0.0.1

2+Version: 0.0.2

3Synopsis: WAI server that automatically reloads code after modification.

4Description: This handler automatically reloads your source code upon any changes. It works by using the hint package, essentially embedding GHC inside the handler. The handler (both the executable and library) takes three arguments: the port to listen on, the module name containing the application function, and the name of the function.

5 .

@@ -23,8 +23,8 @@ Source-repository head

23Library

24 Build-Depends: base >= 3 && < 5,

25 wai >= 0.2.1 && < 0.3,

26+ wai-extra >= 0.2.3 && < 0.3,

26 directory >= 1.0 && < 1.1,

27 directory >= 1.0 && < 1.1,

27− sendfile >= 0.6 && < 0.8,

28 network >= 2.2 && < 2.3,

29 bytestring >= 0.9 && < 0.10,

30 hint >= 0.3.2.3 && < 0.4