From bdbb73f94d26848334d696da5a1cfe1246205f35 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 30 Oct 2012 16:16:29 +0200 Subject: [PATCH 1/3] Check for import changes in Shakespeare files (#413) --- yesod/Build.hs | 110 +++++++++++++++++++++++++++++++++++----------- yesod/Devel.hs | 83 +++++++++++++++++++++------------- yesod/yesod.cabal | 4 ++ 3 files changed, 140 insertions(+), 57 deletions(-) diff --git a/yesod/Build.hs b/yesod/Build.hs index e5219dde..26907f04 100644 --- a/yesod/Build.hs +++ b/yesod/Build.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} module Build ( getDeps , touchDeps @@ -11,32 +12,53 @@ module Build -- FIXME there's a bug when getFileStatus applies to a file -- temporary deleted (e.g., Vim saving a file) -import Control.Applicative ((<|>), many) +import Control.Applicative ((<|>), many, (<$>)) import qualified Data.Attoparsec.Text.Lazy as A import Data.Char (isSpace, isUpper) import qualified Data.Text.Lazy.IO as TIO import Control.Exception (SomeException, try) +import Control.Exception.Lifted (handle) import Control.Monad (when, filterM, forM, forM_, (>=>)) +import Control.Monad.Trans.State (StateT, get, put, execStateT) +import Control.Monad.Trans.Writer (WriterT, tell, execWriterT) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Class (lift) -import Data.Monoid (mappend) +import Data.Monoid (Monoid (mappend, mempty)) import qualified Data.Map as Map import qualified Data.Set as Set import qualified System.Posix.Types import System.Directory -import System.FilePath (takeExtension, replaceExtension, ()) +import System.FilePath (takeExtension, replaceExtension, (), takeDirectory) import System.PosixCompat.Files (getFileStatus, setFileTimes, accessTime, modificationTime) +import Text.Shakespeare (Deref) +import Text.Julius (juliusUsedIdentifiers) +import Text.Cassius (cassiusUsedIdentifiers) +import Text.Lucius (luciusUsedIdentifiers) touch :: IO () -touch = touchDeps id updateFileTime =<< fmap snd (getDeps []) +touch = do + m <- handle (\(_ :: SomeException) -> return Map.empty) $ readFile touchCache >>= readIO + x <- fmap snd (getDeps []) + m' <- execStateT (execWriterT $ touchDeps id updateFileTime x) m + createDirectoryIfMissing True $ takeDirectory touchCache + writeFile touchCache $ show m' + where + touchCache = "dist/touchCache.txt" -recompDeps :: [FilePath] -> IO () -recompDeps = getDeps >=> touchDeps hiFile removeHi . snd +-- | Returns True if any files were touched, otherwise False +recompDeps :: [FilePath] -> StateT (Map.Map FilePath (Set.Set Deref)) IO Bool +recompDeps = + fmap toBool . execWriterT . (liftIO . getDeps >=> touchDeps hiFile removeHi . snd) + where + toBool NoFilesTouched = False + toBool SomeFilesTouched = True -type Deps = Map.Map FilePath (Set.Set FilePath) +type Deps = Map.Map FilePath ([FilePath], ComparisonType) getDeps :: [FilePath] -> IO ([FilePath], Deps) getDeps hsSourceDirs = do @@ -47,17 +69,35 @@ getDeps hsSourceDirs = do deps' <- mapM determineDeps hss return $ (hss, fixDeps $ zip hss deps') +data AnyFilesTouched = NoFilesTouched | SomeFilesTouched +instance Monoid AnyFilesTouched where + mempty = NoFilesTouched + mappend NoFilesTouched NoFilesTouched = mempty + mappend _ _ = SomeFilesTouched + touchDeps :: (FilePath -> FilePath) -> (FilePath -> FilePath -> IO ()) -> - Deps -> IO () + Deps -> WriterT AnyFilesTouched (StateT (Map.Map FilePath (Set.Set Deref)) IO) () touchDeps f action deps = (mapM_ go . Map.toList) deps where - go (x, ys) = - forM_ (Set.toList ys) $ \y -> do - n <- x `isNewerThan` f y + go (x, (ys, ct)) = do + isChanged <- handle (\(_ :: SomeException) -> return True) $ lift $ + case ct of + AlwaysOutdated -> return True + CompareUsedIdentifiers getDerefs -> do + derefMap <- get + s <- liftIO $ readFile x + let newDerefs = Set.fromList $ getDerefs s + put $ Map.insert x newDerefs derefMap + case Map.lookup x derefMap of + Just oldDerefs | oldDerefs == newDerefs -> return False + _ -> return True + when isChanged $ forM_ ys $ \y -> do + n <- liftIO $ x `isNewerThan` f y when n $ do - putStrLn ("Forcing recompile for " ++ y ++ " because of " ++ x) - action x y + liftIO $ putStrLn ("Forcing recompile for " ++ y ++ " because of " ++ x) + liftIO $ action x y + tell SomeFilesTouched -- | remove the .hi files for a .hs file, thereby forcing a recompile removeHi :: FilePath -> FilePath -> IO () @@ -95,12 +135,14 @@ getFileStatus' fp = do Left _ -> return (0, 0) Right fs -> return (accessTime fs, modificationTime fs) -fixDeps :: [(FilePath, [FilePath])] -> Deps +fixDeps :: [(FilePath, [(ComparisonType, FilePath)])] -> Deps fixDeps = - Map.unionsWith mappend . map go + Map.unionsWith combine . map go where - go :: (FilePath, [FilePath]) -> Deps - go (x, ys) = Map.fromList $ map (\y -> (y, Set.singleton x)) ys + go :: (FilePath, [(ComparisonType, FilePath)]) -> Deps + go (x, ys) = Map.fromList $ map (\(ct, y) -> (y, ([x], ct))) ys + + combine (ys1, ct) (ys2, _) = (ys1 `mappend` ys2, ct) findHaskellFiles :: FilePath -> IO [FilePath] findHaskellFiles path = do @@ -125,21 +167,34 @@ findHaskellFiles path = do watch_files = [".hs", ".lhs"] data TempType = StaticFiles FilePath - | Verbatim | Messages FilePath | Hamlet + | Verbatim | Messages FilePath | Hamlet | Widget | Julius | Cassius | Lucius deriving Show -determineDeps :: FilePath -> IO [FilePath] +-- | How to tell if a file is outdated. +data ComparisonType = AlwaysOutdated + | CompareUsedIdentifiers (String -> [Deref]) + +determineDeps :: FilePath -> IO [(ComparisonType, FilePath)] determineDeps x = do y <- TIO.readFile x -- FIXME catch IO exceptions let z = A.parse (many $ (parser <|> (A.anyChar >> return Nothing))) y case z of A.Fail{} -> return [] - A.Done _ r -> mapM go r >>= filterM doesFileExist . concat + A.Done _ r -> mapM go r >>= filterM (doesFileExist . snd) . concat where - go (Just (StaticFiles fp, _)) = getFolderContents fp - go (Just (Hamlet, f)) = return [f, "templates/" ++ f ++ ".hamlet"] - go (Just (Verbatim, f)) = return [f] - go (Just (Messages f, _)) = getFolderContents f + go (Just (StaticFiles fp, _)) = map ((,) AlwaysOutdated) <$> getFolderContents fp + go (Just (Hamlet, f)) = return [(AlwaysOutdated, f)] + go (Just (Widget, f)) = return + [ (AlwaysOutdated, "templates/" ++ f ++ ".hamlet") + , (CompareUsedIdentifiers $ map fst . juliusUsedIdentifiers, "templates/" ++ f ++ ".julius") + , (CompareUsedIdentifiers $ map fst . luciusUsedIdentifiers, "templates/" ++ f ++ ".lucius") + , (CompareUsedIdentifiers $ map fst . cassiusUsedIdentifiers, "templates/" ++ f ++ ".cassius") + ] + go (Just (Julius, f)) = return [(CompareUsedIdentifiers $ map fst . juliusUsedIdentifiers, f)] + go (Just (Cassius, f)) = return [(CompareUsedIdentifiers $ map fst . cassiusUsedIdentifiers, f)] + go (Just (Lucius, f)) = return [(CompareUsedIdentifiers $ map fst . luciusUsedIdentifiers, f)] + go (Just (Verbatim, f)) = return [(AlwaysOutdated, f)] + go (Just (Messages f, _)) = map ((,) AlwaysOutdated) <$> getFolderContents f go Nothing = return [] parser = do @@ -151,9 +206,12 @@ determineDeps x = do <|> (A.string "$(ihamletFile " >> return Hamlet) <|> (A.string "$(whamletFile " >> return Hamlet) <|> (A.string "$(html " >> return Hamlet) - <|> (A.string "$(widgetFile " >> return Hamlet) + <|> (A.string "$(widgetFile " >> return Widget) <|> (A.string "$(Settings.hamletFile " >> return Hamlet) - <|> (A.string "$(Settings.widgetFile " >> return Hamlet) + <|> (A.string "$(Settings.widgetFile " >> return Widget) + <|> (A.string "$(juliusFile " >> return Julius) + <|> (A.string "$(cassiusFile " >> return Cassius) + <|> (A.string "$(luciusFile " >> return Lucius) <|> (A.string "$(persistFile " >> return Verbatim) <|> ( A.string "$(persistFileWith " >> diff --git a/yesod/Devel.hs b/yesod/Devel.hs index 9a3e872c..b022f546 100644 --- a/yesod/Devel.hs +++ b/yesod/Devel.hs @@ -28,9 +28,12 @@ import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, tryPutMVar) import qualified Control.Exception as Ex -import Control.Monad (forever, unless, void, +import Control.Monad (unless, void, when) +import Control.Monad.Trans.State (evalStateT, get) +import Control.Monad.IO.Class (liftIO) + import Data.Char (isNumber, isUpper) import qualified Data.List as L import qualified Data.Map as Map @@ -114,7 +117,7 @@ devel opts passThroughArgs = withManager $ \manager -> do _ <- forkIO $ do filesModified <- newEmptyMVar watchTree manager "." (const True) (\_ -> void (tryPutMVar filesModified ())) - mainOuterLoop filesModified + evalStateT (mainOuterLoop filesModified) Map.empty _ <- getLine writeLock opts exitSuccess @@ -123,50 +126,57 @@ devel opts passThroughArgs = withManager $ \manager -> do -- outer loop re-reads the cabal file mainOuterLoop filesModified = do - cabal <- D.findPackageDesc "." - gpd <- D.readPackageDescription D.normal cabal - ldar <- lookupLdAr - (hsSourceDirs, lib) <- checkCabalFile gpd - removeFileIfExists (bd "setup-config") - configure cabal gpd opts - removeFileIfExists "yesod-devel/ghcargs.txt" -- these files contain the wrong data after - removeFileIfExists "yesod-devel/arargs.txt" -- the configure step, remove them to force - removeFileIfExists "yesod-devel/ldargs.txt" -- a cabal build first - ghcVer <- ghcVersion - rebuild <- mkRebuild gpd ghcVer cabal opts ldar + cabal <- liftIO $ D.findPackageDesc "." + gpd <- liftIO $ D.readPackageDescription D.normal cabal + ldar <- liftIO lookupLdAr + (hsSourceDirs, lib) <- liftIO $ checkCabalFile gpd + liftIO $ removeFileIfExists (bd "setup-config") + liftIO $ configure cabal gpd opts + liftIO $ removeFileIfExists "yesod-devel/ghcargs.txt" -- these files contain the wrong data after + liftIO $ removeFileIfExists "yesod-devel/arargs.txt" -- the configure step, remove them to force + liftIO $ removeFileIfExists "yesod-devel/ldargs.txt" -- a cabal build first + ghcVer <- liftIO ghcVersion + rebuild <- liftIO $ mkRebuild gpd ghcVer cabal opts ldar mainInnerLoop hsSourceDirs filesModified cabal gpd lib ghcVer rebuild -- inner loop rebuilds after files change mainInnerLoop hsSourceDirs filesModified cabal gpd lib ghcVer rebuild = go where go = do - recompDeps hsSourceDirs - list <- getFileList hsSourceDirs [cabal] - success <- rebuild - pkgArgs <- ghcPackageArgs opts ghcVer (D.packageDescription gpd) lib + _ <- recompDeps hsSourceDirs + list <- liftIO $ getFileList hsSourceDirs [cabal] + success <- liftIO rebuild + pkgArgs <- liftIO $ ghcPackageArgs opts ghcVer (D.packageDescription gpd) lib let devArgs = pkgArgs ++ ["devel.hs"] ++ passThroughArgs + let loop list0 = do + (haskellFileChanged, list1) <- liftIO $ watchForChanges filesModified hsSourceDirs [cabal] list0 (eventTimeout opts) + anyTouched <- recompDeps hsSourceDirs + unless (anyTouched || haskellFileChanged) $ loop list1 if not success - then do + then liftIO $ do putStrLn "Build failure, pausing..." runBuildHook $ failHook opts else do - runBuildHook $ successHook opts - removeLock opts - putStrLn $ if verbose opts then "Starting development server: runghc " ++ L.unwords devArgs + liftIO $ runBuildHook $ successHook opts + liftIO $ removeLock opts + liftIO $ putStrLn + $ if verbose opts then "Starting development server: runghc " ++ L.unwords devArgs else "Starting development server..." - (_,_,_,ph) <- createProcess $ proc "runghc" devArgs - watchTid <- forkIO . try_ $ do - watchForChanges filesModified hsSourceDirs [cabal] list (eventTimeout opts) + (_,_,_,ph) <- liftIO $ createProcess $ proc "runghc" devArgs + derefMap <- get + watchTid <- liftIO . forkIO . try_ $ flip evalStateT derefMap $ do + loop list + liftIO $ do putStrLn "Stopping development server..." writeLock opts threadDelay 1000000 putStrLn "Terminating development server..." terminateProcess ph - ec <- waitForProcess' ph - putStrLn $ "Exit code: " ++ show ec - Ex.throwTo watchTid (userError "process finished") - watchForChanges filesModified hsSourceDirs [cabal] list (eventTimeout opts) - n <- cabal `isNewerThan` (bd "setup-config") + ec <- liftIO $ waitForProcess' ph + liftIO $ putStrLn $ "Exit code: " ++ show ec + liftIO $ Ex.throwTo watchTid (userError "process finished") + loop list + n <- liftIO $ cabal `isNewerThan` (bd "setup-config") if n then mainOuterLoop filesModified else go runBuildHook :: Maybe String -> IO () @@ -294,13 +304,24 @@ getFileList hsSourceDirs extraFiles = do Left (_ :: Ex.SomeException) -> (f, 0) Right fs -> (f, modificationTime fs) -watchForChanges :: MVar () -> [FilePath] -> [FilePath] -> FileList -> Int -> IO () +-- | Returns @True@ if a .hs file changed. +watchForChanges :: MVar () -> [FilePath] -> [FilePath] -> FileList -> Int -> IO (Bool, FileList) watchForChanges filesModified hsSourceDirs extraFiles list t = do newList <- getFileList hsSourceDirs extraFiles if list /= newList - then return () + then do + let haskellFileChanged = not $ Map.null $ Map.filterWithKey isHaskell $ + Map.differenceWith compareTimes newList list `Map.union` + Map.differenceWith compareTimes list newList + return (haskellFileChanged, newList) else timeout (1000000*t) (takeMVar filesModified) >> watchForChanges filesModified hsSourceDirs extraFiles list t + where + compareTimes x y + | x == y = Nothing + | otherwise = Just x + + isHaskell filename _ = takeExtension filename `elem` [".hs", ".lhs", ".hsc", ".cabal"] checkDevelFile :: IO () checkDevelFile = do diff --git a/yesod/yesod.cabal b/yesod/yesod.cabal index 38ab42db..fad0a6a4 100644 --- a/yesod/yesod.cabal +++ b/yesod/yesod.cabal @@ -113,6 +113,9 @@ executable yesod , parsec >= 2.1 && < 4 , text >= 0.11 , shakespeare-text >= 1.0 && < 1.1 + , shakespeare >= 1.0.2 && < 1.1 + , shakespeare-js >= 1.0.1 && < 1.1 + , shakespeare-css >= 1.0.2 && < 1.1 , bytestring >= 0.9.1.4 , time >= 1.1.4 , template-haskell @@ -134,6 +137,7 @@ executable yesod , optparse-applicative >= 0.4 && < 0.5 , fsnotify >= 0.0 && < 0.1 , split >= 0.2 && < 0.3 + , lifted-base ghc-options: -Wall -threaded main-is: main.hs From b961fb8d5f85e64c1f85450f0ef87370e795c28a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 30 Oct 2012 16:19:24 +0200 Subject: [PATCH 2/3] Ignore the fay folder (#445) --- yesod/Build.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/yesod/Build.hs b/yesod/Build.hs index 26907f04..83084e19 100644 --- a/yesod/Build.hs +++ b/yesod/Build.hs @@ -243,6 +243,7 @@ determineDeps x = do cs <- getDirectoryContents fp let notHidden ('.':_) = False notHidden ('t':"mp") = False + notHidden ('f':"ay") = False notHidden _ = True fmap concat $ forM (filter notHidden cs) $ \c -> do let f = fp ++ '/' : c From 309d3c0f267f9e1ad7f77085fda300f7e5e06fbe Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 30 Oct 2012 17:02:17 +0200 Subject: [PATCH 3/3] yesod devel displays "app not loaded" message In order to achieve this, yesod devel listens on port 3000 and reverse proxies to port 3001. An environment variable is set to tell the app to listen on port 3001. --- yesod-default/Yesod/Default/Main.hs | 9 ++++++-- yesod-default/yesod-default.cabal | 3 ++- yesod/Devel.hs | 33 +++++++++++++++++++++++++++-- yesod/scaffold/project.cabal.cg | 2 +- yesod/yesod.cabal | 3 +++ 5 files changed, 44 insertions(+), 6 deletions(-) diff --git a/yesod-default/Yesod/Default/Main.hs b/yesod-default/Yesod/Default/Main.hs index 5de22ba1..c664de11 100644 --- a/yesod-default/Yesod/Default/Main.hs +++ b/yesod-default/Yesod/Default/Main.hs @@ -15,6 +15,9 @@ import Network.Wai.Middleware.Gzip (gzip, GzipFiles (GzipCacheFolder), gzipFiles import Network.Wai.Middleware.Autohead (autohead) import Network.Wai.Middleware.Jsonp (jsonp) import Control.Monad (when) +import System.Environment (getEnvironment) +import Data.Maybe (fromMaybe) +import Safe (readMay) #ifndef WINDOWS import qualified System.Posix.Signals as Signal @@ -81,7 +84,9 @@ defaultDevelApp -> IO (Int, Application) defaultDevelApp load getApp = do conf <- load - let p = appPort conf - putStrLn $ "Devel application launched: http://localhost:" ++ show p + env <- getEnvironment + let p = fromMaybe (appPort conf) $ lookup "PORT" env >>= readMay + pdisplay = fromMaybe p $ lookup "DISPLAY_PORT" env >>= readMay + putStrLn $ "Devel application launched: http://localhost:" ++ show pdisplay app <- getApp conf return (p, app) diff --git a/yesod-default/yesod-default.cabal b/yesod-default/yesod-default.cabal index 9dd2cbe1..7c464b5e 100644 --- a/yesod-default/yesod-default.cabal +++ b/yesod-default/yesod-default.cabal @@ -1,5 +1,5 @@ name: yesod-default -version: 1.1.0.2 +version: 1.1.1 license: MIT license-file: LICENSE author: Patrick Brisbin @@ -34,6 +34,7 @@ library , unordered-containers , hamlet >= 1.1 && < 1.2 , data-default + , safe if !os(windows) build-depends: unix diff --git a/yesod/Devel.hs b/yesod/Devel.hs index b022f546..7c7352e6 100644 --- a/yesod/Devel.hs +++ b/yesod/Devel.hs @@ -41,6 +41,7 @@ import Data.Maybe (fromMaybe) import qualified Data.Set as Set import System.Directory +import System.Environment (getEnvironment) import System.Exit (ExitCode (..), exitFailure, exitSuccess) @@ -62,7 +63,8 @@ import System.Process (ProcessHandle, readProcess, runInteractiveProcess, system, - terminateProcess) + terminateProcess, + env) import System.Timeout (timeout) import Build (getDeps, isNewerThan, @@ -72,6 +74,12 @@ import GhcBuild (buildPackage, import qualified Config as GHC import SrcLoc (Located) +import Network.HTTP.ReverseProxy (waiProxyTo, ProxyDest (ProxyDest)) +import Network (withSocketsDo) +import Network.Wai (responseLBS) +import Network.HTTP.Types (status200) +import Network.Wai.Handler.Warp (run) +import Network.HTTP.Conduit (newManager, def) lockFile :: DevelOpts -> FilePath lockFile _opts = "yesod-devel/devel-terminate" @@ -108,8 +116,26 @@ cabalCommand opts | isCabalDev opts = "cabal-dev" defaultDevelOpts :: DevelOpts defaultDevelOpts = DevelOpts False False False (-1) Nothing Nothing Nothing +-- | Run a reverse proxy from port 3000 to 3001. If there is no response on +-- 3001, give an appropriate message to the user. +reverseProxy :: IO () +reverseProxy = withSocketsDo $ do + manager <- newManager def + run 3000 $ waiProxyTo + (const $ return $ Right $ ProxyDest "localhost" 3001) + onExc + manager + where + onExc _ _ = return $ responseLBS + status200 + [ ("content-type", "text/html") + , ("Refresh", "1") + ] + "

App not ready, please refresh

" + devel :: DevelOpts -> [String] -> IO () devel opts passThroughArgs = withManager $ \manager -> do + _ <- forkIO reverseProxy checkDevelFile writeLock opts @@ -162,7 +188,10 @@ devel opts passThroughArgs = withManager $ \manager -> do liftIO $ putStrLn $ if verbose opts then "Starting development server: runghc " ++ L.unwords devArgs else "Starting development server..." - (_,_,_,ph) <- liftIO $ createProcess $ proc "runghc" devArgs + env0 <- liftIO getEnvironment + (_,_,_,ph) <- liftIO $ createProcess (proc "runghc" devArgs) + { env = Just $ ("PORT", "3001") : ("DISPLAY_PORT", "3000") : env0 + } derefMap <- get watchTid <- liftIO . forkIO . try_ $ flip evalStateT derefMap $ do loop list diff --git a/yesod/scaffold/project.cabal.cg b/yesod/scaffold/project.cabal.cg index 106cc654..a9615051 100644 --- a/yesod/scaffold/project.cabal.cg +++ b/yesod/scaffold/project.cabal.cg @@ -55,7 +55,7 @@ library , yesod-core >= 1.1.2 && < 1.2 , yesod-auth >= 1.1 && < 1.2 , yesod-static >= 1.1 && < 1.2 - , yesod-default >= 1.1 && < 1.2 + , yesod-default >= 1.1.1 && < 1.2 , yesod-form >= 1.1 && < 1.2 , yesod-test >= 0.3 && < 0.4 , clientsession >= 0.8 && < 0.9 diff --git a/yesod/yesod.cabal b/yesod/yesod.cabal index fad0a6a4..fa967532 100644 --- a/yesod/yesod.cabal +++ b/yesod/yesod.cabal @@ -138,6 +138,9 @@ executable yesod , fsnotify >= 0.0 && < 0.1 , split >= 0.2 && < 0.3 , lifted-base + , http-reverse-proxy >= 0.1.0.4 + , network + , http-conduit ghc-options: -Wall -threaded main-is: main.hs