git.iko.soy/typeable/wai
on master help sign in
Better queue management
482f546Michael Snoyman
Network/Wai/Handler/DevelServer.hs+32−34
compare with master
unifiedsplit
@@ -36,29 +36,26 @@ run :: Port -> ModuleName -> FunctionName -> IO ()
36run port modu func = do
36run port modu func = do
37 queue <- C.newChan
37 queue <- C.newChan
38 mqueue <- M.newMVar queue
38 mqueue <- M.newMVar queue
39− mmqueue <- M.newMVar mqueue
40− startApp mqueue $ loadingApp Nothing
39+ startApp queue $ loadingApp Nothing
41− _ <- forkIO $ fillApp modu func mmqueue
40+ _ <- forkIO $ fillApp modu func mqueue
42− run' port queue
41+ run' port mqueue
43
42
44−startApp :: M.MVar Queue -> Handler -> IO ()
43+startApp :: Queue -> Handler -> IO ()
45−startApp mqueue withApp =
44+startApp queue withApp = do
46 forkIO (withApp go) >> return ()
45 forkIO (withApp go) >> return ()
47 where
46 where
48 go app = do
47 go app = do
49− queue' <- M.tryTakeMVar mqueue
48+ msession <- C.readChan queue
50− case queue' of
49+ case msession of
51 Nothing -> return ()
50 Nothing -> return ()
52− Just queue -> do
53− M.putMVar mqueue queue
54− (req, onRes) <- C.readChan queue
51+ Just (req, onRes) -> do
55 res <- app req
52 res <- app req
56 -- FIXME exceptions?
53 -- FIXME exceptions?
57 onRes res
54 onRes res
58 go app
55 go app
59
56
60−fillApp :: String -> String -> M.MVar (M.MVar Queue) -> IO ()
57+fillApp :: String -> String -> M.MVar Queue -> IO ()
61−fillApp modu func mmqueue =
58+fillApp modu func mqueue =
62 go Nothing []
59 go Nothing []
63 where
60 where
64 go prevError prevFiles = do
61 go prevError prevFiles = do
@@ -76,35 +73,35 @@ fillApp modu func mmqueue =
76 go newError newFiles
73 go newError newFiles
77 reload prevError = do
74 reload prevError = do
78 putStrLn "Attempting to interpret your app..."
75 putStrLn "Attempting to interpret your app..."
79− loadingApp' prevError mmqueue
76+ loadingApp' prevError mqueue
80 res <- theapp modu func
77 res <- theapp modu func
81 case res of
78 case res of
82 Left err -> do
79 Left err -> do
83 putStrLn $ "Compile failed: " ++ show err
80 putStrLn $ "Compile failed: " ++ show err
84− loadingApp' (Just $ toException err) mmqueue
81+ loadingApp' (Just $ toException err) mqueue
85 return (Just $ toException err, [])
82 return (Just $ toException err, [])
86 Right (app, files) -> do
83 Right (app, files) -> do
87 putStrLn "Interpreting success, new app loaded"
84 putStrLn "Interpreting success, new app loaded"
88 handle onInitErr $ do
85 handle onInitErr $ do
89− swapApp app mmqueue
86+ swapApp app mqueue
90 files' <- forM files $ \f -> do
87 files' <- forM files $ \f -> do
91 t <- getModificationTime f
88 t <- getModificationTime f
92 return (f, t)
89 return (f, t)
93 return (Nothing, files')
90 return (Nothing, files')
94 onInitErr e = do
91 onInitErr e = do
95 putStrLn $ "Error initializing application: " ++ show e
92 putStrLn $ "Error initializing application: " ++ show e
96− loadingApp' (Just e) mmqueue
93+ loadingApp' (Just e) mqueue
97 return (Just e, [])
94 return (Just e, [])
98
95
99−loadingApp' :: Maybe SomeException -> M.MVar (M.MVar Queue) -> IO ()
96+loadingApp' :: Maybe SomeException -> M.MVar Queue -> IO ()
100−loadingApp' err mmqueue = swapApp (loadingApp err) mmqueue
97+loadingApp' err mqueue = swapApp (loadingApp err) mqueue
101
98
102−swapApp app mmqueue = do
99+swapApp app mqueue = do
103− oldmqueue <- M.takeMVar mmqueue
100+ oldqueue <- M.takeMVar mqueue
104− queue <- M.takeMVar oldmqueue
101+ C.writeChan oldqueue Nothing
105− mqueue <- M.newMVar queue
102+ queue <- C.newChan
106− M.putMVar mmqueue mqueue
103+ M.putMVar mqueue queue
107− startApp mqueue app
104+ startApp queue app
108
105
109loadingApp :: Maybe SomeException -> Handler
106loadingApp :: Maybe SomeException -> Handler
110loadingApp err f =
107loadingApp err f =
@@ -132,7 +129,7 @@ theapp modu func =
132 toSlash '.' = '/'
129 toSlash '.' = '/'
133 toSlash c = c
130 toSlash c = c
134
131
135−run' :: Port -> Queue -> IO ()
132+run' :: Port -> M.MVar Queue -> IO ()
136run' port = withSocketsDo .
133run' port = withSocketsDo .
137 bracket
134 bracket
138 (listenOn $ PortNumber $ fromIntegral port)
135 (listenOn $ PortNumber $ fromIntegral port)
@@ -140,22 +137,23 @@ run' port = withSocketsDo .
140 serveConnections port
137 serveConnections port
141type Port = Int
138type Port = Int
142
139
143−serveConnections :: Port -> Queue -> Socket -> IO ()
140+serveConnections :: Port -> M.MVar Queue -> Socket -> IO ()
144−serveConnections port queue socket = do
141+serveConnections port mqueue socket = do
145 (conn, remoteHost', _) <- accept socket
142 (conn, remoteHost', _) <- accept socket
146− _ <- forkIO $ serveConnection port queue conn remoteHost'
143+ _ <- forkIO $ serveConnection port mqueue conn remoteHost'
147− serveConnections port queue socket
144+ serveConnections port mqueue socket
148
145
149−type Queue = C.Chan (Request, Response -> IO ())
146+type Queue = C.Chan (Maybe (Request, Response -> IO ()))
150
147
151−serveConnection :: Port -> Queue -> Handle -> String -> IO ()
148+serveConnection :: Port -> M.MVar Queue -> Handle -> String -> IO ()
152−serveConnection port queue conn remoteHost' = do
149+serveConnection port mqueue conn remoteHost' = do
153 env <- hParseRequest port conn remoteHost'
150 env <- hParseRequest port conn remoteHost'
154 let onRes res =
151 let onRes res =
155 finally
152 finally
156 (sendResponse (httpVersion env) conn res)
153 (sendResponse (httpVersion env) conn res)
157 (hClose conn)
154 (hClose conn)
155+ queue <- M.readMVar mqueue
158− C.writeChan queue (env, onRes)
156+ C.writeChan queue $ Just (env, onRes)
159
157
160hParseRequest :: Port -> Handle -> String -> IO Request
158hParseRequest :: Port -> Handle -> String -> IO Request
161hParseRequest port conn remoteHost' = do
159hParseRequest port conn remoteHost' = do
TestApp.hs+12−7
@@ -22,11 +22,16 @@ testApp handler = do
22 when exi $ removeFile db
22 when exi $ removeFile db
23 withSqlitePool db 10 $ \pool -> do
23 withSqlitePool db 10 $ \pool -> do
24 flip runSqlPool pool $ runMigration $ migrate $ Dummy ""
24 flip runSqlPool pool $ runMigration $ migrate $ Dummy ""
25− handler $ const $ do
25+ handler $ \req -> do
26+ if pathInfo req == "/favicon.ico"
27+ then return $ Response status301 [("Location", "http://docs.yesodweb.com/favicon.ico")]
28+ $ ResponseLBS $ pack ""
29+ else do
30+ print $ pathInfo req
26− x <- flip runSqlPool pool $ do
31+ x <- flip runSqlPool pool $ do
27− insert $ Dummy ""
32+ insert $ Dummy ""
28− count ([] :: [Filter Dummy])
33+ count ([] :: [Filter Dummy])
29− return $ Response status200
34+ return $ Response status200
30− [("Content-Type", "text/plain")]
35+ [("Content-Type", "text/plain")]
31− $ ResponseLBS $ pack $ "Counter: " ++ show x
36+ $ ResponseLBS $ pack $ "Counter: " ++ show x
32 putStrLn "handler completed, this should only happen at the beginning of a reload"
37 putStrLn "handler completed, this should only happen at the beginning of a reload"