@@ -15,7 +15,8 @@ import qualified Data.ByteString.Lazy.Char8 as L8
1515import Network
1616 ( listenOn, accept, sClose, PortID(PortNumber), Socket
1717 , withSocketsDo)
18−import Control.Exception (bracket, finally, Exception, throwIO)
18+import Control.Exception (bracket, finally, Exception, throwIO,
19+ handle, SomeException, toException)
1920import System.IO (Handle, hClose)
2021import Control.Concurrent (forkIO, threadDelay)
2122import Control.Monad (unless, forM)
@@ -26,18 +27,38 @@ import Data.Typeable (Typeable)
2627import Network.Socket.SendFile
2728import Control.Arrow (first)
2829import qualified Control.Concurrent.MVar as M
30+import qualified Control.Concurrent.Chan as C
2931import System.Directory (getModificationTime)
3032
3133type FunctionName = String
3234
3335run :: Port -> ModuleName -> FunctionName -> IO ()
3436run port modu func = do
35− app <- M.newMVar $ loadingApp Nothing
36− _ <- forkIO $ fillApp modu func app
37− run' port app
37+ queue <- C.newChan
38+ mqueue <- M.newMVar queue
39+ mmqueue <- M.newMVar mqueue
40+ startApp mqueue $ loadingApp Nothing
41+ _ <- forkIO $ fillApp modu func mmqueue
42+ run' port queue
3843
39−fillApp :: String -> String -> M.MVar Application -> IO ()
40−fillApp modu func mapp =
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+
60+fillApp :: String -> String -> M.MVar (M.MVar Queue) -> IO ()
61+fillApp modu func mmqueue =
4162 go Nothing []
4263 where
4364 go prevError prevFiles = do
@@ -55,27 +76,39 @@ fillApp modu func mapp =
5576 go newError newFiles
5677 reload prevError = do
5778 putStrLn "Attempting to interpret your app..."
58− _ <- M.swapMVar mapp $ loadingApp prevError
79+ loadingApp' prevError mmqueue
5980 res <- theapp modu func
6081 case res of
6182 Left err -> do
6283 putStrLn $ "Compile failed: " ++ show err
63− _ <- M.swapMVar mapp $ loadingApp $ Just err
64− return (Just err, [])
84+ loadingApp' (Just $ toException err) mmqueue
85+ return (Just $ toException err, [])
6586 Right (app, files) -> do
6687 putStrLn "Interpreting success, new app loaded"
67− app $ \app' -> (forkIO $ do
68− _ <- M.swapMVar mapp app'
69− return ()) >> return ()
70− files' <- forM files $ \f -> do
71− t <- getModificationTime f
72− return (f, t)
73− return (Nothing, files')
88+ handle onInitErr $ do
89+ swapApp app mmqueue
90+ files' <- forM files $ \f -> do
91+ t <- getModificationTime f
92+ return (f, t)
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
74101
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
75108
76−loadingApp :: Maybe InterpreterError -> Application
77−loadingApp err _ =
78− return $ Response status200
109+loadingApp :: Maybe SomeException -> Handler
110+loadingApp err f =
111+ f $ const $ return $ Response status200
79112 [ ("Content-Type", "text/plain")
80113 , ("Refresh", "1")
81114 ] $ ResponseLBS $ L8.pack $ toMessage err
@@ -99,7 +132,7 @@ theapp modu func =
99132 toSlash '.' = '/'
100133 toSlash c = c
101134
102−run' :: Port -> MHandler -> IO ()
135+run' :: Port -> Queue -> IO ()
103136run' port = withSocketsDo .
104137 bracket
105138 (listenOn $ PortNumber $ fromIntegral port)
@@ -107,26 +140,22 @@ run' port = withSocketsDo .
107140 serveConnections port
108141type Port = Int
109142
110−serveConnections :: Port -> MHandler -> Socket -> IO ()
111−serveConnections port app socket = do
143+serveConnections :: Port -> Queue -> Socket -> IO ()
144+serveConnections port queue socket = do
112145 (conn, remoteHost', _) <- accept socket
113− _ <- forkIO $ serveConnection port app conn remoteHost'
114− serveConnections port app socket
146+ _ <- forkIO $ serveConnection port queue conn remoteHost'
147+ serveConnections port queue socket
115148
116−serveConnection :: Port -> MHandler -> Handle -> String -> IO ()
117−serveConnection port handler conn remoteHost' =
118− finally
119− serveConnection'
120− (hClose conn)
121− where
122− serveConnection' = do
123− env <- hParseRequest port conn remoteHost'
124− putStrLn "reading handler"
125− app <- M.readMVar handler
126− putStrLn "done reading handler"
127− res <- app env
128− putStrLn "got result"
129− sendResponse (httpVersion env) conn res
149+type Queue = C.Chan (Request, Response -> IO ())
150+
151+serveConnection :: Port -> Queue -> Handle -> String -> IO ()
152+serveConnection port queue conn remoteHost' = do
153+ env <- hParseRequest port conn remoteHost'
154+ let onRes res =
155+ finally
156+ (sendResponse (httpVersion env) conn res)
157+ (hClose conn)
158+ C.writeChan queue (env, onRes)
130159
131160hParseRequest :: Port -> Handle -> String -> IO Request
132161hParseRequest port conn remoteHost' = do