@@ -1,13 +1,15 @@
11{-# LANGUAGE DeriveDataTypeable #-}
22{-# LANGUAGE FlexibleContexts #-}
33{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE StandaloneDeriving #-}
46module Network.Wai.Handler.DevelServer
57 ( run
68 , runQuit
79 , runNoWatch
810 ) where
911
10−import Language.Haskell.Interpreter
12+import Language.Haskell.Interpreter hiding (typeOf)
1113import Network.Wai
1214
1315import Data.Text.Lazy (pack)
@@ -25,23 +27,25 @@ import Control.Concurrent (forkIO, threadDelay)
2527import qualified Control.Concurrent.MVar as M
2628import qualified Control.Concurrent.Chan as C
2729import 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
2932
3033import Data.List (nub, group, sort)
3134import System.Time (ClockTime)
35+import Data.Typeable (typeOf, Typeable1 (..), mkTyCon, mkTyConApp)
36+import Data.Enumerator (Iteratee)
37+import Data.ByteString (ByteString)
3238
3339type FunctionName = String
3440
35−runNoWatch :: Port -> ModuleName -> FunctionName
41+runNoWatch :: Int -> ModuleName -> FunctionName
3642 -> (FilePath -> IO [FilePath]) -> IO ()
3743runNoWatch port modu func extras = do
38− queue <- C.newChan
39− mqueue <- M.newMVar queue
40− startApp queue $ loadingApp Nothing
41− _ <- reload modu func mqueue extras Nothing
42− run' port mqueue
44+ ah <- initAppHolder
45+ _ <- reload modu func extras Nothing ah
46+ Warp.run port $ toApp ah
4347
44−runQuit :: Port -> ModuleName -> FunctionName -> (FilePath -> IO [FilePath])
48+runQuit :: Int -> ModuleName -> FunctionName -> (FilePath -> IO [FilePath])
4549 -> IO ()
4650runQuit port modu func extras = do
4751 _ <- forkIO $ run port modu func extras
@@ -53,15 +57,14 @@ runQuit port modu func extras = do
5357 'q':_ -> putStrLn "Quitting, goodbye!"
5458 _ -> go
5559
56−run :: Port -> ModuleName -> FunctionName -> (FilePath -> IO [FilePath])
60+run :: Int -> ModuleName -> FunctionName -> (FilePath -> IO [FilePath])
5761 -> IO ()
5862run port modu func extras = do
59− queue <- C.newChan
60− mqueue <- M.newMVar queue
61− startApp queue $ loadingApp Nothing
62− _ <- forkIO $ fillApp modu func mqueue extras
63− run' port mqueue
63+ ah <- initAppHolder
64+ _ <- forkIO $ fillApp modu func extras ah
65+ Warp.run port $ toApp ah
6466
67+{-
6568startApp :: Queue -> Handler -> IO ()
6669startApp queue withApp = do
6770 forkIO (withApp go) >> return ()
@@ -81,6 +84,7 @@ startApp queue withApp = do
8184 $ charsToLBS
8285 $ "Exception thrown while running application\n\n" ++ show e
8386 void x = x >> return ()
87+-}
8488
8589getTimes :: [FilePath] -> IO [ClockTime]
8690getTimes = E.handle (constSE $ return []) . mapM getModificationTime
@@ -88,9 +92,9 @@ getTimes = E.handle (constSE $ return []) . mapM getModificationTime
8892constSE :: x -> SomeException -> x
8993constSE = const
9094
91−fillApp :: String -> String -> M.MVar Queue
92− -> (FilePath -> IO [FilePath]) -> IO ()
93−fillApp modu func mqueue dirs =
95+fillApp :: String -> String
96+ -> (FilePath -> IO [FilePath]) -> AppHolder -> IO ()
97+fillApp modu func dirs ah =
9498 go Nothing []
9599 where
96100 go prevError prevFiles = do
@@ -102,40 +106,41 @@ fillApp modu func mqueue dirs =
102106 return $ times /= map snd prevFiles
103107 (newError, newFiles) <-
104108 if toReload
105− then reload modu func mqueue dirs prevError
109+ then reload modu func dirs prevError ah
106110 else return (prevError, prevFiles)
107111 threadDelay 1000000
108112 go newError newFiles
109113
110−reload :: String -> String -> M.MVar Queue
114+reload :: String -> String
111115 -> (FilePath -> IO [FilePath])
112116 -> Maybe SomeException
117+ -> AppHolder
113118 -> IO (Maybe SomeException, [(FilePath, ClockTime)])
114−reload modu func mqueue extras prevError = do
119+reload modu func extras prevError ah = do
115120 case prevError of
116121 Nothing -> putStrLn "Attempting to interpret your app..."
117122 _ -> return ()
118− loadingApp' prevError mqueue
123+ loadingApp' prevError ah
119124 res <- theapp modu func
120125 case res of
121126 Left err -> do
122127 if show (Just err) /= show prevError
123128 then putStrLn $ "Compile failed: " ++ showInterpError err
124129 else return ()
125− loadingApp' (Just $ toException err) mqueue
130+ loadingApp' (Just $ toException err) ah
126131 return (Just $ toException err, [])
127132 Right (app, files') -> E.handle onInitErr $ do
128133 files'' <- mapM extras files'
129134 let files = map head $ group $ sort $ concat $ files' : files''
130135 putStrLn "Interpreting success, new app loaded"
131136 E.handle onInitErr $ do
132− swapApp app mqueue
137+ swapApp app ah
133138 times <- getTimes files
134139 return (Nothing, zip files times)
135140 where
136141 onInitErr e = do
137142 putStrLn $ "Error initializing application: " ++ show e
138− loadingApp' (Just e) mqueue
143+ loadingApp' (Just e) ah
139144 return (Just e, [])
140145
141146showInterpError :: InterpreterError -> String
@@ -143,16 +148,8 @@ showInterpError (WontCompile errs) =
143148 concat . nub $ map (\(GhcError msg) -> '\n':'\n':msg) errs
144149showInterpError err = show err
145150
146−loadingApp' :: Maybe SomeException -> M.MVar Queue -> IO ()
147−loadingApp' err mqueue = swapApp (loadingApp err) mqueue
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
151+loadingApp' :: Maybe SomeException -> AppHolder -> IO ()
152+loadingApp' err = swapApp (loadingApp err)
156153
157154loadingApp :: Maybe SomeException -> Handler
158155loadingApp err f =
@@ -171,44 +168,23 @@ charsToLBS = encodeUtf8 . pack
171168
172169type Handler = (Application -> IO ()) -> IO ()
173170
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+
174179theapp :: String -> String -> IO (Either InterpreterError (Handler, [FilePath]))
175180theapp modu func =
176181 runInterpreter $ do
177182 loadModules [modu]
178183 mods <- getLoadedModules
179− setImports ["Prelude", "Network.Wai", modu]
184+ setImports ["Prelude", "Network.Wai", "Data.Enumerator", "Data.ByteString.Internal", modu]
180185 app <- interpret func infer
181186 return (app, map toFile mods)
182187 where
183188 toFile s = map toSlash s ++ ".hs"
184189 toSlash '.' = '/'
185190 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)