diff --git a/yesod-default/Yesod/Default/Main.hs b/yesod-default/Yesod/Default/Main.hs index ccb232c7..955aa7a6 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/Build.hs b/yesod/Build.hs index e5219dde..83084e19 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 " >> @@ -185,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 diff --git a/yesod/Devel.hs b/yesod/Devel.hs index 9a3e872c..7c7352e6 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 @@ -38,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) @@ -59,7 +63,8 @@ import System.Process (ProcessHandle, readProcess, runInteractiveProcess, system, - terminateProcess) + terminateProcess, + env) import System.Timeout (timeout) import Build (getDeps, isNewerThan, @@ -69,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" @@ -105,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 @@ -114,7 +143,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 +152,60 @@ 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) + 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 + 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 +333,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 fd2cb9dc..c13a4fe6 100644 --- a/yesod/yesod.cabal +++ b/yesod/yesod.cabal @@ -74,6 +74,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 @@ -99,6 +102,10 @@ executable yesod , conduit >= 0.5 && < 0.6 , resourcet >= 0.3 && < 0.5 , base64-bytestring + , lifted-base + , http-reverse-proxy >= 0.1.0.4 + , network + , http-conduit ghc-options: -Wall -threaded main-is: main.hs