8bb1196 · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

Don't rerun initialization each time (not complete)

8bb1196Michael Snoyman16 years ago

Network/Wai/Handler/DevelServer.hs+17−13

compare with master

unifiedsplit

@@ -25,7 +25,7 @@ import Data.Typeable (Typeable)

26import Network.Socket.SendFile

27import Control.Arrow (first)

28−import Control.Concurrent.MVar as M

28+import qualified Control.Concurrent.MVar as M

29import System.Directory (getModificationTime)

31type FunctionName = String

@@ -36,7 +36,7 @@ run port modu func = do

36 _ <- forkIO $ fillApp modu func app

37 run' port app

39−fillApp :: String -> String -> MVar Handler -> IO ()

39+fillApp :: String -> String -> M.MVar Application -> IO ()

40fillApp modu func mapp =

41 go Nothing []

42 where

@@ -55,25 +55,27 @@ fillApp modu func mapp =

55 go newError newFiles

56 reload prevError = do

57 putStrLn "Attempting to interpret your app..."

58− _ <- swapMVar mapp $ loadingApp prevError

58+ _ <- M.swapMVar mapp $ loadingApp prevError

59 res <- theapp modu func

60 case res of

61 Left err -> do

62 putStrLn $ "Compile failed: " ++ show err

63− _ <- swapMVar mapp $ loadingApp $ Just err

63+ _ <- M.swapMVar mapp $ loadingApp $ Just err

64 return (Just err, [])

65 Right (app, files) -> do

66 putStrLn "Interpreting success, new app loaded"

67+ app $ \app' -> (forkIO $ do

67− _ <- swapMVar mapp app

68+ _ <- M.swapMVar mapp app'

69+ return ()) >> return ()

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

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

69 t <- getModificationTime f

71 t <- getModificationTime f

70 return (f, t)

72 return (f, t)

71 return (Nothing, files')

73 return (Nothing, files')

74−loadingApp :: Maybe InterpreterError -> Handler

76+loadingApp :: Maybe InterpreterError -> Application

75−loadingApp err f =

77+loadingApp err _ =

76− f $ const $ return $ Response status200

78+ return $ Response status200

77 [ ("Content-Type", "text/plain")

79 [ ("Content-Type", "text/plain")

78 , ("Refresh", "1")

80 , ("Refresh", "1")

79 ] $ ResponseLBS $ L8.pack $ toMessage err

81 ] $ ResponseLBS $ L8.pack $ toMessage err

@@ -82,7 +84,7 @@ loadingApp err f =

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

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

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

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

85−type MHandler = M.MVar Handler

87+type MHandler = M.MVar Application

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

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

88theapp modu func =

90theapp modu func =

@@ -119,10 +121,12 @@ serveConnection port handler conn remoteHost' =

119 where

121 where

120 serveConnection' = do

122 serveConnection' = do

121 env <- hParseRequest port conn remoteHost'

123 env <- hParseRequest port conn remoteHost'

124+ putStrLn "reading handler"

122− handler' <- M.readMVar handler

125+ app <- M.readMVar handler

123− handler' $ \app -> do

126+ putStrLn "done reading handler"

124− res <- app env

127+ res <- app env

128+ putStrLn "got result"

125− sendResponse (httpVersion env) conn res

129+ sendResponse (httpVersion env) conn res

126

130

127hParseRequest :: Port -> Handle -> String -> IO Request

131hParseRequest :: Port -> Handle -> String -> IO Request

128hParseRequest port conn remoteHost' = do

132hParseRequest port conn remoteHost' = do

TestApp.hsnew file+15

@@ -0,0 +1,15 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+module TestApp (testApp) where

4+import Network.Wai

5+import Data.ByteString.Lazy.Char8 (pack)

6+import Control.Concurrent.MVar

8+testApp handler = do

9+ putStrLn "testApp called, this should happen only once per reload"

10+ var <- newMVar 0

11+ handler $ const $ do

12+ counter <- modifyMVar var $ \i -> return (i + 1, i + 1)

13+ return $ Response status200

14+ [("Content-Type", "text/plain")]

15+ $ ResponseLBS $ pack $ "Counter: " ++ show counter