470 lines
21 KiB
Haskell
470 lines
21 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
module Devel
|
|
( devel
|
|
, DevelOpts(..)
|
|
, defaultDevelOpts
|
|
) where
|
|
|
|
|
|
import qualified Distribution.Compiler as D
|
|
import qualified Distribution.InstalledPackageInfo as IPI
|
|
import qualified Distribution.ModuleName as D
|
|
import qualified Distribution.Package as D
|
|
import qualified Distribution.PackageDescription as D
|
|
import qualified Distribution.PackageDescription.Parse as D
|
|
import qualified Distribution.Simple.Build as D
|
|
import qualified Distribution.Simple.Compiler as D
|
|
import qualified Distribution.Simple.Configure as D
|
|
import qualified Distribution.Simple.LocalBuildInfo as D
|
|
import qualified Distribution.Simple.Program as D
|
|
import qualified Distribution.Simple.Register as D
|
|
import qualified Distribution.Simple.Setup as DSS
|
|
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 qualified Control.Exception as Ex
|
|
import Control.Monad (forever, unless, void,
|
|
when)
|
|
import Control.Monad.IO.Class (liftIO)
|
|
import Control.Monad.Trans.State (evalStateT, get)
|
|
|
|
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.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)
|
|
|
|
import qualified Config as GHC
|
|
import Network (withSocketsDo)
|
|
import Network.HTTP.Conduit (def, newManager)
|
|
import Network.HTTP.ReverseProxy (ProxyDest (ProxyDest),
|
|
waiProxyTo)
|
|
import Network.HTTP.Types (status200)
|
|
import Network.Wai (responseLBS)
|
|
import Network.Wai.Handler.Warp (run)
|
|
import SrcLoc (Located)
|
|
|
|
lockFile :: DevelOpts -> FilePath
|
|
lockFile _opts = "yesod-devel/devel-terminate"
|
|
|
|
writeLock :: DevelOpts -> IO ()
|
|
writeLock opts = do
|
|
createDirectoryIfMissing True "yesod-devel"
|
|
writeFile (lockFile opts) ""
|
|
createDirectoryIfMissing True "dist" -- for compatibility with old devel.hs
|
|
writeFile "dist/devel-terminate" ""
|
|
|
|
removeLock :: DevelOpts -> IO ()
|
|
removeLock opts = do
|
|
removeFileIfExists (lockFile opts)
|
|
removeFileIfExists "dist/devel-terminate" -- for compatibility with old devel.hs
|
|
|
|
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
|
|
} deriving (Show, Eq)
|
|
|
|
getBuildDir :: DevelOpts -> String
|
|
getBuildDir opts = fromMaybe "dist" (buildDir opts)
|
|
|
|
defaultDevelOpts :: DevelOpts
|
|
defaultDevelOpts = DevelOpts False False False (-1) Nothing Nothing Nothing
|
|
|
|
-- | Run a reverse proxy from port 3000 to 3001. If there is no response on
|
|
-- 3001, give an appropriate message to the user.
|
|
reverseProxy :: IO ()
|
|
reverseProxy = withSocketsDo $ do
|
|
manager <- newManager def
|
|
forever $ do
|
|
run 3000 $ waiProxyTo
|
|
(const $ return $ Right $ ProxyDest "127.0.0.1" 3001)
|
|
onExc
|
|
manager
|
|
putStrLn "Reverse proxy stopped, but it shouldn't"
|
|
threadDelay 1000000
|
|
putStrLn "Restarting reverse proxy"
|
|
where
|
|
onExc _ _ = return $ responseLBS
|
|
status200
|
|
[ ("content-type", "text/html")
|
|
, ("Refresh", "1")
|
|
]
|
|
"<h1>App not ready, please refresh</h1>"
|
|
|
|
devel :: DevelOpts -> [String] -> IO ()
|
|
devel opts passThroughArgs = withManager $ \manager -> do
|
|
_ <- forkIO reverseProxy
|
|
checkDevelFile
|
|
writeLock opts
|
|
|
|
putStrLn "Yesod devel server. Press ENTER to quit"
|
|
_ <- forkIO $ do
|
|
filesModified <- newEmptyMVar
|
|
watchTree manager "." (const True) (\_ -> void (tryPutMVar filesModified ()))
|
|
evalStateT (mainOuterLoop filesModified) Map.empty
|
|
_ <- getLine
|
|
writeLock opts
|
|
exitSuccess
|
|
where
|
|
bd = getBuildDir opts
|
|
|
|
-- outer loop re-reads the cabal file
|
|
mainOuterLoop filesModified = do
|
|
ghcVer <- liftIO ghcVersion
|
|
cabal <- liftIO $ D.findPackageDesc "."
|
|
gpd <- liftIO $ D.readPackageDescription D.normal cabal
|
|
ldar <- liftIO lookupLdAr
|
|
(hsSourceDirs, lib) <- liftIO $ checkCabalFile gpd
|
|
liftIO $ removeFileIfExists (bd </> "setup-config")
|
|
liftIO $ configure cabal ghcVer gpd opts
|
|
liftIO $ removeFileIfExists "yesod-devel/ghcargs.txt" -- these files contain the wrong data after
|
|
liftIO $ removeFileIfExists "yesod-devel/arargs.txt" -- the configure step, remove them to force
|
|
liftIO $ removeFileIfExists "yesod-devel/ldargs.txt" -- a cabal build first
|
|
rebuild <- liftIO $ mkRebuild gpd ghcVer cabal opts ldar
|
|
mainInnerLoop hsSourceDirs filesModified cabal gpd lib ghcVer rebuild
|
|
|
|
-- inner loop rebuilds after files change
|
|
mainInnerLoop hsSourceDirs filesModified cabal gpd lib ghcVer rebuild = go
|
|
where
|
|
go = do
|
|
_ <- recompDeps hsSourceDirs
|
|
list <- liftIO $ getFileList hsSourceDirs [cabal]
|
|
success <- liftIO rebuild
|
|
pkgArgs <- liftIO $ ghcPackageArgs opts ghcVer (D.packageDescription gpd) lib
|
|
let devArgs = pkgArgs ++ ["devel.hs"] ++ passThroughArgs
|
|
let loop list0 = do
|
|
(haskellFileChanged, list1) <- liftIO $ watchForChanges filesModified hsSourceDirs [cabal] list0 (eventTimeout opts)
|
|
anyTouched <- recompDeps hsSourceDirs
|
|
unless (anyTouched || haskellFileChanged) $ loop list1
|
|
if not success
|
|
then liftIO $ do
|
|
putStrLn "Build failure, pausing..."
|
|
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
|
|
(_,_,_,ph) <- liftIO $ createProcess (proc "runghc" devArgs)
|
|
{ env = Just $ ("PORT", "3001") : ("DISPLAY_PORT", "3000") : env0
|
|
}
|
|
derefMap <- get
|
|
watchTid <- liftIO . forkIO . try_ $ flip evalStateT derefMap $ do
|
|
loop list
|
|
liftIO $ do
|
|
putStrLn "Stopping development server..."
|
|
writeLock opts
|
|
threadDelay 1000000
|
|
putStrLn "Terminating development server..."
|
|
terminateProcess ph
|
|
ec <- liftIO $ waitForProcess' ph
|
|
liftIO $ putStrLn $ "Exit code: " ++ show ec
|
|
liftIO $ Ex.throwTo watchTid (userError "process finished")
|
|
loop list
|
|
n <- liftIO $ cabal `isNewerThan` (bd </> "setup-config")
|
|
if n then mainOuterLoop filesModified else go
|
|
|
|
runBuildHook :: Maybe String -> IO ()
|
|
runBuildHook (Just s) = do
|
|
ret <- system s
|
|
case ret of
|
|
ExitFailure _ -> putStrLn ("Error executing hook: " ++ s)
|
|
_ -> return ()
|
|
runBuildHook Nothing = return ()
|
|
|
|
{-
|
|
configure with the built-in Cabal lib for non-cabal-dev, since
|
|
otherwise we cannot read the configuration later
|
|
|
|
cabal-dev uses the command-line tool, we can fall back to
|
|
cabal-dev buildopts if required
|
|
-}
|
|
configure :: FilePath -> String -> D.GenericPackageDescription -> DevelOpts -> IO ()
|
|
configure _cabalFile ghcVer gpd opts = do
|
|
lbi <- D.configure (gpd, hookedBuildInfo) configFlags
|
|
D.writePersistBuildConfig (getBuildDir opts) lbi -- fixme we could keep this in memory instead of file
|
|
where
|
|
hookedBuildInfo = (Nothing, [])
|
|
configFlags0 | forceCabal opts = config
|
|
| otherwise = config
|
|
{ DSS.configProgramPaths =
|
|
[ ("ar", "yesod-ar-wrapper")
|
|
, ("ld", "yesod-ld-wrapper")
|
|
, ("ghc", "yesod-ghc-wrapper")
|
|
]
|
|
, DSS.configHcPkg = DSS.Flag "ghc-pkg"
|
|
}
|
|
#if MIN_VERSION_Cabal(1,16,0)
|
|
configFlags | isCabalDev opts = configFlags0
|
|
{ DSS.configPackageDBs =
|
|
[ Nothing
|
|
, Just D.GlobalPackageDB
|
|
, Just cabalDevPackageDb
|
|
]
|
|
}
|
|
#else
|
|
configFlags | isCabalDev opts = configFlags0
|
|
{ DSS.configPackageDB = DSS.Flag cabalDevPackageDb
|
|
}
|
|
#endif
|
|
| otherwise = configFlags0
|
|
|
|
cabalDevPackageDb = D.SpecificPackageDB ("cabal-dev/packages-" ++ ghcVer ++ ".conf")
|
|
|
|
|
|
config = (DSS.defaultConfigFlags D.defaultProgramConfiguration)
|
|
{ DSS.configConfigurationsFlags =
|
|
[ (D.FlagName "devel", True) -- legacy
|
|
, (D.FlagName "library-only", True)
|
|
]
|
|
, DSS.configProfLib = DSS.Flag False
|
|
, DSS.configUserInstall = DSS.Flag True
|
|
}
|
|
|
|
removeFileIfExists :: FilePath -> IO ()
|
|
removeFileIfExists file = removeFile file `Ex.catch` handler
|
|
where
|
|
handler :: IOError -> IO ()
|
|
handler e | isDoesNotExistError e = return ()
|
|
| otherwise = Ex.throw e
|
|
|
|
mkRebuild :: D.GenericPackageDescription -> String -> FilePath -> DevelOpts -> (FilePath, FilePath) -> IO (IO Bool)
|
|
mkRebuild gpd ghcVer cabalFile opts (ldPath, arPath)
|
|
| GHC.cProjectVersion /= ghcVer = failWith "Yesod has been compiled with a different GHC version, please reinstall"
|
|
| forceCabal opts = return (rebuildCabal gpd opts)
|
|
| otherwise = do
|
|
return $ do
|
|
n1 <- cabalFile `isNewerThan` "yesod-devel/ghcargs.txt"
|
|
n2 <- cabalFile `isNewerThan` "yesod-devel/arargs.txt"
|
|
n3 <- cabalFile `isNewerThan` "yesod-devel/ldargs.txt"
|
|
if n1 || n2 || n3
|
|
then rebuildCabal gpd 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 :: D.GenericPackageDescription -> DevelOpts -> IO Bool
|
|
rebuildCabal _gpd opts = do
|
|
putStrLn $ "Rebuilding application... (using Cabal library)"
|
|
lbi <- getPersistBuildConfig opts -- fixme we could cache this from the configure step
|
|
let buildFlags | verbose opts = DSS.defaultBuildFlags
|
|
| otherwise = DSS.defaultBuildFlags { DSS.buildVerbosity = DSS.Flag D.silent }
|
|
tryBool $ D.build (D.localPkgDescr lbi) lbi buildFlags []
|
|
|
|
tryBool :: IO a -> IO Bool
|
|
tryBool a = (a >> return True) `Ex.catch` \(e::Ex.SomeException) -> do
|
|
putStrLn $ "Exception: " ++ show e
|
|
return False
|
|
|
|
try_ :: forall a. IO a -> IO ()
|
|
try_ x = (Ex.try x :: IO (Either Ex.SomeException a)) >> return ()
|
|
|
|
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 $ flip mapM 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 ()
|
|
checkDevelFile = do
|
|
e <- doesFileExist "devel.hs"
|
|
unless e $ failWith "file devel.hs not found"
|
|
|
|
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 (D.fromString "Application" `notElem` 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 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
|
|
|
|
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
|
|
|
|
ghcVersion :: IO String
|
|
ghcVersion = fmap getNumber $ readProcess "runghc" ["--numeric-version", "0"] []
|
|
where
|
|
getNumber = filter (\x -> isNumber x || x == '.')
|
|
|
|
ghcPackageArgs :: DevelOpts -> String -> D.PackageDescription -> D.Library -> IO [String]
|
|
ghcPackageArgs opts ghcVer cabal lib = do
|
|
lbi <- getPersistBuildConfig opts
|
|
cbi <- fromMaybeErr errCbi (D.libraryConfig lbi)
|
|
if isCabalDev opts
|
|
then return ("-hide-all-packages" : "-no-user-package-conf" : inplaceConf
|
|
: selfPkgArg lbi : cabalDevConf : depArgs lbi cbi)
|
|
else return ("-hide-all-packages" : inplaceConf : selfPkgArg lbi : depArgs lbi cbi)
|
|
where
|
|
selfPkgArg lbi = pkgArg . D.inplacePackageId . D.package . D.localPkgDescr $ lbi
|
|
pkgArg (D.InstalledPackageId pkgId) = "-package-id" ++ pkgId
|
|
depArgs lbi cbi = map pkgArg (deps lbi cbi)
|
|
deps lbi cbi = let pkgInfo = D.inplaceInstalledPackageInfo "." (getBuildDir opts) cabal lib lbi cbi
|
|
in IPI.depends $ pkgInfo
|
|
errCbi = "No library ComponentBuildInfo"
|
|
cabalDevConf = "-package-confcabal-dev/packages-" ++ ghcVer ++ ".conf"
|
|
inplaceConf = "-package-conf" ++ (getBuildDir opts</>"package.conf.inplace")
|
|
|
|
getPersistBuildConfig :: DevelOpts -> IO D.LocalBuildInfo
|
|
getPersistBuildConfig opts = fromRightErr errLbi =<< getPersistConfigLenient opts -- D.maybeGetPersistBuildConfig path
|
|
where
|
|
errLbi = "Could not read BuildInfo file: " ++ D.localBuildInfoFile (getBuildDir opts) ++
|
|
"\nMake sure that cabal-install has been compiled with the same GHC version as yesod." ++
|
|
"\nand that the Cabal library used by GHC is the same version"
|
|
|
|
-- there can be slight differences in the cabal version, ignore those when loading the file as long as we can parse it
|
|
getPersistConfigLenient :: DevelOpts -> IO (Either String D.LocalBuildInfo)
|
|
getPersistConfigLenient opts = do
|
|
let file = D.localBuildInfoFile (getBuildDir opts)
|
|
exists <- doesFileExist file
|
|
if not exists
|
|
then return (Left $ "file does not exist: " ++ file)
|
|
else do
|
|
xs <- readFile file
|
|
return $ case lines xs of
|
|
[_,l2] -> -- two lines, header and serialized rest
|
|
case reads l2 of
|
|
[(bi,_)] -> Right bi
|
|
_ -> (Left "cannot parse contents")
|
|
_ -> (Left "not a valid header/content file")
|
|
|
|
fromMaybeErr :: String -> Maybe b -> IO b
|
|
fromMaybeErr err Nothing = failWith err
|
|
fromMaybeErr _ (Just x) = return x
|
|
|
|
fromRightErr :: String -> Either String b -> IO b
|
|
fromRightErr str (Left err) = failWith (str ++ "\n" ++ err)
|
|
fromRightErr _ (Right b) = return b
|
|
|
|
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
|
|
(_, pgmc) <- D.configCompiler (Just D.GHC) Nothing Nothing D.defaultProgramConfiguration D.silent
|
|
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)
|
|
|
|
-- | 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
|
|
|