diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2014, Arne Link +Copyright (c) 2016, Pedro Tacla Yamada + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Arne Link nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,220 @@ +module Main where + +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.STM.TChan (TChan, dupTChan, newTChan, + readTChan, writeTChan) +import Control.Exception (bracket) +import Control.Monad (forever, unless, when) +import Control.Monad.STM (atomically) +import qualified Data.ByteString.Lazy as ByteString +import Data.Digest.Pure.MD5 (md5) +import Data.Maybe +import Data.Monoid +import Data.Text (isInfixOf, pack) +import Options.Applicative +import Paths_yesod_fast_devel +import System.Console.ANSI +import System.Directory (copyFile, doesDirectoryExist, + findExecutable) +import System.Exit +import System.FilePath (takeDirectory) +import System.FilePath.Glob +import System.FilePath.Posix (takeBaseName) +import System.FSNotify (Event (..), watchTree, + withManager) +import System.IO (BufferMode (..), Handle, + hPutStrLn, hSetBuffering, stderr, + stdout) +import System.Process + +data Options + = PatchDevelMain { pdmFilePath :: FilePath} + | PrintPatchedMain + | StartServer { ssFilePath :: FilePath} + +options :: ParserInfo Options +options = + info + (allCommands <**> helper) + (header "Faster yesod-devel with GHCi and Browser Sync") + where + allCommands = + subparser + (patchDevelMain <> printPatchedMain <> startServer <> + metavar "patch | server| print-patched-main") + printPatchedMain = + command + "print-patched-main" + (info (pure PrintPatchedMain) (progDesc "Print the patched DevelMain")) + startServer = + command + "server" + (info + (StartServer . fromMaybe "app/DevelMain.hs" <$> + optional (argument str (metavar "devel-main-path")) <**> + helper) + (progDesc "Start the development servers")) + patchDevelMain = + command + "patch" + (info + (PatchDevelMain . fromMaybe "app/DevelMain.hs" <$> + optional (argument str (metavar "devel-main-path")) <**> + helper) + (progDesc "Patch your devel main with browser-sync")) + +main :: IO () +main = do + cmd <- execParser options + case cmd of + PatchDevelMain fp -> initYesodFastDevel fp + StartServer fp -> go fp + PrintPatchedMain -> + putStrLn =<< readFile =<< getDataFileName "PatchedDevelMain.hs" + where + go develMainPth = do + hSetBuffering stdout LineBuffering + hSetBuffering stderr LineBuffering + chan <- atomically newTChan + _ <- forkIO $ do + hPutStrLn stderr "Watching files for changes..." + watchThread chan + _ <- forkIO $ do + hPutStrLn stderr "Spawning browser-sync..." + browserSyncThread + hPutStrLn stderr "Spawning GHCi..." + _ <- replThread develMainPth chan + return () + +initYesodFastDevel :: FilePath -> IO () +initYesodFastDevel develMainPth = do + verifyDirectory + verifyDevelMain + patchedDevelMain <- getDataFileName "PatchedDevelMain.hs" + copyFile patchedDevelMain develMainPth + putStrLn "Patched `DevelMain.hs`" + browserSyncPth <- findExecutable "browser-sync" + putStrLn "Make sure you have `foreign-store` on your cabal file" + when (isNothing browserSyncPth) $ + putStrLn "Install `browser-sync` to have livereload at port 4000" + exitSuccess + where + verifyDirectory = do + let dir = takeDirectory develMainPth + putStrLn ("Verifying `" ++ dir ++ "` exists") + dexists <- doesDirectoryExist dir + unless dexists $ do + hPutStrLn stderr ("Directory `" ++ dir ++ "` not found") + exitFailure + verifyDevelMain = do + putStrLn "Verifying `DevelMain.hs` isn't modified" + userDevelMd5 <- md5 <$> ByteString.readFile develMainPth + originalDevelMd5 <- + md5 <$> (ByteString.readFile =<< getDataFileName "OriginalDevelMain.hs") + patchedDevelMd5 <- + md5 <$> (ByteString.readFile =<< getDataFileName "PatchedDevelMain.hs") + when (userDevelMd5 == patchedDevelMd5) $ do + putStrLn "DevelMain.hs is already patched" + exitSuccess + when (userDevelMd5 /= originalDevelMd5) $ do + hPutStrLn stderr "Found a weird DevelMain.hs on your project" + hPutStrLn stderr "Use `yesod-fast-devel print-patched-main`" + exitFailure + +browserSyncThread :: IO () +browserSyncThread = do + browserSyncPth <- findExecutable "browser-sync" + when (isJust browserSyncPth) $ callCommand cmd + where + cmd = + "browser-sync start --no-open --files=\"devel-main-since\" --proxy \"localhost:3000\" --port 4000" + +watchThread :: TChan Event -> IO () +watchThread writeChan = + withManager $ \mgr + -- start a watching job (in the background) + -> do + _ <- watchTree mgr "." shouldReload (reloadApplication writeChan) + -- sleep forever (until interrupted) + forever $ threadDelay 1000000000 + +replThread :: FilePath -> TChan Event -> IO () +replThread develMainPth chan = do + readChan <- atomically (dupTChan chan) + bracket newRepl onError (onSuccess readChan) + where + onError (_, _, _, process) = do + interruptProcessGroupOf process + threadDelay 100000 + terminateProcess process + threadDelay 100000 + waitForProcess process + onSuccess readChan (Just replIn, _, _, _) = do + hSetBuffering replIn LineBuffering + threadDelay 1000000 + hPutStrLn replIn loadString + hPutStrLn replIn startString + forever $ do + event <- atomically (readTChan readChan) + putStrLn "-----------------------------" + setSGR [SetColor Foreground Vivid Yellow] + print event + setSGR [Reset] + putStrLn "-----------------------------" + hPutStrLn replIn loadString + hPutStrLn replIn startString + onSuccess _ (_, _, _, _) = do + hPutStrLn stderr "Can't open GHCi's stdin" + exitFailure + startString = "update" + loadString = ":load " ++ develMainPth + +shouldReload :: Event -> Bool +shouldReload event = not (or conditions) + where + fp = + case event of + Added filePath _ -> filePath + Modified filePath _ -> filePath + Removed filePath _ -> filePath + conditions = + [ notInPath ".git" + , notInPath "yesod-devel" + , notInPath "dist" + , notInFile "#" + , notInPath ".cabal-sandbox" + , notInFile "flycheck_" + , notInPath ".stack-work" + , notInGlob (compile "**/*.sqlite3-*") + , notInGlob (compile "*.sqlite3-*") + , notInFile "stack.yaml" + , notInGlob (compile "*.hi") + , notInGlob (compile "**/*.hi") + , notInGlob (compile "*.o") + , notInGlob (compile "**/*.o") + , notInFile "devel-main-since" + ] + notInPath t = t `isInfixOf` pack fp + notInFile t = t `isInfixOf` pack (takeBaseName fp) + notInGlob pt = match pt fp + +reloadApplication :: TChan Event -> Event -> IO () +reloadApplication chan event = atomically (writeTChan chan event) + +newRepl :: IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) +newRepl = + createProcess $ newProc "stack" ["ghci", "--ghc-options", "-O0 -fobject-code"] + +newProc :: FilePath -> [String] -> CreateProcess +newProc cmd args = + CreateProcess + { cmdspec = RawCommand cmd args + , cwd = Nothing + , env = Nothing + , std_in = CreatePipe + , std_out = Inherit + , std_err = Inherit + , close_fds = False + , create_group = True + , delegate_ctlc = False + } diff --git a/OriginalDevelMain.hs b/OriginalDevelMain.hs new file mode 100644 --- /dev/null +++ b/OriginalDevelMain.hs @@ -0,0 +1,99 @@ +-- | Running your app inside GHCi. +-- +-- To start up GHCi for usage with Yesod, first make sure you are in dev mode: +-- +-- > cabal configure -fdev +-- +-- Note that @yesod devel@ automatically sets the dev flag. +-- Now launch the repl: +-- +-- > cabal repl --ghc-options="-O0 -fobject-code" +-- +-- To start your app, run: +-- +-- > :l DevelMain +-- > DevelMain.update +-- +-- You can also call @DevelMain.shutdown@ to stop the app +-- +-- You will need to add the foreign-store package to your .cabal file. +-- It is very light-weight. +-- +-- If you don't use cabal repl, you will need +-- to run the following in GHCi or to add it to +-- your .ghci file. +-- +-- :set -DDEVELOPMENT +-- +-- There is more information about this approach, +-- on the wiki: https://github.com/yesodweb/yesod/wiki/ghci + +module DevelMain where + +import Prelude +import Application (getApplicationRepl, shutdownApp) + +import Control.Exception (finally) +import Control.Monad ((>=>)) +import Control.Concurrent +import Data.IORef +import Foreign.Store +import Network.Wai.Handler.Warp +import GHC.Word + +-- | Start or restart the server. +-- newStore is from foreign-store. +-- A Store holds onto some data across ghci reloads +update :: IO () +update = do + mtidStore <- lookupStore tidStoreNum + case mtidStore of + -- no server running + Nothing -> do + done <- storeAction doneStore newEmptyMVar + tid <- start done + _ <- storeAction (Store tidStoreNum) (newIORef tid) + return () + -- server is already running + Just tidStore -> restartAppInNewThread tidStore + where + doneStore :: Store (MVar ()) + doneStore = Store 0 + + -- shut the server down with killThread and wait for the done signal + restartAppInNewThread :: Store (IORef ThreadId) -> IO () + restartAppInNewThread tidStore = modifyStoredIORef tidStore $ \tid -> do + killThread tid + withStore doneStore takeMVar + readStore doneStore >>= start + + + -- | Start the server in a separate thread. + start :: MVar () -- ^ Written to when the thread is killed. + -> IO ThreadId + start done = do + (port, site, app) <- getApplicationRepl + forkIO (finally (runSettings (setPort port defaultSettings) app) + -- Note that this implies concurrency + -- between shutdownApp and the next app that is starting. + -- Normally this should be fine + (putMVar done () >> shutdownApp site)) + +-- | kill the server +shutdown :: IO () +shutdown = do + mtidStore <- lookupStore tidStoreNum + case mtidStore of + -- no server running + Nothing -> putStrLn "no Yesod app running" + Just tidStore -> do + withStore tidStore $ readIORef >=> killThread + putStrLn "Yesod app is shutdown" + +tidStoreNum :: Word32 +tidStoreNum = 1 + +modifyStoredIORef :: Store (IORef a) -> (a -> IO a) -> IO () +modifyStoredIORef store f = withStore store $ \ref -> do + v <- readIORef ref + f v >>= writeIORef ref diff --git a/PatchedDevelMain.hs b/PatchedDevelMain.hs new file mode 100644 --- /dev/null +++ b/PatchedDevelMain.hs @@ -0,0 +1,103 @@ +-- | Running your app inside GHCi. +-- +-- To start up GHCi for usage with Yesod, first make sure you are in dev mode: +-- +-- > cabal configure -fdev +-- +-- Note that @yesod devel@ automatically sets the dev flag. +-- Now launch the repl: +-- +-- > cabal repl --ghc-options="-O0 -fobject-code" +-- +-- To start your app, run: +-- +-- > :l DevelMain +-- > DevelMain.update +-- +-- You can also call @DevelMain.shutdown@ to stop the app +-- +-- You will need to add the foreign-store package to your .cabal file. +-- It is very light-weight. +-- +-- If you don't use cabal repl, you will need +-- to run the following in GHCi or to add it to +-- your .ghci file. +-- +-- :set -DDEVELOPMENT +-- +-- There is more information about this approach, +-- on the wiki: https://github.com/yesodweb/yesod/wiki/ghci + +module DevelMain where + +import Prelude +import Application (getApplicationRepl, shutdownApp) + +import Control.Exception (finally) +import Control.Monad ((>=>)) +import Control.Concurrent +import Data.IORef +import Data.Time.Clock +import Foreign.Store +import Network.Wai.Handler.Warp +import GHC.Word + +-- | Start or restart the server. +-- newStore is from foreign-store. +-- A Store holds onto some data across ghci reloads +update :: IO () +update = do + mtidStore <- lookupStore tidStoreNum + case mtidStore of + -- no server running + Nothing -> do + done <- storeAction doneStore newEmptyMVar + tid <- start done + _ <- storeAction (Store tidStoreNum) (newIORef tid) + return () + -- server is already running + Just tidStore -> restartAppInNewThread tidStore + where + doneStore :: Store (MVar ()) + doneStore = Store 0 + + -- shut the server down with killThread and wait for the done signal + restartAppInNewThread :: Store (IORef ThreadId) -> IO () + restartAppInNewThread tidStore = modifyStoredIORef tidStore $ \tid -> do + killThread tid + withStore doneStore takeMVar + readStore doneStore >>= start + + + -- | Start the server in a separate thread. + start :: MVar () -- ^ Written to when the thread is killed. + -> IO ThreadId + start done = do + (port, site, app) <- getApplicationRepl + tid <- forkIO (finally (runSettings (setPort port defaultSettings) app) + -- Note that this implies concurrency + -- between shutdownApp and the next app that is starting. + -- Normally this should be fine + (putMVar done () >> shutdownApp site)) + writeFile "devel-main-since" =<< show <$> getCurrentTime + return tid + + +-- | kill the server +shutdown :: IO () +shutdown = do + mtidStore <- lookupStore tidStoreNum + case mtidStore of + -- no server running + Nothing -> putStrLn "no Yesod app running" + Just tidStore -> do + withStore tidStore $ readIORef >=> killThread + putStrLn "Yesod app is shutdown" + +tidStoreNum :: Word32 +tidStoreNum = 1 + +modifyStoredIORef :: Store (IORef a) -> (a -> IO a) -> IO () +modifyStoredIORef store f = withStore store $ \ref -> do + v <- readIORef ref + f v >>= writeIORef ref diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/yesod-fast-devel.cabal b/yesod-fast-devel.cabal new file mode 100644 --- /dev/null +++ b/yesod-fast-devel.cabal @@ -0,0 +1,46 @@ +-- This file has been generated from package.yaml by hpack version 0.17.0. +-- +-- see: https://github.com/sol/hpack + +name: yesod-fast-devel +version: 0.1.2.0 +synopsis: Fast live-reloading for yesod applications. +description: https://github.com/haskellbr/yesod-fast-devel +license: BSD3 +license-file: LICENSE +author: Arne Link, Pedro Tacla Yamada +maintainer: tacla.yamada@gmail.com +category: Development +homepage: https://github.com/haskellbr/yesod-fast-devel#readme +bug-reports: https://github.com/haskellbr/yesod-fast-devel/issues +build-type: Simple +cabal-version: >= 1.10 + +data-files: + OriginalDevelMain.hs + PatchedDevelMain.hs + +source-repository head + type: git + location: https://github.com/haskellbr/yesod-fast-devel + +executable yesod-fast-devel + default-extensions: OverloadedStrings LambdaCase + main-is: Main.hs + build-depends: + Glob >=0.7 + , ansi-terminal + , base >=4.7 && <5 + , bytestring >=0.10.6.0 + , directory >=1.2.2.0 + , filepath >=1.4.0.0 + , fsnotify >=0.1.0.0 + , optparse-applicative + , process >=1.2.0.0 + , pureMD5 >=2.1 + , stm >=2.1.1.0 + , system-filepath + , temporary >=1.2.0.0 + , text >=1.2.0.0 + default-language: Haskell2010 + ghc-options: -threaded