yesod devel

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

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

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

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 <command>"
             putStrLn "Available commands:"

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