mirror of
http://101.35.51.105:3000/congyu/Hakysidian.git
synced 2026-04-27 21:40:50 +08:00
better tui for watch
This commit is contained in:
@@ -31,6 +31,7 @@ executable hakysidian
|
||||
, array
|
||||
, directory
|
||||
, filepath
|
||||
, process
|
||||
, time
|
||||
, wai-app-static
|
||||
, warp
|
||||
|
||||
+326
-61
@@ -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 </dev/tty"])
|
||||
"" :: IO (Either SomeException (ExitCode, String, String))
|
||||
pure $ do
|
||||
(exitCode, stdoutText, _) <- either (const Nothing) Just result
|
||||
case exitCode of
|
||||
ExitSuccess -> 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
|
||||
|
||||
Reference in New Issue
Block a user