From c55a122236285d4ee1bffc302430221019177967 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 18 Apr 2011 16:38:14 +0300 Subject: [PATCH] yesod devel --- Network/Wai/Application/Devel.hs | 59 ++++++++++++++++++ Scaffold/Build.hs | 15 +++-- Scaffold/Devel.hs | 103 +++++++++++++++++++++++++++++++ scaffold.hs | 4 +- yesod.cabal | 5 ++ 5 files changed, 180 insertions(+), 6 deletions(-) create mode 100644 Network/Wai/Application/Devel.hs create mode 100644 Scaffold/Devel.hs diff --git a/Network/Wai/Application/Devel.hs b/Network/Wai/Application/Devel.hs new file mode 100644 index 00000000..7a741367 --- /dev/null +++ b/Network/Wai/Application/Devel.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.Wai.Application.Devel + ( -- * Types + AppHolder + , AppRunner + , WithAppRunner + -- * Functions + , initAppHolder + , swapApp + , swapAppSimple + , toApp + ) where + +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar + ( MVar, newEmptyMVar, newMVar + , takeMVar, putMVar, readMVar + ) +import Network.Wai (Application, responseLBS) +import Network.HTTP.Types (status500) +import Data.ByteString.Lazy.Char8 () +import Control.Monad.IO.Class (liftIO) + +type AppHolder = MVar (Application, MVar ()) +type AppRunner = Application -> IO () +type WithAppRunner = AppRunner -> IO () + +initAppHolder :: IO AppHolder +initAppHolder = do + flag <- newEmptyMVar + newMVar (initApp, flag) + where + initApp _ = return + $ responseLBS status500 [("Content-Type", "text/plain")] + $ "No app has yet been loaded" + +swapAppSimple :: Application -> AppHolder -> IO () +swapAppSimple app = + swapApp war + where + war f = f app + +swapApp :: WithAppRunner -> AppHolder -> IO () +swapApp war ah = void $ forkIO $ war $ \app -> do + (_, oldFlag) <- takeMVar ah + -- allow the old app to cleanup + putMVar oldFlag () + -- now place the new app into the AppHolder, waiting for a termination + -- signal + flag <- newEmptyMVar + putMVar ah (app, flag) + takeMVar flag -- this causes execution to hang until we are terminated + where + void x = x >> return () + +toApp :: AppHolder -> Application +toApp ah req = do + (app, _) <- liftIO $ readMVar ah + app req diff --git a/Scaffold/Build.hs b/Scaffold/Build.hs index 7e35b669..d193440a 100644 --- a/Scaffold/Build.hs +++ b/Scaffold/Build.hs @@ -1,17 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} module Scaffold.Build ( build + , getDeps + , touchDeps + , findHaskellFiles ) where import qualified Distribution.Simple.Build as B -import Distribution.PackageDescription.Parse -import Distribution.Verbosity (normal) import System.Directory (getDirectoryContents, doesDirectoryExist) import Data.List (isSuffixOf) -import Distribution.PackageDescription (packageDescription) -import Distribution.Simple.Utils (defaultPackageDesc, defaultHookedPackageDesc) import Distribution.Simple.Setup (defaultBuildFlags) -import Distribution.Simple.Configure (getPersistBuildConfig, localBuildInfoFile) +import Distribution.Simple.Configure (getPersistBuildConfig) import Distribution.Simple.LocalBuildInfo import qualified Data.Attoparsec.Text.Lazy as A import qualified Data.Text.Lazy.IO as TIO @@ -44,6 +43,12 @@ build = do type Deps = Map.Map FilePath (Set.Set FilePath) +getDeps :: IO Deps +getDeps = do + hss <- findHaskellFiles "." + deps' <- mapM determineHamletDeps hss + return $ fixDeps $ zip hss deps' + touchDeps :: Deps -> IO () touchDeps = mapM_ go . Map.toList diff --git a/Scaffold/Devel.hs b/Scaffold/Devel.hs new file mode 100644 index 00000000..015b81eb --- /dev/null +++ b/Scaffold/Devel.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE OverloadedStrings #-} +module Scaffold.Devel + ( devel + ) where + +import qualified Distribution.Simple.Build as B +import Distribution.Simple.Configure (configure) +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 (FlagName (FlagName), package, emptyHookedBuildInfo) +import Distribution.Simple.LocalBuildInfo (localPkgDescr) +import Scaffold.Build (getDeps, touchDeps, findHaskellFiles) +import System.Plugins (loadDynamic) +import Network.Wai.Handler.Warp (run) +import Network.Wai.Application.Devel +import Network.Wai.Middleware.Debug (debug) +import Data.Dynamic (fromDynamic) +import Distribution.Text (display) +import Distribution.Simple.Install (install) +import Distribution.Simple.Register (register) +import Control.Concurrent (forkIO, threadDelay) +import Control.Exception (try, SomeException) +import System.PosixCompat.Files (modificationTime, getFileStatus) +import qualified Data.Map as Map +import System.Posix.Types (EpochTime) +import Blaze.ByteString.Builder.Char.Utf8 (fromString) +import Network.Wai (Application, Response (ResponseBuilder)) +import Network.HTTP.Types (status500) +import Control.Monad (when) + +devel :: IO () +devel = do + appHolder <- initAppHolder + _ <- forkIO $ run 3000 $ debug $ toApp appHolder + + cabal <- defaultPackageDesc normal + gpd <- readPackageDescription normal cabal + + mhpd <- defaultHookedPackageDesc + hooked <- + case mhpd of + Nothing -> return emptyHookedBuildInfo + Just fp -> readHookedBuildInfo normal fp + + lbi <- configure (gpd, hooked) (defaultConfigFlags defaultProgramConfiguration) + { configConfigurationsFlags = [(FlagName "devel", True)] + , configUserInstall = Flag True + } + + let myTry :: IO (Either String x) -> IO (Either String x) + myTry f = try f >>= \x -> return $ case x of + Left e -> Left $ show (e :: SomeException) + Right y -> y + let getNewApp :: IO (Either String WithAppRunner) + getNewApp = myTry $ do + deps <- getDeps + touchDeps deps + + B.build + (localPkgDescr lbi) + lbi + defaultBuildFlags + [] + + install (localPkgDescr lbi) lbi defaultCopyFlags + register (localPkgDescr lbi) lbi defaultRegisterFlags + + let pi' = display $ package $ localPkgDescr lbi + dyn <- loadDynamic (pi', "Controller", "withDevelApp") + return $ case fmap fromDynamic dyn of + Nothing -> Left "withDevelApp not found" + Just Nothing -> Left "Not a withApp" + Just (Just withApp) -> Right withApp + + loop Map.empty appHolder getNewApp + +type FileList = Map.Map FilePath EpochTime + +getFileList :: IO FileList +getFileList = do + files <- findHaskellFiles "." + deps <- getDeps + let files' = files ++ map fst (Map.toList deps) + fmap Map.fromList $ flip mapM files' $ \f -> do + fs <- getFileStatus f + return (f, modificationTime fs) + +loop :: FileList -> AppHolder -> IO (Either String WithAppRunner) -> IO () +loop oldList appHolder getNewApp = do + newList <- getFileList + when (newList /= oldList) $ do + res <- getNewApp + case res of + Left s -> swapAppSimple (errApp s) appHolder + Right x -> swapApp x appHolder + threadDelay 1000000 + loop newList appHolder getNewApp + +errApp :: String -> Application +errApp s _ = return $ ResponseBuilder status500 [("Content-Type", "text/plain")] $ fromString s diff --git a/scaffold.hs b/scaffold.hs index 8337a58d..1ce4a593 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -13,7 +13,8 @@ import qualified Data.Text.Lazy.Encoding as LT import Control.Monad (when, unless) import System.Environment (getArgs) -import Scaffold.Build +import Scaffold.Build (build) +import Scaffold.Devel (devel) qq :: String #if __GLASGOW_HASKELL__ >= 700 @@ -37,6 +38,7 @@ main = do case args of ["init"] -> scaffold ["build"] -> build + ["devel"] -> devel _ -> do putStrLn "Usage: yesod " putStrLn "Available commands:" diff --git a/yesod.cabal b/yesod.cabal index 391bbfda..1392c861 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -57,10 +57,15 @@ executable yesod , unix-compat >= 0.2 && < 0.3 , containers >= 0.2 && < 0.5 , attoparsec-text >= 0.8.5 && < 0.9 + , http-types >= 0.6.1 && < 0.7 + , blaze-builder >= 0.2 && < 0.4 + , direct-plugins >= 1.1 && < 1.2 ghc-options: -Wall main-is: scaffold.hs other-modules: CodeGen Scaffold.Build + Scaffold.Devel + Network.Wai.Application.Devel if flag(ghc7) cpp-options: -DGHC7