diff --git a/Network/Wai/Application/Devel.hs b/Network/Wai/Application/Devel.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Application/Devel.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.Wai.Application.Devel + ( -- * Types + AppHolder + , AppRunner + , WithAppRunner + -- * Functions + , initAppHolder + , swapApp + , swapAppSimple + , toApp + ) where + +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar + ( MVar, newEmptyMVar, newMVar + , takeMVar, putMVar, readMVar + ) +import Network.Wai (Application, responseLBS, status500) +import Data.ByteString.Lazy.Char8 () +import Control.Monad.IO.Class (liftIO) + +type AppHolder = MVar (Application, MVar ()) +type AppRunner = Application -> IO () +type WithAppRunner = AppRunner -> IO () + +initAppHolder :: IO AppHolder +initAppHolder = do + flag <- newEmptyMVar + newMVar (initApp, flag) + where + initApp _ = return + $ responseLBS status500 [("Content-Type", "text/plain")] + $ "No app has yet been loaded" + +swapAppSimple :: Application -> AppHolder -> IO () +swapAppSimple app = + swapApp war + where + war f = f app + +swapApp :: WithAppRunner -> AppHolder -> IO () +swapApp war ah = void $ forkIO $ war $ \app -> do + (_, oldFlag) <- takeMVar ah + -- allow the old app to cleanup + putMVar oldFlag () + -- now place the new app into the AppHolder, waiting for a termination + -- signal + flag <- newEmptyMVar + putMVar ah (app, flag) + takeMVar flag -- this causes execution to hang until we are terminated + where + void x = x >> return () + +toApp :: AppHolder -> Application +toApp ah req = do + (app, _) <- liftIO $ readMVar ah + app req diff --git a/Network/Wai/Handler/DevelServer.hs b/Network/Wai/Handler/DevelServer.hs --- a/Network/Wai/Handler/DevelServer.hs +++ b/Network/Wai/Handler/DevelServer.hs @@ -1,53 +1,60 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -module Network.Wai.Handler.DevelServer (run, runNoWatch) where +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +module Network.Wai.Handler.DevelServer + ( run + , runQuit + , runNoWatch + ) where -import Language.Haskell.Interpreter +import Language.Haskell.Interpreter hiding (typeOf) import Network.Wai -import qualified Data.ByteString.Lazy.UTF8 as U +import Data.Text.Lazy (pack) +import Data.Text.Lazy.Encoding (encodeUtf8) import qualified Data.ByteString.Lazy.Char8 as L8 -import Network - ( listenOn, accept, sClose, PortID(PortNumber), Socket - , withSocketsDo) -import Control.Exception (bracket, finally, Exception, - SomeException, toException) +import Control.Exception (Exception, SomeException, toException) import qualified Control.Exception as E -import System.IO (Handle, hClose) import Control.Concurrent (forkIO, threadDelay) -import qualified Control.Concurrent.MVar as M -import qualified Control.Concurrent.Chan as C import System.Directory (getModificationTime) -import Network.Wai.Handler.SimpleServer (parseRequest, sendResponse) -import Control.Monad (filterM) - -import Control.Arrow ((&&&)) -import System.Directory (doesDirectoryExist, - doesFileExist, getDirectoryContents) -import Control.Applicative ((<$>)) +import qualified Network.Wai.Handler.Warp as Warp +import Network.Wai.Application.Devel -import Data.List (nub) +import Data.List (nub, group, sort) +import System.Time (ClockTime) type FunctionName = String -runNoWatch :: Port -> ModuleName -> FunctionName -> [FilePath] -> IO () -runNoWatch port modu func dirs = do - queue <- C.newChan - mqueue <- M.newMVar queue - startApp queue $ loadingApp Nothing - reload modu func mqueue dirs Nothing - run' port mqueue +runNoWatch :: Int -> ModuleName -> FunctionName + -> (FilePath -> IO [FilePath]) -> IO () +runNoWatch port modu func extras = do + ah <- initAppHolder + _ <- reload modu func extras Nothing ah + Warp.run port $ toApp ah -run :: Port -> ModuleName -> FunctionName -> [FilePath] -> IO () -run port modu func dirs = do - queue <- C.newChan - mqueue <- M.newMVar queue - startApp queue $ loadingApp Nothing - _ <- forkIO $ fillApp modu func mqueue dirs - run' port mqueue +runQuit :: Int -> ModuleName -> FunctionName -> (FilePath -> IO [FilePath]) + -> IO () +runQuit port modu func extras = do + _ <- forkIO $ run port modu func extras + go + where + go = do + x <- getLine + case x of + 'q':_ -> putStrLn "Quitting, goodbye!" + _ -> go +run :: Int -> ModuleName -> FunctionName -> (FilePath -> IO [FilePath]) + -> IO () +run port modu func extras = do + ah <- initAppHolder + _ <- forkIO $ fillApp modu func extras ah + Warp.run port $ toApp ah + +{- startApp :: Queue -> Handler -> IO () startApp queue withApp = do forkIO (withApp go) >> return () @@ -61,17 +68,23 @@ go app onErr :: SomeException -> IO Response onErr e = return - $ Response status500 [("Content-Type", "text/plain; charset=utf-8")] - $ ResponseLBS $ U.fromString + $ responseLBS + status500 + [("Content-Type", "text/plain; charset=utf-8")] + $ charsToLBS $ "Exception thrown while running application\n\n" ++ show e void x = x >> return () +-} +getTimes :: [FilePath] -> IO [ClockTime] getTimes = E.handle (constSE $ return []) . mapM getModificationTime + constSE :: x -> SomeException -> x constSE = const -fillApp :: String -> String -> M.MVar Queue -> [FilePath] -> IO () -fillApp modu func mqueue dirs = +fillApp :: String -> String + -> (FilePath -> IO [FilePath]) -> AppHolder -> IO () +fillApp modu func dirs ah = go Nothing [] where go prevError prevFiles = do @@ -83,37 +96,41 @@ return $ times /= map snd prevFiles (newError, newFiles) <- if toReload - then reload modu func mqueue dirs prevError + then reload modu func dirs prevError ah else return (prevError, prevFiles) threadDelay 1000000 go newError newFiles --- reload :: String -> String -> M.MVar Queue -> [FilePath] -> Maybe SomeException -> IO (Maybe SomeException, [ClockTime]) -reload modu func mqueue dirs prevError = do +reload :: String -> String + -> (FilePath -> IO [FilePath]) + -> Maybe SomeException + -> AppHolder + -> IO (Maybe SomeException, [(FilePath, ClockTime)]) +reload modu func extras prevError ah = do case prevError of Nothing -> putStrLn "Attempting to interpret your app..." _ -> return () - loadingApp' prevError mqueue + loadingApp' prevError ah res <- theapp modu func case res of Left err -> do if show (Just err) /= show prevError then putStrLn $ "Compile failed: " ++ showInterpError err else return () - loadingApp' (Just $ toException err) mqueue + loadingApp' (Just $ toException err) ah return (Just $ toException err, []) Right (app, files') -> E.handle onInitErr $ do - files'' <- mapM fileList dirs - let files = concat $ files' : files'' + files'' <- mapM extras files' + let files = map head $ group $ sort $ concat $ files' : files'' putStrLn "Interpreting success, new app loaded" E.handle onInitErr $ do - swapApp app mqueue + swapApp app ah times <- getTimes files return (Nothing, zip files times) where onInitErr e = do putStrLn $ "Error initializing application: " ++ show e - loadingApp' (Just e) mqueue + loadingApp' (Just e) ah return (Just e, []) showInterpError :: InterpreterError -> String @@ -121,49 +138,24 @@ concat . nub $ map (\(GhcError msg) -> '\n':'\n':msg) errs showInterpError err = show err -fileList :: FilePath -> IO [FilePath] -fileList top = do - ex <- doesDirectoryExist top - if ex then fileList' top "" else return [] - -fileList' :: FilePath -> FilePath -> IO [FilePath] -fileList' realTop top = do - let prefix1 = top ++ "/" - prefix2 = realTop ++ prefix1 - allContents <- filter notHidden <$> getDirectoryContents prefix2 - let all' = map ((++) prefix1 &&& (++) prefix2) allContents - files <- map snd <$> filterM (doesFileExist . snd) all' - dirs <- filterM (doesDirectoryExist . snd) all' >>= - mapM (fileList' realTop . fst) - return $ concat $ files : dirs - -notHidden :: FilePath -> Bool -notHidden ('.':_) = False -notHidden _ = True - -loadingApp' :: Maybe SomeException -> M.MVar Queue -> IO () -loadingApp' err mqueue = swapApp (loadingApp err) mqueue - -swapApp :: Handler -> M.MVar Queue -> IO () -swapApp app mqueue = do - oldqueue <- M.takeMVar mqueue - C.writeChan oldqueue Nothing - queue <- C.newChan - M.putMVar mqueue queue - startApp queue app +loadingApp' :: Maybe SomeException -> AppHolder -> IO () +loadingApp' err = swapApp (loadingApp err) loadingApp :: Maybe SomeException -> Handler loadingApp err f = - f $ const $ return $ Response status200 + f $ const $ return $ responseLBS status200 ( ("Content-Type", "text/plain") : case err of Nothing -> [("Refresh", "1")] Just _ -> [] - ) $ ResponseLBS $ L8.pack $ toMessage err + ) $ toMessage err where toMessage Nothing = "Loading code changes, please wait" - toMessage (Just err') = "Error loading code: " ++ show err' + toMessage (Just err') = charsToLBS $ "Error loading code: " ++ show err' +charsToLBS :: String -> L8.ByteString +charsToLBS = encodeUtf8 . pack + type Handler = (Application -> IO ()) -> IO () theapp :: String -> String -> IO (Either InterpreterError (Handler, [FilePath])) @@ -171,36 +163,10 @@ runInterpreter $ do loadModules [modu] mods <- getLoadedModules - setImports ["Prelude", "Network.Wai", modu] + setImports ["Prelude", "Network.Wai", "Data.Enumerator", "Data.ByteString.Internal", modu] app <- interpret func infer return (app, map toFile mods) where toFile s = map toSlash s ++ ".hs" toSlash '.' = '/' toSlash c = c - -run' :: Port -> M.MVar Queue -> IO () -run' port = withSocketsDo . - bracket - (listenOn $ PortNumber $ fromIntegral port) - sClose . - serveConnections port -type Port = Int - -serveConnections :: Port -> M.MVar Queue -> Socket -> IO () -serveConnections port mqueue socket = do - (conn, remoteHost', _) <- accept socket - _ <- forkIO $ serveConnection port mqueue conn remoteHost' - serveConnections port mqueue socket - -type Queue = C.Chan (Maybe (Request, Response -> IO ())) - -serveConnection :: Port -> M.MVar Queue -> Handle -> String -> IO () -serveConnection port mqueue conn remoteHost' = do - env <- parseRequest port conn remoteHost' - let onRes res = - finally - (sendResponse (httpVersion env) conn res) - (hClose conn) - queue <- M.readMVar mqueue - C.writeChan queue $ Just (env, onRes) diff --git a/wai-handler-devel-unwatched.hs b/wai-handler-devel-unwatched.hs --- a/wai-handler-devel-unwatched.hs +++ b/wai-handler-devel-unwatched.hs @@ -7,23 +7,19 @@ { port :: Int , moduleName :: String , function :: String - , yesod :: Bool } deriving (Show, Data, Typeable) main :: IO () main = do - Devel p m f y <- cmdArgs Devel + Devel p m f <- cmdArgs Devel { port = 3000 &= argPos 0 &= typ "PORT" , moduleName = "" &= argPos 1 &= typ "MODULE" , function = "" &= argPos 2 &= typ "FUNCTION" - , yesod = False &= help "Monitor typical Yesod folders (hamlet, etc)" } &= summary "WAI development web server" - _ <- forkIO $ runNoWatch p m f $ folders y + _ <- forkIO $ runNoWatch p m f $ const $ return [] go where - folders False = [] - folders True = ["hamlet", "cassius", "julius"] go = do x <- getLine case x of diff --git a/wai-handler-devel.cabal b/wai-handler-devel.cabal --- a/wai-handler-devel.cabal +++ b/wai-handler-devel.cabal @@ -1,5 +1,5 @@ Name: wai-handler-devel -Version: 0.1.1.2 +Version: 0.2.0 Synopsis: WAI server that automatically reloads code after modification. Description: 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. . @@ -21,15 +21,19 @@ location: git://github.com/snoyberg/wai-handler-devel.git Library - Build-Depends: base >= 3 && < 5 - , wai >= 0.2.1 && < 0.3 - , wai-extra >= 0.2.3 && < 0.3 - , directory >= 1.0 && < 1.2 - , network >= 2.2 && < 2.4 - , bytestring >= 0.9 && < 0.10 - , hint >= 0.3.2.3 && < 0.4 - , utf8-string >= 0.3 && < 0.4 + Build-Depends: base >= 4 && < 5 + , wai >= 0.3 && < 0.4 + , warp >= 0.3 && < 0.4 + , directory >= 1.0 && < 1.2 + , network >= 2.2 && < 2.4 + , bytestring >= 0.9 && < 0.10 + , hint >= 0.3.2.3 && < 0.4 + , text >= 0.7 && < 0.12 + , old-time >= 1.0 && < 1.1 + , enumerator >= 0.4.6 && < 0.5 + , transformers >= 0.2.2 && < 0.3 Exposed-modules: Network.Wai.Handler.DevelServer + Network.Wai.Application.Devel ghc-options: -Wall Executable wai-handler-devel diff --git a/wai-handler-devel.hs b/wai-handler-devel.hs --- a/wai-handler-devel.hs +++ b/wai-handler-devel.hs @@ -1,31 +1,19 @@ {-# LANGUAGE DeriveDataTypeable #-} -import Network.Wai.Handler.DevelServer (run) +import Network.Wai.Handler.DevelServer (runQuit) import System.Console.CmdArgs -import Control.Concurrent (forkIO) data Devel = Devel { port :: Int , moduleName :: String , function :: String - , yesod :: Bool } deriving (Show, Data, Typeable) main :: IO () main = do - Devel p m f y <- cmdArgs Devel + Devel p m f <- cmdArgs Devel { port = 3000 &= argPos 0 &= typ "PORT" , moduleName = "" &= argPos 1 &= typ "MODULE" , function = "" &= argPos 2 &= typ "FUNCTION" - , yesod = False &= help "Monitor typical Yesod folders (hamlet, etc)" } &= summary "WAI development web server" - _ <- forkIO $ run p m f $ folders y - go - where - folders False = [] - folders True = ["hamlet", "cassius", "julius"] - go = do - x <- getLine - case x of - 'q':_ -> putStrLn "Quitting, goodbye!" - _ -> go + runQuit p m f $ const $ return []