From b04e034b0decb80e5d6e249c0b11fa7d9216c600 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 29 Apr 2011 09:24:22 +0300 Subject: [PATCH] Ugly devel hack, but it (hopefully) works --- Network/Wai/Application/Devel.hs | 59 ----------------- Scaffold/Devel.hs | 105 ++++++++++++++++++++++--------- yesod.cabal | 5 +- 3 files changed, 79 insertions(+), 90 deletions(-) delete mode 100644 Network/Wai/Application/Devel.hs diff --git a/Network/Wai/Application/Devel.hs b/Network/Wai/Application/Devel.hs deleted file mode 100644 index 7a741367..00000000 --- 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 index 015b81eb..a3ae9ca4 100644 --- a/Scaffold/Devel.hs +++ b/Scaffold/Devel.hs @@ -13,28 +13,40 @@ import Distribution.PackageDescription.Parse (readPackageDescription, readHooked 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) + +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 +62,15 @@ devel = do , 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 @@ -69,13 +84,50 @@ devel = do 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 + writeFile "dist/devel.hs" $ unlines + [ "{-# LANGUAGE PackageImports #-}" + , concat + [ "import \"" + , "haskellers" -- FIXME + , "\" 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 @@ -88,16 +140,13 @@ getFileList = do 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 index 0129e616..5914e099 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.8.0 +version: 0.8.0.1 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -59,13 +59,12 @@ executable yesod , 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