From f5910a50ff2e17b4431162d5176f157314799de4 Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Fri, 2 Sep 2011 00:26:22 +0200 Subject: [PATCH 01/12] 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 From cb0de490100f8d0b92d2a92537c834e366906ef2 Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Fri, 2 Sep 2011 07:26:49 +0200 Subject: [PATCH 02/12] Don't print package description --- yesod/Build.hs | 6 +++--- yesod/Devel.hs | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/yesod/Build.hs b/yesod/Build.hs index ebcc1b3f..13414da2 100644 --- a/yesod/Build.hs +++ b/yesod/Build.hs @@ -16,7 +16,8 @@ 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 Control.Exception (SomeException, try) +import Control.Monad (when, filterM, forM, forM_) import Data.Char (isSpace) import Data.Monoid (mappend) import qualified Data.Map as Map @@ -24,8 +25,7 @@ import qualified Data.Set as Set import qualified System.Posix.Types import System.PosixCompat.Files (setFileTimes, getFileStatus, accessTime, modificationTime) -import Control.Monad (filterM, forM, forM_) -import Control.Exception (SomeException, try) + touch :: IO () touch = mapM_ go . Map.toList =<< getDeps diff --git a/yesod/Devel.hs b/yesod/Devel.hs index a7d1866d..3efa0144 100644 --- a/yesod/Devel.hs +++ b/yesod/Devel.hs @@ -165,7 +165,7 @@ checkCabalFile gpd = case D.condLibrary gpd of case (D.hsSourceDirs . D.libBuildInfo) dLib of ["dist/src-devel"] -> return () _ -> - T.putStrLn upgradeMessage >> print gpd >> exitFailure + T.putStrLn upgradeMessage >> exitFailure lookupDevelLib :: D.CondTree D.ConfVar c a -> Maybe a lookupDevelLib ct = listToMaybe . map (\(_,x,_) -> D.condTreeData x) . From 611bb89e83eaea4996e3e1f06b22429e04706515 Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Fri, 2 Sep 2011 07:51:12 +0200 Subject: [PATCH 03/12] handle exceptions when cleaning --- yesod/Build.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/yesod/Build.hs b/yesod/Build.hs index 13414da2..cce4888c 100644 --- a/yesod/Build.hs +++ b/yesod/Build.hs @@ -81,8 +81,8 @@ copyToDev file = do cleanDev :: IO () cleanDev = do - exists <- doesDirectoryExist develSrcDir - when exists (removeDirectoryRecursive develSrcDir) + try' $ removeDirectoryRecursive develSrcDir + return () try' :: IO x -> IO (Either SomeException x) try' = try From 7a1629eaba93f304b7bdb22311b2e8ace3a7cb07 Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Fri, 2 Sep 2011 09:41:37 +0200 Subject: [PATCH 04/12] change recompile method, revert scaffold changes --- yesod/Build.hs | 85 ++++++++++++--------------------- yesod/Devel.hs | 49 ++++--------------- yesod/scaffold/project.cabal.cg | 3 +- 3 files changed, 40 insertions(+), 97 deletions(-) diff --git a/yesod/Build.hs b/yesod/Build.hs index cce4888c..a984ee0d 100644 --- a/yesod/Build.hs +++ b/yesod/Build.hs @@ -1,8 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Build - ( copySources - , getDeps - , copyDeps + ( getDeps + , touchDeps , touch , findHaskellFiles ) where @@ -10,79 +9,55 @@ module Build -- FIXME there's a bug when getFileStatus applies to a file -- temporary deleted (e.g., Vim saving a file) -import System.FilePath (takeFileName, takeDirectory, ()) -import System.Directory -import Data.List (isSuffixOf) +import Control.Applicative ((<|>)) +import Control.Exception (SomeException, try) +import Control.Monad (when, filterM, forM, forM_) + import qualified Data.Attoparsec.Text.Lazy as A -import qualified Data.Text.Lazy.IO as TIO -import Control.Applicative ((<|>)) -import Control.Exception (SomeException, try) -import Control.Monad (when, filterM, forM, forM_) -import Data.Char (isSpace) -import Data.Monoid (mappend) +import Data.Char (isSpace) +import Data.Monoid (mappend) +import Data.List (isSuffixOf) import qualified Data.Map as Map import qualified Data.Set as Set +import qualified Data.Text.Lazy.IO as TIO + import qualified System.Posix.Types -import System.PosixCompat.Files (setFileTimes, getFileStatus, +import System.Directory +import System.FilePath (replaceExtension, ()) +import System.PosixCompat.Files (setFileTimes, getFileStatus, accessTime, modificationTime) - touch :: IO () -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 "." - forM_ hss $ \hs -> do - n <- hs `isNewerThan` (develSrcDir hs) - when n (copyToDev hs) +touch = touchDeps =<< getDeps 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' -copyDeps :: Deps -> IO () -copyDeps deps = (mapM_ go . Map.toList) deps >> copySources' +touchDeps :: Deps -> IO () +touchDeps deps = (mapM_ go . Map.toList) deps where 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 + n <- x `isNewerThan` (hiFile y) + when n $ do + putStrLn ("Forcing recompile for " ++ y ++ " because of " ++ x) + removeHi y -copyToDev :: FilePath -> IO () -copyToDev file = do - createDirectoryIfMissing True targetDir - copyFile file (targetDir takeFileName file) - where - dir = takeDirectory file - targetDir = develSrcDir dir +-- | remove the .hi files for a .hs file, thereby forcing a recompile +removeHi :: FilePath -> IO () +removeHi hs = mapM_ removeFile' hiFiles + where + removeFile' file = try' (removeFile file) >> return () + hiFiles = map (\e -> "dist/build" replaceExtension hs e) + ["hi", "p_hi"] -cleanDev :: IO () -cleanDev = do - try' $ removeDirectoryRecursive develSrcDir - return () +hiFile :: FilePath -> FilePath +hiFile hs = "dist/build" replaceExtension hs "hi" try' :: IO x -> IO (Either SomeException x) try' = try diff --git a/yesod/Devel.hs b/yesod/Devel.hs index 3efa0144..9d57f9f1 100644 --- a/yesod/Devel.hs +++ b/yesod/Devel.hs @@ -27,12 +27,12 @@ import System.Directory (doesFileExist, removeFile, import System.Exit (exitFailure) import System.Posix.Types (EpochTime) import System.PosixCompat.Files (modificationTime, getFileStatus) -import System.Process (runCommand, terminateProcess, +import System.Process (runCommand, terminateProcess, waitForProcess, rawSystem) import Text.Shakespeare.Text (st) -import Build (getDeps, copySources, copyDeps, findHaskellFiles) +import Build (touch, getDeps, findHaskellFiles) devel :: Bool -> IO () devel isDevel = do @@ -45,7 +45,6 @@ devel isDevel = do checkCabalFile gpd - copySources _ <- if isDevel then rawSystem "cabal-dev" ["configure", "--cabal-install-arg=-fdevel"] else rawSystem "cabal" ["configure", "-fdevel"] @@ -59,8 +58,7 @@ mainLoop :: Bool -> IO () mainLoop isDevel = forever $ do putStrLn "Rebuilding app" - deps <- getDeps - copyDeps deps + touch list <- getFileList _ <- if isDevel @@ -105,7 +103,7 @@ getFileList = do fs <- getFileStatus f return (f, modificationTime fs) -watchForChanges :: FileList -> IO () -- ThreadId -> IO () +watchForChanges :: FileList -> IO () watchForChanges list = do newList <- getFileList if list /= newList @@ -147,10 +145,6 @@ terminateDevel = do exitSuccess |] -{- - 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 @@ -163,9 +157,11 @@ checkCabalFile gpd = case D.condLibrary gpd of exitFailure Just dLib -> case (D.hsSourceDirs . D.libBuildInfo) dLib of - ["dist/src-devel"] -> return () - _ -> - T.putStrLn upgradeMessage >> exitFailure + [] -> return () + ["."] -> return () + _ -> + putStrLn $ "WARNING: yesod devel may not work correctly with " ++ + "custom hs-source-dirs" lookupDevelLib :: D.CondTree D.ConfVar c a -> Maybe a lookupDevelLib ct = listToMaybe . map (\(_,x,_) -> D.condTreeData x) . @@ -174,31 +170,4 @@ lookupDevelLib ct = listToMaybe . map (\(_,x,_) -> D.condTreeData x) . 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/scaffold/project.cabal.cg b/yesod/scaffold/project.cabal.cg index d88be4d4..3109b5ed 100644 --- a/yesod/scaffold/project.cabal.cg +++ b/yesod/scaffold/project.cabal.cg @@ -23,14 +23,13 @@ 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 From 20f7355696f75b8d9af96afd9c348938048b19fd Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Fri, 2 Sep 2011 10:55:33 +0300 Subject: [PATCH 05/12] fix list formatting --- README.md | 1 + 1 file changed, 1 insertion(+) diff --git a/README.md b/README.md index 47de7ed9..0bd62e16 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,5 @@ A next generation web framework using the Haskell programming language, featuring: + * safety & security: guaranteed at compile time * performance: a greater concurrent load than any other web application server * developer productivity: efficiently handles all your basic web development needs From 745c3d79d63a6550ab2f68136033d97e80505203 Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Fri, 2 Sep 2011 12:20:14 +0200 Subject: [PATCH 06/12] improve restarting application --- yesod/Build.hs | 2 +- yesod/Devel.hs | 38 ++++++++++++++++++++++---------------- 2 files changed, 23 insertions(+), 17 deletions(-) diff --git a/yesod/Build.hs b/yesod/Build.hs index a984ee0d..936184e4 100644 --- a/yesod/Build.hs +++ b/yesod/Build.hs @@ -24,7 +24,7 @@ import qualified Data.Text.Lazy.IO as TIO import qualified System.Posix.Types import System.Directory import System.FilePath (replaceExtension, ()) -import System.PosixCompat.Files (setFileTimes, getFileStatus, +import System.PosixCompat.Files (getFileStatus, accessTime, modificationTime) touch :: IO () diff --git a/yesod/Devel.hs b/yesod/Devel.hs index 9d57f9f1..7bf6078a 100644 --- a/yesod/Devel.hs +++ b/yesod/Devel.hs @@ -14,7 +14,8 @@ 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 Control.Exception as Ex +import Control.Monad (forever) import qualified Data.List as L import qualified Data.Map as Map @@ -22,8 +23,8 @@ import Data.Maybe (listToMaybe) import qualified Data.Text as T import qualified Data.Text.IO as T -import System.Directory (doesFileExist, removeFile, - getDirectoryContents) +import System.Directory (removeFile, getDirectoryContents) + import System.Exit (exitFailure) import System.Posix.Types (EpochTime) import System.PosixCompat.Files (modificationTime, getFileStatus) @@ -34,10 +35,12 @@ import Text.Shakespeare.Text (st) import Build (touch, getDeps, findHaskellFiles) +lockFile :: FilePath +lockFile = "dist/devel-terminate" + devel :: Bool -> IO () devel isDevel = do - e <- doesFileExist "dist/devel-flag" - when e $ removeFile "dist/devel-flag" + writeFile lockFile "" cabal <- D.findPackageDesc "." gpd <- D.readPackageDescription D.normal cabal @@ -56,7 +59,7 @@ devel isDevel = do mainLoop :: Bool -> IO () mainLoop isDevel = forever $ do - putStrLn "Rebuilding app" + putStrLn "Rebuilding application..." touch @@ -65,19 +68,23 @@ mainLoop isDevel = forever $ do then rawSystem "cabal" ["build"] else rawSystem "cabal-dev" ["build"] + try_ $ removeFile lockFile 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" "" + watchTid <- forkIO . try_ $ do + watchForChanges list + putStrLn "Stopping development server..." + writeFile lockFile "" threadDelay 1000000 - -- fixme, check whether process is still alive? - putStrLn "Terminating external process" + putStrLn "Terminating development server..." terminateProcess ph ec <- waitForProcess ph putStrLn $ "Exit code: " ++ show ec + Ex.throwTo watchTid (userError "process finished") + +try_ :: forall a. IO a -> IO () +try_ x = (Ex.try x :: IO (Either Ex.SomeException a)) >> return () pkgConfigs :: Bool -> IO String pkgConfigs isDev @@ -127,7 +134,7 @@ import Control.Concurrent (threadDelay) main :: IO () main = do - putStrLn "Starting app" + putStrLn "Starting devel application" wdap <- (return . fromJust . fromDynamic) withDevelAppPort forkIO . wdap $ \(port, app) -> run port app loop @@ -135,13 +142,12 @@ main = do loop :: IO () loop = do threadDelay 100000 - e <- doesFileExist "dist/devel-flag" + e <- doesFileExist "dist/devel-terminate" if e then terminateDevel else loop terminateDevel :: IO () terminateDevel = do - removeFile "dist/devel-flag" - putStrLn "Terminating server" + putStrLn "Devel application exiting" exitSuccess |] From 533a3df684ebf7e4460f13c0dad9f9d4b3dfef07 Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Fri, 2 Sep 2011 12:23:40 +0200 Subject: [PATCH 07/12] newline fix --- yesod/Devel.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/yesod/Devel.hs b/yesod/Devel.hs index 7bf6078a..9ef103ee 100644 --- a/yesod/Devel.hs +++ b/yesod/Devel.hs @@ -24,7 +24,6 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import System.Directory (removeFile, getDirectoryContents) - import System.Exit (exitFailure) import System.Posix.Types (EpochTime) import System.PosixCompat.Files (modificationTime, getFileStatus) From ddb470b1a78c840b23dcb9955c9d964256628309 Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Mon, 5 Sep 2011 22:17:10 +0200 Subject: [PATCH 08/12] make sure that dist directory exists --- yesod/Devel.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) mode change 100644 => 100755 yesod/Devel.hs diff --git a/yesod/Devel.hs b/yesod/Devel.hs old mode 100644 new mode 100755 index 9ef103ee..348a3efd --- a/yesod/Devel.hs +++ b/yesod/Devel.hs @@ -23,7 +23,8 @@ import Data.Maybe (listToMaybe) import qualified Data.Text as T import qualified Data.Text.IO as T -import System.Directory (removeFile, getDirectoryContents) +import System.Directory (createDirectoryIfMissing, removeFile, + getDirectoryContents) import System.Exit (exitFailure) import System.Posix.Types (EpochTime) import System.PosixCompat.Files (modificationTime, getFileStatus) @@ -39,6 +40,7 @@ lockFile = "dist/devel-terminate" devel :: Bool -> IO () devel isDevel = do + createDirectoryIfMissing True "dist" writeFile lockFile "" cabal <- D.findPackageDesc "." @@ -95,8 +97,8 @@ pkgConfigs isDev | otherwise = return inplacePkg where inplacePkg = "-package-confdist/package.conf.inplace" - isConfig pkg = "packages-" `L.isPrefixOf` pkg && - ".conf" `L.isSuffixOf` pkg + isConfig dir = "packages-" `L.isPrefixOf` dir && + ".conf" `L.isSuffixOf` dir type FileList = Map.Map FilePath EpochTime From 58a91c7634b79296dc1ab0ee84a96f2f2b698205 Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Mon, 5 Sep 2011 23:04:48 +0200 Subject: [PATCH 09/12] exit application on enter --- yesod/Devel.hs | 48 ++++++++++++++++++++++++++++++------------------ 1 file changed, 30 insertions(+), 18 deletions(-) diff --git a/yesod/Devel.hs b/yesod/Devel.hs index 348a3efd..00bd40f2 100755 --- a/yesod/Devel.hs +++ b/yesod/Devel.hs @@ -25,7 +25,7 @@ import qualified Data.Text.IO as T import System.Directory (createDirectoryIfMissing, removeFile, getDirectoryContents) -import System.Exit (exitFailure) +import System.Exit (exitFailure, exitSuccess) import System.Posix.Types (EpochTime) import System.PosixCompat.Files (modificationTime, getFileStatus) import System.Process (runCommand, terminateProcess, @@ -38,24 +38,38 @@ import Build (touch, getDeps, findHaskellFiles) lockFile :: FilePath lockFile = "dist/devel-terminate" -devel :: Bool -> IO () -devel isDevel = do - createDirectoryIfMissing True "dist" +writeLock :: IO () +writeLock = do + createDirectoryIfMissing True "dist" writeFile lockFile "" - cabal <- D.findPackageDesc "." - gpd <- D.readPackageDescription D.normal cabal - let pid = (D.package . D.packageDescription) gpd +removeLock :: IO () +removeLock = try_ (removeFile lockFile) - checkCabalFile gpd +devel :: Bool -> IO () +devel isDevel = do + writeLock + + putStrLn "Yesod devel server. Pres ENTER to quit" + _ <- forkIO $ do + cabal <- D.findPackageDesc "." + gpd <- D.readPackageDescription D.normal cabal + let pid = (D.package . D.packageDescription) gpd - _ <- if isDevel - then rawSystem "cabal-dev" ["configure", "--cabal-install-arg=-fdevel"] - else rawSystem "cabal" ["configure", "-fdevel"] + checkCabalFile gpd - T.writeFile "dist/devel.hs" (develFile pid) + _ <- if isDevel + then rawSystem "cabal-dev" ["configure", "--cabal-install-arg=-fdevel"] + else rawSystem "cabal" ["configure", "-fdevel"] + + T.writeFile "dist/devel.hs" (develFile pid) + + mainLoop isDevel + + _ <- getLine + writeLock + exitSuccess - mainLoop isDevel mainLoop :: Bool -> IO () @@ -69,14 +83,14 @@ mainLoop isDevel = forever $ do then rawSystem "cabal" ["build"] else rawSystem "cabal-dev" ["build"] - try_ $ removeFile lockFile + removeLock putStrLn "Starting development server..." pkg <- pkgConfigs isDevel ph <- runCommand $ concat ["runghc ", pkg, " dist/devel.hs"] watchTid <- forkIO . try_ $ do watchForChanges list putStrLn "Stopping development server..." - writeFile lockFile "" + writeLock threadDelay 1000000 putStrLn "Terminating development server..." terminateProcess ph @@ -147,9 +161,7 @@ loop = do if e then terminateDevel else loop terminateDevel :: IO () -terminateDevel = do - putStrLn "Devel application exiting" - exitSuccess +terminateDevel = exitSuccess |] checkCabalFile :: D.GenericPackageDescription -> IO () From 2a8cb7c06612838ce0ed42a5f653d3f660a80c7c Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Mon, 5 Sep 2011 23:13:55 +0200 Subject: [PATCH 10/12] add help message --- yesod/main.hs | 1 + 1 file changed, 1 insertion(+) mode change 100644 => 100755 yesod/main.hs diff --git a/yesod/main.hs b/yesod/main.hs old mode 100644 new mode 100755 index 5f06344b..c2c17275 --- a/yesod/main.hs +++ b/yesod/main.hs @@ -30,5 +30,6 @@ main = do putStrLn " build Build project (performs TH dependency analysis)" putStrLn " touch Touch any files with altered TH dependencies but do not build" putStrLn " devel Run project with the devel server" + putStrLn " use --dev devel to build with cabal-dev" putStrLn " version Print the version of Yesod" From 71e1e5761560159bc3cb259cab69d0390d98d070 Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Tue, 6 Sep 2011 09:27:19 +0200 Subject: [PATCH 11/12] wait for file changes after server has quit --- yesod/Devel.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/yesod/Devel.hs b/yesod/Devel.hs index 00bd40f2..e4843861 100755 --- a/yesod/Devel.hs +++ b/yesod/Devel.hs @@ -97,6 +97,7 @@ mainLoop isDevel = forever $ do ec <- waitForProcess ph putStrLn $ "Exit code: " ++ show ec Ex.throwTo watchTid (userError "process finished") + watchForChanges list try_ :: forall a. IO a -> IO () try_ x = (Ex.try x :: IO (Either Ex.SomeException a)) >> return () From e25389c4dd0c0780733a8527d764551e7669253c Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Tue, 6 Sep 2011 09:35:36 +0200 Subject: [PATCH 12/12] whoops switched cabal-dev and cabal --- yesod/Devel.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/yesod/Devel.hs b/yesod/Devel.hs index e4843861..b1a7a6ee 100755 --- a/yesod/Devel.hs +++ b/yesod/Devel.hs @@ -80,8 +80,8 @@ mainLoop isDevel = forever $ do list <- getFileList _ <- if isDevel - then rawSystem "cabal" ["build"] - else rawSystem "cabal-dev" ["build"] + then rawSystem "cabal-dev" ["build"] + else rawSystem "cabal" ["build"] removeLock putStrLn "Starting development server..."