654ae5b · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

Migrated to Warp, and it works again

654ae5bMichael Snoyman16 years ago

Network/Wai/Handler/DevelServer.hs+41−65

compare with master

unifiedsplit

@@ -1,13 +1,15 @@

1{-# LANGUAGE DeriveDataTypeable #-}

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE StandaloneDeriving #-}

4module Network.Wai.Handler.DevelServer

6module Network.Wai.Handler.DevelServer

5 ( run

7 ( run

6 , runQuit

8 , runQuit

7 , runNoWatch

9 , runNoWatch

8 ) where

10 ) where

10−import Language.Haskell.Interpreter

12+import Language.Haskell.Interpreter hiding (typeOf)

11import Network.Wai

13import Network.Wai

13import Data.Text.Lazy (pack)

15import Data.Text.Lazy (pack)

@@ -25,23 +27,25 @@ import Control.Concurrent (forkIO, threadDelay)

25import qualified Control.Concurrent.MVar as M

27import qualified Control.Concurrent.MVar as M

26import qualified Control.Concurrent.Chan as C

28import qualified Control.Concurrent.Chan as C

27import System.Directory (getModificationTime)

29import System.Directory (getModificationTime)

28−import Network.Wai.Handler.Warp (parseRequest, sendResponse, drainRequestBody)

30+import qualified Network.Wai.Handler.Warp as Warp

31+import Network.Wai.Application.Devel

30import Data.List (nub, group, sort)

33import Data.List (nub, group, sort)

31import System.Time (ClockTime)

34import System.Time (ClockTime)

35+import Data.Typeable (typeOf, Typeable1 (..), mkTyCon, mkTyConApp)

36+import Data.Enumerator (Iteratee)

37+import Data.ByteString (ByteString)

33type FunctionName = String

39type FunctionName = String

35−runNoWatch :: Port -> ModuleName -> FunctionName

41+runNoWatch :: Int -> ModuleName -> FunctionName

36 -> (FilePath -> IO [FilePath]) -> IO ()

42 -> (FilePath -> IO [FilePath]) -> IO ()

37runNoWatch port modu func extras = do

43runNoWatch port modu func extras = do

38− queue <- C.newChan

44+ ah <- initAppHolder

39− mqueue <- M.newMVar queue

40− startApp queue $ loadingApp Nothing

41− _ <- reload modu func mqueue extras Nothing

45+ _ <- reload modu func extras Nothing ah

42− run' port mqueue

46+ Warp.run port $ toApp ah

44−runQuit :: Port -> ModuleName -> FunctionName -> (FilePath -> IO [FilePath])

48+runQuit :: Int -> ModuleName -> FunctionName -> (FilePath -> IO [FilePath])

45 -> IO ()

49 -> IO ()

46runQuit port modu func extras = do

50runQuit port modu func extras = do

47 _ <- forkIO $ run port modu func extras

51 _ <- forkIO $ run port modu func extras

@@ -53,15 +57,14 @@ runQuit port modu func extras = do

53 'q':_ -> putStrLn "Quitting, goodbye!"

57 'q':_ -> putStrLn "Quitting, goodbye!"

54 _ -> go

58 _ -> go

56−run :: Port -> ModuleName -> FunctionName -> (FilePath -> IO [FilePath])

60+run :: Int -> ModuleName -> FunctionName -> (FilePath -> IO [FilePath])

57 -> IO ()

61 -> IO ()

58run port modu func extras = do

62run port modu func extras = do

59− queue <- C.newChan

63+ ah <- initAppHolder

60− mqueue <- M.newMVar queue

61− startApp queue $ loadingApp Nothing

62− _ <- forkIO $ fillApp modu func mqueue extras

64+ _ <- forkIO $ fillApp modu func extras ah

63− run' port mqueue

65+ Warp.run port $ toApp ah

67+{-

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

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

66startApp queue withApp = do

69startApp queue withApp = do

67 forkIO (withApp go) >> return ()

70 forkIO (withApp go) >> return ()

@@ -81,6 +84,7 @@ startApp queue withApp = do

81 $ charsToLBS

84 $ charsToLBS

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

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

83 void x = x >> return ()

86 void x = x >> return ()

87+-}

85getTimes :: [FilePath] -> IO [ClockTime]

89getTimes :: [FilePath] -> IO [ClockTime]

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

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

@@ -88,9 +92,9 @@ getTimes = E.handle (constSE $ return []) . mapM getModificationTime

88constSE :: x -> SomeException -> x

92constSE :: x -> SomeException -> x

89constSE = const

93constSE = const

91−fillApp :: String -> String -> M.MVar Queue

95+fillApp :: String -> String

92− -> (FilePath -> IO [FilePath]) -> IO ()

96+ -> (FilePath -> IO [FilePath]) -> AppHolder -> IO ()

93−fillApp modu func mqueue dirs =

97+fillApp modu func dirs ah =

94 go Nothing []

98 go Nothing []

95 where

99 where

96 go prevError prevFiles = do

100 go prevError prevFiles = do

@@ -102,40 +106,41 @@ fillApp modu func mqueue dirs =

102 return $ times /= map snd prevFiles

106 return $ times /= map snd prevFiles

103 (newError, newFiles) <-

107 (newError, newFiles) <-

104 if toReload

108 if toReload

105− then reload modu func mqueue dirs prevError

109+ then reload modu func dirs prevError ah

106 else return (prevError, prevFiles)

110 else return (prevError, prevFiles)

107 threadDelay 1000000

111 threadDelay 1000000

108 go newError newFiles

112 go newError newFiles

109

113

110−reload :: String -> String -> M.MVar Queue

114+reload :: String -> String

111 -> (FilePath -> IO [FilePath])

115 -> (FilePath -> IO [FilePath])

112 -> Maybe SomeException

116 -> Maybe SomeException

117+ -> AppHolder

113 -> IO (Maybe SomeException, [(FilePath, ClockTime)])

118 -> IO (Maybe SomeException, [(FilePath, ClockTime)])

114−reload modu func mqueue extras prevError = do

119+reload modu func extras prevError ah = do

115 case prevError of

120 case prevError of

116 Nothing -> putStrLn "Attempting to interpret your app..."

121 Nothing -> putStrLn "Attempting to interpret your app..."

117 _ -> return ()

122 _ -> return ()

118− loadingApp' prevError mqueue

123+ loadingApp' prevError ah

119 res <- theapp modu func

124 res <- theapp modu func

120 case res of

125 case res of

121 Left err -> do

126 Left err -> do

122 if show (Just err) /= show prevError

127 if show (Just err) /= show prevError

123 then putStrLn $ "Compile failed: " ++ showInterpError err

128 then putStrLn $ "Compile failed: " ++ showInterpError err

124 else return ()

129 else return ()

125− loadingApp' (Just $ toException err) mqueue

130+ loadingApp' (Just $ toException err) ah

126 return (Just $ toException err, [])

131 return (Just $ toException err, [])

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

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

128 files'' <- mapM extras files'

133 files'' <- mapM extras files'

129 let files = map head $ group $ sort $ concat $ files' : files''

134 let files = map head $ group $ sort $ concat $ files' : files''

130 putStrLn "Interpreting success, new app loaded"

135 putStrLn "Interpreting success, new app loaded"

131 E.handle onInitErr $ do

136 E.handle onInitErr $ do

132− swapApp app mqueue

137+ swapApp app ah

133 times <- getTimes files

138 times <- getTimes files

134 return (Nothing, zip files times)

139 return (Nothing, zip files times)

135 where

140 where

136 onInitErr e = do

141 onInitErr e = do

137 putStrLn $ "Error initializing application: " ++ show e

142 putStrLn $ "Error initializing application: " ++ show e

138− loadingApp' (Just e) mqueue

143+ loadingApp' (Just e) ah

139 return (Just e, [])

144 return (Just e, [])

140

145

141showInterpError :: InterpreterError -> String

146showInterpError :: InterpreterError -> String

@@ -143,16 +148,8 @@ showInterpError (WontCompile errs) =

143 concat . nub $ map (\(GhcError msg) -> '\n':'\n':msg) errs

148 concat . nub $ map (\(GhcError msg) -> '\n':'\n':msg) errs

144showInterpError err = show err

149showInterpError err = show err

145

150

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

151+loadingApp' :: Maybe SomeException -> AppHolder -> IO ()

147−loadingApp' err mqueue = swapApp (loadingApp err) mqueue

152+loadingApp' err = swapApp (loadingApp err)

148−

149−swapApp :: Handler -> M.MVar Queue -> IO ()

150−swapApp app mqueue = do

151− oldqueue <- M.takeMVar mqueue

152− C.writeChan oldqueue Nothing

153− queue <- C.newChan

154− M.putMVar mqueue queue

155− startApp queue app

156

153

157loadingApp :: Maybe SomeException -> Handler

154loadingApp :: Maybe SomeException -> Handler

158loadingApp err f =

155loadingApp err f =

@@ -171,44 +168,23 @@ charsToLBS = encodeUtf8 . pack

171

168

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

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

173

170

171+instance Typeable1 (Iteratee ByteString IO) where

172+ typeOf1 _ =

173+ mkTyConApp i [c, io]

174+ where

175+ i = mkTyCon "Data.Enumerator.Iteratee"

176+ c = typeOf (undefined :: ByteString)

177+ io = typeOf1 (undefined :: IO ())

178+

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

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

175theapp modu func =

180theapp modu func =

176 runInterpreter $ do

181 runInterpreter $ do

177 loadModules [modu]

182 loadModules [modu]

178 mods <- getLoadedModules

183 mods <- getLoadedModules

179− setImports ["Prelude", "Network.Wai", modu]

184+ setImports ["Prelude", "Network.Wai", "Data.Enumerator", "Data.ByteString.Internal", modu]

180 app <- interpret func infer

185 app <- interpret func infer

181 return (app, map toFile mods)

186 return (app, map toFile mods)

182 where

187 where

183 toFile s = map toSlash s ++ ".hs"

188 toFile s = map toSlash s ++ ".hs"

184 toSlash '.' = '/'

189 toSlash '.' = '/'

185 toSlash c = c

190 toSlash c = c

186−

187−run' :: Port -> M.MVar Queue -> IO ()

188−run' port = withSocketsDo .

189− bracket

190− (listenOn $ PortNumber $ fromIntegral port)

191− sClose .

192− serveConnections port

193−type Port = Int

194−

195−serveConnections :: Port -> M.MVar Queue -> Socket -> IO ()

196−serveConnections port mqueue socket = do

197− (conn, remoteHost', _) <- accept socket

198− _ <- forkIO $ serveConnection port mqueue conn remoteHost'

199− serveConnections port mqueue socket

200−

201−type Queue = C.Chan (Maybe (Request, Response -> IO ()))

202−

203−serveConnection :: Port -> M.MVar Queue -> Handle -> String -> IO ()

204−serveConnection port mqueue conn remoteHost' = do

205− (ilen, env) <- parseRequest port conn remoteHost'

206− let onRes res =

207− finally

208− (do

209− _ <- sendResponse env (httpVersion env) conn res

210− drainRequestBody conn ilen

211− return ())

212− (hClose conn)

213− queue <- M.readMVar mqueue

214− C.writeChan queue $ Just (env, onRes)

run-testapp.hs+3−1

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

1import Network.Wai.Handler.DevelServer (runQuit)

2+import Data.Enumerator (Iteratee)

3+import Data.ByteString (ByteString)

3−main = runQuit 3000 "TestApp" "testApp" (const $ return ["hamlet/testapp.hamlet"])

5+main = runQuit 3000 "TestApp2" "testapp" (const $ return ["hamlet/testapp.hamlet"])

wai-handler-devel.cabal+3

@@ -30,7 +30,10 @@ Library

30 , hint >= 0.3.2.3 && < 0.4

31 , text >= 0.7 && < 0.12

32 , old-time >= 1.0 && < 1.1

33+ , enumerator >= 0.4.5 && < 0.5

34+ , transformers >= 0.2.2 && < 0.3

33 Exposed-modules: Network.Wai.Handler.DevelServer

35 Exposed-modules: Network.Wai.Handler.DevelServer

36+ Network.Wai.Application.Devel

34 ghc-options: -Wall

37 ghc-options: -Wall

36Executable wai-handler-devel

39Executable wai-handler-devel