From f5910a50ff2e17b4431162d5176f157314799de4 Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Fri, 2 Sep 2011 00:26:22 +0200 Subject: [PATCH] improve yesod devel --- yesod/Build.hs | 95 +++++++---- yesod/Devel.hs | 288 ++++++++++++++++++-------------- yesod/input/done.cg | 3 + yesod/main.hs | 7 +- yesod/scaffold/project.cabal.cg | 3 +- yesod/yesod.cabal | 2 + 6 files changed, 244 insertions(+), 154 deletions(-) diff --git a/yesod/Build.hs b/yesod/Build.hs index 86829ca4..ebcc1b3f 100644 --- a/yesod/Build.hs +++ b/yesod/Build.hs @@ -1,62 +1,100 @@ {-# LANGUAGE OverloadedStrings #-} module Build - ( touch + ( copySources , getDeps - , touchDeps + , copyDeps + , touch , findHaskellFiles ) where --- FIXME there's a bug when getFileStatus applies to a file temporary deleted (e.g., Vim saving a file) +-- FIXME there's a bug when getFileStatus applies to a file +-- temporary deleted (e.g., Vim saving a file) -import System.Directory (getDirectoryContents, doesDirectoryExist, doesFileExist) +import System.FilePath (takeFileName, takeDirectory, ()) +import System.Directory import Data.List (isSuffixOf) import qualified Data.Attoparsec.Text.Lazy as A import qualified Data.Text.Lazy.IO as TIO import Control.Applicative ((<|>)) +import Control.Monad (when) import Data.Char (isSpace) import Data.Monoid (mappend) import qualified Data.Map as Map import qualified Data.Set as Set -import System.PosixCompat.Files (accessTime, modificationTime, getFileStatus, setFileTimes) import qualified System.Posix.Types -import Control.Monad (filterM, forM) +import System.PosixCompat.Files (setFileTimes, getFileStatus, + accessTime, modificationTime) +import Control.Monad (filterM, forM, forM_) import Control.Exception (SomeException, try) --- | Touch any files with altered dependencies but do not build touch :: IO () -touch = do +touch = mapM_ go . Map.toList =<< getDeps + where + go (x, ys) = do + (_, mod1) <- getFileStatus' x + forM_ (Set.toList ys) $ \y -> do + (access, mod2) <- getFileStatus' y + when (mod2 < mod1) $ do + putStrLn ("Touching " ++ y ++ " because of " ++ x) + setFileTimes y access mod1 + + +-- | Copy all .hs files to the devel src dir +copySources :: IO () +copySources = cleanDev >> copySources' + +copySources' :: IO () +copySources' = do hss <- findHaskellFiles "." - deps' <- mapM determineHamletDeps hss - let deps = fixDeps $ zip hss deps' - touchDeps deps + forM_ hss $ \hs -> do + n <- hs `isNewerThan` (develSrcDir hs) + when n (copyToDev hs) type Deps = Map.Map FilePath (Set.Set FilePath) +develSrcDir :: FilePath +develSrcDir = "dist/src-devel" + getDeps :: IO Deps getDeps = do hss <- findHaskellFiles "." deps' <- mapM determineHamletDeps hss return $ fixDeps $ zip hss deps' -touchDeps :: Deps -> IO () -touchDeps = - mapM_ go . Map.toList +copyDeps :: Deps -> IO () +copyDeps deps = (mapM_ go . Map.toList) deps >> copySources' where - go (x, ys) = do - (_, mod1) <- getFileStatus' x - flip mapM_ (Set.toList ys) $ \y -> do - (access, mod2) <- getFileStatus' y - if mod2 < mod1 - then do - putStrLn $ "Touching " ++ y ++ " because of " ++ x - _ <- try' $ setFileTimes y access mod1 - return () - else return () + go (x, ys) = + forM_ (Set.toList ys) $ \y -> do + n <- x `isNewerThan` (develSrcDir y) + when n $ do + putStrLn ("Copying " ++ y ++ " because of " ++ x) + copyToDev y + +copyToDev :: FilePath -> IO () +copyToDev file = do + createDirectoryIfMissing True targetDir + copyFile file (targetDir takeFileName file) + where + dir = takeDirectory file + targetDir = develSrcDir dir + +cleanDev :: IO () +cleanDev = do + exists <- doesDirectoryExist develSrcDir + when exists (removeDirectoryRecursive develSrcDir) try' :: IO x -> IO (Either SomeException x) try' = try -getFileStatus' :: FilePath -> IO (System.Posix.Types.EpochTime, System.Posix.Types.EpochTime) +isNewerThan :: FilePath -> FilePath -> IO Bool +isNewerThan f1 f2 = do + (_, mod1) <- getFileStatus' f1 + (_, mod2) <- getFileStatus' f2 + return (mod1 > mod2) + +getFileStatus' :: FilePath -> + IO (System.Posix.Types.EpochTime, System.Posix.Types.EpochTime) getFileStatus' fp = do efs <- try' $ getFileStatus fp case efs of @@ -75,10 +113,11 @@ findHaskellFiles path = do contents <- getDirectoryContents path fmap concat $ mapM go contents where - go ('.':_) = return [] - go "dist" = return [] + go ('.':_) = return [] + go "cabal-dev" = return [] + go "dist" = return [] go x = do - let y = path ++ '/' : x + let y = path x d <- doesDirectoryExist y if d then findHaskellFiles y diff --git a/yesod/Devel.hs b/yesod/Devel.hs index 4a19652e..a7d1866d 100644 --- a/yesod/Devel.hs +++ b/yesod/Devel.hs @@ -1,127 +1,98 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} module Devel ( devel ) where --- import qualified Distribution.Simple.Build as B --- import Distribution.Simple.Configure (configure) -import Distribution.Simple (defaultMainArgs) --- import Distribution.Simple.Setup (defaultConfigFlags, configConfigurationsFlags, configUserInstall, Flag (..), defaultBuildFlags, defaultCopyFlags, defaultRegisterFlags) -import Distribution.Simple.Utils (defaultPackageDesc, defaultHookedPackageDesc) --- import Distribution.Simple.Program (defaultProgramConfiguration) -import Distribution.Verbosity (normal) -import Distribution.PackageDescription.Parse (readPackageDescription, readHookedBuildInfo) -import Distribution.PackageDescription (emptyHookedBuildInfo) --- import Distribution.Simple.LocalBuildInfo (localPkgDescr) -import Build (getDeps, touchDeps, findHaskellFiles) --- import Network.Wai.Handler.Warp (run) --- import Network.Wai.Middleware.Debug (debug) --- import Distribution.Text (display) --- import Distribution.Simple.Install (install) --- import Distribution.Simple.Register (register) -import Control.Concurrent (forkIO, threadDelay, ThreadId, killThread) -import Control.Exception (try, SomeException) -import System.PosixCompat.Files (modificationTime, getFileStatus) + +import qualified Distribution.Simple.Utils as D +import qualified Distribution.Verbosity as D +import qualified Distribution.Package as D +import qualified Distribution.PackageDescription.Parse as D +import qualified Distribution.PackageDescription as D + +import Control.Concurrent (forkIO, threadDelay) +import Control.Monad (when, forever) + +import qualified Data.List as L import qualified Data.Map as Map -import System.Posix.Types (EpochTime) --- import Blaze.ByteString.Builder.Char.Utf8 (fromString) --- import Network.Wai (Application, Response (ResponseBuilder), responseLBS) --- import Network.HTTP.Types (status500) -import Control.Monad (when, forever) -import System.Process (runCommand, terminateProcess, waitForProcess) -import qualified Data.IORef as I -import qualified Data.ByteString.Lazy.Char8 as L -import System.Directory (doesFileExist, removeFile, getDirectoryContents) --- import Distribution.Package (PackageName (..), pkgName) -import Data.Maybe (mapMaybe) +import Data.Maybe (listToMaybe) +import qualified Data.Text as T +import qualified Data.Text.IO as T -appMessage :: L.ByteString -> IO () -appMessage _ = forever $ do - -- run 3000 . const . return $ responseLBS status500 [("Content-Type", "text/plain")] l - threadDelay 10000 +import System.Directory (doesFileExist, removeFile, + getDirectoryContents) +import System.Exit (exitFailure) +import System.Posix.Types (EpochTime) +import System.PosixCompat.Files (modificationTime, getFileStatus) +import System.Process (runCommand, terminateProcess, + waitForProcess, rawSystem) -swapApp :: I.IORef ThreadId -> IO ThreadId -> IO () -swapApp i f = do - I.readIORef i >>= killThread - f >>= I.writeIORef i +import Text.Shakespeare.Text (st) -devel :: ([String] -> IO ()) -- ^ cabal - -> IO () -devel cabalCmd = do +import Build (getDeps, copySources, copyDeps, findHaskellFiles) + +devel :: Bool -> IO () +devel isDevel = do e <- doesFileExist "dist/devel-flag" when e $ removeFile "dist/devel-flag" - listenThread <- forkIO (appMessage "Initializing, please wait") >>= I.newIORef - cabal <- defaultPackageDesc normal - _ <- readPackageDescription normal cabal + cabal <- D.findPackageDesc "." + gpd <- D.readPackageDescription D.normal cabal + let pid = (D.package . D.packageDescription) gpd - mhpd <- defaultHookedPackageDesc - _ <- case mhpd of - Nothing -> return emptyHookedBuildInfo - Just fp -> readHookedBuildInfo normal fp + checkCabalFile gpd - cabalCmd ["configure", "-fdevel"] + copySources + _ <- if isDevel + then rawSystem "cabal-dev" ["configure", "--cabal-install-arg=-fdevel"] + else rawSystem "cabal" ["configure", "-fdevel"] - let myTry :: IO () -> IO () - myTry f = try f >>= \x -> case x of - Left err -> swapApp listenThread $ forkIO $ appMessage $ L.pack $ show (err :: SomeException) - Right y -> return y - let getNewApp :: IO () - getNewApp = myTry $ do - putStrLn "Rebuilding app" - swapApp listenThread $ forkIO $ appMessage "Rebuilding your app, please wait" + T.writeFile "dist/devel.hs" (develFile pid) - deps <- getDeps - touchDeps deps + mainLoop isDevel - cabalCmd ["build"] - defaultMainArgs ["install"] - pi' <- getPackageName - writeFile "dist/devel.hs" $ unlines - [ "{-# LANGUAGE PackageImports #-}" - , concat - [ "import \"" - , pi' - , "\" Application (withDevelAppPort)" - ] - , "import Data.Dynamic (fromDynamic)" - , "import Network.Wai.Handler.Warp (run)" - , "import Data.Maybe (fromJust)" - , "import Control.Concurrent (forkIO)" - , "import System.Directory (doesFileExist, removeFile)" - , "import Control.Concurrent (threadDelay)" - , "" - , "main :: IO ()" - , "main = do" - , " putStrLn \"Starting app\"" - , " wdap <- return $ fromJust $ fromDynamic withDevelAppPort" - , " forkIO $ wdap $ \\(port, app) -> run port app" - , " loop" - , "" - , "loop :: IO ()" - , "loop = do" - , " threadDelay 100000" - , " e <- doesFileExist \"dist/devel-flag\"" - , " if e then removeFile \"dist/devel-flag\" else loop" - ] - swapApp listenThread $ forkIO $ do - putStrLn "Calling runghc..." - ph <- runCommand "runghc dist/devel.hs" - let forceType :: Either SomeException () -> () - forceType = const () - fmap forceType $ try sleepForever - writeFile "dist/devel-flag" "" - putStrLn "Terminating external process" - terminateProcess ph - putStrLn "Process terminated" - ec <- waitForProcess ph - putStrLn $ "Exit code: " ++ show ec +mainLoop :: Bool -> IO () +mainLoop isDevel = forever $ do + putStrLn "Rebuilding app" - loop Map.empty getNewApp + deps <- getDeps + copyDeps deps -sleepForever :: IO () -sleepForever = forever $ threadDelay 1000000 + list <- getFileList + _ <- if isDevel + then rawSystem "cabal" ["build"] + else rawSystem "cabal-dev" ["build"] + + putStrLn "Starting development server..." + pkg <- pkgConfigs isDevel + ph <- runCommand $ concat ["runghc ", pkg, " dist/devel.hs"] + watchForChanges list + putStrLn "Stopping development server..." + _ <- forkIO $ do + writeFile "dist/devel-flag" "" + threadDelay 1000000 + -- fixme, check whether process is still alive? + putStrLn "Terminating external process" + terminateProcess ph + ec <- waitForProcess ph + putStrLn $ "Exit code: " ++ show ec + +pkgConfigs :: Bool -> IO String +pkgConfigs isDev + | isDev = do + devContents <- getDirectoryContents "cabal-dev" + let confs = filter isConfig devContents + return . unwords $ inplacePkg : + map ("-package-confcabal-dev/"++) confs + | otherwise = return inplacePkg + where + inplacePkg = "-package-confdist/package.conf.inplace" + isConfig pkg = "packages-" `L.isPrefixOf` pkg && + ".conf" `L.isSuffixOf` pkg type FileList = Map.Map FilePath EpochTime @@ -134,25 +105,100 @@ getFileList = do fs <- getFileStatus f return (f, modificationTime fs) -loop :: FileList -> IO () -> IO () -loop oldList getNewApp = do +watchForChanges :: FileList -> IO () -- ThreadId -> IO () +watchForChanges list = do newList <- getFileList - when (newList /= oldList) getNewApp - threadDelay 1000000 - loop newList getNewApp + if list /= newList + then return () + else threadDelay 1000000 >> watchForChanges list + +showPkgName :: D.PackageId -> String +showPkgName = (\(D.PackageName n) -> n) . D.pkgName + +develFile :: D.PackageId -> T.Text +develFile pid = [st| +{-# LANGUAGE PackageImports #-} +import "#{showPkgName pid}" Application (withDevelAppPort) +import Data.Dynamic (fromDynamic) +import Network.Wai.Handler.Warp (run) +import Data.Maybe (fromJust) +import Control.Concurrent (forkIO) +import System.Directory (doesFileExist, removeFile) +import System.Exit (exitSuccess) +import Control.Concurrent (threadDelay) + +main :: IO () +main = do + putStrLn "Starting app" + wdap <- (return . fromJust . fromDynamic) withDevelAppPort + forkIO . wdap $ \(port, app) -> run port app + loop + +loop :: IO () +loop = do + threadDelay 100000 + e <- doesFileExist "dist/devel-flag" + if e then terminateDevel else loop + +terminateDevel :: IO () +terminateDevel = do + removeFile "dist/devel-flag" + putStrLn "Terminating server" + exitSuccess +|] {- -errApp :: String -> Application -errApp s _ = return $ ResponseBuilder status500 [("Content-Type", "text/plain")] $ fromString s + check whether cabal file from old scaffold needs to be updated + should be removed after 1.0 release? -} +checkCabalFile :: D.GenericPackageDescription -> IO () +checkCabalFile gpd = case D.condLibrary gpd of + Nothing -> do + putStrLn "Error: incorrect cabal file, no library" + exitFailure + Just ct -> + case lookupDevelLib ct of + Nothing -> do + putStrLn "Error: no library configuration for -fdevel" + exitFailure + Just dLib -> + case (D.hsSourceDirs . D.libBuildInfo) dLib of + ["dist/src-devel"] -> return () + _ -> + T.putStrLn upgradeMessage >> print gpd >> exitFailure -getPackageName :: IO String -getPackageName = do - xs <- getDirectoryContents "." - case mapMaybe (toCabal . reverse) xs of - [x] -> return x - [] -> error "No cabal files found" - _ -> error "Too many cabal files found" +lookupDevelLib :: D.CondTree D.ConfVar c a -> Maybe a +lookupDevelLib ct = listToMaybe . map (\(_,x,_) -> D.condTreeData x) . + filter isDevelLib . D.condTreeComponents $ ct where - toCabal ('l':'a':'b':'a':'c':'.':x) = Just $ reverse x - toCabal _ = Nothing + isDevelLib ((D.Var (D.Flag (D.FlagName "devel"))), _, _) = True + isDevelLib _ = False + +upgradeMessage :: T.Text +upgradeMessage = [st| +Your cabal file needs to be updated for this version of yesod devel. +Find the lines: +library + if flag(devel) + Buildable: True + else + Buildable: False + + if os(windows) + cpp-options: -DWINDOWS + + hs-source-dirs: . + +And replace them with: +library + if flag(devel) + Buildable: True + hs-source-dirs: dist/src-devel + else + Buildable: False + hs-source-dirs: . + + if os(windows) + cpp-options: -DWINDOWS +|] + diff --git a/yesod/input/done.cg b/yesod/input/done.cg index 8021c266..0e6066c9 100644 --- a/yesod/input/done.cg +++ b/yesod/input/done.cg @@ -26,4 +26,7 @@ Start your project: cd ~project~ && cabal install && yesod devel +or if you use cabal-dev: + + cd ~project~ && cabal-dev install && yesod --dev devel diff --git a/yesod/main.hs b/yesod/main.hs index 0c6f19b9..5f06344b 100644 --- a/yesod/main.hs +++ b/yesod/main.hs @@ -1,12 +1,11 @@ import Scaffolding.Scaffolder import System.Environment (getArgs) import System.Exit (exitWith) +import System.Process (rawSystem) import Build (touch) import Devel (devel) -import System.Process (rawSystem) - main :: IO () main = do args' <- getArgs @@ -15,13 +14,12 @@ main = do "--dev":rest -> (True, rest) _ -> (False, args') let cmd = if isDev then "cabal-dev" else "cabal" - let cabal rest = rawSystem cmd rest >> return () let build rest = rawSystem cmd $ "build":rest case args of ["init"] -> scaffold "build":rest -> touch >> build rest >>= exitWith ["touch"] -> touch - ["devel"] -> devel cabal + ["devel"] -> devel isDev ["version"] -> putStrLn "0.9" "configure":rest -> rawSystem cmd ("configure":rest) >>= exitWith _ -> do @@ -33,3 +31,4 @@ main = do putStrLn " touch Touch any files with altered TH dependencies but do not build" putStrLn " devel Run project with the devel server" putStrLn " version Print the version of Yesod" + diff --git a/yesod/scaffold/project.cabal.cg b/yesod/scaffold/project.cabal.cg index 3109b5ed..d88be4d4 100644 --- a/yesod/scaffold/project.cabal.cg +++ b/yesod/scaffold/project.cabal.cg @@ -23,13 +23,14 @@ Flag devel library if flag(devel) Buildable: True + hs-source-dirs: dist/src-devel else Buildable: False + hs-source-dirs: . if os(windows) cpp-options: -DWINDOWS - hs-source-dirs: . exposed-modules: Application other-modules: Foundation Model diff --git a/yesod/yesod.cabal b/yesod/yesod.cabal index e2362ff2..16917310 100644 --- a/yesod/yesod.cabal +++ b/yesod/yesod.cabal @@ -87,6 +87,7 @@ executable yesod build-depends: base >= 4 && < 4.3 build-depends: parsec >= 2.1 && < 4 , text >= 0.11 && < 0.12 + , shakespeare-text >= 0.10 && < 0.11 , bytestring >= 0.9 && < 0.10 , time >= 1.1.4 && < 1.3 , template-haskell @@ -97,6 +98,7 @@ executable yesod , attoparsec-text >= 0.8.5 && < 0.9 , http-types >= 0.6.1 && < 0.7 , blaze-builder >= 0.2 && < 0.4 + , filepath >= 1.2 && < 1.3 , process ghc-options: -Wall -threaded main-is: main.hs