yesod 0.8.0 → 0.8.1
raw patch · 3 files changed
+83/−93 lines, 3 filesdep +processdep −direct-pluginsdep ~hamletdep ~yesod-core
Dependencies added: process
Dependencies removed: direct-plugins
Dependency ranges changed: hamlet, yesod-core
Files
- Network/Wai/Application/Devel.hs +0/−59
- Scaffold/Devel.hs +79/−29
- yesod.cabal +4/−5
− 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 view
@@ -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
yesod.cabal view
@@ -1,5 +1,5 @@ name: yesod-version: 0.8.0+version: 0.8.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -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