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
}