Ugly devel hack, but it (hopefully) works

Network/Wai/Application/Devel.hs

@@ -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

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.Concurrent (forkIO, threadDelay, ThreadId, killThread)
-import Control.Exception (try, SomeException)
+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
+    e <- doesFileExist "dist/devel-flag"
-    _ <- forkIO $ run 3000 $ debug $ toApp appHolder
+    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)
+    let myTry :: IO () -> IO ()
-        myTry f = try f >>= \x -> return $ case x of
+        myTry f = try f >>= \x -> case x of
-                                    Left e -> Left $ show (e :: SomeException)
+                                    Left e -> swapApp listenThread $ forkIO $ appMessage $ L.pack $ show (e :: SomeException)
-                                    Right y -> y
+                                    Right y -> return y
-    let getNewApp :: IO (Either String WithAppRunner)
+    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")
+            writeFile "dist/devel.hs" $ unlines
-            return $ case fmap fromDynamic dyn of
+                [ "{-# LANGUAGE PackageImports #-}"
-                Nothing -> Left "withDevelApp not found"
+                , concat
-                Just Nothing -> Left "Not a withApp"
+                    [ "import \""
-                Just (Just withApp) -> Right withApp
+                    , "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 :: FileList -> IO () -> IO ()
-loop oldList appHolder getNewApp = do
+loop oldList getNewApp = do
+    putStrLn "Testing files..."
     newList <- getFileList
-    when (newList /= oldList) $ do
+    when (newList /= oldList) getNewApp
-        res <- getNewApp
-        case res of
-            Left s -> swapAppSimple (errApp s) appHolder
-            Right x -> swapApp x appHolder
     threadDelay 1000000
-    loop newList appHolder getNewApp
+    loop newList getNewApp
 
 errApp :: String -> Application
 errApp s _ = return $ ResponseBuilder status500 [("Content-Type", "text/plain")] $ fromString s

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 <michael@snoyman.com>
@@ -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