3849989 · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

Added directory monitoring

3849989Michael Snoyman16 years ago

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

compare with master

unifiedsplit

@@ -21,15 +21,21 @@ import qualified Control.Concurrent.MVar as M

21import qualified Control.Concurrent.Chan as C

22import System.Directory (getModificationTime)

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

24+import Control.Monad (filterM)

25+

26+import Control.Arrow ((&&&))

27+import System.Directory (doesDirectoryExist,

28+ doesFileExist, getDirectoryContents)

29+import Control.Applicative ((<$>))

25type FunctionName = String

31type FunctionName = String

27−run :: Port -> ModuleName -> FunctionName -> IO ()

33+run :: Port -> ModuleName -> FunctionName -> [FilePath] -> IO ()

28−run port modu func = do

34+run port modu func dirs = do

29 queue <- C.newChan

35 queue <- C.newChan

30 mqueue <- M.newMVar queue

36 mqueue <- M.newMVar queue

31 startApp queue $ loadingApp Nothing

37 startApp queue $ loadingApp Nothing

32− _ <- forkIO $ fillApp modu func mqueue

38+ _ <- forkIO $ fillApp modu func mqueue dirs

33 run' port mqueue

39 run' port mqueue

35startApp :: Queue -> Handler -> IO ()

41startApp :: Queue -> Handler -> IO ()

@@ -41,7 +47,7 @@ startApp queue withApp = do

41 case msession of

47 case msession of

42 Nothing -> return ()

48 Nothing -> return ()

43 Just (req, onRes) -> do

49 Just (req, onRes) -> do

44− void $ forkIO $ (handle onErr $ app req) >>= onRes

50+ void $ forkIO $ (E.handle onErr $ app req) >>= onRes

45 go app

51 go app

46 onErr :: SomeException -> IO Response

52 onErr :: SomeException -> IO Response

47 onErr e = return

53 onErr e = return

@@ -50,13 +56,13 @@ startApp queue withApp = do

50 $ "Exception thrown while running application\n\n" ++ show e

56 $ "Exception thrown while running application\n\n" ++ show e

51 void x = x >> return ()

57 void x = x >> return ()

53−fillApp :: String -> String -> M.MVar Queue -> IO ()

59+fillApp :: String -> String -> M.MVar Queue -> [FilePath] -> IO ()

54−fillApp modu func mqueue =

60+fillApp modu func mqueue dirs =

55 go Nothing []

61 go Nothing []

56 where

62 where

57 constSE :: x -> SomeException -> x

63 constSE :: x -> SomeException -> x

58 constSE = const

64 constSE = const

59− getTimes = handle (constSE $ return []) . mapM getModificationTime

65+ getTimes = E.handle (constSE $ return []) . mapM getModificationTime

60 go prevError prevFiles = do

66 go prevError prevFiles = do

61 toReload <-

67 toReload <-

62 if null prevFiles

68 if null prevFiles

@@ -79,7 +85,9 @@ fillApp modu func mqueue =

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

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

80 loadingApp' (Just $ toException err) mqueue

86 loadingApp' (Just $ toException err) mqueue

81 return (Just $ toException err, [])

87 return (Just $ toException err, [])

82− Right (app, files) -> do

88+ Right (app, files') -> E.handle onInitErr $ do

89+ files'' <- mapM fileList dirs

90+ let files = concat $ files' : files''

83 putStrLn "Interpreting success, new app loaded"

91 putStrLn "Interpreting success, new app loaded"

84 E.handle onInitErr $ do

92 E.handle onInitErr $ do

85 swapApp app mqueue

93 swapApp app mqueue

@@ -90,6 +98,26 @@ fillApp modu func mqueue =

90 loadingApp' (Just e) mqueue

98 loadingApp' (Just e) mqueue

91 return (Just e, [])

99 return (Just e, [])

100

101+fileList :: FilePath -> IO [FilePath]

102+fileList top = do

103+ ex <- doesDirectoryExist top

104+ if ex then fileList' top "" else return []

105+

106+fileList' :: FilePath -> FilePath -> IO [FilePath]

107+fileList' realTop top = do

108+ let prefix1 = top ++ "/"

109+ prefix2 = realTop ++ prefix1

110+ allContents <- filter notHidden <$> getDirectoryContents prefix2

111+ let all' = map ((++) prefix1 &&& (++) prefix2) allContents

112+ files <- map snd <$> filterM (doesFileExist . snd) all'

113+ dirs <- filterM (doesDirectoryExist . snd) all' >>=

114+ mapM (fileList' realTop . fst)

115+ return $ concat $ files : dirs

116+

117+notHidden :: FilePath -> Bool

118+notHidden ('.':_) = False

119+notHidden _ = True

120+

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

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

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

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

123

TestApp.hs+6−2

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

1{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving #-}

2+{-# LANGUAGE TemplateHaskell #-}

2{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE OverloadedStrings #-}

3module TestApp (testApp) where

4module TestApp (testApp) where

@@ -8,6 +9,7 @@ import Database.Persist.Sqlite

8import System.Directory

9import System.Directory

9import Control.Monad (when)

10import Control.Monad (when)

10import Helper

11import Helper

12+import Text.Hamlet

12mkPersist [$persist|

14mkPersist [$persist|

13Dummy

15Dummy

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

32 insert $ Dummy ""

34 insert $ Dummy ""

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

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

34 return $ Response status200

36 return $ Response status200

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

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

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

38+ $ ResponseLBS

39+ $ renderHamlet id

40+ $(hamletFileDebug "hamlet/testapp.hamlet")

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

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

wai-handler-devel.cabal+1−1

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

1Name: wai-handler-devel

2−Version: 0.0.2

2+Version: 0.1.0

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 .

wai-handler-devel.hs+6−2

@@ -7,19 +7,23 @@ data Devel = Devel

7 { port :: Int

8 , moduleName :: String

9 , function :: String

10+ , yesod :: Bool

10 }

11 }

11 deriving (Show, Data, Typeable)

12 deriving (Show, Data, Typeable)

13main :: IO ()

14main :: IO ()

14main = do

15main = do

15− Devel p m f <- cmdArgs Devel

16+ Devel p m f y <- cmdArgs Devel

16 { port = 3000 &= argPos 0 &= typ "PORT"

17 { port = 3000 &= argPos 0 &= typ "PORT"

17 , moduleName = "" &= argPos 1 &= typ "MODULE"

18 , moduleName = "" &= argPos 1 &= typ "MODULE"

18 , function = "" &= argPos 2 &= typ "FUNCTION"

19 , function = "" &= argPos 2 &= typ "FUNCTION"

20+ , yesod = False &= help "Monitor typical Yesod folders (hamlet, etc)"

19 } &= summary "WAI development web server"

21 } &= summary "WAI development web server"

20− _ <- forkIO $ run p m f

22+ _ <- forkIO $ run p m f $ folders y

21 go

23 go

22 where

24 where

25+ folders False = []

26+ folders True = ["hamlet", "cassius", "julius"]

23 go = do

27 go = do

24 x <- getLine

28 x <- getLine

25 case x of

29 case x of