improve restarting application

yesod/Build.hs

@@ -24,7 +24,7 @@ import qualified Data.Text.Lazy.IO as TIO
 import qualified System.Posix.Types
 import           System.Directory
 import           System.FilePath (replaceExtension, (</>))
-import           System.PosixCompat.Files (setFileTimes, getFileStatus,
+import           System.PosixCompat.Files (getFileStatus,
                                              accessTime, modificationTime)
 
 touch :: IO ()

yesod/Devel.hs

@@ -14,7 +14,8 @@ import qualified Distribution.PackageDescription.Parse as D
 import qualified Distribution.PackageDescription as D
 
 import           Control.Concurrent (forkIO, threadDelay)
-import           Control.Monad (when, forever)
+import qualified Control.Exception as Ex
+import           Control.Monad (forever)
 
 import qualified Data.List as L
 import qualified Data.Map as Map
@@ -22,8 +23,8 @@ import           Data.Maybe (listToMaybe)
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 
-import           System.Directory (doesFileExist, removeFile,
+import           System.Directory (removeFile, getDirectoryContents)
-                                                getDirectoryContents)
+
 import           System.Exit (exitFailure)
 import           System.Posix.Types (EpochTime)
 import           System.PosixCompat.Files (modificationTime, getFileStatus)
@@ -34,10 +35,12 @@ import Text.Shakespeare.Text (st)
 
 import Build (touch, getDeps, findHaskellFiles)
 
+lockFile :: FilePath
+lockFile = "dist/devel-terminate"
+
 devel :: Bool -> IO ()
 devel isDevel = do
-    e <- doesFileExist "dist/devel-flag"
+    writeFile lockFile ""
-    when e $ removeFile "dist/devel-flag"
 
     cabal <- D.findPackageDesc "."
     gpd   <- D.readPackageDescription D.normal cabal
@@ -56,7 +59,7 @@ devel isDevel = do
 
 mainLoop :: Bool -> IO ()
 mainLoop isDevel = forever $ do
-   putStrLn "Rebuilding app"
+   putStrLn "Rebuilding application..."
 
    touch
 
@@ -65,19 +68,23 @@ mainLoop isDevel = forever $ do
      then rawSystem "cabal"     ["build"]
      else rawSystem "cabal-dev" ["build"]
 
+   try_ $ removeFile lockFile
    putStrLn "Starting development server..."
    pkg <- pkgConfigs isDevel
    ph <- runCommand $ concat ["runghc ", pkg, " dist/devel.hs"]
-   watchForChanges list
+   watchTid <- forkIO . try_ $ do
-   putStrLn "Stopping development server..."
+     watchForChanges list
-   _ <- forkIO $ do
+     putStrLn "Stopping development server..."
-     writeFile "dist/devel-flag" ""
+     writeFile lockFile ""
      threadDelay 1000000
-     -- fixme, check whether process is still alive?
+     putStrLn "Terminating development server..."
-     putStrLn "Terminating external process"
      terminateProcess ph
    ec <- waitForProcess ph
    putStrLn $ "Exit code: " ++ show ec
+   Ex.throwTo watchTid (userError "process finished")
+
+try_ :: forall a. IO a -> IO ()
+try_ x = (Ex.try x :: IO (Either Ex.SomeException a)) >> return ()
 
 pkgConfigs :: Bool -> IO String
 pkgConfigs isDev
@@ -127,7 +134,7 @@ import Control.Concurrent (threadDelay)
 
 main :: IO ()
 main = do
-  putStrLn "Starting app"
+  putStrLn "Starting devel application"
   wdap <- (return . fromJust . fromDynamic) withDevelAppPort
   forkIO . wdap $ \(port, app) -> run port app
   loop
@@ -135,13 +142,12 @@ main = do
 loop :: IO ()
 loop = do
   threadDelay 100000
-  e <- doesFileExist "dist/devel-flag"
+  e <- doesFileExist "dist/devel-terminate"
   if e then terminateDevel else loop
 
 terminateDevel :: IO ()
 terminateDevel = do
-  removeFile "dist/devel-flag"
+  putStrLn "Devel application exiting"
-  putStrLn "Terminating server"
   exitSuccess
 |]