diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,21 @@ +## 1.5.0 + +Rewrite of `yesod devel` to take advantage of Stack for a simpler codebase. + +Advantages: + +* Does not link against the ghc library, so can be used with multiple + GHC versions +* Leverages Stack's ability to check for dependent files, which is + more robust than what yesod devel was doing previously +* Seems to involve less rebuilding of the library on initial run + +Disadvantages: + +* Lost some functionality (e.g., failure hooks, controlling the exit + command) +* Newer codebase, quite likely has bugs that need to be ironed out. + ## 1.4.18.7 * Actually release the changes for #1284 diff --git a/Devel.hs b/Devel.hs --- a/Devel.hs +++ b/Devel.hs @@ -1,163 +1,129 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} module Devel ( devel + , develSignal , DevelOpts(..) - , DevelTermOpt(..) - , defaultDevelOpts ) where -import qualified Distribution.Compiler as D -import qualified Distribution.ModuleName as D -import qualified Distribution.PackageDescription as D -import qualified Distribution.PackageDescription.Parse as D -import qualified Distribution.Simple.Configure as D -import qualified Distribution.Simple.Program as D -import qualified Distribution.Simple.Utils as D -import qualified Distribution.Verbosity as D - -import Control.Applicative ((<$>), (<*>)) -import Control.Concurrent (forkIO, threadDelay) -import Control.Concurrent.MVar (MVar, newEmptyMVar, - takeMVar, tryPutMVar) +import Control.Applicative ((<|>)) +import Control.Concurrent (threadDelay) import Control.Concurrent.Async (race_) -import qualified Control.Exception as Ex +import Control.Concurrent.STM +import qualified Control.Exception.Safe as Ex import Control.Monad (forever, unless, void, - when, forM) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.State (evalStateT, get) -import qualified Data.IORef as I - + when) import qualified Data.ByteString.Lazy as LB -import Data.Char (isNumber, isUpper) -import qualified Data.List as L +import Data.Conduit (($$), (=$)) +import qualified Data.Conduit.Binary as CB +import qualified Data.Conduit.List as CL +import Data.Default.Class (def) +import Data.FileEmbed (embedFile) import qualified Data.Map as Map -import Data.Maybe (fromMaybe) import qualified Data.Set as Set - -import System.Directory -import System.Environment (getEnvironment) -import System.Exit (ExitCode (..), - exitFailure, - exitSuccess) -import System.FilePath (dropExtension, - splitDirectories, - takeExtension, ()) -import System.FSNotify -import System.IO (Handle) -import System.IO.Error (isDoesNotExistError) -import System.Posix.Types (EpochTime) -import System.PosixCompat.Files (getFileStatus, - modificationTime) -import System.Process (ProcessHandle, - createProcess, env, - getProcessExitCode, - proc, readProcess, - system, - terminateProcess) -import System.Timeout (timeout) - -import Build (getDeps, isNewerThan, - recompDeps) -import GhcBuild (buildPackage, - getBuildFlags, getPackageArgs) - -import qualified Config as GHC -import Data.Streaming.Network (bindPortTCP) -import Network (withSocketsDo) -import Network.HTTP.Conduit (conduitManagerSettings, newManager) -import Data.Default.Class (def) -#if MIN_VERSION_http_client(0,4,7) -import Network.HTTP.Client (managerSetProxy, noProxy) -#endif +import Data.Streaming.Network (bindPortTCP, + bindRandomPortTCP) +import Data.String (fromString) +import Data.Time (getCurrentTime) +import qualified Distribution.Package as D +import qualified Distribution.PackageDescription as D +import qualified Distribution.PackageDescription.Parse as D +import qualified Distribution.Simple.Utils as D +import qualified Distribution.Verbosity as D +import Network.HTTP.Client (newManager) +import Network.HTTP.Client (managerSetProxy, + noProxy) +import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.HTTP.ReverseProxy (ProxyDest (ProxyDest), - waiProxyToSettings, wpsTimeout, wpsOnExc) + waiProxyToSettings, + wpsOnExc, wpsTimeout) import qualified Network.HTTP.ReverseProxy as ReverseProxy import Network.HTTP.Types (status200, status503) -import Network.Socket (sClose) -import Network.Wai (responseLBS, requestHeaders, - requestHeaderHost) +import qualified Network.Socket +import Network.Wai (requestHeaderHost, + requestHeaders, + responseLBS) +import Network.Wai.Handler.Warp (defaultSettings, run, + setPort) +import Network.Wai.Handler.WarpTLS (runTLS, + tlsSettingsMemory) import Network.Wai.Parse (parseHttpAccept) -import Network.Wai.Handler.Warp (run, defaultSettings, setPort) -import Network.Wai.Handler.WarpTLS (runTLS, tlsSettingsMemory) -import SrcLoc (Located) -import Data.FileEmbed (embedFile) +import Say +import System.Directory +import System.Environment (getEnvironment, + getExecutablePath) +import System.FilePath (takeDirectory, + takeFileName, ()) +import System.FSNotify +import System.IO (stdout, stderr) +import System.IO.Error (isDoesNotExistError) +import System.Process.Typed -lockFile :: FilePath -lockFile = "yesod-devel/devel-terminate" +-- We have two special files: +-- +-- * The terminate file tells the child process to die simply by being +-- present. Ideally we'd handle this via killing the process +-- directly, but that's historically never worked reliably. +-- +-- * The signal file, which tells us that "stack build" has succeeded +-- yet again. +data SpecialFile = TermFile | SignalFile -writeLock :: DevelOpts -> IO () -writeLock _opts = do - createDirectoryIfMissing True "yesod-devel" - writeFile lockFile "" - createDirectoryIfMissing True "dist" -- for compatibility with old devel.hs - writeFile "dist/devel-terminate" "" +specialFilePath :: SpecialFile -> FilePath -removeLock :: DevelOpts -> IO () -removeLock _opts = do - removeFileIfExists lockFile - removeFileIfExists "dist/devel-terminate" -- for compatibility with old devel.hs +-- used by scaffolded app, cannot change +specialFilePath TermFile = "yesod-devel/devel-terminate" -data DevelTermOpt = TerminateOnEnter | TerminateOnlyInterrupt - deriving (Show, Eq) - -data DevelOpts = DevelOpts - { isCabalDev :: Bool - , forceCabal :: Bool - , verbose :: Bool - , eventTimeout :: Int -- negative value for no timeout - , successHook :: Maybe String - , failHook :: Maybe String - , buildDir :: Maybe String - , develPort :: Int - , develTlsPort :: Int - , proxyTimeout :: Int - , useReverseProxy :: Bool - , terminateWith :: DevelTermOpt +-- only used internally, can change +specialFilePath SignalFile = "yesod-devel/rebuild" - -- Support for GHC_PACKAGE_PATH wrapping - , develConfigOpts :: [String] - , develEnv :: Maybe [(String, String)] - } deriving (Show, Eq) +-- | Write a special file +writeSpecialFile :: SpecialFile -> IO () +writeSpecialFile sp = do + let fp = specialFilePath sp + createDirectoryIfMissing True $ takeDirectory fp + now <- getCurrentTime + writeFile fp $ show now -getBuildDir :: DevelOpts -> String -getBuildDir opts = fromMaybe "dist" (buildDir opts) +-- | Remove a special file +removeSpecialFile :: SpecialFile -> IO () +removeSpecialFile sp = removeFile (specialFilePath sp) `Ex.catch` \e -> + if isDoesNotExistError e + then return () + else Ex.throwIO e -defaultDevelOpts :: DevelOpts -defaultDevelOpts = DevelOpts - { isCabalDev = False - , forceCabal = False - , verbose = False - , eventTimeout = -1 - , successHook = Nothing - , failHook = Nothing - , buildDir = Nothing - , develPort = 3000 - , develTlsPort = 3443 - , proxyTimeout = 10 - , useReverseProxy = True - , terminateWith = TerminateOnEnter - , develConfigOpts = [] - , develEnv = Nothing - } +-- | Get an absolute path to the special file +canonicalizeSpecialFile :: SpecialFile -> IO FilePath +canonicalizeSpecialFile sp = do + let fp = specialFilePath sp + dir = takeDirectory fp + file = takeFileName fp + createDirectoryIfMissing True dir + dir' <- canonicalizePath dir + return $ dir' file -cabalProgram :: DevelOpts -> FilePath -cabalProgram opts - | isCabalDev opts = "cabal-dev" - | otherwise = "cabal" +-- | Used as a callback from "stack build --exec" to write the signal file +develSignal :: IO () +develSignal = writeSpecialFile SignalFile --- | Run a reverse proxy from port 3000 to 3001. If there is no response on --- 3001, give an appropriate message to the user. -reverseProxy :: DevelOpts -> I.IORef Int -> IO () -reverseProxy opts iappPort = do -#if MIN_VERSION_http_client(0,4,7) - manager <- newManager $ managerSetProxy noProxy conduitManagerSettings -#else - manager <- newManager conduitManagerSettings -#endif - let refreshHtml = LB.fromChunks $ return $(embedFile "refreshing.html") +-- | Options to be provided on the command line +data DevelOpts = DevelOpts + { verbose :: Bool + , successHook :: Maybe String + , develPort :: Int + , develTlsPort :: Int + , proxyTimeout :: Int + , useReverseProxy :: Bool + } deriving (Show, Eq) + +-- | Run a reverse proxy from the develPort and develTlsPort ports to +-- the app running in appPortVar. If there is no response on the +-- application port, give an appropriate message to the user. +reverseProxy :: DevelOpts -> TVar Int -> IO () +reverseProxy opts appPortVar = do + manager <- newManager $ managerSetProxy noProxy tlsManagerSettings + let refreshHtml = LB.fromChunks [$(embedFile "refreshing.html")] let onExc _ req | maybe False (("application/json" `elem`) . parseHttpAccept) (lookup "accept" $ requestHeaders req) = @@ -173,7 +139,7 @@ let proxyApp = waiProxyToSettings (const $ do - appPort <- liftIO $ I.readIORef iappPort + appPort <- atomically $ readTVar appPortVar return $ ReverseProxy.WPRProxyDest $ ProxyDest "127.0.0.1" appPort) @@ -209,361 +175,268 @@ app req' send httpProxy = run (develPort opts) proxyApp httpsProxy = runProxyTls (develTlsPort opts) proxyApp - putStrLn "Application can be accessed at:\n" - putStrLn $ "http://localhost:" ++ show (develPort opts) - putStrLn $ "https://localhost:" ++ show (develTlsPort opts) - putStrLn $ "If you wish to test https capabilities, you should set the following variable:" - putStrLn $ " export APPROOT=https://localhost:" ++ show (develTlsPort opts) - putStrLn "" - loop (race_ httpProxy httpsProxy) `Ex.catch` \e -> do - print (e :: Ex.SomeException) - _ <- exitFailure - Ex.throwIO e -- heh, just for good measure - where - loop proxies = forever $ do - void proxies - putStrLn $ "Reverse proxy stopped, but it shouldn't" - threadDelay 1000000 - putStrLn $ "Restarting reverse proxies" + say "Application can be accessed at:\n" + sayString $ "http://localhost:" ++ show (develPort opts) + sayString $ "https://localhost:" ++ show (develTlsPort opts) + say $ "If you wish to test https capabilities, you should set the following variable:" + sayString $ " export APPROOT=https://localhost:" ++ show (develTlsPort opts) + say "" + race_ httpProxy httpsProxy +-- | Check if the given port is available. checkPort :: Int -> IO Bool checkPort p = do - es <- Ex.try $ bindPortTCP p "*4" + es <- Ex.tryIO $ bindPortTCP p "*4" case es of - Left (_ :: Ex.IOException) -> return False + Left _ -> return False Right s -> do - sClose s + Network.Socket.close s return True -getPort :: DevelOpts -> Int -> IO Int -getPort opts _ - | not (useReverseProxy opts) = return $ develPort opts -getPort _ p0 = - loop p0 - where - loop p = do - avail <- checkPort p - if avail then return p else loop (succ p) +-- | Get a random, unused port. +getNewPort :: DevelOpts -> IO Int +getNewPort opts = do + (port, socket) <- bindRandomPortTCP "*" + when (verbose opts) $ sayString $ "Got new port: " ++ show port + Network.Socket.close socket + return port +-- | Utility function unlessM :: Monad m => m Bool -> m () -> m () unlessM c a = c >>= \res -> unless res a -devel :: DevelOpts -> [String] -> IO () -devel opts passThroughArgs = withSocketsDo $ withManager $ \manager -> do - unlessM (checkPort $ develPort opts) $ error "devel port unavailable" - iappPort <- getPort opts 17834 >>= I.newIORef - when (useReverseProxy opts) $ void $ forkIO $ reverseProxy opts iappPort - develHsPath <- checkDevelFile - writeLock opts +-- | Find the file containing the devel code to be run. +checkDevelFile :: IO FilePath +checkDevelFile = + loop paths + where + paths = ["app/devel.hs", "devel.hs", "src/devel.hs"] - let (terminator, after) = case terminateWith opts of - TerminateOnEnter -> - ("Type 'quit'", blockQuit) - TerminateOnlyInterrupt -> -- run for one year - ("Interrupt", threadDelay $ 1000 * 1000 * 60 * 60 * 24 * 365) + loop [] = error $ "file devel.hs not found, checked: " ++ show paths + loop (x:xs) = do + e <- doesFileExist x + if e + then return x + else loop xs - blockQuit = do - s <- getLine - if s == "quit" - then return () - else do - putStrLn "Type 'quit' to quit" - blockQuit +-- | Get the set of all flags available in the given cabal file +getAvailableFlags :: D.GenericPackageDescription -> Set.Set String +getAvailableFlags = + Set.fromList . map (unFlagName . D.flagName) . D.genPackageFlags + where + unFlagName (D.FlagName fn) = fn +-- | This is the main entry point. Run the devel server. +devel :: DevelOpts -- ^ command line options + -> [String] -- ^ extra options to pass to Stack + -> IO () +devel opts passThroughArgs = do + -- Check that the listening ports are available + unlessM (checkPort $ develPort opts) $ error "devel port unavailable" + unlessM (checkPort $ develTlsPort opts) $ error "devel TLS port unavailable" - putStrLn $ "Yesod devel server. " ++ terminator ++ " to quit" - void $ forkIO $ do - filesModified <- newEmptyMVar - void $ forkIO $ - void $ watchTree manager "." (const True) (\_ -> void (tryPutMVar filesModified ())) - evalStateT (mainOuterLoop develHsPath iappPort filesModified) Map.empty - after - writeLock opts - exitSuccess - where - bd = getBuildDir opts + -- Friendly message to the user + say "Yesod devel server. Enter 'quit' or hit Ctrl-C to quit." - -- outer loop re-reads the cabal file - mainOuterLoop develHsPath iappPort filesModified = do - ghcVer <- liftIO ghcVersion -#if MIN_VERSION_Cabal(1,20,0) - cabal <- liftIO $ D.tryFindPackageDesc "." + -- Find out the name of our package, needed for the upcoming Stack + -- commands +#if MIN_VERSION_Cabal(1, 20, 0) + cabal <- D.tryFindPackageDesc "." #else - cabal <- liftIO $ D.findPackageDesc "." + cabal <- D.findPackageDesc "." #endif - gpd <- liftIO $ D.readPackageDescription D.normal cabal - ldar <- liftIO lookupLdAr - (hsSourceDirs, _) <- liftIO $ checkCabalFile gpd - liftIO $ removeFileIfExists (bd "setup-config") - c <- liftIO $ configure opts passThroughArgs - if c then do - -- these files contain the wrong data after the configure step, - -- remove them to force a cabal build first - liftIO $ mapM_ removeFileIfExists [ "yesod-devel/ghcargs.txt" - , "yesod-devel/arargs.txt" - , "yesod-devel/ldargs.txt" - ] - rebuild <- liftIO $ mkRebuild ghcVer cabal opts ldar - mainInnerLoop develHsPath iappPort hsSourceDirs filesModified cabal rebuild - else do - liftIO (threadDelay 5000000) - mainOuterLoop develHsPath iappPort filesModified + gpd <- D.readPackageDescription D.normal cabal + let pd = D.packageDescription gpd + D.PackageIdentifier (D.PackageName packageName) _version = D.package pd - -- inner loop rebuilds after files change - mainInnerLoop develHsPath iappPort hsSourceDirs filesModified cabal rebuild = go - where - go = do - _ <- recompDeps hsSourceDirs - list <- liftIO $ getFileList hsSourceDirs [cabal] - success <- liftIO rebuild - pkgArgs <- liftIO (ghcPackageArgs opts) - let devArgs = pkgArgs ++ [develHsPath] - 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 liftIO $ do - putStrLn "\x1b[1;31mBuild failure, pausing...\x1b[0m" - runBuildHook $ failHook opts - else do - liftIO $ runBuildHook $ successHook opts - liftIO $ removeLock opts - liftIO $ putStrLn - $ if verbose opts then "Starting development server: runghc " ++ L.unwords devArgs - else "Starting development server..." - env0 <- liftIO getEnvironment + -- Which file contains the code to run + develHsPath <- checkDevelFile - -- get a new port for the new process to listen on - appPort <- liftIO $ I.readIORef iappPort >>= getPort opts . (+ 1) - liftIO $ I.writeIORef iappPort appPort + -- The port that we're currently listening on, and that the + -- reverse proxy should point to + appPortVar <- newTVarIO (-1) - (_,_,_,ph) <- liftIO $ createProcess (proc "runghc" devArgs) - { env = Just $ Map.toList - $ Map.insert "PORT" (show appPort) - $ Map.insert "DISPLAY_PORT" (show $ develPort opts) - $ Map.fromList 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 <- 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 develHsPath iappPort filesModified else go + -- If we're actually using reverse proxying, spawn off a reverse + -- proxy thread + let withRevProxy = + if useReverseProxy opts + then race_ (reverseProxy opts appPortVar) + else id -runBuildHook :: Maybe String -> IO () -runBuildHook (Just s) = do - ret <- system s - case ret of - ExitFailure _ -> putStrLn ("Error executing hook: " ++ s) - _ -> return () -runBuildHook Nothing = return () + -- Run the following concurrently. If any of them exit, take the + -- whole thing down. + -- + -- We need to put withChangedVar outside of all this, since we + -- need to ensure we start watching files before the stack build + -- loop starts. + withChangedVar $ \changedVar -> withRevProxy $ race_ + -- Start the build loop + (runStackBuild appPortVar packageName (getAvailableFlags gpd)) -{- - run `cabal configure' with our wrappers --} -configure :: DevelOpts -> [String] -> IO Bool -configure opts extraArgs = - checkExit =<< createProcess (proc (cabalProgram opts) $ - [ "configure" - , "-flibrary-only" - , "--disable-tests" - , "--disable-benchmarks" - , "-fdevel" - , "--disable-library-profiling" - , "--with-ld=yesod-ld-wrapper" - , "--with-ghc=yesod-ghc-wrapper" - , "--with-ar=yesod-ar-wrapper" - , "--with-hc-pkg=ghc-pkg" - ] ++ develConfigOpts opts ++ extraArgs - ) { env = develEnv opts } + -- Run the app itself, restarting when a build succeeds + (runApp appPortVar changedVar develHsPath) + where + -- say, but only when verbose is on + sayV = when (verbose opts) . sayString -removeFileIfExists :: FilePath -> IO () -removeFileIfExists file = removeFile file `Ex.catch` handler - where - handler :: IOError -> IO () - handler e | isDoesNotExistError e = return () - | otherwise = Ex.throw e + -- Leverage "stack build --file-watch" to do the build + runStackBuild appPortVar packageName availableFlags = do + -- We call into this app for the devel-signal command + myPath <- getExecutablePath + let procConfig = setStdout createSource + $ setStderr createSource + $ setDelegateCtlc True $ proc "stack" $ + [ "build" + , "--fast" + , "--file-watch" -mkRebuild :: String -> FilePath -> DevelOpts -> (FilePath, FilePath) -> IO (IO Bool) -mkRebuild ghcVer cabalFile opts (ldPath, arPath) - | GHC.cProjectVersion /= ghcVer = - failWith "Yesod has been compiled with a different GHC version, please reinstall yesod-bin" - | forceCabal opts = return (rebuildCabal opts) - | otherwise = - return $ do - ns <- mapM (cabalFile `isNewerThan`) - [ "yesod-devel/ghcargs.txt", "yesod-devel/arargs.txt", "yesod-devel/ldargs.txt" ] - if or ns - then rebuildCabal opts - else do - bf <- getBuildFlags - rebuildGhc bf ldPath arPath + -- Indicate the component we want + , packageName ++ ":lib" + -- signal the watcher that a build has succeeded + , "--exec", myPath ++ " devel-signal" + ] ++ -rebuildGhc :: [Located String] -> FilePath -> FilePath -> IO Bool -rebuildGhc bf ld ar = do - putStrLn "Rebuilding application... (using GHC API)" - buildPackage bf ld ar + -- Turn on relevant flags + concatMap + (\flagName -> [ "--flag", packageName ++ ":" ++ flagName]) + (Set.toList $ Set.intersection + availableFlags + (Set.fromList ["dev", "library-only"])) ++ -rebuildCabal :: DevelOpts -> IO Bool -rebuildCabal opts = do - putStrLn $ "Rebuilding application... (using " ++ cabalProgram opts ++ ")" - checkExit =<< createProcess (proc (cabalProgram opts) args) - { env = develEnv opts - } - where - args | verbose opts = [ "build" ] - | otherwise = [ "build", "-v0" ] + -- Add the success hook + (case successHook opts of + Nothing -> [] + Just h -> ["--exec", h]) ++ -try_ :: forall a. IO a -> IO () -try_ x = void (Ex.try x :: IO (Either Ex.SomeException a)) + -- Any extra args passed on the command line + passThroughArgs -type FileList = Map.Map FilePath EpochTime + sayV $ show procConfig -getFileList :: [FilePath] -> [FilePath] -> IO FileList -getFileList hsSourceDirs extraFiles = do - (files, deps) <- getDeps hsSourceDirs - let files' = extraFiles ++ files ++ map fst (Map.toList deps) - fmap Map.fromList $ forM files' $ \f -> do - efs <- Ex.try $ getFileStatus f - return $ case efs of - Left (_ :: Ex.SomeException) -> (f, 0) - Right fs -> (f, modificationTime fs) + -- Monitor the stdout and stderr content from the build process. Any + -- time some output comes, we invalidate the currently running app by + -- changing the destination port for reverse proxying to -1. We also + -- make sure that all content to stdout or stderr from the build + -- process is piped to the actual stdout and stderr handles. + withProcess_ procConfig $ \p -> do + let helper getter h = runConduit + $ getter p + $$ CL.iterM (\_ -> atomically $ writeTVar appPortVar (-1)) + =$ CB.sinkHandle h + race_ (helper getStdout stdout) (helper getStderr stderr) --- | 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 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 + -- Run the inner action with a TVar which will be set to True + -- whenever the signal file is modified. + withChangedVar inner = withManager $ \manager -> do + -- Variable indicating that the signal file has been changed. We + -- reset it each time we handle the signal. + changedVar <- newTVarIO False - isHaskell filename _ = takeExtension filename `elem` [".hs", ".lhs", ".hsc", ".cabal"] + -- Get the absolute path of the signal file, needed for the + -- file watching + develSignalFile' <- canonicalizeSpecialFile SignalFile -checkDevelFile :: IO FilePath -checkDevelFile = - loop paths - where - paths = ["app/devel.hs", "devel.hs", "src/devel.hs"] + -- Start watching the signal file, and set changedVar to + -- True each time it's changed. + void $ watchDir manager + -- Using fromString to work with older versions of fsnotify + -- that use system-filepath + (fromString (takeDirectory develSignalFile')) + (\e -> eventPath e == fromString develSignalFile') + (const $ atomically $ writeTVar changedVar True) - loop [] = failWith $ "file devel.hs not found, checked: " ++ show paths - loop (x:xs) = do - e <- doesFileExist x - if e - then return x - else loop xs + -- Run the inner action + inner changedVar -checkCabalFile :: D.GenericPackageDescription -> IO ([FilePath], D.Library) -checkCabalFile gpd = case D.condLibrary gpd of - Nothing -> failWith "incorrect cabal file, no library" - Just ct -> - case lookupDevelLib gpd ct of - Nothing -> - failWith "no development flag found in your configuration file. Expected a 'library-only' flag or the older 'devel' flag" - Just dLib -> do - let hsSourceDirs = D.hsSourceDirs . D.libBuildInfo $ dLib - fl <- getFileList hsSourceDirs [] - let unlisted = checkFileList fl dLib - unless (null unlisted) $ do - putStrLn "WARNING: the following source files are not listed in exposed-modules or other-modules:" - mapM_ putStrLn unlisted - when ("Application" `notElem` (map (last . D.components) $ D.exposedModules dLib)) $ - putStrLn "WARNING: no exposed module Application" - return (hsSourceDirs, dLib) + -- Each time the library builds successfully, run the application + runApp appPortVar changedVar develHsPath = do + -- Wait for the first change, indicating that the library + -- has been built + atomically $ do + changed <- readTVar changedVar + check changed + writeTVar changedVar False -failWith :: String -> IO a -failWith msg = do - putStrLn $ "ERROR: " ++ msg - exitFailure + sayV "First successful build complete, running app" -checkFileList :: FileList -> D.Library -> [FilePath] -checkFileList fl lib = filter (not . isSetup) . filter isUnlisted . filter isSrcFile $ sourceFiles - where - al = allModules lib - -- a file is only a possible 'module file' if all path pieces start with a capital letter - sourceFiles = filter isSrcFile . map fst . Map.toList $ fl - isSrcFile file = let dirs = filter (/=".") $ splitDirectories file - in all (isUpper . head) dirs && (takeExtension file `elem` [".hs", ".lhs"]) - isUnlisted file = not (toModuleName file `Set.member` al) - toModuleName = L.intercalate "." . filter (/=".") . splitDirectories . dropExtension + -- We're going to set the PORT and DISPLAY_PORT variables + -- for the child below + env <- fmap Map.fromList getEnvironment - isSetup "Setup.hs" = True - isSetup "./Setup.hs" = True - isSetup "Setup.lhs" = True - isSetup "./Setup.lhs" = True - isSetup _ = False + -- Keep looping forever, print any synchronous exceptions, + -- and eventually die from an async exception from one of + -- the other threads (via race_ above). + forever $ Ex.handleAny (\e -> sayErrString $ "Exception in runApp: " ++ show e) $ do + -- Get the port the child should listen on, and tell + -- the reverse proxy about it + newPort <- + if useReverseProxy opts + then getNewPort opts + -- no reverse proxy, so use the develPort directly + else return (develPort opts) + atomically $ writeTVar appPortVar newPort -allModules :: D.Library -> Set.Set String -allModules lib = Set.fromList $ map toString $ D.exposedModules lib ++ (D.otherModules . D.libBuildInfo) lib - where - toString = L.intercalate "." . D.components + -- Modified environment + let env' = Map.toList + $ Map.insert "PORT" (show newPort) + $ Map.insert "DISPLAY_PORT" (show $ develPort opts) + env -ghcVersion :: IO String -ghcVersion = fmap getNumber $ readProcess "runghc" ["--numeric-version", "0"] [] - where - getNumber = filter (\x -> isNumber x || x == '.') + -- Remove the terminate file so we don't immediately exit + removeSpecialFile TermFile -ghcPackageArgs :: DevelOpts -> IO [String] -ghcPackageArgs opts = getBuildFlags >>= getPackageArgs (buildDir opts) + -- Launch the main function in the Main module defined + -- in the file develHsPath. We use ghc instead of + -- runghc to avoid the extra (confusing) resident + -- runghc process. Starting with GHC 8.0.2, that will + -- not be necessary. -lookupDevelLib :: D.GenericPackageDescription -> D.CondTree D.ConfVar c a -> Maybe a -lookupDevelLib gpd ct | found = Just (D.condTreeData ct) - | otherwise = Nothing - where - flags = map (unFlagName . D.flagName) $ D.genPackageFlags gpd - unFlagName (D.FlagName x) = x - found = any (`elem` ["library-only", "devel"]) flags + {- Hmm, unknown errors trying to get this to work. Just doing the + - runghc thing instead. --- location of `ld' and `ar' programs -lookupLdAr :: IO (FilePath, FilePath) -lookupLdAr = do - mla <- lookupLdAr' - case mla of - Nothing -> failWith "Cannot determine location of `ar' or `ld' program" - Just la -> return la + let procDef = setStdin closed $ setEnv env' $ proc "stack" + [ "ghc" + , "--" + , develHsPath + , "-e" + , "Main.main" + ] + -} + let procDef = setStdin closed $ setEnv env' $ proc "stack" + [ "runghc" + , "--" + , develHsPath + ] -lookupLdAr' :: IO (Maybe (FilePath, FilePath)) -lookupLdAr' = do -#if MIN_VERSION_Cabal(1,18,0) - (_, _, pgmc) <- D.configCompilerEx (Just D.GHC) Nothing Nothing D.defaultProgramConfiguration D.silent -#else - (_, pgmc) <- D.configCompiler (Just D.GHC) Nothing Nothing D.defaultProgramConfiguration D.silent -#endif - pgmc' <- D.configureAllKnownPrograms D.silent pgmc - return $ (,) <$> look D.ldProgram pgmc' <*> look D.arProgram pgmc' - where - look pgm pdb = fmap D.programPath (D.lookupProgram pgm pdb) + sayV $ "Running child process: " ++ show procDef --- | nonblocking version of @waitForProcess@ -waitForProcess' :: ProcessHandle -> IO ExitCode -waitForProcess' pid = go - where - go = do - mec <- getProcessExitCode pid - case mec of - Just ec -> return ec - Nothing -> threadDelay 100000 >> go + -- Start running the child process with GHC + withProcess procDef $ \p -> do + -- Wait for either the process to exit, or for a new build to come through + eres <- atomically (fmap Left (waitExitCodeSTM p) <|> fmap Right + (do changed <- readTVar changedVar + check changed + writeTVar changedVar False)) + -- on an async exception, make sure the child dies + `Ex.onException` writeSpecialFile TermFile + case eres of + -- Child exited, which indicates some + -- error. Let the user know, sleep for a bit + -- to avoid busy-looping, and then we'll try + -- again. + Left ec -> do + sayErrString $ "Unexpected: child process exited with " ++ show ec + threadDelay 1000000 + sayErrString "Trying again" + -- New build succeeded + Right () -> do + -- Kill the child process, both with the + -- TermFile, and by signaling the process + -- directly. + writeSpecialFile TermFile + stopProcess p --- | wait for process started by @createProcess@, return True for ExitSuccess -checkExit :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO Bool -checkExit (_,_,_,h) = (==ExitSuccess) <$> waitForProcess' h + -- Wait until the child properly exits, then we'll try again + ec <- waitExitCode p + sayV $ "Expected: child process exited with " ++ show ec diff --git a/GhcBuild.hs b/GhcBuild.hs deleted file mode 100644 --- a/GhcBuild.hs +++ /dev/null @@ -1,547 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -{-# OPTIONS_GHC -fno-warn-unused-binds #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -{-# OPTIONS_GHC -fno-warn-unused-matches #-} -{- - There is a lot of code copied from GHC here, and some conditional - compilation. Instead of fixing all warnings and making it much more - difficult to compare the code to the original, just ignore unused - binds and imports. --} -{-# LANGUAGE CPP #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{- - build package with the GHC API --} - -module GhcBuild (getBuildFlags, buildPackage, getPackageArgs) where - -import qualified Control.Exception as Ex -import Control.Monad (when) -import Data.IORef -import System.Process (rawSystem) -import System.Environment (getEnvironment) - -import CmdLineParser -import Data.Char (toLower) -import Data.List (isPrefixOf, isSuffixOf, partition) -import Data.Maybe (fromMaybe) -import DriverPhases (Phase (..), anyHsc, isHaskellSrcFilename, - isSourceFilename, startPhase) -import DriverPipeline (compileFile, link, linkBinary, oneShot) -import DynFlags (DynFlags, compilerInfo) -import qualified DynFlags -import qualified DynFlags as DF -import qualified GHC -import GHC.Paths (libdir) -import HscTypes (HscEnv (..), emptyHomePackageTable) -import qualified Module -import MonadUtils (liftIO) -import Panic (throwGhcException, panic) -import SrcLoc (Located, mkGeneralLocated) -import qualified StaticFlags -#if __GLASGOW_HASKELL__ >= 707 -import DynFlags (ldInputs) -#else -import StaticFlags (v_Ld_inputs) -#endif -import System.FilePath (normalise, ()) -import Util (consIORef, looksLikeModuleName) - -{- - This contains a huge hack: - GHC only accepts setting static flags once per process, however it has no way to - get the remaining options from the command line, without setting the static flags. - This code overwrites the IORef to disable the check. This will likely cause - problems if the flags are modified, but fortunately that's relatively uncommon. --} -getBuildFlags :: IO [Located String] -getBuildFlags = do - argv0 <- fmap read $ readFile "yesod-devel/ghcargs.txt" -- generated by yesod-ghc-wrapper - argv0' <- prependHsenvArgv argv0 - let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0' - mbMinusB | null minusB_args = Nothing - | otherwise = Just (drop 2 (last minusB_args)) - let argv1' = map (mkGeneralLocated "on the commandline") argv1 - writeIORef StaticFlags.v_opt_C_ready False -- the huge hack - (argv2, staticFlagWarnings) <- GHC.parseStaticFlags argv1' - return argv2 - -prependHsenvArgv :: [String] -> IO [String] -prependHsenvArgv argv = do - env <- getEnvironment - return $ case (lookup "HSENV" env) of - Nothing -> argv - _ -> hsenvArgv ++ argv - where hsenvArgv = words $ fromMaybe "" (lookup "PACKAGE_DB_FOR_GHC" env) - --- construct a command line for loading the right packages -getPackageArgs :: Maybe String -> [Located String] -> IO [String] -getPackageArgs buildDir argv2 = do - (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2 - GHC.runGhc (Just libdir) $ do - dflags0 <- GHC.getSessionDynFlags - (dflags1, _, _) <- GHC.parseDynamicFlags dflags0 argv3 - let pkgFlags = map convertPkgFlag (GHC.packageFlags dflags1) - ignorePkgFlags = -#if __GLASGOW_HASKELL__ >= 800 - map convertIgnorePkgFlag (GHC.ignorePackageFlags dflags1) -#else - [] -#endif - trustPkgFlags = -#if __GLASGOW_HASKELL__ >= 800 - map convertTrustPkgFlag (GHC.trustFlags dflags1) -#else - [] -#endif - hideAll | gopt DF.Opt_HideAllPackages dflags1 = [ "-hide-all-packages"] - | otherwise = [] - ownPkg = packageString (DF.thisPackage dflags1) - return (reverse (extra dflags1) ++ hideAll ++ trustPkgFlags ++ ignorePkgFlags ++ pkgFlags ++ ownPkg) - where -#if __GLASGOW_HASKELL__ >= 800 - convertIgnorePkgFlag (DF.IgnorePackage p) = "-ignore-package" ++ p - convertTrustPkgFlag (DF.TrustPackage p) = "-trust" ++ p - convertTrustPkgFlag (DF.DistrustPackage p) = "-distrust" ++ p -#else - convertPkgFlag (DF.IgnorePackage p) = "-ignore-package" ++ p - convertPkgFlag (DF.TrustPackage p) = "-trust" ++ p - convertPkgFlag (DF.DistrustPackage p) = "-distrust" ++ p -#endif -#if __GLASGOW_HASKELL__ >= 800 - convertPkgFlag (DF.ExposePackage _ (DF.PackageArg p) _) = "-package" ++ p - convertPkgFlag (DF.ExposePackage _ (DF.UnitIdArg p) _) = "-package-id" ++ p -#elif __GLASGOW_HASKELL__ == 710 - convertPkgFlag (DF.ExposePackage (DF.PackageArg p) _) = "-package" ++ p - convertPkgFlag (DF.ExposePackage (DF.PackageIdArg p) _) = "-package-id" ++ p - convertPkgFlag (DF.ExposePackage (DF.PackageKeyArg p) _) = "-package-key" ++ p -#else - convertPkgFlag (DF.ExposePackage p) = "-package" ++ p - convertPkgFlag (DF.ExposePackageId p) = "-package-id" ++ p -#endif - convertPkgFlag (DF.HidePackage p) = "-hide-package" ++ p -#if __GLASGOW_HASKELL__ >= 800 - -- See: https://github.com/yesodweb/yesod/issues/1284 - packageString _flags = [] - --packageString flags = "-package-id" ++ Module.unitIdString flags -#elif __GLASGOW_HASKELL__ == 710 - packageString flags = ["-package-key" ++ Module.packageKeyString flags] -#else - packageString flags = ["-package-id" ++ Module.packageIdString flags ++ "-inplace"] -#endif -#if __GLASGOW_HASKELL__ >= 705 - extra df = inplaceConf ++ extra' - where - extra' = concatMap convertExtra (extraConfs df) - -- old cabal-install sometimes misses the .inplace db, fix it here - inplaceConf - | any (".inplace" `isSuffixOf`) extra' = [] - | otherwise = ["-package-db" ++ fromMaybe "dist" buildDir - ++ "/package.conf.inplace"] - extraConfs df = GHC.extraPkgConfs df [] - convertExtra DF.GlobalPkgConf = [ ] - convertExtra DF.UserPkgConf = [ ] - convertExtra (DF.PkgConfFile file) = [ "-package-db" ++ file ] -#else - extra df = inplaceConf ++ extra' - where - extra' = map ("-package-conf"++) (GHC.extraPkgConfs df) - -- old cabal-install sometimes misses the .inplace db, fix it here - inplaceConf - | any (".inplace" `isSuffixOf`) extra' = [] - | otherwise = ["-package-conf" ++ fromMaybe "dist" buildDir - ++ "/package.conf.inplace"] -#endif - -#if __GLASGOW_HASKELL__ >= 707 - gopt = DF.gopt -#else - gopt = DF.dopt -#endif - - -buildPackage :: [Located String] -> FilePath -> FilePath -> IO Bool -buildPackage a ld ar = buildPackage' a ld ar `Ex.catch` \e -> do - putStrLn ("exception building package: " ++ show (e :: Ex.SomeException)) - return False - -buildPackage' :: [Located String] -> FilePath -> FilePath -> IO Bool -buildPackage' argv2 ld ar = do - (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2 - GHC.runGhc (Just libdir) $ do - dflags0 <- GHC.getSessionDynFlags - (dflags1, _, _) <- GHC.parseDynamicFlags dflags0 argv3 - let dflags2 = dflags1 { GHC.ghcMode = GHC.CompManager - , GHC.hscTarget = GHC.hscTarget dflags1 - , GHC.ghcLink = GHC.LinkBinary - , GHC.verbosity = 1 - } - (dflags3, fileish_args, _) <- GHC.parseDynamicFlags dflags2 argv3 - GHC.setSessionDynFlags dflags3 - let normal_fileish_paths = map (normalise . GHC.unLoc) fileish_args - (srcs, objs) = partition_args normal_fileish_paths [] [] - (hs_srcs, non_hs_srcs) = partition haskellish srcs - haskellish (f,Nothing) = - looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f - haskellish (_,Just phase) = -#if MIN_VERSION_ghc(8,0,0) - phase `notElem` [As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm, StopLn] -#elif MIN_VERSION_ghc(7,8,3) - phase `notElem` [As True, As False, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn] -#elif MIN_VERSION_ghc(7,4,0) - phase `notElem` [As, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn] -#else - phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn] -#endif - hsc_env <- GHC.getSession --- if (null hs_srcs) --- then liftIO (oneShot hsc_env StopLn srcs) --- else do -#if MIN_VERSION_ghc(7,2,0) - o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x) -#else - o_files <- mapM (\x -> compileFile hsc_env StopLn x) -#endif - non_hs_srcs -#if __GLASGOW_HASKELL__ >= 707 - let dflags4 = dflags3 - { ldInputs = map (DF.FileOption "") (reverse o_files) - ++ ldInputs dflags3 - } - GHC.setSessionDynFlags dflags4 -#else - liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files) -#endif - targets <- mapM (uncurry GHC.guessTarget) hs_srcs - GHC.setTargets targets - ok_flag <- GHC.load GHC.LoadAllTargets - if GHC.failed ok_flag - then return False - else liftIO (linkPkg ld ar) >> return True - -linkPkg :: FilePath -> FilePath -> IO () -linkPkg ld ar = do - arargs <- fmap read $ readFile "yesod-devel/arargs.txt" - rawSystem ar arargs - ldargs <- fmap read $ readFile "yesod-devel/ldargs.txt" - rawSystem ld ldargs - return () - --------------------------------------------------------------------------------------------- --- stuff below copied from ghc main.hs --------------------------------------------------------------------------------------------- - -partition_args :: [String] -> [(String, Maybe Phase)] -> [String] - -> ([(String, Maybe Phase)], [String]) -partition_args [] srcs objs = (reverse srcs, reverse objs) -partition_args ("-x":suff:args) srcs objs - | "none" <- suff = partition_args args srcs objs - | StopLn <- phase = partition_args args srcs (slurp ++ objs) - | otherwise = partition_args rest (these_srcs ++ srcs) objs - where phase = startPhase suff - (slurp,rest) = break (== "-x") args - these_srcs = zip slurp (repeat (Just phase)) -partition_args (arg:args) srcs objs - | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs - | otherwise = partition_args args srcs (arg:objs) - - {- - We split out the object files (.o, .dll) and add them - to v_Ld_inputs for use by the linker. - - The following things should be considered compilation manager inputs: - - - haskell source files (strings ending in .hs, .lhs or other - haskellish extension), - - - module names (not forgetting hierarchical module names), - - - and finally we consider everything not containing a '.' to be - a comp manager input, as shorthand for a .hs or .lhs filename. - - Everything else is considered to be a linker object, and passed - straight through to the linker. - -} -looks_like_an_input :: String -> Bool -looks_like_an_input m = isSourceFilename m - || looksLikeModuleName m - || '.' `notElem` m - - - --- Parsing the mode flag - -parseModeFlags :: [Located String] - -> IO (Mode, - [Located String], - [Located String]) -parseModeFlags args = do - let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) = - runCmdLine (processArgs mode_flags args) - (Nothing, [], []) - mode = case mModeFlag of - Nothing -> doMakeMode - Just (m, _) -> m - errs = errs1 ++ map (mkGeneralLocated "on the commandline") errs2 -#if __GLASGOW_HASKELL__ >= 710 - errorsToGhcException' = errorsToGhcException . map (\(GHC.L _ e) -> ("on the commandline", e)) -#else - errorsToGhcException' = errorsToGhcException -#endif - - when (not (null errs)) $ throwGhcException $ errorsToGhcException' errs - return (mode, flags' ++ leftover, warns) - -type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String]) - -- mode flags sometimes give rise to new DynFlags (eg. -C, see below) - -- so we collect the new ones and return them. - -mode_flags :: [Flag ModeM] -mode_flags = - [ ------- help / version ---------------------------------------------- - mkFlag "?" (PassFlag (setMode showGhcUsageMode)) - , mkFlag "-help" (PassFlag (setMode showGhcUsageMode)) - , mkFlag "V" (PassFlag (setMode showVersionMode)) - , mkFlag "-version" (PassFlag (setMode showVersionMode)) - , mkFlag "-numeric-version" (PassFlag (setMode showNumVersionMode)) - , mkFlag "-info" (PassFlag (setMode showInfoMode)) - , mkFlag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode)) - , mkFlag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode)) - ] ++ - [ mkFlag k' (PassFlag (setMode (printSetting k))) - | k <- ["Project version", - "Booter version", - "Stage", - "Build platform", - "Host platform", - "Target platform", - "Have interpreter", - "Object splitting supported", - "Have native code generator", - "Support SMP", - "Unregisterised", - "Tables next to code", - "RTS ways", - "Leading underscore", - "Debug on", - "LibDir", - "Global Package DB", - "C compiler flags", - "Gcc Linker flags", - "Ld Linker flags"], - let k' = "-print-" ++ map (replaceSpace . toLower) k - replaceSpace ' ' = '-' - replaceSpace c = c - ] ++ - ------- interfaces ---------------------------------------------------- - [ mkFlag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f) - "--show-iface")) - - ------- primary modes ------------------------------------------------ - , mkFlag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f - addFlag "-no-link" f)) - , mkFlag "M" (PassFlag (setMode doMkDependHSMode)) - , mkFlag "E" (PassFlag (setMode (stopBeforeMode anyHsc))) - , mkFlag "C" (PassFlag (\f -> do setMode (stopBeforeMode HCc) f - addFlag "-fvia-C" f)) -#if MIN_VERSION_ghc(7,8,3) - , mkFlag "S" (PassFlag (setMode (stopBeforeMode (As True)))) -#else - , mkFlag "S" (PassFlag (setMode (stopBeforeMode As))) -#endif - , mkFlag "-make" (PassFlag (setMode doMakeMode)) - , mkFlag "-interactive" (PassFlag (setMode doInteractiveMode)) - , mkFlag "-abi-hash" (PassFlag (setMode doAbiHashMode)) - , mkFlag "e" (SepArg (\s -> setMode (doEvalMode s) "-e")) - ] -#if MIN_VERSION_ghc(7,10,1) - where mkFlag fName fOptKind = Flag fName fOptKind AllModes -#else - where mkFlag fName fOptKind = Flag fName fOptKind -#endif - -setMode :: Mode -> String -> EwM ModeM () -setMode newMode newFlag = liftEwM $ do - (mModeFlag, errs, flags') <- getCmdLineState - let (modeFlag', errs') = - case mModeFlag of - Nothing -> ((newMode, newFlag), errs) - Just (oldMode, oldFlag) -> - case (oldMode, newMode) of - -- -c/--make are allowed together, and mean --make -no-link - _ | isStopLnMode oldMode && isDoMakeMode newMode - || isStopLnMode newMode && isDoMakeMode oldMode -> - ((doMakeMode, "--make"), []) - - -- If we have both --help and --interactive then we - -- want showGhciUsage - _ | isShowGhcUsageMode oldMode && - isDoInteractiveMode newMode -> - ((showGhciUsageMode, oldFlag), []) - | isShowGhcUsageMode newMode && - isDoInteractiveMode oldMode -> - ((showGhciUsageMode, newFlag), []) - -- Otherwise, --help/--version/--numeric-version always win - | isDominantFlag oldMode -> ((oldMode, oldFlag), []) - | isDominantFlag newMode -> ((newMode, newFlag), []) - -- We need to accumulate eval flags like "-e foo -e bar" - (Right (Right (DoEval esOld)), - Right (Right (DoEval [eNew]))) -> - ((Right (Right (DoEval (eNew : esOld))), oldFlag), - errs) - -- Saying e.g. --interactive --interactive is OK - _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs) - -- Otherwise, complain - _ -> let err = flagMismatchErr oldFlag newFlag - in ((oldMode, oldFlag), err : errs) - putCmdLineState (Just modeFlag', errs', flags') - where isDominantFlag f = isShowGhcUsageMode f || - isShowGhciUsageMode f || - isShowVersionMode f || - isShowNumVersionMode f - -flagMismatchErr :: String -> String -> String -flagMismatchErr oldFlag newFlag - = "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'" - -addFlag :: String -> String -> EwM ModeM () -addFlag s flag = liftEwM $ do - (m, e, flags') <- getCmdLineState - putCmdLineState (m, e, mkGeneralLocated loc s : flags') - where loc = "addFlag by " ++ flag ++ " on the commandline" - -type Mode = Either PreStartupMode PostStartupMode -type PostStartupMode = Either PreLoadMode PostLoadMode - -data PreStartupMode - = ShowVersion -- ghc -V/--version - | ShowNumVersion -- ghc --numeric-version - | ShowSupportedExtensions -- ghc --supported-extensions - | Print String -- ghc --print-foo - -showVersionMode, showNumVersionMode, showSupportedExtensionsMode :: Mode -showVersionMode = mkPreStartupMode ShowVersion -showNumVersionMode = mkPreStartupMode ShowNumVersion -showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions - -mkPreStartupMode :: PreStartupMode -> Mode -mkPreStartupMode = Left - -isShowVersionMode :: Mode -> Bool -isShowVersionMode (Left ShowVersion) = True -isShowVersionMode _ = False - -isShowNumVersionMode :: Mode -> Bool -isShowNumVersionMode (Left ShowNumVersion) = True -isShowNumVersionMode _ = False - -data PreLoadMode - = ShowGhcUsage -- ghc -? - | ShowGhciUsage -- ghci -? - | ShowInfo -- ghc --info - | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo - -showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode -showGhcUsageMode = mkPreLoadMode ShowGhcUsage -showGhciUsageMode = mkPreLoadMode ShowGhciUsage -showInfoMode = mkPreLoadMode ShowInfo - -printSetting :: String -> Mode -printSetting k = mkPreLoadMode (PrintWithDynFlags f) - where f dflags = fromMaybe (panic ("Setting not found: " ++ show k)) -#if MIN_VERSION_ghc(7,2,0) - $ lookup k (compilerInfo dflags) -#else - $ fmap convertPrintable (lookup k compilerInfo) - where - convertPrintable (DynFlags.String s) = s - convertPrintable (DynFlags.FromDynFlags f) = f dflags -#endif - -mkPreLoadMode :: PreLoadMode -> Mode -mkPreLoadMode = Right . Left - -isShowGhcUsageMode :: Mode -> Bool -isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True -isShowGhcUsageMode _ = False - -isShowGhciUsageMode :: Mode -> Bool -isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True -isShowGhciUsageMode _ = False - -data PostLoadMode - = ShowInterface FilePath -- ghc --show-iface - | DoMkDependHS -- ghc -M - | StopBefore Phase -- ghc -E | -C | -S - -- StopBefore StopLn is the default - | DoMake -- ghc --make - | DoInteractive -- ghc --interactive - | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"] - | DoAbiHash -- ghc --abi-hash - -doMkDependHSMode, doMakeMode, doInteractiveMode, doAbiHashMode :: Mode -doMkDependHSMode = mkPostLoadMode DoMkDependHS -doMakeMode = mkPostLoadMode DoMake -doInteractiveMode = mkPostLoadMode DoInteractive -doAbiHashMode = mkPostLoadMode DoAbiHash - - -showInterfaceMode :: FilePath -> Mode -showInterfaceMode fp = mkPostLoadMode (ShowInterface fp) - -stopBeforeMode :: Phase -> Mode -stopBeforeMode phase = mkPostLoadMode (StopBefore phase) - -doEvalMode :: String -> Mode -doEvalMode str = mkPostLoadMode (DoEval [str]) - -mkPostLoadMode :: PostLoadMode -> Mode -mkPostLoadMode = Right . Right - -isDoInteractiveMode :: Mode -> Bool -isDoInteractiveMode (Right (Right DoInteractive)) = True -isDoInteractiveMode _ = False - -isStopLnMode :: Mode -> Bool -isStopLnMode (Right (Right (StopBefore StopLn))) = True -isStopLnMode _ = False - -isDoMakeMode :: Mode -> Bool -isDoMakeMode (Right (Right DoMake)) = True -isDoMakeMode _ = False - -#ifdef GHCI -isInteractiveMode :: PostLoadMode -> Bool -isInteractiveMode DoInteractive = True -isInteractiveMode _ = False -#endif - --- isInterpretiveMode: byte-code compiler involved -isInterpretiveMode :: PostLoadMode -> Bool -isInterpretiveMode DoInteractive = True -isInterpretiveMode (DoEval _) = True -isInterpretiveMode _ = False - -needsInputsMode :: PostLoadMode -> Bool -needsInputsMode DoMkDependHS = True -needsInputsMode (StopBefore _) = True -needsInputsMode DoMake = True -needsInputsMode _ = False - --- True if we are going to attempt to link in this mode. --- (we might not actually link, depending on the GhcLink flag) -isLinkMode :: PostLoadMode -> Bool -isLinkMode (StopBefore StopLn) = True -isLinkMode DoMake = True -isLinkMode DoInteractive = True -isLinkMode (DoEval _) = True -isLinkMode _ = False - -isCompManagerMode :: PostLoadMode -> Bool -isCompManagerMode DoMake = True -isCompManagerMode DoInteractive = True -isCompManagerMode (DoEval _) = True -isCompManagerMode _ = False diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,110 @@ +## yesod-bin: the Yesod executable + +This executable is almost exclusively used for its `yesod devel` +capabilities, providing a development server for web apps. It also +provides some legacy functionality, almost all of which has been +superceded by functionality in the +[Haskell Stack build tool](http://haskellstack.org/). This README will +speak exclusively about `yesod devel`. + +__CAVEAT__ There may be some issues using `yesod devel` in Docker-enabled +projects. See [comment on +Github](https://github.com/yesodweb/yesod/pull/1305#issuecomment-263204471). + +### Development server + +The development server will automatically recompile your application +whenever you make source code changes. It will then launch your app, +and reverse-proxy to it. The reverse proxying ensures that you can +connect to your application on a dedicated port, always get the latest +version available, and won't get dropped connections when the app +isn't yet ready. Instead, you'll get some very motivating messages: + +![Motivation](https://i.sli.mg/nO6DvN.png) + +## Common workflows + +The standard Yesod scaffoldings are configured to work with `yesod +devel` out of the box (though see below for non-Yesod +development). For the most part, from within your application +directory, you'll just want to run: + +* `stack build yesod-bin` +* `stack exec -- yesod devel` + +This will install the corresponding version of the `yesod` executable +into your currently selected snapshot, and then use that +executable. (Starting with version 1.5.0, you can be more lax and use +a `yesod` executable compiled for a different snapshot. Once 1.5.0 is +more widespread we'll probably update these instructions.) + +Some other common questions: + +* If you want to control which port you can access your application + on, use the `--port` command line option, e.g. `stack exec -- yesod + devel --port 4000`. Changing your port inside your source code _will + not work_, because you need to change the reverse proxying port. +* If you want to run a command after each successful build, you can + use `stack exec -- yesod devel --success-hook "echo Yay!"` +* If for some reason you want to disable the reverse proxy + capabilities, use `stack exec -- yesod devel + --disable-reverse-proxy` + +## How it works + +The workflow of the devel server is pretty simple: + +* Launch a reverse proxy server +* Use Stack file-watch capability to run a build loop on your code, + rebuilding each time a file is modified +* Have Stack call `yesod devel-signal` to write to a specific file + (`yesod-devel/rebuild`) each time a rebuild is successful +* Each time `yesod-devel/rebuild` is modified: + * Kill the current child process + * Get a new random port + * Tell the reverse proxy server about the new port to forward to + * Run the application's devel script with two environment variables + set: + * `PORT` gives the newly generated random port. The application + needs to listen on that port. + * `DISPLAY_PORT` gives the port that the reverse proxy is + listening on, used for display purposes or generating URLs. + +Now some weird notes: + +* The devel script can be one of the following three files. `yesod + devel` will search for them in the given order. That script must + provide a `main` function. + * `app/devel.hs` + * `devel.hs` + * `src/devel.hs` +* Unfortunately, directly killing the `ghc` interpreter has never + worked reliably, so we have an extra hack: when killing the process, + `yesod devel` also writes to a file + `yesod-devel/devel-terminate`. Your devel script should respect this + file and shutdown whenever it exists. +* If your .cabal file defines them, `yesod devel` will tell Stack to + build with the flags `dev` and `library-only`. You can use this to + speed up compile times (biggest win: skip building executables, thus + the name `library-only`). + +If that all seems a little complicated, remember that the Yesod +scaffolding handles all of this for you. But if you want to implement +it yourself... + +## Non-Yesod development + +If you'd like to use the `yesod devel` server for your non-Yesod +application, or even for a Yesod application not based on the +scaffolding, this section is for you! We've got a +[sample application in the repository](https://github.com/yesodweb/yesod/tree/master/yesod-bin/devel-example) +that demonstrates how to get this set up. It demonstrates a good way +to jump through the hoops implied above. + +One important note: I highly recommend putting _all_ of the logic in +your library, and then providing a `develMain :: IO ()` function which +yoru `app/devel.hs` script reexports as `main`. I've found this to +greatly simplify things overall, since you can ensure all of your +dependencies are specified correctly in your `.cabal` file. Also, I +recommend using `PackageImports` in that file, as the example app +shows. diff --git a/ghcwrapper.hs b/ghcwrapper.hs deleted file mode 100644 --- a/ghcwrapper.hs +++ /dev/null @@ -1,65 +0,0 @@ -{- - wrapper executable that captures arguments to ghc, ar or ld --} - -{-# LANGUAGE CPP #-} -module Main where - -import Control.Monad (when) -import Data.Maybe (fromMaybe) - -import Distribution.Compiler (CompilerFlavor (..)) -import qualified Distribution.Simple.Configure as D -import Distribution.Simple.Program (arProgram, - defaultProgramConfiguration, - ghcProgram, ldProgram, - programPath) -import Distribution.Simple.Program.Db (configureAllKnownPrograms, - lookupProgram) -import Distribution.Simple.Program.Types (Program (..)) -import Distribution.Verbosity (silent) - -import System.Directory (doesDirectoryExist) -import System.Environment (getArgs) -import System.Exit (ExitCode (..), exitWith) -import System.IO (hPutStrLn, stderr) -import System.Process (rawSystem, readProcess) - - -#ifdef LDCMD -cmd :: Program -cmd = ldProgram -outFile = "yesod-devel/ldargs.txt" -#else -#ifdef ARCMD -cmd :: Program -cmd = arProgram -outFile ="yesod-devel/arargs.txt" -#else -cmd :: Program -cmd = ghcProgram -outFile = "yesod-devel/ghcargs.txt" -#endif -#endif - -runProgram :: Program -> [String] -> IO ExitCode -runProgram pgm args = do -#if MIN_VERSION_Cabal(1,18,0) - (_, comp, pgmc) <- D.configCompilerEx (Just GHC) Nothing Nothing defaultProgramConfiguration silent -#else - (comp, pgmc) <- D.configCompiler (Just GHC) Nothing Nothing defaultProgramConfiguration silent -#endif - pgmc' <- configureAllKnownPrograms silent pgmc - case lookupProgram pgm pgmc' of - Nothing -> do - hPutStrLn stderr ("cannot find program '" ++ programName pgm ++ "'") - return (ExitFailure 1) - Just p -> rawSystem (programPath p) args - -main :: IO () -main = do - args <- getArgs - e <- doesDirectoryExist "yesod-devel" - when e $ writeFile outFile (show args ++ "\n") - ex <- runProgram cmd args - exitWith ex diff --git a/main.hs b/main.hs --- a/main.hs +++ b/main.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} +module Main (main) where import Control.Monad (unless) import Data.Monoid @@ -7,11 +8,10 @@ import Options.Applicative import System.Environment (getEnvironment) import System.Exit (ExitCode (ExitSuccess), exitWith, exitFailure) -import System.FilePath (splitSearchPath) import System.Process (rawSystem) import AddHandler (addHandler) -import Devel (DevelOpts (..), devel, DevelTermOpt(..)) +import Devel (DevelOpts (..), devel, develSignal) import Keter (keter) import Options (injectDefaults) import qualified Paths_yesod_bin @@ -48,19 +48,14 @@ | Configure | Build { buildExtraArgs :: [String] } | Touch - | Devel { _develDisableApi :: Bool - , _develSuccessHook :: Maybe String - , _develFailHook :: Maybe String - , _develRescan :: Int - , _develBuildDir :: Maybe String - , develIgnore :: [String] + | Devel { develSuccessHook :: Maybe String , develExtraArgs :: [String] - , _develPort :: Int - , _develTlsPort :: Int - , _proxyTimeout :: Int - , _noReverseProxy :: Bool - , _interruptOnly :: Bool + , develPort :: Int + , develTlsPort :: Int + , proxyTimeout :: Int + , noReverseProxy :: Bool } + | DevelSignal | Test | AddHandler { addHandlerRoute :: Maybe String @@ -89,11 +84,6 @@ d@Devel{} -> d { develExtraArgs = args } c -> c }) - , ("yesod.devel.ignore" , \o args -> o { optCommand = - case optCommand o of - d@Devel{} -> d { develIgnore = args } - c -> c - }) , ("yesod.build.extracabalarg" , \o args -> o { optCommand = case optCommand o of b@Build{} -> b { buildExtraArgs = args } @@ -111,25 +101,15 @@ Version -> putStrLn ("yesod-bin version: " ++ showVersion Paths_yesod_bin.version) AddHandler{..} -> addHandler addHandlerRoute addHandlerPattern addHandlerMethods Test -> cabalTest cabal - Devel{..} ->do - (configOpts, menv) <- handleGhcPackagePath - let develOpts = DevelOpts - { isCabalDev = optCabalPgm o == CabalDev - , forceCabal = _develDisableApi - , verbose = optVerbose o - , eventTimeout = _develRescan - , successHook = _develSuccessHook - , failHook = _develFailHook - , buildDir = _develBuildDir - , develPort = _develPort - , develTlsPort = _develTlsPort - , proxyTimeout = _proxyTimeout - , useReverseProxy = not _noReverseProxy - , terminateWith = if _interruptOnly then TerminateOnlyInterrupt else TerminateOnEnter - , develConfigOpts = configOpts - , develEnv = menv - } - devel develOpts develExtraArgs + Devel{..} -> devel DevelOpts + { verbose = optVerbose o + , successHook = develSuccessHook + , develPort = develPort + , develTlsPort = develTlsPort + , proxyTimeout = proxyTimeout + , useReverseProxy = not noReverseProxy + } develExtraArgs + DevelSignal -> develSignal where cabalTest cabal = do env <- getEnvironment @@ -154,19 +134,6 @@ ] exitFailure - -handleGhcPackagePath :: IO ([String], Maybe [(String, String)]) -handleGhcPackagePath = do - env <- getEnvironment - case lookup "GHC_PACKAGE_PATH" env of - Nothing -> return ([], Nothing) - Just gpp -> do - let opts = "--package-db=clear" - : "--package-db=global" - : map ("--package-db=" ++) - (drop 1 $ reverse $ splitSearchPath gpp) - return (opts, Just $ filter (\(x, _) -> x /= "GHC_PACKAGE_PATH") env) - optParser' :: ParserInfo Options optParser' = info (helper <*> optParser) ( fullDesc <> header "Yesod Web Framework command line utility" ) @@ -186,6 +153,8 @@ (progDesc $ "Touch any files with altered TH dependencies but do not build" ++ windowsWarning)) <> command "devel" (info (helper <*> develOptions) (progDesc "Run project with the devel server")) + <> command "devel-signal" (info (helper <*> pure DevelSignal) + (progDesc "Used internally by the devel command")) <> command "test" (info (pure Test) (progDesc "Build and run the integration tests")) <> command "add-handler" (info (helper <*> addHandlerOptions) @@ -208,26 +177,10 @@ where optStrToList m = option (words <$> str) $ value [] <> m -defaultRescan :: Int -defaultRescan = 10 - develOptions :: Parser Command -develOptions = Devel <$> switch ( long "disable-api" <> short 'd' - <> help "Disable fast GHC API rebuilding") - <*> optStr ( long "success-hook" <> short 's' <> metavar "COMMAND" +develOptions = Devel <$> optStr ( long "success-hook" <> short 's' <> metavar "COMMAND" <> help "Run COMMAND after rebuild succeeds") - <*> optStr ( long "failure-hook" <> short 'f' <> metavar "COMMAND" - <> help "Run COMMAND when rebuild fails") - <*> option auto ( long "event-timeout" <> short 't' <> value defaultRescan <> metavar "N" - <> help ("Force rescan of files every N seconds (default " - ++ show defaultRescan - ++ ", use -1 to rely on FSNotify alone)") ) - <*> optStr ( long "builddir" <> short 'b' - <> help "Set custom cabal build directory, default `dist'") - <*> many ( strOption ( long "ignore" <> short 'i' <> metavar "DIR" - <> help "ignore file changes in DIR" ) - ) - <*> extraCabalArgs + <*> extraStackArgs <*> option auto ( long "port" <> short 'p' <> value 3000 <> metavar "N" <> help "Devel server listening port" ) <*> option auto ( long "tls-port" <> short 'q' <> value 3443 <> metavar "N" @@ -236,8 +189,11 @@ <> help "Devel server timeout before returning 'not ready' message (in seconds, 0 for none)" ) <*> switch ( long "disable-reverse-proxy" <> short 'n' <> help "Disable reverse proxy" ) - <*> switch ( long "interrupt-only" <> short 'c' - <> help "Disable exiting when enter is pressed") + +extraStackArgs :: Parser [String] +extraStackArgs = many (strOption ( long "extra-stack-arg" <> short 'e' <> metavar "ARG" + <> help "pass extra argument ARG to stack") + ) extraCabalArgs :: Parser [String] extraCabalArgs = many (strOption ( long "extra-cabal-arg" <> short 'e' <> metavar "ARG" diff --git a/yesod-bin.cabal b/yesod-bin.cabal --- a/yesod-bin.cabal +++ b/yesod-bin.cabal @@ -1,42 +1,23 @@ name: yesod-bin -version: 1.4.18.7 +version: 1.5.0 license: MIT license-file: LICENSE author: Michael Snoyman maintainer: Michael Snoyman synopsis: The yesod helper executable. -description: Provides scaffolding, devel server, and some simple code generation helpers. +description: See README.md for more information category: Web, Yesod stability: Stable cabal-version: >= 1.6 build-type: Simple homepage: http://www.yesodweb.com/ -data-files: refreshing.html extra-source-files: + README.md ChangeLog.md + refreshing.html *.pem -executable yesod-ghc-wrapper - main-is: ghcwrapper.hs - build-depends: - base >= 4 && < 5 - , Cabal - -executable yesod-ld-wrapper - main-is: ghcwrapper.hs - cpp-options: -DLDCMD - build-depends: - base >= 4 && < 5 - , Cabal - -executable yesod-ar-wrapper - main-is: ghcwrapper.hs - cpp-options: -DARCMD - build-depends: - base >= 4 && < 5 - , Cabal - executable yesod if os(windows) cpp-options: -DWINDOWS @@ -44,8 +25,6 @@ ld-options: -Wl,-zwxneeded build-depends: base >= 4.3 && < 5 - , ghc >= 7.0.3 - , ghc-paths >= 0.1 , parsec >= 2.1 && < 4 , text >= 0.11 , shakespeare >= 2.0 @@ -53,7 +32,7 @@ , time >= 1.1.4 , template-haskell , directory >= 1.2.1 - , Cabal + , Cabal >= 1.18 , unix-compat >= 0.2 && < 0.5 , containers >= 0.2 , attoparsec >= 0.10 @@ -75,10 +54,13 @@ , base64-bytestring , lifted-base , http-reverse-proxy >= 0.4 - , network - , http-conduit >= 2.1.4 - , http-client + , network >= 2.5 + , http-client-tls + , http-client >= 0.4.7 , project-template >= 0.1.1 + , safe-exceptions + , say + , stm , transformers , transformers-compat , warp >= 1.3.7.5 @@ -89,12 +71,12 @@ , warp-tls >= 3.0.1 , async , deepseq + , typed-process ghc-options: -Wall -threaded -rtsopts main-is: main.hs other-modules: Devel Build - GhcBuild Keter AddHandler Paths_yesod_bin