git.iko.soy/typeable/wai
on master help sign in
Proper queueing support
21bdf8eMichael Snoyman
Network/Wai/Handler/DevelServer.hs+67−38
compare with master
unifiedsplit
@@ -15,7 +15,8 @@ import qualified Data.ByteString.Lazy.Char8 as L8
15import Network
15import Network
16 ( listenOn, accept, sClose, PortID(PortNumber), Socket
16 ( listenOn, accept, sClose, PortID(PortNumber), Socket
17 , withSocketsDo)
17 , withSocketsDo)
18−import Control.Exception (bracket, finally, Exception, throwIO)
18+import Control.Exception (bracket, finally, Exception, throwIO,
19+ handle, SomeException, toException)
19import System.IO (Handle, hClose)
20import System.IO (Handle, hClose)
20import Control.Concurrent (forkIO, threadDelay)
21import Control.Concurrent (forkIO, threadDelay)
21import Control.Monad (unless, forM)
22import Control.Monad (unless, forM)
@@ -26,18 +27,38 @@ import Data.Typeable (Typeable)
26import Network.Socket.SendFile
27import Network.Socket.SendFile
27import Control.Arrow (first)
28import Control.Arrow (first)
28import qualified Control.Concurrent.MVar as M
29import qualified Control.Concurrent.MVar as M
30+import qualified Control.Concurrent.Chan as C
29import System.Directory (getModificationTime)
31import System.Directory (getModificationTime)
30
32
31type FunctionName = String
33type FunctionName = String
32
34
33run :: Port -> ModuleName -> FunctionName -> IO ()
35run :: Port -> ModuleName -> FunctionName -> IO ()
34run port modu func = do
36run port modu func = do
37+ queue <- C.newChan
38+ mqueue <- M.newMVar queue
39+ mmqueue <- M.newMVar mqueue
35− app <- M.newMVar $ loadingApp Nothing
40+ startApp mqueue $ loadingApp Nothing
36− _ <- forkIO $ fillApp modu func app
41+ _ <- forkIO $ fillApp modu func mmqueue
37− run' port app
42+ run' port queue
38
43
44+startApp :: M.MVar Queue -> Handler -> IO ()
45+startApp mqueue withApp =
46+ forkIO (withApp go) >> return ()
47+ where
48+ go app = do
49+ queue' <- M.tryTakeMVar mqueue
50+ case queue' of
51+ Nothing -> return ()
52+ Just queue -> do
53+ M.putMVar mqueue queue
54+ (req, onRes) <- C.readChan queue
55+ res <- app req
56+ -- FIXME exceptions?
57+ onRes res
58+ go app
59+
39−fillApp :: String -> String -> M.MVar Application -> IO ()
60+fillApp :: String -> String -> M.MVar (M.MVar Queue) -> IO ()
40−fillApp modu func mapp =
61+fillApp modu func mmqueue =
41 go Nothing []
62 go Nothing []
42 where
63 where
43 go prevError prevFiles = do
64 go prevError prevFiles = do
@@ -55,27 +76,39 @@ fillApp modu func mapp =
55 go newError newFiles
76 go newError newFiles
56 reload prevError = do
77 reload prevError = do
57 putStrLn "Attempting to interpret your app..."
78 putStrLn "Attempting to interpret your app..."
58− _ <- M.swapMVar mapp $ loadingApp prevError
79+ loadingApp' prevError mmqueue
59 res <- theapp modu func
80 res <- theapp modu func
60 case res of
81 case res of
61 Left err -> do
82 Left err -> do
62 putStrLn $ "Compile failed: " ++ show err
83 putStrLn $ "Compile failed: " ++ show err
63− _ <- M.swapMVar mapp $ loadingApp $ Just err
84+ loadingApp' (Just $ toException err) mmqueue
64− return (Just err, [])
85+ return (Just $ toException err, [])
65 Right (app, files) -> do
86 Right (app, files) -> do
66 putStrLn "Interpreting success, new app loaded"
87 putStrLn "Interpreting success, new app loaded"
67− app $ \app' -> (forkIO $ do
88+ handle onInitErr $ do
68− _ <- M.swapMVar mapp app'
89+ swapApp app mmqueue
69− return ()) >> return ()
70− files' <- forM files $ \f -> do
90+ files' <- forM files $ \f -> do
71− t <- getModificationTime f
91+ t <- getModificationTime f
72− return (f, t)
92+ return (f, t)
73− return (Nothing, files')
93+ return (Nothing, files')
94+ onInitErr e = do
95+ putStrLn $ "Error initializing application: " ++ show e
96+ loadingApp' (Just e) mmqueue
97+ return (Just e, [])
98+
99+loadingApp' :: Maybe SomeException -> M.MVar (M.MVar Queue) -> IO ()
100+loadingApp' err mmqueue = swapApp (loadingApp err) mmqueue
74
101
102+swapApp app mmqueue = do
103+ oldmqueue <- M.takeMVar mmqueue
104+ queue <- M.takeMVar oldmqueue
105+ mqueue <- M.newMVar queue
106+ M.putMVar mmqueue mqueue
107+ startApp mqueue app
75
108
76−loadingApp :: Maybe InterpreterError -> Application
109+loadingApp :: Maybe SomeException -> Handler
77−loadingApp err _ =
110+loadingApp err f =
78− return $ Response status200
111+ f $ const $ return $ Response status200
79 [ ("Content-Type", "text/plain")
112 [ ("Content-Type", "text/plain")
80 , ("Refresh", "1")
113 , ("Refresh", "1")
81 ] $ ResponseLBS $ L8.pack $ toMessage err
114 ] $ ResponseLBS $ L8.pack $ toMessage err
@@ -99,7 +132,7 @@ theapp modu func =
99 toSlash '.' = '/'
132 toSlash '.' = '/'
100 toSlash c = c
133 toSlash c = c
101
134
102−run' :: Port -> MHandler -> IO ()
135+run' :: Port -> Queue -> IO ()
103run' port = withSocketsDo .
136run' port = withSocketsDo .
104 bracket
137 bracket
105 (listenOn $ PortNumber $ fromIntegral port)
138 (listenOn $ PortNumber $ fromIntegral port)
@@ -107,26 +140,22 @@ run' port = withSocketsDo .
107 serveConnections port
140 serveConnections port
108type Port = Int
141type Port = Int
109
142
110−serveConnections :: Port -> MHandler -> Socket -> IO ()
143+serveConnections :: Port -> Queue -> Socket -> IO ()
111−serveConnections port app socket = do
144+serveConnections port queue socket = do
112 (conn, remoteHost', _) <- accept socket
145 (conn, remoteHost', _) <- accept socket
113− _ <- forkIO $ serveConnection port app conn remoteHost'
146+ _ <- forkIO $ serveConnection port queue conn remoteHost'
114− serveConnections port app socket
147+ serveConnections port queue socket
115
148
149+type Queue = C.Chan (Request, Response -> IO ())
150+
116−serveConnection :: Port -> MHandler -> Handle -> String -> IO ()
151+serveConnection :: Port -> Queue -> Handle -> String -> IO ()
117−serveConnection port handler conn remoteHost' =
152+serveConnection port queue conn remoteHost' = do
118− finally
119− serveConnection'
120− (hClose conn)
121− where
122− serveConnection' = do
123− env <- hParseRequest port conn remoteHost'
153+ env <- hParseRequest port conn remoteHost'
124− putStrLn "reading handler"
154+ let onRes res =
125− app <- M.readMVar handler
155+ finally
126− putStrLn "done reading handler"
127− res <- app env
128− putStrLn "got result"
129− sendResponse (httpVersion env) conn res
156+ (sendResponse (httpVersion env) conn res)
157+ (hClose conn)
158+ C.writeChan queue (env, onRes)
130
159
131hParseRequest :: Port -> Handle -> String -> IO Request
160hParseRequest :: Port -> Handle -> String -> IO Request
132hParseRequest port conn remoteHost' = do
161hParseRequest port conn remoteHost' = do
TestApp.hs+24−7
@@ -1,15 +1,32 @@
1+{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving #-}
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
2module TestApp (testApp) where
3module TestApp (testApp) where
3
4
4import Network.Wai
5import Network.Wai
5import Data.ByteString.Lazy.Char8 (pack)
6import Data.ByteString.Lazy.Char8 (pack)
6−import Control.Concurrent.MVar
7+import Database.Persist.Sqlite
8+import System.Directory
9+import Control.Monad (when)
10+
11+mkPersist [$persist|
12+Dummy
13+ dummy String
14+|]
7
15
8testApp handler = do
16testApp handler = do
9 putStrLn "testApp called, this should happen only once per reload"
17 putStrLn "testApp called, this should happen only once per reload"
10− var <- newMVar 0
18+ let db = "test.db3"
11− handler $ const $ do
19+ -- Swap between the following two lines as necessary to generate errors
12− counter <- modifyMVar var $ \i -> return (i + 1, i + 1)
20+ exi <- doesFileExist db
21+ --let exi = True
22+ when exi $ removeFile db
23+ withSqlitePool db 10 $ \pool -> do
24+ flip runSqlPool pool $ runMigration $ migrate $ Dummy ""
25+ handler $ const $ do
26+ x <- flip runSqlPool pool $ do
27+ insert $ Dummy ""
28+ count ([] :: [Filter Dummy])
13− return $ Response status200
29+ return $ Response status200
14− [("Content-Type", "text/plain")]
30+ [("Content-Type", "text/plain")]
15− $ ResponseLBS $ pack $ "Counter: " ++ show counter
31+ $ ResponseLBS $ pack $ "Counter: " ++ show x
32+ putStrLn "handler completed, this should only happen at the beginning of a reload"