yesod-bin 1.4.18.7 → 1.5.0
raw patch · 7 files changed
+486/−1159 lines, 7 filesdep +http-client-tlsdep +safe-exceptionsdep +saydep −ghcdep −ghc-pathsdep −http-conduitdep ~Cabaldep ~basedep ~http-client
Dependencies added: http-client-tls, safe-exceptions, say, stm, typed-process
Dependencies removed: ghc, ghc-paths, http-conduit
Dependency ranges changed: Cabal, base, http-client, network
Files
- ChangeLog.md +18/−0
- Devel.hs +320/−447
- GhcBuild.hs +0/−547
- README.md +110/−0
- ghcwrapper.hs +0/−65
- main.hs +26/−70
- yesod-bin.cabal +12/−30
ChangeLog.md view
@@ -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
Devel.hs view
@@ -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
− GhcBuild.hs
@@ -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
+ README.md view
@@ -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:++++## 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.
− ghcwrapper.hs
@@ -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
main.hs view
@@ -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"
yesod-bin.cabal view
@@ -1,42 +1,23 @@ name: yesod-bin-version: 1.4.18.7+version: 1.5.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> maintainer: Michael Snoyman <michael@snoyman.com> 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