@@ -0,0 +1,185 @@
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+ ) where
10+
11+import Language.Haskell.Interpreter hiding (typeOf)
12+import Network.Wai
13+import Network.HTTP.Types (status200)
14+
15+import Data.Text.Lazy (pack)
16+import Data.Text.Lazy.Encoding (encodeUtf8)
17+import qualified Data.ByteString.Lazy.Char8 as L8
18+import Control.Exception (Exception, SomeException, toException, fromException)
19+import qualified Control.Exception as E
20+import Control.Concurrent (forkIO, threadDelay)
21+
22+import Data.Maybe
23+import Control.Monad
24+import Control.Concurrent.MVar
25+
26+import System.Directory (getModificationTime)
27+import qualified Network.Wai.Handler.Warp as Warp
28+import Network.Wai.Application.Devel
29+import Network.Wai.Middleware.Debug (debug)
30+
31+import Data.List (nub, group, sort)
32+import System.Time (ClockTime)
33+
34+type FunctionName = String
35+
36+runNoWatch :: Int -> ModuleName -> FunctionName
37+ -> (FilePath -> IO [FilePath]) -> IO ()
38+runNoWatch port modu func extras = do
39+ ah <- initAppHolder
40+ _ <- reload modu func extras Nothing ah
41+ Warp.run port $ toApp ah
42+
43+runQuit :: Int -> ModuleName -> FunctionName -> (FilePath -> IO [FilePath])
44+ -> IO ()
45+runQuit port modu func extras = do
46+ sig <- newEmptyMVar
47+ _ <- forkIO $ run port modu func extras (Just sig)
48+ go sig
49+ where
50+ go sig = do
51+ x <- getLine
52+ case x of
53+ 'q':_ -> putStrLn "Quitting, goodbye!"
54+ 'r':_ -> do
55+ putStrLn "Forcing reinterpretation"
56+ _ <- tryPutMVar sig ()
57+ go sig
58+ _ -> go sig
59+
60+run :: Int -> ModuleName -> FunctionName -> (FilePath -> IO [FilePath]) -> Maybe (MVar ())
61+ -> IO ()
62+run port modu func extras msig = do
63+ ah <- initAppHolder
64+ _ <- forkIO $ fillApp modu func extras ah msig
65+ Warp.run port $ toApp ah
66+
67+{-
68+startApp :: Queue -> Handler -> IO ()
69+startApp queue withApp = do
70+ forkIO (withApp go) >> return ()
71+ where
72+ go app = do
73+ msession <- C.readChan queue
74+ case msession of
75+ Nothing -> return ()
76+ Just (req, onRes) -> do
77+ void $ forkIO $ (E.handle onErr $ app req) >>= onRes
78+ go app
79+ onErr :: SomeException -> IO Response
80+ onErr e = return
81+ $ responseLBS
82+ status500
83+ [("Content-Type", "text/plain; charset=utf-8")]
84+ $ charsToLBS
85+ $ "Exception thrown while running application\n\n" ++ show e
86+ void x = x >> return ()
87+-}
88+
89+getTimes :: [FilePath] -> IO [ClockTime]
90+getTimes = E.handle (constSE $ return []) . mapM getModificationTime
91+
92+constSE :: x -> SomeException -> x
93+constSE = const
94+
95+fillApp :: String -> String
96+ -> (FilePath -> IO [FilePath]) -> AppHolder -> Maybe (MVar ()) -> IO ()
97+fillApp modu func dirs ah msig =
98+ go Nothing []
99+ where
100+ go prevError prevFiles = do
101+ forceReload <- maybe (return False) (fmap isJust . tryTakeMVar) msig
102+ toReload <-
103+ if forceReload || null prevFiles
104+ then return True
105+ else do
106+ times <- getTimes $ map fst prevFiles
107+ return $ times /= map snd prevFiles
108+ (newError, newFiles) <-
109+ if toReload
110+ then reload modu func dirs prevError ah
111+ else return (prevError, prevFiles)
112+ threadDelay 1000000
113+ go newError newFiles
114+
115+reload :: String -> String
116+ -> (FilePath -> IO [FilePath])
117+ -> Maybe SomeException
118+ -> AppHolder
119+ -> IO (Maybe SomeException, [(FilePath, ClockTime)])
120+reload modu func extras prevError ah = do
121+ case prevError of
122+ Nothing -> putStrLn "Attempting to interpret your app..."
123+ _ -> return ()
124+ loadingApp' prevError ah
125+ res <- theapp modu func
126+ case res of
127+ Left err -> do
128+ when (show (Just err) /= show prevError) $
129+ putStrLn $ "Compile failed: " ++ showInterpError err
130+ loadingApp' (Just $ toException err) ah
131+ return (Just $ toException err, [])
132+ Right (app, files') -> E.handle onInitErr $ do
133+ files'' <- mapM extras files'
134+ let files = map head $ group $ sort $ concat $ files' : files''
135+ putStrLn "Interpreting success, new app loaded"
136+ E.handle onInitErr $ do
137+ swapApp (\f -> app $ f . debug) ah
138+ times <- getTimes files
139+ return (Nothing, zip files times)
140+ where
141+ onInitErr e = do
142+ putStrLn $ "Error initializing application: " ++ show e
143+ loadingApp' (Just e) ah
144+ return (Just e, [])
145+
146+showInterpError :: InterpreterError -> String
147+showInterpError (WontCompile errs) =
148+ concat . nub $ map (\(GhcError msg) -> '\n':'\n':msg) errs
149+showInterpError err = show err
150+
151+loadingApp' :: Maybe SomeException -> AppHolder -> IO ()
152+loadingApp' err = swapApp (loadingApp err)
153+
154+loadingApp :: Maybe SomeException -> Handler
155+loadingApp err f =
156+ f $ const $ return $ responseLBS status200
157+ ( ("Content-Type", "text/plain")
158+ : case err of
159+ Nothing -> [("Refresh", "1")]
160+ Just _ -> []
161+ ) $ toMessage err
162+ where
163+ toMessage Nothing = "Loading code changes, please wait"
164+ toMessage (Just err') = charsToLBS $ "Error loading code: " ++
165+ (case fromException err' of
166+ Just e -> showInterpError e
167+ Nothing -> show err')
168+
169+charsToLBS :: String -> L8.ByteString
170+charsToLBS = encodeUtf8 . pack
171+
172+type Handler = (Application -> IO ()) -> IO ()
173+
174+theapp :: String -> String -> IO (Either InterpreterError (Handler, [FilePath]))
175+theapp modu func =
176+ runInterpreter $ do
177+ loadModules [modu]
178+ mods <- getLoadedModules
179+ setImports ["Prelude", "Network.Wai", "Data.Enumerator", "Data.ByteString.Internal", modu]
180+ app <- interpret func infer
181+ return (app, map toFile mods)
182+ where
183+ toFile s = map toSlash s ++ ".hs"
184+ toSlash '.' = '/'
185+ toSlash c = c