@@ -1,215 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−module Network.Wai.Handler.DevelServer
6− ( run
7− , runQuit
8− , runNoWatch
9− , runWithReloadActions
10− , runQuitWithReloadActions
11− ) where
12−
13−import Language.Haskell.Interpreter hiding (typeOf)
14−import Network.Wai
15−import Network.HTTP.Types (status200)
16−
17−import Data.Text.Lazy (pack)
18−import Data.Text.Lazy.Encoding (encodeUtf8)
19−import qualified Data.ByteString.Lazy.Char8 as L8
20−import Control.Exception (Exception, SomeException, toException, fromException, finally, mask)
21−import qualified Control.Exception as E
22−import Control.Concurrent (ThreadId, myThreadId, threadDelay, killThread)
23−import qualified Control.Concurrent as Concurrent
24−
25−import Data.Maybe
26−import Control.Monad
27−import Control.Concurrent.MVar
28−
29−import qualified Network.Wai.Handler.Warp as Warp
30−import Network.Wai.Application.Devel
31−import Network.Wai.Middleware.RequestLogger (logStdoutDev)
32−
33−import Data.List (nub, group, sort)
34−
35−import Network.Wai.Handler.DevelServer.Compat
36−
37−type FunctionName = String
38−
39−runNoWatch :: Int -> ModuleName -> FunctionName
40− -> (FilePath -> IO [FilePath]) -> IO ()
41−runNoWatch port modu func extras = do
42− ah <- initAppHolder
43− _ <- reload modu func extras Nothing ah []
44− Warp.run port $ toApp ah
45−
46−runQuit :: Int -> ModuleName -> FunctionName -> (FilePath -> IO [FilePath])
47− -> IO ()
48−runQuit port modu func extras = runQuitWithReloadActions port modu func extras []
49−
50−-- |
51−-- A version of `Concurrent.forkIO` that re-throws any uncaught
52−-- `E.UserInterrupt` from the child thread in the parent thread.
53−--
54−-- We need this because using hint (or the GHC API) causes @UserInterrupt@ to
55−-- occur in the thread that runs `runInterpreter` instead of the main thread.
56−forkIO :: IO () -> IO ThreadId
57−forkIO action = do
58− threadId <- myThreadId
59− Concurrent.forkIO (action `E.catch` \e -> case e of
60− E.UserInterrupt -> E.throwTo threadId e
61− _ -> E.throwIO e
62− )
63−
64−runQuitWithReloadActions :: Int -> ModuleName -> FunctionName -> (FilePath -> IO [FilePath])
65− -> [IO (IO ())] -> IO ()
66−runQuitWithReloadActions port modu func extras actions = do
67− sig <- newEmptyMVar
68− mask $ \unmask -> do
69− threadId <- forkIO $ runWithReloadActions port modu func extras (Just sig) actions
70− unmask (go sig) `finally` killThread threadId
71− where
72− go sig = do
73− x <- getLine
74− case x of
75− 'q':_ -> putStrLn "Quitting, goodbye!"
76− 'r':_ -> do
77− putStrLn "Forcing reinterpretation"
78− _ <- tryPutMVar sig ()
79− go sig
80− _ -> go sig
81−
82−runWithReloadActions :: Int -> ModuleName -> FunctionName -> (FilePath -> IO [FilePath])
83− -> Maybe (MVar ()) -> [IO (IO ())] -> IO ()
84−runWithReloadActions port modu func extras msig initActions = do
85− actions <- mapM id initActions
86− ah <- initAppHolder
87− mask $ \unmask -> do
88− threadId <- forkIO $ fillApp modu func extras ah msig actions
89− unmask (Warp.run port $ toApp ah) `finally` killThread threadId
90−
91−run :: Int -> ModuleName -> FunctionName -> (FilePath -> IO [FilePath]) -> Maybe (MVar ())
92− -> IO ()
93−run port modu func extras msig = runWithReloadActions port modu func extras msig []
94−
95−{-
96−startApp :: Queue -> Handler -> IO ()
97−startApp queue withApp = do
98− forkIO (withApp go) >> return ()
99− where
100− go app = do
101− msession <- C.readChan queue
102− case msession of
103− Nothing -> return ()
104− Just (req, onRes) -> do
105− void $ forkIO $ (E.handle onErr $ app req) >>= onRes
106− go app
107− onErr :: SomeException -> IO Response
108− onErr e = return
109− $ responseLBS
110− status500
111− [("Content-Type", "text/plain; charset=utf-8")]
112− $ charsToLBS
113− $ "Exception thrown while running application\n\n" ++ show e
114− void x = x >> return ()
115−-}
116−
117−getTimes :: [FilePath] -> IO [TimeStamp]
118−getTimes = E.handle (constSE $ return []) . mapM getTimeStamp
119−
120−constSE :: x -> SomeException -> x
121−constSE = const
122−
123−fillApp :: String -> String
124− -> (FilePath -> IO [FilePath]) -> AppHolder -> Maybe (MVar ()) -> [IO ()] -> IO ()
125−fillApp modu func dirs ah msig actions =
126− go Nothing []
127− where
128− go prevError prevFiles = do
129− forceReload <- maybe (return False) (fmap isJust . tryTakeMVar) msig
130− toReload <-
131− if forceReload || null prevFiles
132− then return True
133− else do
134− times <- getTimes $ map fst prevFiles
135− return $ times /= map snd prevFiles
136− (newError, newFiles) <-
137− if toReload
138− then reload modu func dirs prevError ah actions
139− else return (prevError, prevFiles)
140− threadDelay 1000000
141− go newError newFiles
142−
143−reload :: String -> String
144− -> (FilePath -> IO [FilePath])
145− -> Maybe SomeException
146− -> AppHolder
147− -> [IO ()]
148− -> IO (Maybe SomeException, [(FilePath, TimeStamp)])
149−reload modu func extras prevError ah actions = do
150− case prevError of
151− Nothing -> putStrLn "Attempting to interpret your app..."
152− _ -> return ()
153− loadingApp' prevError ah
154− res <- theapp modu func
155− case res of
156− Left err -> do
157− when (show (Just err) /= show prevError) $
158− putStrLn $ "Compile failed: " ++ showInterpError err
159− loadingApp' (Just $ toException err) ah
160− return (Just $ toException err, [])
161− Right (app, files') -> E.handle onInitErr $ do
162− files'' <- mapM extras files'
163− let files = map head $ group $ sort $ concat $ files' : files''
164− putStrLn "Interpreting success, new app loaded"
165− E.handle onInitErr $ do
166− swapApp (\f -> app $ f . logStdoutDev) ah
167− times <- getTimes files
168− sequence_ actions
169− return (Nothing, zip files times)
170− where
171− onInitErr e = do
172− putStrLn $ "Error initializing application: " ++ show e
173− loadingApp' (Just e) ah
174− return (Just e, [])
175−
176−showInterpError :: InterpreterError -> String
177−showInterpError (WontCompile errs) =
178− concat . nub $ map (\(GhcError msg) -> '\n':'\n':msg) errs
179−showInterpError err = show err
180−
181−loadingApp' :: Maybe SomeException -> AppHolder -> IO ()
182−loadingApp' err = swapApp (loadingApp err)
183−
184−loadingApp :: Maybe SomeException -> Handler
185−loadingApp err f =
186− f $ const $ return $ responseLBS status200
187− ( ("Content-Type", "text/plain")
188− : case err of
189− Nothing -> [("Refresh", "1")]
190− Just _ -> []
191− ) $ toMessage err
192− where
193− toMessage Nothing = "Loading code changes, please wait"
194− toMessage (Just err') = charsToLBS $ "Error loading code: " ++
195− (case fromException err' of
196− Just e -> showInterpError e
197− Nothing -> show err')
198−
199−charsToLBS :: String -> L8.ByteString
200−charsToLBS = encodeUtf8 . pack
201−
202−type Handler = (Application -> IO ()) -> IO ()
203−
204−theapp :: String -> String -> IO (Either InterpreterError (Handler, [FilePath]))
205−theapp modu func =
206− runInterpreter $ do
207− loadModules [modu]
208− mods <- getLoadedModules
209− setImports ["Prelude", "Network.Wai", "Data.ByteString.Internal", "Control.Monad.Trans.Resource", modu]
210− app <- interpret func infer
211− return (app, map toFile mods)
212− where
213− toFile s = map toSlash s ++ ".hs"
214− toSlash '.' = '/'
215− toSlash c = c