diff --git a/Network/Wai/Application/Devel.hs b/Network/Wai/Application/Devel.hs deleted file mode 100644 --- a/Network/Wai/Application/Devel.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# 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) -import Network.HTTP.Types (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/Scaffold/Devel.hs b/Scaffold/Devel.hs --- a/Scaffold/Devel.hs +++ b/Scaffold/Devel.hs @@ -13,28 +13,41 @@ import Distribution.PackageDescription (FlagName (FlagName), package, emptyHookedBuildInfo) import Distribution.Simple.LocalBuildInfo (localPkgDescr) import Scaffold.Build (getDeps, touchDeps, findHaskellFiles) -import System.Plugins (loadDynamic) import Network.Wai.Handler.Warp (run) -import Network.Wai.Application.Devel import Network.Wai.Middleware.Debug (debug) -import Data.Dynamic (fromDynamic) import Distribution.Text (display) import Distribution.Simple.Install (install) import Distribution.Simple.Register (register) -import Control.Concurrent (forkIO, threadDelay) -import Control.Exception (try, SomeException) +import Control.Concurrent (forkIO, threadDelay, ThreadId, killThread) +import Control.Exception (try, SomeException, finally) import System.PosixCompat.Files (modificationTime, getFileStatus) import qualified Data.Map as Map import System.Posix.Types (EpochTime) import Blaze.ByteString.Builder.Char.Utf8 (fromString) -import Network.Wai (Application, Response (ResponseBuilder)) +import Network.Wai (Application, Response (ResponseBuilder), responseLBS) import Network.HTTP.Types (status500) -import Control.Monad (when) +import Control.Monad (when, forever) +import System.Process (runCommand, terminateProcess, getProcessExitCode, waitForProcess) +import qualified Data.IORef as I +import qualified Data.ByteString.Lazy.Char8 as L +import System.Directory (doesFileExist, removeFile) +import Distribution.Package (PackageName (..), pkgName) +appMessage :: L.ByteString -> IO () +appMessage l = forever $ do + run 3000 . const . return $ responseLBS status500 [("Content-Type", "text/plain")] l + threadDelay 10000 + +swapApp :: I.IORef ThreadId -> IO ThreadId -> IO () +swapApp i f = do + I.readIORef i >>= killThread + f >>= I.writeIORef i + devel :: IO () devel = do - appHolder <- initAppHolder - _ <- forkIO $ run 3000 $ debug $ toApp appHolder + e <- doesFileExist "dist/devel-flag" + when e $ removeFile "dist/devel-flag" + listenThread <- forkIO (appMessage "Initializing, please wait") >>= I.newIORef cabal <- defaultPackageDesc normal gpd <- readPackageDescription normal cabal @@ -50,12 +63,15 @@ , configUserInstall = Flag True } - let myTry :: IO (Either String x) -> IO (Either String x) - myTry f = try f >>= \x -> return $ case x of - Left e -> Left $ show (e :: SomeException) - Right y -> y - let getNewApp :: IO (Either String WithAppRunner) + let myTry :: IO () -> IO () + myTry f = try f >>= \x -> case x of + Left e -> swapApp listenThread $ forkIO $ appMessage $ L.pack $ show (e :: SomeException) + Right y -> return y + let getNewApp :: IO () getNewApp = myTry $ do + putStrLn "Rebuilding app" + swapApp listenThread $ forkIO $ appMessage "Rebuilding your app, please wait" + deps <- getDeps touchDeps deps @@ -68,15 +84,52 @@ install (localPkgDescr lbi) lbi defaultCopyFlags register (localPkgDescr lbi) lbi defaultRegisterFlags - let pi' = display $ package $ localPkgDescr lbi - dyn <- loadDynamic (pi', "Controller", "withDevelApp") - return $ case fmap fromDynamic dyn of - Nothing -> Left "withDevelApp not found" - Just Nothing -> Left "Not a withApp" - Just (Just withApp) -> Right withApp + let PackageName pi' = pkgName $ package $ localPkgDescr lbi + writeFile "dist/devel.hs" $ unlines + [ "{-# LANGUAGE PackageImports #-}" + , concat + [ "import \"" + , pi' + , "\" Controller (withDevelApp)" + ] + , "import Data.Dynamic (fromDynamic)" + , "import Network.Wai.Handler.Warp (run)" + , "import Network.Wai.Middleware.Debug (debug)" + , "import Data.Maybe (fromJust)" + , "import Control.Concurrent (forkIO)" + , "import System.Directory (doesFileExist, removeFile)" + , "import Control.Concurrent (threadDelay)" + , "" + , "main :: IO ()" + , "main = do" + , " putStrLn \"Starting app\"" + , " forkIO $ (fromJust $ fromDynamic withDevelApp) $ run 3000" + , " loop" + , "" + , "loop :: IO ()" + , "loop = do" + , " threadDelay 100000" + , " e <- doesFileExist \"dist/devel-flag\"" + , " if e then removeFile \"dist/devel-flag\" else loop" + ] + swapApp listenThread $ forkIO $ do + putStrLn "Calling runghc..." + ph <- runCommand "runghc dist/devel.hs" + let forceType :: Either SomeException () -> () + forceType = const () + fmap forceType $ try sleepForever + writeFile "dist/devel-flag" "" + putStrLn "Terminating external process" + terminateProcess ph + putStrLn "Process terminated" + ec <- waitForProcess ph + putStrLn $ "Exit code: " ++ show ec - loop Map.empty appHolder getNewApp + loop Map.empty getNewApp +sleepForever :: IO () +sleepForever = forever $ threadDelay 1000000 + type FileList = Map.Map FilePath EpochTime getFileList :: IO FileList @@ -88,16 +141,13 @@ fs <- getFileStatus f return (f, modificationTime fs) -loop :: FileList -> AppHolder -> IO (Either String WithAppRunner) -> IO () -loop oldList appHolder getNewApp = do +loop :: FileList -> IO () -> IO () +loop oldList getNewApp = do + putStrLn "Testing files..." newList <- getFileList - when (newList /= oldList) $ do - res <- getNewApp - case res of - Left s -> swapAppSimple (errApp s) appHolder - Right x -> swapApp x appHolder + when (newList /= oldList) getNewApp threadDelay 1000000 - loop newList appHolder getNewApp + loop newList getNewApp errApp :: String -> Application errApp s _ = return $ ResponseBuilder status500 [("Content-Type", "text/plain")] $ fromString s diff --git a/yesod.cabal b/yesod.cabal --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.8.0 +version: 0.8.1 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -24,7 +24,7 @@ cpp-options: -DGHC7 else build-depends: base >= 4 && < 4.3 - build-depends: yesod-core >= 0.8 && < 0.9 + build-depends: yesod-core >= 0.8.1 && < 0.9 , yesod-auth >= 0.4 && < 0.5 , yesod-json >= 0.1 && < 0.2 , yesod-persistent >= 0.1 && < 0.2 @@ -34,7 +34,7 @@ , transformers >= 0.2 && < 0.3 , wai >= 0.4 && < 0.5 , wai-extra >= 0.4 && < 0.5 - , hamlet >= 0.8 && < 0.9 + , hamlet >= 0.8.1 && < 0.9 , warp >= 0.4 && < 0.5 , mime-mail >= 0.3 && < 0.4 , hjsmin >= 0.0.13 && < 0.1 @@ -59,13 +59,12 @@ , attoparsec-text >= 0.8.5 && < 0.9 , http-types >= 0.6.1 && < 0.7 , blaze-builder >= 0.2 && < 0.4 - , direct-plugins >= 1.1 && < 1.2 + , process ghc-options: -Wall -threaded main-is: scaffold.hs other-modules: CodeGen Scaffold.Build Scaffold.Devel - Network.Wai.Application.Devel if flag(ghc7) cpp-options: -DGHC7