haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch '1304-stack-based-devel'

Browse Source
This commit is contained in:
Michael Snoyman 2016-11-29 13:43:01 +02:00
commit 784f04ae7a
16 changed files with 606 additions and 1176 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
stack.yaml
View File

@ -26,3 +26,6 @@ extra-deps:
- conduit-extra-1.1.14 - conduit-extra-1.1.14
- streaming-commons-0.1.16 - streaming-commons-0.1.16
- typed-process-0.1.0.0
- say-0.1.0.0
- safe-exceptions-0.1.4.0

18
yesod-bin/ChangeLog.md
View File

@ -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 ## 1.4.18.7
* Actually release the changes for #1284 * Actually release the changes for #1284

799
yesod-bin/Devel.hs
View File

@ -1,163 +1,129 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TemplateHaskell #-}
module Devel module Devel
( devel ( devel
, develSignal
, DevelOpts(..) , DevelOpts(..)
, DevelTermOpt(..)
, defaultDevelOpts
) where ) where
import qualified Distribution.Compiler as D import Control.Applicative ((<|>))
import qualified Distribution.ModuleName as D import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (race_)
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.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 qualified Data.Set as Set
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 as D
import qualified Distribution.PackageDescription.Parse 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.Simple.Utils as D
import qualified Distribution.Verbosity as D import qualified Distribution.Verbosity as D
import Network.HTTP.Client (newManager)
import Control.Applicative ((<$>), (<*>)) import Network.HTTP.Client (managerSetProxy,
import Control.Concurrent (forkIO, threadDelay) noProxy)
import Control.Concurrent.MVar (MVar, newEmptyMVar, import Network.HTTP.Client.TLS (tlsManagerSettings)
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.ReverseProxy (ProxyDest (ProxyDest), import Network.HTTP.ReverseProxy (ProxyDest (ProxyDest),
waiProxyToSettings, wpsTimeout, wpsOnExc) waiProxyToSettings,
wpsOnExc, wpsTimeout)
import qualified Network.HTTP.ReverseProxy as ReverseProxy import qualified Network.HTTP.ReverseProxy as ReverseProxy
import Network.HTTP.Types (status200, status503) import Network.HTTP.Types (status200, status503)
import Network.Socket (sClose) import qualified Network.Socket
import Network.Wai (responseLBS, requestHeaders, import Network.Wai (requestHeaderHost,
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.Parse (parseHttpAccept)
import Network.Wai.Handler.Warp (run, defaultSettings, setPort) import Say
import Network.Wai.Handler.WarpTLS (runTLS, tlsSettingsMemory) import System.Directory
import SrcLoc (Located) import System.Environment (getEnvironment,
import Data.FileEmbed (embedFile) 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 -- We have two special files:
lockFile = "yesod-devel/devel-terminate" --
-- * 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 () specialFilePath :: SpecialFile -> FilePath
writeLock _opts = do
createDirectoryIfMissing True "yesod-devel"
writeFile lockFile ""
createDirectoryIfMissing True "dist" -- for compatibility with old devel.hs
writeFile "dist/devel-terminate" ""
removeLock :: DevelOpts -> IO () -- used by scaffolded app, cannot change
removeLock _opts = do specialFilePath TermFile = "yesod-devel/devel-terminate"
removeFileIfExists lockFile
removeFileIfExists "dist/devel-terminate" -- for compatibility with old devel.hs
data DevelTermOpt = TerminateOnEnter | TerminateOnlyInterrupt -- only used internally, can change
deriving (Show, Eq) 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 data DevelOpts = DevelOpts
{ isCabalDev :: Bool { verbose :: Bool
, forceCabal :: Bool , successHook :: Maybe String
, verbose :: Bool , develPort :: Int
, eventTimeout :: Int -- negative value for no timeout , develTlsPort :: Int
, successHook :: Maybe String , proxyTimeout :: Int
, failHook :: Maybe String
, buildDir :: Maybe String
, develPort :: Int
, develTlsPort :: Int
, proxyTimeout :: Int
, useReverseProxy :: Bool , useReverseProxy :: Bool
, terminateWith :: DevelTermOpt
-- Support for GHC_PACKAGE_PATH wrapping
, develConfigOpts :: [String]
, develEnv :: Maybe [(String, String)]
} deriving (Show, Eq) } deriving (Show, Eq)
getBuildDir :: DevelOpts -> String -- | Run a reverse proxy from the develPort and develTlsPort ports to
getBuildDir opts = fromMaybe "dist" (buildDir opts) -- the app running in appPortVar. If there is no response on the
-- application port, give an appropriate message to the user.
defaultDevelOpts :: DevelOpts reverseProxy :: DevelOpts -> TVar Int -> IO ()
defaultDevelOpts = DevelOpts reverseProxy opts appPortVar = do
{ isCabalDev = False manager <- newManager $ managerSetProxy noProxy tlsManagerSettings
, forceCabal = False let refreshHtml = LB.fromChunks [$(embedFile "refreshing.html")]
, 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")
let onExc _ req let onExc _ req
| maybe False (("application/json" `elem`) . parseHttpAccept) | maybe False (("application/json" `elem`) . parseHttpAccept)
(lookup "accept" $ requestHeaders req) = (lookup "accept" $ requestHeaders req) =
@ -173,7 +139,7 @@ reverseProxy opts iappPort = do
let proxyApp = waiProxyToSettings let proxyApp = waiProxyToSettings
(const $ do (const $ do
appPort <- liftIO $ I.readIORef iappPort appPort <- atomically $ readTVar appPortVar
return $ return $
ReverseProxy.WPRProxyDest ReverseProxy.WPRProxyDest
$ ProxyDest "127.0.0.1" appPort) $ ProxyDest "127.0.0.1" appPort)
@ -209,361 +175,268 @@ reverseProxy opts iappPort = do
app req' send app req' send
httpProxy = run (develPort opts) proxyApp httpProxy = run (develPort opts) proxyApp
httpsProxy = runProxyTls (develTlsPort opts) proxyApp httpsProxy = runProxyTls (develTlsPort opts) proxyApp
putStrLn "Application can be accessed at:\n" say "Application can be accessed at:\n"
putStrLn $ "http://localhost:" ++ show (develPort opts) sayString $ "http://localhost:" ++ show (develPort opts)
putStrLn $ "https://localhost:" ++ show (develTlsPort opts) sayString $ "https://localhost:" ++ show (develTlsPort opts)
putStrLn $ "If you wish to test https capabilities, you should set the following variable:" say $ "If you wish to test https capabilities, you should set the following variable:"
putStrLn $ " export APPROOT=https://localhost:" ++ show (develTlsPort opts) sayString $ " export APPROOT=https://localhost:" ++ show (develTlsPort opts)
putStrLn "" say ""
loop (race_ httpProxy httpsProxy) `Ex.catch` \e -> do race_ httpProxy httpsProxy
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"
-- | Check if the given port is available.
checkPort :: Int -> IO Bool checkPort :: Int -> IO Bool
checkPort p = do checkPort p = do
es <- Ex.try $ bindPortTCP p "*4" es <- Ex.tryIO $ bindPortTCP p "*4"
case es of case es of
Left (_ :: Ex.IOException) -> return False Left _ -> return False
Right s -> do Right s -> do
sClose s Network.Socket.close s
return True return True
getPort :: DevelOpts -> Int -> IO Int -- | Get a random, unused port.
getPort opts _ getNewPort :: DevelOpts -> IO Int
| not (useReverseProxy opts) = return $ develPort opts getNewPort opts = do
getPort _ p0 = (port, socket) <- bindRandomPortTCP "*"
loop p0 when (verbose opts) $ sayString $ "Got new port: " ++ show port
where Network.Socket.close socket
loop p = do return port
avail <- checkPort p
if avail then return p else loop (succ p)
-- | Utility function
unlessM :: Monad m => m Bool -> m () -> m () unlessM :: Monad m => m Bool -> m () -> m ()
unlessM c a = c >>= \res -> unless res a unlessM c a = c >>= \res -> unless res a
devel :: DevelOpts -> [String] -> IO () -- | Find the file containing the devel code to be run.
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"]
checkDevelFile :: IO FilePath checkDevelFile :: IO FilePath
checkDevelFile = checkDevelFile =
loop paths loop paths
where where
paths = ["app/devel.hs", "devel.hs", "src/devel.hs"] 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 loop (x:xs) = do
e <- doesFileExist x e <- doesFileExist x
if e if e
then return x then return x
else loop xs else loop xs
checkCabalFile :: D.GenericPackageDescription -> IO ([FilePath], D.Library) -- | Get the set of all flags available in the given cabal file
checkCabalFile gpd = case D.condLibrary gpd of getAvailableFlags :: D.GenericPackageDescription -> Set.Set String
Nothing -> failWith "incorrect cabal file, no library" getAvailableFlags =
Just ct -> Set.fromList . map (unFlagName . D.flagName) . D.genPackageFlags
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)
failWith :: String -> IO a
failWith msg = do
putStrLn $ "ERROR: " ++ msg
exitFailure
checkFileList :: FileList -> D.Library -> [FilePath]
checkFileList fl lib = filter (not . isSetup) . filter isUnlisted . filter isSrcFile $ sourceFiles
where where
al = allModules lib unFlagName (D.FlagName fn) = fn
-- 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
isSetup "Setup.hs" = True -- | This is the main entry point. Run the devel server.
isSetup "./Setup.hs" = True devel :: DevelOpts -- ^ command line options
isSetup "Setup.lhs" = True -> [String] -- ^ extra options to pass to Stack
isSetup "./Setup.lhs" = True -> IO ()
isSetup _ = False 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"
allModules :: D.Library -> Set.Set String -- Friendly message to the user
allModules lib = Set.fromList $ map toString $ D.exposedModules lib ++ (D.otherModules . D.libBuildInfo) lib say "Yesod devel server. Enter 'quit' or hit Ctrl-C to quit."
where
toString = L.intercalate "." . D.components
ghcVersion :: IO String -- Find out the name of our package, needed for the upcoming Stack
ghcVersion = fmap getNumber $ readProcess "runghc" ["--numeric-version", "0"] [] -- commands
where #if MIN_VERSION_Cabal(1, 20, 0)
getNumber = filter (\x -> isNumber x || x == '.') cabal <- D.tryFindPackageDesc "."
ghcPackageArgs :: DevelOpts -> IO [String]
ghcPackageArgs opts = getBuildFlags >>= getPackageArgs (buildDir opts)
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
-- 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
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 #else
(_, pgmc) <- D.configCompiler (Just D.GHC) Nothing Nothing D.defaultProgramConfiguration D.silent cabal <- D.findPackageDesc "."
#endif #endif
pgmc' <- D.configureAllKnownPrograms D.silent pgmc gpd <- D.readPackageDescription D.normal cabal
return $ (,) <$> look D.ldProgram pgmc' <*> look D.arProgram pgmc' let pd = D.packageDescription gpd
where D.PackageIdentifier (D.PackageName packageName) _version = D.package pd
look pgm pdb = fmap D.programPath (D.lookupProgram pgm pdb)
-- | nonblocking version of @waitForProcess@ -- Which file contains the code to run
waitForProcess' :: ProcessHandle -> IO ExitCode develHsPath <- checkDevelFile
waitForProcess' pid = go
-- 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.
--
-- 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 the app itself, restarting when a build succeeds
(runApp appPortVar changedVar develHsPath)
where where
go = do -- say, but only when verbose is on
mec <- getProcessExitCode pid sayV = when (verbose opts) . sayString
case mec of
Just ec -> return ec
Nothing -> threadDelay 100000 >> go
-- | wait for process started by @createProcess@, return True for ExitSuccess -- Leverage "stack build --file-watch" to do the build
checkExit :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO Bool runStackBuild appPortVar packageName availableFlags = do
checkExit (_,_,_,h) = (==ExitSuccess) <$> waitForProcess' h -- 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"
-- Indicate the component we want
, packageName ++ ":lib"
-- signal the watcher that a build has succeeded
, "--exec", myPath ++ " devel-signal"
] ++
-- Turn on relevant flags
concatMap
(\flagName -> [ "--flag", packageName ++ ":" ++ flagName])
(Set.toList $ Set.intersection
availableFlags
(Set.fromList ["dev", "library-only"])) ++
-- Add the success hook
(case successHook opts of
Nothing -> []
Just h -> ["--exec", h]) ++
-- Any extra args passed on the command line
passThroughArgs
sayV $ show procConfig
-- 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)
-- 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
-- Get the absolute path of the signal file, needed for the
-- file watching
develSignalFile' <- canonicalizeSpecialFile SignalFile
-- 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)
-- Run the inner action
inner changedVar
-- 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
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.
{- Hmm, unknown errors trying to get this to work. Just doing the
- runghc thing instead.
let procDef = setStdin closed $ setEnv env' $ proc "stack"
[ "ghc"
, "--"
, develHsPath
, "-e"
, "Main.main"
]
-}
let procDef = setStdin closed $ setEnv env' $ proc "stack"
[ "runghc"
, "--"
, develHsPath
]
sayV $ "Running child process: " ++ show procDef
-- 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

547
yesod-bin/GhcBuild.hs
View File

@ -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

106
yesod-bin/README.md Normal file
View File

@ -0,0 +1,106 @@
## 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`.
### Development server
The development server will automatically recompile your application
whenever you make source code changes. It will then launch your app,
and reverse-proxy to it. The reverse proxying ensures that you can
connect to your application on a dedicated port, always get the latest
version available, and won't get dropped connections when the app
isn't yet ready. Instead, you'll get some very motivating messages:
![Motivation](https://i.sli.mg/nO6DvN.png)
## Common workflows
The standard Yesod scaffoldings are configured to work with `yesod
devel` out of the box (though see below for non-Yesod
development). For the most part, from within your application
directory, you'll just want to run:
* `stack build yesod-bin`
* `stack exec -- yesod devel`
This will install the corresponding version of the `yesod` executable
into your currently selected snapshot, and then use that
executable. (Starting with version 1.5.0, you can be more lax and use
a `yesod` executable compiled for a different snapshot. Once 1.5.0 is
more widespread we'll probably update these instructions.)
Some other common questions:
* If you want to control which port you can access your application
on, use the `--port` command line option, e.g. `stack exec -- yesod
devel --port 4000`. Changing your port inside your source code _will
not work_, because you need to change the reverse proxying port.
* If you want to run a command after each successful build, you can
use `stack exec -- yesod devel --success-hook "echo Yay!"`
* If for some reason you want to disable the reverse proxy
capabilities, use `stack exec -- yesod devel
--disable-reverse-proxy`
## How it works
The workflow of the devel server is pretty simple:
* Launch a reverse proxy server
* Use Stack file-watch capability to run a build loop on your code,
rebuilding each time a file is modified
* Have Stack call `yesod devel-signal` to write to a specific file
(`yesod-devel/rebuild`) each time a rebuild is successful
* Each time `yesod-devel/rebuild` is modified:
* Kill the current child process
* Get a new random port
* Tell the reverse proxy server about the new port to forward to
* Run the application's devel script with two environment variables
set:
* `PORT` gives the newly generated random port. The application
needs to listen on that port.
* `DISPLAY_PORT` gives the port that the reverse proxy is
listening on, used for display purposes or generating URLs.
Now some weird notes:
* The devel script can be one of the following three files. `yesod
devel` will search for them in the given order. That script must
provide a `main` function.
* `app/devel.hs`
* `devel.hs`
* `src/devel.hs`
* Unfortunately, directly killing the `ghc` interpreter has never
worked reliably, so we have an extra hack: when killing the process,
`yesod devel` also writes to a file
`yesod-devel/devel-terminate`. Your devel script should respect this
file and shutdown whenever it exists.
* If your .cabal file defines them, `yesod devel` will tell Stack to
build with the flags `dev` and `library-only`. You can use this to
speed up compile times (biggest win: skip building executables, thus
the name `library-only`).
If that all seems a little complicated, remember that the Yesod
scaffolding handles all of this for you. But if you want to implement
it yourself...
## Non-Yesod development
If you'd like to use the `yesod devel` server for your non-Yesod
application, or even for a Yesod application not based on the
scaffolding, this section is for you! We've got a
[sample application in the repository](https://github.com/yesodweb/yesod/tree/master/yesod-bin/devel-example)
that demonstrates how to get this set up. It demonstrates a good way
to jump through the hoops implied above.
One important note: I highly recommend putting _all_ of the logic in
your library, and then providing a `develMain :: IO ()` function which
yoru `app/devel.hs` script reexports as `main`. I've found this to
greatly simplify things overall, since you can ensure all of your
dependencies are specified correctly in your `.cabal` file. Also, I
recommend using `PackageImports` in that file, as the example app
shows.

1
yesod-bin/devel-example/.gitignore vendored Normal file
View File

@ -0,0 +1 @@
yesod-devel/

5
yesod-bin/devel-example/README.md Normal file
View File

@ -0,0 +1,5 @@
An example non-Yesod application that is compatible with `yesod devel`. Steps
to use it:
* `stack build yesod-bin`
* `stack exec -- yesod devel`

2
yesod-bin/devel-example/Setup.hs Normal file
View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

6
yesod-bin/devel-example/app/Main.hs Normal file
View File

@ -0,0 +1,6 @@
module Main where
import DevelExample
main :: IO ()
main = prodMain

5
yesod-bin/devel-example/app/devel.hs Normal file
View File

@ -0,0 +1,5 @@
{-# LANGUAGE PackageImports #-}
import "devel-example" DevelExample (develMain)
main :: IO ()
main = develMain

30
yesod-bin/devel-example/devel-example.cabal Normal file
View File

@ -0,0 +1,30 @@
name: devel-example
version: 0.1.0.0
build-type: Simple
cabal-version: >=1.10
flag library-only
default: False
description: Do not build the executable
library
hs-source-dirs: src
exposed-modules: DevelExample
build-depends: base
, async
, directory
, http-types
, wai
, wai-extra
, warp
default-language: Haskell2010
executable devel-example
hs-source-dirs: app
main-is: Main.hs
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends: base
, devel-example
default-language: Haskell2010
if flag(library-only)
buildable: False

47
yesod-bin/devel-example/src/DevelExample.hs Normal file
View File

@ -0,0 +1,47 @@
{-# LANGUAGE OverloadedStrings #-}
module DevelExample
( prodMain
, develMain
) where
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (race_)
import Network.HTTP.Types
import Network.Wai
import Network.Wai.Handler.Warp
import Network.Wai.Middleware.RequestLogger
import System.Directory (doesFileExist)
import System.Environment
myApp :: Application
myApp _req send = send $ responseLBS
status200
[(hContentType, "text/html; charset=utf-8")]
"<p>Well, this is really <b>boring</b>.</p>"
prodMain :: IO ()
prodMain = do
putStrLn "Running in production mode on port 8080"
run 8080 $ logStdout myApp
develMain :: IO ()
develMain = race_ watchTermFile $ do
port <- fmap read $ getEnv "PORT"
displayPort <- getEnv "DISPLAY_PORT"
putStrLn $ "Running in development mode on port " ++ show port
putStrLn $ "But you should connect to port " ++ displayPort
run port $ logStdoutDev myApp
-- | Would certainly be more efficient to use fsnotify, but this is
-- simpler.
watchTermFile :: IO ()
watchTermFile =
loop
where
loop = do
exists <- doesFileExist "yesod-devel/devel-terminate"
if exists
then return ()
else do
threadDelay 100000
loop

8
yesod-bin/devel-example/stack.yaml Normal file
View File

@ -0,0 +1,8 @@
resolver: lts-7.10
packages:
- .
- ..
extra-deps:
- typed-process-0.1.0.0

65
yesod-bin/ghcwrapper.hs
View File

@ -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

96
yesod-bin/main.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
module Main (main) where
import Control.Monad (unless) import Control.Monad (unless)
import Data.Monoid import Data.Monoid
@ -7,11 +8,10 @@ import Data.Version (showVersion)
import Options.Applicative import Options.Applicative
import System.Environment (getEnvironment) import System.Environment (getEnvironment)
import System.Exit (ExitCode (ExitSuccess), exitWith, exitFailure) import System.Exit (ExitCode (ExitSuccess), exitWith, exitFailure)
import System.FilePath (splitSearchPath)
import System.Process (rawSystem) import System.Process (rawSystem)
import AddHandler (addHandler) import AddHandler (addHandler)
import Devel (DevelOpts (..), devel, DevelTermOpt(..)) import Devel (DevelOpts (..), devel, develSignal)
import Keter (keter) import Keter (keter)
import Options (injectDefaults) import Options (injectDefaults)
import qualified Paths_yesod_bin import qualified Paths_yesod_bin
@ -48,19 +48,14 @@ data Command = Init [String]
| Configure | Configure
| Build { buildExtraArgs :: [String] } | Build { buildExtraArgs :: [String] }
| Touch | Touch
| Devel { _develDisableApi :: Bool | Devel { develSuccessHook :: Maybe String
, _develSuccessHook :: Maybe String
, _develFailHook :: Maybe String
, _develRescan :: Int
, _develBuildDir :: Maybe String
, develIgnore :: [String]
, develExtraArgs :: [String] , develExtraArgs :: [String]
, _develPort :: Int , develPort :: Int
, _develTlsPort :: Int , develTlsPort :: Int
, _proxyTimeout :: Int , proxyTimeout :: Int
, _noReverseProxy :: Bool , noReverseProxy :: Bool
, _interruptOnly :: Bool
} }
| DevelSignal
| Test | Test
| AddHandler | AddHandler
{ addHandlerRoute :: Maybe String { addHandlerRoute :: Maybe String
@ -89,11 +84,6 @@ main = do
d@Devel{} -> d { develExtraArgs = args } d@Devel{} -> d { develExtraArgs = args }
c -> c 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 = , ("yesod.build.extracabalarg" , \o args -> o { optCommand =
case optCommand o of case optCommand o of
b@Build{} -> b { buildExtraArgs = args } b@Build{} -> b { buildExtraArgs = args }
@ -111,25 +101,15 @@ main = do
Version -> putStrLn ("yesod-bin version: " ++ showVersion Paths_yesod_bin.version) Version -> putStrLn ("yesod-bin version: " ++ showVersion Paths_yesod_bin.version)
AddHandler{..} -> addHandler addHandlerRoute addHandlerPattern addHandlerMethods AddHandler{..} -> addHandler addHandlerRoute addHandlerPattern addHandlerMethods
Test -> cabalTest cabal Test -> cabalTest cabal
Devel{..} ->do Devel{..} -> devel DevelOpts
(configOpts, menv) <- handleGhcPackagePath { verbose = optVerbose o
let develOpts = DevelOpts , successHook = develSuccessHook
{ isCabalDev = optCabalPgm o == CabalDev , develPort = develPort
, forceCabal = _develDisableApi , develTlsPort = develTlsPort
, verbose = optVerbose o , proxyTimeout = proxyTimeout
, eventTimeout = _develRescan , useReverseProxy = not noReverseProxy
, successHook = _develSuccessHook } develExtraArgs
, failHook = _develFailHook DevelSignal -> develSignal
, 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
where where
cabalTest cabal = do cabalTest cabal = do
env <- getEnvironment env <- getEnvironment
@ -154,19 +134,6 @@ main = do
] ]
exitFailure 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' :: ParserInfo Options
optParser' = info (helper <*> optParser) ( fullDesc <> header "Yesod Web Framework command line utility" ) 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)) (progDesc $ "Touch any files with altered TH dependencies but do not build" ++ windowsWarning))
<> command "devel" (info (helper <*> develOptions) <> command "devel" (info (helper <*> develOptions)
(progDesc "Run project with the devel server")) (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) <> command "test" (info (pure Test)
(progDesc "Build and run the integration tests")) (progDesc "Build and run the integration tests"))
<> command "add-handler" (info (helper <*> addHandlerOptions) <> command "add-handler" (info (helper <*> addHandlerOptions)
@ -208,26 +177,10 @@ keterOptions = Keter
where where
optStrToList m = option (words <$> str) $ value [] <> m optStrToList m = option (words <$> str) $ value [] <> m
defaultRescan :: Int
defaultRescan = 10
develOptions :: Parser Command develOptions :: Parser Command
develOptions = Devel <$> switch ( long "disable-api" <> short 'd' develOptions = Devel <$> optStr ( long "success-hook" <> short 's' <> metavar "COMMAND"
<> help "Disable fast GHC API rebuilding")
<*> optStr ( long "success-hook" <> short 's' <> metavar "COMMAND"
<> help "Run COMMAND after rebuild succeeds") <> help "Run COMMAND after rebuild succeeds")
<*> optStr ( long "failure-hook" <> short 'f' <> metavar "COMMAND" <*> extraStackArgs
<> 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" <*> option auto ( long "port" <> short 'p' <> value 3000 <> metavar "N"
<> help "Devel server listening port" ) <> help "Devel server listening port" )
<*> option auto ( long "tls-port" <> short 'q' <> value 3443 <> metavar "N" <*> option auto ( long "tls-port" <> short 'q' <> value 3443 <> metavar "N"
@ -236,8 +189,11 @@ develOptions = Devel <$> switch ( long "disable-api" <> short 'd'
<> help "Devel server timeout before returning 'not ready' message (in seconds, 0 for none)" ) <> help "Devel server timeout before returning 'not ready' message (in seconds, 0 for none)" )
<*> switch ( long "disable-reverse-proxy" <> short 'n' <*> switch ( long "disable-reverse-proxy" <> short 'n'
<> help "Disable reverse proxy" ) <> 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 :: Parser [String]
extraCabalArgs = many (strOption ( long "extra-cabal-arg" <> short 'e' <> metavar "ARG" extraCabalArgs = many (strOption ( long "extra-cabal-arg" <> short 'e' <> metavar "ARG"

42
yesod-bin/yesod-bin.cabal
View File

@ -1,42 +1,23 @@
name: yesod-bin name: yesod-bin
version: 1.4.18.7 version: 1.5.0
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
maintainer: Michael Snoyman <michael@snoyman.com> maintainer: Michael Snoyman <michael@snoyman.com>
synopsis: The yesod helper executable. 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 category: Web, Yesod
stability: Stable stability: Stable
cabal-version: >= 1.6 cabal-version: >= 1.6
build-type: Simple build-type: Simple
homepage: http://www.yesodweb.com/ homepage: http://www.yesodweb.com/
data-files: refreshing.html
extra-source-files: extra-source-files:
README.md
ChangeLog.md ChangeLog.md
refreshing.html
*.pem *.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 executable yesod
if os(windows) if os(windows)
cpp-options: -DWINDOWS cpp-options: -DWINDOWS
@ -44,8 +25,6 @@ executable yesod
ld-options: -Wl,-zwxneeded ld-options: -Wl,-zwxneeded
build-depends: base >= 4.3 && < 5 build-depends: base >= 4.3 && < 5
, ghc >= 7.0.3
, ghc-paths >= 0.1
, parsec >= 2.1 && < 4 , parsec >= 2.1 && < 4
, text >= 0.11 , text >= 0.11
, shakespeare >= 2.0 , shakespeare >= 2.0
@ -53,7 +32,7 @@ executable yesod
, time >= 1.1.4 , time >= 1.1.4
, template-haskell , template-haskell
, directory >= 1.2.1 , directory >= 1.2.1
, Cabal , Cabal >= 1.18
, unix-compat >= 0.2 && < 0.5 , unix-compat >= 0.2 && < 0.5
, containers >= 0.2 , containers >= 0.2
, attoparsec >= 0.10 , attoparsec >= 0.10
@ -75,10 +54,13 @@ executable yesod
, base64-bytestring , base64-bytestring
, lifted-base , lifted-base
, http-reverse-proxy >= 0.4 , http-reverse-proxy >= 0.4
, network , network >= 2.5
, http-conduit >= 2.1.4 , http-client-tls
, http-client , http-client >= 0.4.7
, project-template >= 0.1.1 , project-template >= 0.1.1
, safe-exceptions
, say
, stm
, transformers , transformers
, transformers-compat , transformers-compat
, warp >= 1.3.7.5 , warp >= 1.3.7.5
@ -89,12 +71,12 @@ executable yesod
, warp-tls >= 3.0.1 , warp-tls >= 3.0.1
, async , async
, deepseq , deepseq
, typed-process
ghc-options: -Wall -threaded -rtsopts ghc-options: -Wall -threaded -rtsopts
main-is: main.hs main-is: main.hs
other-modules: Devel other-modules: Devel
Build Build
GhcBuild
Keter Keter
AddHandler AddHandler
Paths_yesod_bin Paths_yesod_bin