From 83d3a12a23c2d6c3a11fb469b90264990fbb1203 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 23 Nov 2016 13:59:56 +0200 Subject: [PATCH] Rewrite yesod devel based on Stack #1304 Please see ChangeLog for explanation. --- stack.yaml | 2 + yesod-bin/ChangeLog.md | 18 + yesod-bin/Devel.hs | 750 +++++++++++++++----------------------- yesod-bin/GhcBuild.hs | 547 --------------------------- yesod-bin/ghcwrapper.hs | 65 ---- yesod-bin/main.hs | 89 +---- yesod-bin/yesod-bin.cabal | 37 +- 7 files changed, 337 insertions(+), 1171 deletions(-) delete mode 100644 yesod-bin/GhcBuild.hs delete mode 100644 yesod-bin/ghcwrapper.hs diff --git a/stack.yaml b/stack.yaml index 35d92a44..6326c19c 100644 --- a/stack.yaml +++ b/stack.yaml @@ -26,3 +26,5 @@ extra-deps: - conduit-extra-1.1.14 - streaming-commons-0.1.16 +- typed-process-0.1.0.0 +- say-0.1.0.0 diff --git a/yesod-bin/ChangeLog.md b/yesod-bin/ChangeLog.md index ebf29cd1..304a1867 100644 --- a/yesod-bin/ChangeLog.md +++ b/yesod-bin/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/yesod-bin/Devel.hs b/yesod-bin/Devel.hs index 6a25f240..6b60993c 100644 --- a/yesod-bin/Devel.hs +++ b/yesod-bin/Devel.hs @@ -1,163 +1,124 @@ -{-# 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 Control.Applicative ((<|>)) +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (race_) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, + takeMVar) +import Control.Concurrent.STM +import qualified Control.Exception.Safe as Ex +import Control.Monad (forever, unless, void, + when) +import qualified Data.ByteString.Lazy as LB +import Data.Default.Class (def) +import Data.FileEmbed (embedFile) +import qualified Data.Map as Map +import Data.Streaming.Network (bindPortTCP, + bindRandomPortTCP) +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.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.Concurrent.Async (race_) -import qualified Control.Exception 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 - -import qualified Data.ByteString.Lazy as LB -import Data.Char (isNumber, isUpper) -import qualified Data.List as L -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 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.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) - +-- only used internally, can change +specialFilePath SignalFile = "yesod-devel/rebuild" + +-- | Write a special file +writeSpecialFile :: SpecialFile -> IO () +writeSpecialFile sp = do + let fp = specialFilePath sp + createDirectoryIfMissing True $ takeDirectory fp + now <- getCurrentTime + writeFile fp $ show now + +-- | Remove a special file +removeSpecialFile :: SpecialFile -> IO () +removeSpecialFile sp = removeFile (specialFilePath sp) `Ex.catch` \e -> + if isDoesNotExistError e + then return () + else Ex.throwIO e + +-- | 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 + +-- | Used as a callback from "stack build --exec" to write the signal file +develSignal :: IO () +develSignal = writeSpecialFile SignalFile + +-- | Options to be provided on the command line 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 + { verbose :: Bool + , successHook :: Maybe String + , develPort :: Int + , develTlsPort :: Int + , proxyTimeout :: Int , useReverseProxy :: Bool - , terminateWith :: DevelTermOpt - - -- Support for GHC_PACKAGE_PATH wrapping - , develConfigOpts :: [String] - , develEnv :: Maybe [(String, String)] } deriving (Show, Eq) -getBuildDir :: DevelOpts -> String -getBuildDir opts = fromMaybe "dist" (buildDir opts) - -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 - } - -cabalProgram :: DevelOpts -> FilePath -cabalProgram opts - | isCabalDev opts = "cabal-dev" - | otherwise = "cabal" - --- | 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") +-- | 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 +134,7 @@ reverseProxy opts iappPort = do 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 +170,226 @@ reverseProxy opts iappPort = do 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 - - let (terminator, after) = case terminateWith opts of - TerminateOnEnter -> - ("Type 'quit'", blockQuit) - TerminateOnlyInterrupt -> -- run for one year - ("Interrupt", threadDelay $ 1000 * 1000 * 60 * 60 * 24 * 365) - - blockQuit = do - s <- getLine - if s == "quit" - then return () - else do - putStrLn "Type 'quit' to quit" - blockQuit - - - 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 - - -- 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 "." -#else - cabal <- liftIO $ 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 - - -- 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 - - -- get a new port for the new process to listen on - appPort <- liftIO $ I.readIORef iappPort >>= getPort opts . (+ 1) - liftIO $ I.writeIORef iappPort appPort - - (_,_,_,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 - -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 `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 } - -removeFileIfExists :: FilePath -> IO () -removeFileIfExists file = removeFile file `Ex.catch` handler - where - handler :: IOError -> IO () - handler e | isDoesNotExistError e = return () - | otherwise = Ex.throw e - -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 - - -rebuildGhc :: [Located String] -> FilePath -> FilePath -> IO Bool -rebuildGhc bf ld ar = do - putStrLn "Rebuilding application... (using GHC API)" - buildPackage bf ld ar - -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" ] - -try_ :: forall a. IO a -> IO () -try_ x = void (Ex.try x :: IO (Either Ex.SomeException a)) - -type FileList = Map.Map FilePath EpochTime - -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) - --- | 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 - - isHaskell filename _ = takeExtension filename `elem` [".hs", ".lhs", ".hsc", ".cabal"] - +-- | 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"] - loop [] = failWith $ "file devel.hs not found, checked: " ++ show paths + 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 -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) +-- | 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" -failWith :: String -> IO a -failWith msg = do - putStrLn $ "ERROR: " ++ msg - exitFailure + -- Friendly message to the user + say "Yesod devel server. Enter 'quit' or hit Ctrl-C to quit." -checkFileList :: FileList -> D.Library -> [FilePath] -checkFileList fl lib = filter (not . isSetup) . filter isUnlisted . filter isSrcFile $ sourceFiles + -- Find out the name of our package, needed for the upcoming Stack + -- commands + cabal <- D.tryFindPackageDesc "." + gpd <- D.readPackageDescription D.normal cabal + let pd = D.packageDescription gpd + D.PackageIdentifier (D.PackageName packageName) _version = D.package pd + + -- Create a baton to indicate we're watching for file changes. We + -- need to ensure that we install the file watcher before we start + -- the Stack build loop. + watchingBaton <- newEmptyMVar + + -- Which file contains the code to run + develHsPath <- checkDevelFile + + -- The port that we're currently listening on, and that the + -- reverse proxy should point to + appPortVar <- newTVarIO (-1) + + -- 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 + + -- Run the following concurrently. If any of them exit, take the + -- whole thing down. + withRevProxy $ race_ + -- Wait until we're watching for file changes, then start the + -- build loop + (takeMVar watchingBaton >> runStackBuild packageName) + + -- Run the app itself, restarting when a build succeeds + (runApp appPortVar watchingBaton develHsPath) 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 + -- say, but only when verbose is on + sayV = when (verbose opts) . sayString - isSetup "Setup.hs" = True - isSetup "./Setup.hs" = True - isSetup "Setup.lhs" = True - isSetup "./Setup.lhs" = True - isSetup _ = False + -- Leverage "stack build --file-watch" to do the build + runStackBuild packageName = do + -- We call into this app for the devel-signal command + myPath <- getExecutablePath + runProcess_ $ + setDelegateCtlc True $ + proc "stack" $ + [ "build" + , "--fast" + , "--file-watch" -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 + -- Turn on various flags, and indicate the specific + -- component we want + , "--flag", packageName ++ ":dev" + , "--flag", packageName ++ ":library-only" + , packageName ++ ":lib" -ghcVersion :: IO String -ghcVersion = fmap getNumber $ readProcess "runghc" ["--numeric-version", "0"] [] - where - getNumber = filter (\x -> isNumber x || x == '.') + -- signal the watcher that a build has succeeded + , "--exec", myPath ++ " devel-signal" + ] ++ + -- Add the success hook + (case successHook opts of + Nothing -> [] + Just h -> ["--exec", h]) ++ -ghcPackageArgs :: DevelOpts -> IO [String] -ghcPackageArgs opts = getBuildFlags >>= getPackageArgs (buildDir opts) + -- Any extra args passed on the command line + passThroughArgs -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 + -- Each time the library builds successfully, run the application + runApp appPortVar watchingBaton develHsPath = do + -- Get the absolute path of the signal file, needed for the + -- file watching + develSignalFile' <- canonicalizeSpecialFile SignalFile --- 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 + -- Enable file watching + withManager $ \manager -> do + -- Variable indicating that the signal file has been + -- changed. We reset it each time we handle the signal. + changedVar <- newTVarIO False -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) + -- Start watching the signal file, and set changedVar to + -- True each time it's changed. + void $ watchDir manager + (takeDirectory develSignalFile') + (\e -> eventPath e == develSignalFile') + (const $ atomically $ writeTVar changedVar True) --- | 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 + -- Alright, watching is set up, let the build thread know + -- it can get started. + putMVar watchingBaton () --- | 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 for the first change, indicating that the library + -- has been built + atomically $ do + changed <- readTVar changedVar + check changed + writeTVar changedVar False + + sayV "First successful build complete, running app" + + -- We're going to set the PORT and DISPLAY_PORT variables + -- for the child below + env <- fmap Map.fromList getEnvironment + + -- 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 + + -- Modified environment + let env' = Map.toList + $ Map.insert "PORT" (show newPort) + $ Map.insert "DISPLAY_PORT" (show $ develPort opts) + env + + -- Remove the terminate file so we don't immediately exit + removeSpecialFile TermFile + + -- 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. + let procDef = setEnv env' $ proc "stack" + [ "ghc" + , "--" + , develHsPath + , "-e" + , "Main.main" + ] + + -- 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 until the child properly exits, then we'll try again + ec <- waitExitCode p + sayV $ "Expected: child process exited with " ++ show ec diff --git a/yesod-bin/GhcBuild.hs b/yesod-bin/GhcBuild.hs deleted file mode 100644 index f71ef81e..00000000 --- a/yesod-bin/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/yesod-bin/ghcwrapper.hs b/yesod-bin/ghcwrapper.hs deleted file mode 100644 index 172c6eea..00000000 --- a/yesod-bin/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/yesod-bin/main.hs b/yesod-bin/main.hs index 90d72149..3615bcfe 100755 --- a/yesod-bin/main.hs +++ b/yesod-bin/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 Data.Version (showVersion) 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 @@ data Command = Init [String] | 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 @@ main = do 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 @@ main = do 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 @@ main = do ] 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 @@ optParser = Options (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,25 +177,9 @@ keterOptions = Keter 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 <*> option auto ( long "port" <> short 'p' <> value 3000 <> metavar "N" <> help "Devel server listening port" ) @@ -236,8 +189,6 @@ develOptions = Devel <$> switch ( long "disable-api" <> short 'd' <> 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") extraCabalArgs :: Parser [String] extraCabalArgs = many (strOption ( long "extra-cabal-arg" <> short 'e' <> metavar "ARG" diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index 502d9c5e..33ac2408 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -1,5 +1,5 @@ name: yesod-bin -version: 1.4.18.7 +version: 1.5.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -17,26 +17,6 @@ extra-source-files: ChangeLog.md *.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 +24,6 @@ executable yesod 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 +31,7 @@ executable yesod , time >= 1.1.4 , template-haskell , directory >= 1.2.1 - , Cabal + , Cabal >= 1.20 , unix-compat >= 0.2 && < 0.5 , containers >= 0.2 , attoparsec >= 0.10 @@ -75,10 +53,13 @@ executable yesod , 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 +70,12 @@ executable yesod , 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