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

improve yesod devel

Browse Source
This commit is contained in:
Luite Stegeman 2011-09-02 00:26:22 +02:00
parent d7a29448d9
commit f5910a50ff
6 changed files with 244 additions and 154 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

95
yesod/Build.hs
View File

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

288
yesod/Devel.hs
View File

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

3
yesod/input/done.cg
View File

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

7
yesod/main.hs
View File

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

3
yesod/scaffold/project.cabal.cg
View File

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

2
yesod/yesod.cabal
View File

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