diff --git a/hakysidian.cabal b/hakysidian.cabal index 5843779..2ed272e 100644 --- a/hakysidian.cabal +++ b/hakysidian.cabal @@ -31,6 +31,7 @@ executable hakysidian , array , directory , filepath + , process , time , wai-app-static , warp diff --git a/src/site.hs b/src/site.hs index f856e5f..1895e28 100644 --- a/src/site.hs +++ b/src/site.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -7,7 +8,10 @@ import ChaoDoc import Control.Concurrent (forkIO, threadDelay) -import Control.Monad (filterM, unless, void, when) +import Control.Exception (SomeException, bracket_, try) +import Control.Monad (filterM, unless, void) +import Data.Char (isSpace) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Kind (Type) import Data.List (intercalate, isPrefixOf, sort, sortOn) import qualified Data.Map.Strict as M @@ -15,6 +19,8 @@ import Data.Maybe (fromMaybe) import Data.String (fromString) import qualified Data.Text as T import Data.Time.Clock (UTCTime) +import Data.Time.Format (defaultTimeLocale, formatTime) +import Data.Time.LocalTime (getZonedTime) import Hakyll import Hakyll.Core.Runtime (RunMode (RunModeNormal)) import qualified Network.Wai.Handler.Warp as Warp @@ -27,10 +33,19 @@ import System.Directory getModificationTime, listDirectory ) -import System.Environment (getArgs) +import System.Environment (getArgs, getExecutablePath, lookupEnv) import System.Exit (ExitCode (..), die, exitSuccess, exitWith) import System.FilePath import Network.Wai.Application.Static (staticApp) +import System.IO + ( BufferMode (NoBuffering), + hFlush, + hGetBuffering, + hIsTerminalDevice, + hSetBuffering, + stdout + ) +import System.Process (CreateProcess (cwd), proc, readCreateProcessWithExitCode) import Text.Pandoc (HTMLMathMethod (MathML), WriterOptions (..), compileTemplate) import Text.Read (readMaybe) @@ -89,6 +104,30 @@ data CliCommand type FileSnapshot :: Type type FileSnapshot = M.Map FilePath UTCTime +type ServerStatus :: Type +data ServerStatus + = ServerDisabled + | ServerStarting + | ServerRunning + | ServerFailed String + deriving stock (Eq) + +type DashboardState :: Type +data DashboardState = DashboardState + { dashboardStatus :: String, + dashboardLastChange :: String, + dashboardLastBuild :: String, + dashboardLogLines :: [String] + } + deriving stock (Eq) + +type TerminalSize :: Type +data TerminalSize = TerminalSize + { terminalRows :: Int, + terminalCols :: Int + } + deriving stock (Eq) + -------------------------------------------------------------------------------- -- https://www.rohanjain.in/hakyll-clean-urls/ cleanRoute :: Routes @@ -196,41 +235,17 @@ validateProject projectRoot = do "hakysidian is missing required project inputs:" : map (" - " ++) missing -renderWatchPanel :: FilePath -> Configuration -> WatchSettings -> IO () -renderWatchPanel projectRoot config watchSettings = do - notesExists <- doesDirectoryExist (projectRoot "notes") - bibExists <- doesFileExist (projectRoot "reference.bib") - macrosExists <- doesFileExist (projectRoot "math-macros.md") - imagesExists <- doesDirectoryExist (projectRoot "images") - let urlText = fromMaybe "disabled (--no-server)" (watchUrl watchSettings) - statusText = - "notes=" - ++ presentStatus notesExists - ++ ", bib=" - ++ presentStatus bibExists - ++ ", macros=" - ++ presentStatus macrosExists - ++ ", images=" - ++ optionalStatus imagesExists - mapM_ - putStrLn - [ "------------------------------------------------------------", - "hakysidian watch", - "project : " ++ projectRoot, - "output : " ++ destinationDirectory config, - "url : " ++ urlText, - "watching : notes/, reference.bib, math-macros.md, images/ (optional)", - "status : " ++ statusText, - "------------------------------------------------------------" - ] - -presentStatus :: Bool -> String -presentStatus True = "ok" -presentStatus False = "missing" - -optionalStatus :: Bool -> String -optionalStatus True = "present" -optionalStatus False = "absent" +initialDashboardState :: DashboardState +initialDashboardState = + DashboardState + { dashboardStatus = "starting", + dashboardLastChange = "waiting for first build", + dashboardLastBuild = "pending", + dashboardLogLines = + [ "watcher ready", + "watching notes/, reference.bib, math-macros.md, images/ (optional)" + ] + } parseWatchSettings :: Configuration -> [String] -> WatchSettings parseWatchSettings config args = @@ -272,6 +287,177 @@ extractOptionValue option = go | optionPrefix `isPrefixOf` arg = Just (drop (length optionPrefix) arg) | otherwise = go (value : rest) +withWatchTui :: IO a -> IO a +withWatchTui action = do + interactive <- hIsTerminalDevice stdout + if interactive + then do + originalBuffering <- hGetBuffering stdout + bracket_ + (do + hSetBuffering stdout NoBuffering + putStr "\ESC[?1049h\ESC[2J\ESC[H\ESC[?25l" + hFlush stdout) + (do + putStr "\ESC[0m\ESC[?25h\ESC[?1049l" + hFlush stdout + hSetBuffering stdout originalBuffering) + action + else action + +renderWatchDashboard :: + IORef (Maybe (TerminalSize, ServerStatus, DashboardState)) -> + FilePath -> + Configuration -> + WatchSettings -> + IORef ServerStatus -> + DashboardState -> + IO () +renderWatchDashboard renderStateRef projectRoot config watchSettings serverStatusRef dashboard = do + terminalSize <- getTerminalSize + serverStatus <- readIORef serverStatusRef + previousRenderState <- readIORef renderStateRef + let currentRenderState = Just (terminalSize, serverStatus, dashboard) + unless (currentRenderState == previousRenderState) do + let rows = max 1 (terminalRows terminalSize) + cols = max 4 (terminalCols terminalSize) + border = "+" ++ replicate (cols - 2) '-' ++ "+" + infoRows = + [ dashboardRow cols ("Project : " ++ projectRoot), + dashboardRow cols ("Output : " ++ destinationDirectory config), + dashboardRow cols ("Preview : " ++ renderServerStatus watchSettings serverStatus), + dashboardRow cols "Watch : notes/, reference.bib, math-macros.md, images/ (optional)", + dashboardRow cols ("Change : " ++ dashboardLastChange dashboard), + dashboardRow cols ("Build : " ++ dashboardLastBuild dashboard) + ] + headerRows = + [ border, + dashboardTitleRow cols "hakysidian watch" (dashboardStatus dashboard), + border + ] + ++ infoRows + ++ [border, dashboardRow cols "Recent activity", border] + footerRows = [border] + availableLogRows = max 1 (rows - length headerRows - length footerRows) + logRows = + map (dashboardRow cols) $ + padRows availableLogRows $ + takeLast availableLogRows (dashboardLogLines dashboard) + screenRows = take rows (headerRows ++ logRows ++ footerRows) + putStr "\ESC[2J\ESC[H" + putStr (unlines screenRows) + hFlush stdout + writeIORef renderStateRef currentRenderState + +dashboardTitleRow :: Int -> String -> String -> String +dashboardTitleRow width leftText rightText = + dashboardFramedRow width (leftText ++ spacer ++ clippedRight) + where + usableWidth = max 1 (width - 4) + rightWidth = min (usableWidth `div` 3) (length rightText) + clippedRight = + if null rightText + then "" + else ellipsize rightWidth rightText + leftWidth = max 1 (usableWidth - length clippedRight - 1) + clippedLeft = ellipsize leftWidth leftText + spacer + | null clippedRight = "" + | otherwise = replicate (max 1 (usableWidth - length clippedLeft - length clippedRight)) ' ' + +dashboardRow :: Int -> String -> String +dashboardRow width = dashboardFramedRow width + +dashboardFramedRow :: Int -> String -> String +dashboardFramedRow width content = + "| " ++ padRight usableWidth (ellipsize usableWidth content) ++ " |" + where + usableWidth = max 1 (width - 4) + +padRight :: Int -> String -> String +padRight width text = text ++ replicate (max 0 (width - length text)) ' ' + +padRows :: Int -> [String] -> [String] +padRows count rows = + rows ++ replicate (max 0 (count - length rows)) "" + +takeLast :: Int -> [a] -> [a] +takeLast count xs = drop (max 0 (length xs - count)) xs + +ellipsize :: Int -> String -> String +ellipsize width text + | width <= 0 = "" + | length text <= width = text + | width <= 3 = take width text + | otherwise = take (width - 3) text ++ "..." + +renderServerStatus :: WatchSettings -> ServerStatus -> String +renderServerStatus watchSettings serverStatus = case serverStatus of + ServerDisabled -> "disabled (--no-server)" + ServerStarting -> maybe "starting" (++ " (starting)") (watchUrl watchSettings) + ServerRunning -> fromMaybe "running" (watchUrl watchSettings) + ServerFailed err -> + "failed: " ++ err + +getTerminalSize :: IO TerminalSize +getTerminalSize = do + sttySize <- queryTerminalSize + case sttySize of + Just terminalSize -> pure terminalSize + Nothing -> do + rows <- maybe 24 id . (>>= readMaybe) <$> lookupEnv "LINES" + cols <- maybe 80 id . (>>= readMaybe) <$> lookupEnv "COLUMNS" + pure (TerminalSize rows cols) + +queryTerminalSize :: IO (Maybe TerminalSize) +queryTerminalSize = do + result <- + try $ + readCreateProcessWithExitCode + (proc "sh" ["-c", "stty size case words stdoutText of + [rowsText, colsText] -> do + rows <- readMaybe rowsText + cols <- readMaybe colsText + Just (TerminalSize rows cols) + _ -> Nothing + ExitFailure _ -> Nothing + +watchTimestamp :: IO String +watchTimestamp = formatTime defaultTimeLocale "%H:%M:%S" <$> getZonedTime + +trimTrailingSpace :: String -> String +trimTrailingSpace = reverse . dropWhile isSpace . reverse + +normalizeLogLines :: String -> String -> [String] +normalizeLogLines stdoutText stderrText = + filter (not . null) $ + map trimTrailingSpace $ + lines (stdoutText ++ if null stderrText then "" else "\n" ++ stderrText) + +appendLogBatch :: DashboardState -> String -> String -> [String] -> DashboardState +appendLogBatch dashboard title timestamp buildLines = + dashboard + { dashboardLogLines = + takeLast 200 $ + dashboardLogLines dashboard + ++ ("[" ++ timestamp ++ "] " ++ title) + : map (" " ++) buildLines + } + +runCapturedSiteCommand :: FilePath -> String -> IO (ExitCode, [String]) +runCapturedSiteCommand projectRoot command = do + executablePath <- getExecutablePath + (exitCode, stdoutText, stderrText) <- + readCreateProcessWithExitCode + (proc executablePath [command]) {cwd = Just projectRoot} + "" + pure (exitCode, normalizeLogLines stdoutText stderrText) + buildOptions :: Options buildOptions = Options {verbosity = False, optCommand = Build RunModeNormal} @@ -286,47 +472,126 @@ runSiteCommand config options cslPath = hakyllWithExitCodeAndArgs config options (siteRules cslPath) runWatch :: FilePath -> Configuration -> FilePath -> WatchSettings -> IO ExitCode -runWatch projectRoot config cslPath watchSettings = do - renderWatchPanel projectRoot config watchSettings - initialExit <- runSiteCommand config buildOptions cslPath - when (initialExit /= ExitSuccess) $ - putStrLn "build : initial build failed; continuing to watch for changes" - startPreviewServer config watchSettings - initialSnapshot <- snapshotInputs projectRoot - watchLoop initialSnapshot +runWatch projectRoot config _cslPath watchSettings = + withWatchTui do + serverStatusRef <- newIORef initialServerStatus + renderStateRef <- newIORef Nothing + startPreviewServer config watchSettings serverStatusRef + renderWatchDashboard renderStateRef projectRoot config watchSettings serverStatusRef initialDashboardState + (_, initialDashboard) <- + runWatchBuild + "build" + "initial build" + "initial build" + projectRoot + config + watchSettings + renderStateRef + serverStatusRef + initialDashboardState + initialSnapshot <- snapshotInputs projectRoot + watchLoop renderStateRef serverStatusRef initialSnapshot initialDashboard where - watchLoop :: FileSnapshot -> IO ExitCode - watchLoop previousSnapshot = do + initialServerStatus + | watchServerEnabled watchSettings = ServerStarting + | otherwise = ServerDisabled + + watchLoop :: + IORef (Maybe (TerminalSize, ServerStatus, DashboardState)) -> + IORef ServerStatus -> + FileSnapshot -> + DashboardState -> + IO ExitCode + watchLoop renderStateRef serverStatusRef previousSnapshot dashboard = do + renderWatchDashboard renderStateRef projectRoot config watchSettings serverStatusRef dashboard threadDelay 1000000 nextSnapshot <- snapshotInputs projectRoot if nextSnapshot == previousSnapshot - then watchLoop previousSnapshot + then watchLoop renderStateRef serverStatusRef previousSnapshot dashboard else do let changedFiles = diffSnapshots previousSnapshot nextSnapshot - options = + command :: String + command = if any (`M.notMember` nextSnapshot) (M.keys previousSnapshot) - then rebuildOptions - else buildOptions - putStrLn ("change : " ++ intercalate ", " changedFiles) - buildExit <- runSiteCommand config options cslPath - putStrLn ("build : " ++ renderBuildResult buildExit) - watchLoop nextSnapshot + then "rebuild" + else "build" + changeSummary = intercalate ", " changedFiles + (_, nextDashboard) <- + runWatchBuild + command + command + changeSummary + projectRoot + config + watchSettings + renderStateRef + serverStatusRef + dashboard + watchLoop renderStateRef serverStatusRef nextSnapshot nextDashboard renderBuildResult :: ExitCode -> String renderBuildResult ExitSuccess = "success" renderBuildResult (ExitFailure code) = "failed (" ++ show code ++ ")" -startPreviewServer :: Configuration -> WatchSettings -> IO () -startPreviewServer config watchSettings +runWatchBuild :: + String -> + String -> + String -> + FilePath -> + Configuration -> + WatchSettings -> + IORef (Maybe (TerminalSize, ServerStatus, DashboardState)) -> + IORef ServerStatus -> + DashboardState -> + IO (ExitCode, DashboardState) +runWatchBuild command label changeSummary projectRoot config watchSettings renderStateRef serverStatusRef dashboard = do + startedAt <- watchTimestamp + let runningDashboard = + dashboard + { dashboardStatus = "building (" ++ label ++ ")", + dashboardLastChange = changeSummary, + dashboardLastBuild = "running since " ++ startedAt + } + renderWatchDashboard renderStateRef projectRoot config watchSettings serverStatusRef runningDashboard + (exitCode, buildLines) <- runCapturedSiteCommand projectRoot command + finishedAt <- watchTimestamp + let loggedDashboard = + appendLogBatch runningDashboard (label ++ ": " ++ changeSummary) finishedAt buildLines + completedDashboard = + loggedDashboard + { dashboardStatus = + if exitCode == ExitSuccess + then "watching" + else "watching after failed " ++ label, + dashboardLastBuild = + renderBuildResult exitCode + ++ " at " + ++ finishedAt + ++ " via " + ++ label + } + renderWatchDashboard renderStateRef projectRoot config watchSettings serverStatusRef completedDashboard + pure (exitCode, completedDashboard) + +startPreviewServer :: Configuration -> WatchSettings -> IORef ServerStatus -> IO () +startPreviewServer config watchSettings serverStatusRef | watchServerEnabled watchSettings = void $ forkIO $ - Warp.runSettings settings $ - staticApp $ - previewSettings config (destinationDirectory config) - | otherwise = pure () + do + result <- + (try $ + Warp.runSettings settings $ + staticApp $ + previewSettings config (destinationDirectory config)) :: + IO (Either SomeException ()) + case result of + Left err -> writeIORef serverStatusRef (ServerFailed (show err)) + Right () -> pure () + | otherwise = writeIORef serverStatusRef ServerDisabled where settings = + Warp.setBeforeMainLoop (writeIORef serverStatusRef ServerRunning) $ Warp.setPort (watchPort watchSettings) $ Warp.setHost (fromString (watchHost watchSettings)) $ Warp.defaultSettings