Hakysidian/src/site.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}

import ChaoDoc
import Control.Concurrent (forkIO, threadDelay)
import Control.Exception (SomeException, bracket_, try)
import Control.Monad (filterM, unless, void, when)
import Data.Char (isSpace, toLower)
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
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 Network.Wai.Application.Static (staticApp)
import qualified Network.Wai.Handler.Warp as Warp
import qualified Paths_hakysidian as Paths
import System.Directory
  ( canonicalizePath,
    doesDirectoryExist,
    doesFileExist,
    getCurrentDirectory,
    getModificationTime,
    listDirectory,
  )
import System.Environment (getArgs, getExecutablePath, lookupEnv)
import System.Exit (ExitCode (..), die, exitSuccess, exitWith)
import System.FilePath
import System.IO
  ( BufferMode (NoBuffering),
    hFlush,
    hGetBuffering,
    hGetChar,
    hIsTerminalDevice,
    hSetBuffering,
    hWaitForInput,
    stdin,
    stdout,
  )
import System.Posix.IO (stdInput)
import System.Posix.Terminal
  ( TerminalAttributes,
    TerminalMode (EnableEcho, ProcessInput),
    TerminalState (Immediately),
    getTerminalAttributes,
    setTerminalAttributes,
    withMinInput,
    withTime,
    withoutMode,
  )
import System.Process (CreateProcess (cwd), proc, readCreateProcessWithExitCode)
import Text.Pandoc (HTMLMathMethod (MathML), WriterOptions (..), compileTemplate)
import Text.Read (readMaybe)

--------------------------------------------------------------------------------

notesPattern :: Pattern
notesPattern = fromGlob "notes/**"

bundledCssFiles :: [FilePath]
bundledCssFiles =
  [ "css/fonts.css",
    "css/default.css",
    "css/pygentize.css",
    "css/chao-theorems.css",
    "css/sidenotes.css"
  ]

bundledFontFiles :: [FilePath]
bundledFontFiles =
  [ "fonts/Lato-BoldItalic.woff2",
    "fonts/IosevkaCustom-Bold.woff2",
    "fonts/IosevkaCustom-Regular.woff2",
    "fonts/Lato-Bold.woff2",
    "fonts/Lato-Regular.woff2",
    "fonts/IosevkaCustom-Italic.woff2",
    "fonts/LeteSansMath.woff2",
    "fonts/LeteSansMath-Bold.woff2",
    "fonts/Lato-Italic.woff2"
  ]

bundledTemplateFiles :: [FilePath]
bundledTemplateFiles =
  [ "templates/head.html",
    "templates/note.html",
    "templates/notes.html",
    "templates/notes-list.html",
    "templates/index.html",
    "templates/navbar.html"
  ]

type WatchSettings :: Type
data WatchSettings = WatchSettings
  { watchHost :: String,
    watchPort :: Int,
    watchServerEnabled :: Bool
  }

type CliCommand :: Type
data CliCommand
  = BuildCommand
  | CleanCommand
  | HelpCommand
  | RebuildCommand
  | TuiCommand WatchSettings
  | WatchCommand WatchSettings

type TuiAction :: Type
data TuiAction
  = TuiClean
  | TuiQuit
  | TuiStartWatching
  | TuiStopWatching

type FileSnapshot :: Type
type FileSnapshot = M.Map FilePath UTCTime

type TuiWatchState :: Type
data TuiWatchState
  = TuiWatchStopped
  | TuiWatching FileSnapshot

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
cleanRoute = customRoute createIndexRoute
  where
    createIndexRoute ident = takeDirectory path </> takeBaseName path </> "index.html"
      where
        path = toFilePath ident

cleanIndexHtmls :: Item String -> Compiler (Item String)
cleanIndexHtmls = return . fmap (replaceAll pattern replacement)
  where
    pattern :: String
    pattern = "/index.html"

    replacement :: String -> String
    replacement = const "/"

loadNoteLinks :: Compiler [Item String]
loadNoteLinks = do
  noteIds <- sortOn toFilePath <$> getMatches notesPattern
  pure [Item noteId "" | noteId <- noteIds]

--------------------------------------------------------------------------------

siteConfiguration :: FilePath -> Configuration
siteConfiguration projectRoot =
  defaultConfiguration
    { destinationDirectory = projectRoot </> "_site",
      storeDirectory = projectRoot </> "_cache",
      tmpDirectory = projectRoot </> "_cache" </> "tmp",
      providerDirectory = projectRoot,
      ignoreFile = ignoreProjectFile (ignoreFile defaultConfiguration),
      watchIgnore = ignoreProjectFile (watchIgnore defaultConfiguration)
    }

ignoreProjectFile :: (FilePath -> Bool) -> FilePath -> Bool
ignoreProjectFile defaultIgnore path = defaultIgnore path || ignoredProjectPath path

ignoredProjectPath :: FilePath -> Bool
ignoredProjectPath path =
  any (`elem` [".git", ".obsidian"]) (splitDirectories (normalise path))

--------------------------------------------------------------------------------

main :: IO ()
main = do
  args <- getArgs
  projectRoot <- canonicalizePath =<< getCurrentDirectory
  let config = siteConfiguration projectRoot
  cslPath <- Paths.getDataFileName "bib_style.csl"
  case parseCliCommand config args of
    Left err -> die (err <> "\n\n" <> usageText)
    Right HelpCommand -> putStrLn usageText >> exitSuccess
    Right CleanCommand ->
      exitWith =<< runSiteCommand config cleanOptions cslPath
    Right BuildCommand -> do
      validateProject projectRoot
      exitWith =<< runSiteCommand config buildOptions cslPath
    Right RebuildCommand -> do
      validateProject projectRoot
      exitWith =<< runSiteCommand config rebuildOptions cslPath
    Right (TuiCommand watchSettings) -> do
      validateProject projectRoot
      exitWith =<< runTui projectRoot config cslPath watchSettings
    Right (WatchCommand watchSettings) -> do
      validateProject projectRoot
      exitWith =<< runSiteCommand config (watchOptions watchSettings) cslPath

usageText :: String
usageText =
  unlines
    [ "usage: hakysidian [build|clean|rebuild|watch [--host HOST] [--port PORT] [--no-server]|-tui [--host HOST] [--port PORT] [--no-server]]",
      "",
      "Run inside a project directory containing notes/, reference.bib, math-macros.md, and optional images/."
    ]

parseCliCommand :: Configuration -> [String] -> Either String CliCommand
parseCliCommand config args
  | any (`elem` ["-h", "--help"]) args = Right HelpCommand
  | otherwise = case args of
      [] -> Right BuildCommand
      ["build"] -> Right BuildCommand
      ["clean"] -> Right CleanCommand
      ["rebuild"] -> Right RebuildCommand
      "-tui" : rest -> Right (TuiCommand (parseWatchSettings config rest))
      "--tui" : rest -> Right (TuiCommand (parseWatchSettings config rest))
      "watch" : rest -> Right (WatchCommand (parseWatchSettings config rest))
      command : _ -> Left ("Unknown command: " <> command)

validateProject :: FilePath -> IO ()
validateProject projectRoot = do
  notesExists <- doesDirectoryExist (projectRoot </> "notes")
  bibExists <- doesFileExist (projectRoot </> "reference.bib")
  macrosExists <- doesFileExist (projectRoot </> "math-macros.md")
  let missing :: [String]
      missing =
        [ "notes/"
          | not notesExists
        ]
          ++ [ "reference.bib"
               | not bibExists
             ]
          ++ [ "math-macros.md"
               | not macrosExists
             ]
  unless (null missing) $
    die $
      unlines $
        "hakysidian is missing required project inputs:"
          : map ("  - " ++) missing

initialDashboardState :: DashboardState
initialDashboardState =
  DashboardState
    { dashboardStatus = "idle",
      dashboardLastChange = "press w to start watching",
      dashboardLastBuild = "no command run yet",
      dashboardLogLines =
        [ "tui ready",
          "controls: w watch, s stop, c clean, q quit"
        ]
    }

parseWatchSettings :: Configuration -> [String] -> WatchSettings
parseWatchSettings config args =
  WatchSettings
    { watchHost = fromMaybe (previewHost config) (extractOptionValue "--host" args),
      watchPort =
        fromMaybe (previewPort config) $
          extractOptionValue "--port" args >>= readMaybe,
      watchServerEnabled = "--no-server" `notElem` args
    }

watchUrl :: WatchSettings -> Maybe String
watchUrl settings
  | watchServerEnabled settings =
      Just $
        "http://"
          ++ displayHost (watchHost settings)
          ++ ":"
          ++ show (watchPort settings)
          ++ "/"
  | otherwise = Nothing
  where
    displayHost :: String -> String
    displayHost "0.0.0.0" = "127.0.0.1"
    displayHost hostName = hostName

extractOptionValue :: String -> [String] -> Maybe String
extractOptionValue option = go
  where
    optionPrefix = option ++ "="

    go :: [String] -> Maybe String
    go [] = Nothing
    go [arg]
      | optionPrefix `isPrefixOf` arg = Just (drop (length optionPrefix) arg)
      | otherwise = Nothing
    go (arg : value : rest)
      | arg == option = Just value
      | optionPrefix `isPrefixOf` arg = Just (drop (length optionPrefix) arg)
      | otherwise = go (value : rest)

withWatchTui :: IO a -> IO a
withWatchTui action = do
  stdoutInteractive <- hIsTerminalDevice stdout
  stdinInteractive <- hIsTerminalDevice stdin
  if stdoutInteractive
    then do
      originalBuffering <- hGetBuffering stdout
      originalInputBuffering <- hGetBuffering stdin
      originalInputMode <-
        if stdinInteractive
          then Just <$> getTerminalAttributes stdInput
          else pure Nothing
      bracket_
        ( do
            hSetBuffering stdout NoBuffering
            when stdinInteractive do
              hSetBuffering stdin NoBuffering
              maybe
                (pure ())
                (\inputMode -> setTerminalAttributes stdInput (watchInputMode inputMode) Immediately)
                originalInputMode
            putStr "\ESC[?1049h\ESC[2J\ESC[H\ESC[?25l"
            hFlush stdout
        )
        ( do
            putStr "\ESC[0m\ESC[?25h\ESC[?1049l"
            hFlush stdout
            maybe
              (pure ())
              (\inputMode -> setTerminalAttributes stdInput inputMode Immediately)
              originalInputMode
            when stdinInteractive do
              hSetBuffering stdin originalInputBuffering
            hSetBuffering stdout originalBuffering
        )
        action
    else action

watchInputMode :: TerminalAttributes -> TerminalAttributes
watchInputMode inputMode =
  withTime
    ( withMinInput
        ( withoutMode
            (withoutMode inputMode ProcessInput)
            EnableEcho
        )
        1
    )
    0

renderWatchDashboard ::
  IORef (Maybe (TerminalSize, ServerStatus, DashboardState)) ->
  FilePath ->
  WatchSettings ->
  IORef ServerStatus ->
  DashboardState ->
  IO ()
renderWatchDashboard renderStateRef projectRoot 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 ("Preview : " ++ renderServerStatus watchSettings serverStatus),
            dashboardRow cols ("Change  : " ++ dashboardLastChange dashboard),
            dashboardRow cols ("Last op : " ++ dashboardLastBuild dashboard)
          ]
        headerRows =
          [ border,
            dashboardTitleRow cols "hakysidian tui" (dashboardStatus dashboard),
            border
          ]
            ++ infoRows
            ++ [border, dashboardRow cols "Recent activity", border]
        footerRows =
          [ border,
            dashboardRow cols "Controls: w watch, s stop, c clean, q quit, Ctrl-C interrupt",
            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 (intercalate "\n" screenRows)
    hFlush stdout
    writeIORef renderStateRef currentRenderState

dashboardTitleRow :: Int -> String -> String -> String
dashboardTitleRow width leftText rightText =
  dashboardRow 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 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 <- fromMaybe 24 . (>>= readMaybe) <$> lookupEnv "LINES"
      cols <- fromMaybe 80 . (>>= 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

watchLoopDelayMicros :: Int
watchLoopDelayMicros = 1000000

watchInputPollMicros :: Int
watchInputPollMicros = 100000

waitForTuiAction :: Bool -> Int -> IO (Maybe TuiAction)
waitForTuiAction watchInputEnabled remainingMicros
  | remainingMicros <= 0 = pure Nothing
  | otherwise = do
      nextAction <- pollTuiAction watchInputEnabled
      case nextAction of
        Just action -> pure (Just action)
        Nothing -> do
          threadDelay (min watchInputPollMicros remainingMicros)
          waitForTuiAction watchInputEnabled (remainingMicros - watchInputPollMicros)

pollTuiAction :: Bool -> IO (Maybe TuiAction)
pollTuiAction watchInputEnabled
  | not watchInputEnabled = pure Nothing
  | otherwise = drainInput
  where
    drainInput = do
      hasInput <- hWaitForInput stdin 0
      if hasInput
        then do
          inputChar <- hGetChar stdin
          case parseTuiAction inputChar of
            Just action -> pure (Just action)
            Nothing -> drainInput
        else pure Nothing

parseTuiAction :: Char -> Maybe TuiAction
parseTuiAction inputChar = case toLower inputChar of
  'c' -> Just TuiClean
  'q' -> Just TuiQuit
  's' -> Just TuiStopWatching
  'w' -> Just TuiStartWatching
  _ -> Nothing

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}

cleanOptions :: Options
cleanOptions = Options {verbosity = False, optCommand = Clean}

rebuildOptions :: Options
rebuildOptions = Options {verbosity = False, optCommand = Rebuild}

watchOptions :: WatchSettings -> Options
watchOptions watchSettings =
  Options
    { verbosity = False,
      optCommand =
        Watch
          { host = watchHost watchSettings,
            port = watchPort watchSettings,
            no_server = not (watchServerEnabled watchSettings)
          }
    }

runSiteCommand :: Configuration -> Options -> FilePath -> IO ExitCode
runSiteCommand config options cslPath =
  hakyllWithExitCodeAndArgs config options (siteRules cslPath)

runTui :: FilePath -> Configuration -> FilePath -> WatchSettings -> IO ExitCode
runTui projectRoot config _cslPath watchSettings = do
  stdoutInteractive <- hIsTerminalDevice stdout
  stdinInteractive <- hIsTerminalDevice stdin
  let watchInputEnabled = stdoutInteractive && stdinInteractive
  if watchInputEnabled
    then
      withWatchTui do
        serverStatusRef <- newIORef initialServerStatus
        renderStateRef <- newIORef Nothing
        startPreviewServer config watchSettings serverStatusRef
        renderWatchDashboard renderStateRef projectRoot watchSettings serverStatusRef initialDashboardState
        tuiLoop watchInputEnabled renderStateRef serverStatusRef TuiWatchStopped initialDashboardState
    else do
      putStrLn "hakysidian -tui requires an interactive terminal."
      pure (ExitFailure 1)
  where
    initialServerStatus
      | watchServerEnabled watchSettings = ServerStarting
      | otherwise = ServerDisabled

    tuiLoop ::
      Bool ->
      IORef (Maybe (TerminalSize, ServerStatus, DashboardState)) ->
      IORef ServerStatus ->
      TuiWatchState ->
      DashboardState ->
      IO ExitCode
    tuiLoop watchInputEnabled renderStateRef serverStatusRef watchState dashboard = do
      renderWatchDashboard renderStateRef projectRoot watchSettings serverStatusRef dashboard
      nextAction <- waitForTuiAction watchInputEnabled watchLoopDelayMicros
      case nextAction of
        Just TuiQuit -> pure ExitSuccess
        Just TuiStartWatching -> case watchState of
          TuiWatching _ ->
            tuiLoop watchInputEnabled renderStateRef serverStatusRef watchState dashboard
          TuiWatchStopped -> do
            (_, nextDashboard) <-
              runDashboardCommand
                "rebuild"
                "watch start"
                "manual start"
                "building (watch start)"
                (watchCommandStatus "watch start")
                projectRoot
                watchSettings
                renderStateRef
                serverStatusRef
                dashboard
            nextSnapshot <- snapshotInputs projectRoot
            tuiLoop watchInputEnabled renderStateRef serverStatusRef (TuiWatching nextSnapshot) nextDashboard
        Just TuiStopWatching -> case watchState of
          TuiWatchStopped ->
            tuiLoop watchInputEnabled renderStateRef serverStatusRef watchState dashboard
          TuiWatching _ -> do
            nextDashboard <-
              appendDashboardMessage
                ( dashboard
                    { dashboardStatus = "idle",
                      dashboardLastChange = "watch stopped"
                    }
                )
                "watch stopped"
            tuiLoop watchInputEnabled renderStateRef serverStatusRef TuiWatchStopped nextDashboard
        Just TuiClean -> do
          (_, nextDashboard) <-
            runDashboardCommand
              "clean"
              "clean"
              "manual clean"
              "cleaning"
              cleanCommandStatus
              projectRoot
              watchSettings
              renderStateRef
              serverStatusRef
              dashboard
          tuiLoop watchInputEnabled renderStateRef serverStatusRef TuiWatchStopped nextDashboard
        Nothing -> case watchState of
          TuiWatchStopped ->
            tuiLoop watchInputEnabled renderStateRef serverStatusRef watchState dashboard
          TuiWatching previousSnapshot -> do
            nextSnapshot <- snapshotInputs projectRoot
            if nextSnapshot == previousSnapshot
              then tuiLoop watchInputEnabled renderStateRef serverStatusRef watchState dashboard
              else do
                let changedFiles = diffSnapshots previousSnapshot nextSnapshot
                    command :: String
                    command =
                      if any (`M.notMember` nextSnapshot) (M.keys previousSnapshot)
                        then "rebuild"
                        else "build"
                    changeSummary = intercalate ", " changedFiles
                (_, nextDashboard) <-
                  runDashboardCommand
                    command
                    command
                    changeSummary
                    ("building (" ++ command ++ ")")
                    (watchCommandStatus command)
                    projectRoot
                    watchSettings
                    renderStateRef
                    serverStatusRef
                    dashboard
                tuiLoop watchInputEnabled renderStateRef serverStatusRef (TuiWatching nextSnapshot) nextDashboard

    watchCommandStatus :: String -> ExitCode -> String
    watchCommandStatus label exitCode
      | exitCode == ExitSuccess = "watching"
      | otherwise = "watching after failed " ++ label

    cleanCommandStatus :: ExitCode -> String
    cleanCommandStatus exitCode
      | exitCode == ExitSuccess = "idle"
      | otherwise = "idle after failed clean"

renderBuildResult :: ExitCode -> String
renderBuildResult ExitSuccess = "success"
renderBuildResult (ExitFailure code) = "failed (" ++ show code ++ ")"

appendDashboardMessage :: DashboardState -> String -> IO DashboardState
appendDashboardMessage dashboard message = do
  timestamp <- watchTimestamp
  pure (appendLogBatch dashboard message timestamp [])

runDashboardCommand ::
  String ->
  String ->
  String ->
  String ->
  (ExitCode -> String) ->
  FilePath ->
  WatchSettings ->
  IORef (Maybe (TerminalSize, ServerStatus, DashboardState)) ->
  IORef ServerStatus ->
  DashboardState ->
  IO (ExitCode, DashboardState)
runDashboardCommand command label changeSummary runningStatus completedStatus projectRoot watchSettings renderStateRef serverStatusRef dashboard = do
  startedAt <- watchTimestamp
  let runningDashboard =
        dashboard
          { dashboardStatus = runningStatus,
            dashboardLastChange = changeSummary,
            dashboardLastBuild = "running since " ++ startedAt
          }
  renderWatchDashboard renderStateRef projectRoot watchSettings serverStatusRef runningDashboard
  (exitCode, buildLines) <- runCapturedSiteCommand projectRoot command
  finishedAt <- watchTimestamp
  let loggedDashboard =
        appendLogBatch runningDashboard (label ++ ": " ++ changeSummary) finishedAt buildLines
      completedDashboard =
        loggedDashboard
          { dashboardStatus = completedStatus exitCode,
            dashboardLastBuild =
              renderBuildResult exitCode
                ++ " at "
                ++ finishedAt
                ++ " via "
                ++ label
          }
  renderWatchDashboard renderStateRef projectRoot watchSettings serverStatusRef completedDashboard
  pure (exitCode, completedDashboard)

startPreviewServer :: Configuration -> WatchSettings -> IORef ServerStatus -> IO ()
startPreviewServer config watchSettings serverStatusRef
  | watchServerEnabled watchSettings =
      void $
        forkIO $
          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

snapshotInputs :: FilePath -> IO FileSnapshot
snapshotInputs projectRoot = do
  inputFiles <- trackedInputs projectRoot
  entries <- traverse toSnapshotEntry inputFiles
  pure (M.fromList entries)
  where
    toSnapshotEntry :: FilePath -> IO (FilePath, UTCTime)
    toSnapshotEntry path = do
      modifiedAt <- getModificationTime path
      pure (makeRelative projectRoot path, modifiedAt)

trackedInputs :: FilePath -> IO [FilePath]
trackedInputs projectRoot = do
  requiredFiles <-
    filterM
      doesFileExist
      [ projectRoot </> "reference.bib",
        projectRoot </> "math-macros.md"
      ]
  noteFiles <- trackedFilesIn (projectRoot </> "notes")
  imageFiles <- trackedFilesIn (projectRoot </> "images")
  pure (sort (requiredFiles ++ noteFiles ++ imageFiles))

trackedFilesIn :: FilePath -> IO [FilePath]
trackedFilesIn root = do
  exists <- doesDirectoryExist root
  if exists
    then do
      entries <- listDirectory root
      fmap concat
        <$> traverse
          ( \name -> do
              let path = root </> name
              isDir <- doesDirectoryExist path
              if isDir
                then trackedFilesIn path
                else pure [path]
          )
          entries
    else pure []

diffSnapshots :: FileSnapshot -> FileSnapshot -> [FilePath]
diffSnapshots previousSnapshot nextSnapshot =
  sort
    [ path
      | path <- M.keys (M.union previousSnapshot nextSnapshot),
        M.lookup path previousSnapshot /= M.lookup path nextSnapshot
    ]

--------------------------------------------------------------------------------

siteRules :: FilePath -> Rules ()
siteRules cslPath = do
  match "images/**" $ do
    route idRoute
    compile copyFileCompiler

  match "math-macros.md" $
    compile getResourceBody

  match "reference.bib" $
    compile getResourceBody

  mapM_ createBundledCss bundledCssFiles
  mapM_ createBundledCopy bundledFontFiles
  createBundledCopy "favicon.ico"
  mapM_ createBundledTemplate bundledTemplateFiles

  match notesPattern $ do
    route cleanRoute
    compile $ do
      notes <- loadNoteLinks
      tocCtx <- getTocCtx cslPath (listField "notes" defaultContext (pure notes) <> defaultContext)
      chaoDocCompiler cslPath
        >>= loadAndApplyTemplate "templates/note.html" tocCtx
        >>= relativizeUrls

  create ["index.html"] $ do
    route idRoute
    compile $ do
      notes <- loadNoteLinks
      let notesCtx =
            listField "notes" defaultContext (pure notes)
              <> constField "title" "Notes"
              <> defaultContext
      makeItem ""
        >>= loadAndApplyTemplate "templates/notes.html" notesCtx
        >>= loadAndApplyTemplate "templates/index.html" notesCtx
        >>= relativizeUrls
        >>= cleanIndexHtmls

createBundledCss :: FilePath -> Rules ()
createBundledCss relPath = create [fromFilePath relPath] $ do
  route idRoute
  compile bundledCssCompiler

createBundledCopy :: FilePath -> Rules ()
createBundledCopy relPath = create [fromFilePath relPath] $ do
  route idRoute
  compile bundledCopyCompiler

createBundledTemplate :: FilePath -> Rules ()
createBundledTemplate relPath =
  create [fromFilePath relPath] $
    compile bundledTemplateCompiler

bundledAssetPath :: Compiler FilePath
bundledAssetPath = do
  ident <- getUnderlying
  unsafeCompiler $ Paths.getDataFileName (toFilePath ident)

bundledTextCompiler :: Compiler (Item String)
bundledTextCompiler = do
  assetPath <- bundledAssetPath
  contents <- unsafeCompiler (readFile assetPath)
  makeItem contents

bundledCssCompiler :: Compiler (Item String)
bundledCssCompiler = fmap compressCss <$> bundledTextCompiler

bundledCopyCompiler :: Compiler (Item CopyFile)
bundledCopyCompiler = do
  assetPath <- bundledAssetPath
  makeItem (CopyFile assetPath)

bundledTemplateCompiler :: Compiler (Item Template)
bundledTemplateCompiler = do
  item <- bundledTextCompiler
  template <- compileTemplateItem item
  pure (itemSetBody template item)

--------------------------------------------------------------------------------

-- toc from https://github.com/slotThe/slotThe.github.io
getTocCtx :: FilePath -> Context a -> Compiler (Context a)
getTocCtx cslPath ctx = do
  noToc <- (Just "true" ==) <$> (getUnderlying >>= (`getMetadataField` "no-toc"))
  writerOpts <- mkTocWriter defaultHakyllWriterOptions
  toc <- writePandocWith writerOpts <$> chaoDocPandocCompiler cslPath
  pure $
    mconcat
      [ ctx,
        constField "toc" $ killLinkIds (itemBody toc),
        if noToc then boolField "no-toc" (pure noToc) else mempty
      ]
  where
    mkTocWriter :: WriterOptions -> Compiler WriterOptions
    mkTocWriter writerOpts = do
      tmpl <- either (const Nothing) Just <$> unsafeCompiler (compileTemplate "" "$toc$")
      pure $
        writerOpts
          { writerTableOfContents = True,
            writerTOCDepth = 2,
            writerTemplate = tmpl,
            writerHTMLMathMethod = MathML
          }

    asTxt :: (T.Text -> T.Text) -> String -> String
    asTxt f = T.unpack . f . T.pack

    killLinkIds :: String -> String
    killLinkIds = asTxt (mconcat . go . T.splitOn "id=\"toc-")
      where
        go :: [T.Text] -> [T.Text]
        go = \case
          [] -> []
          x : xs -> x : map (T.drop 1 . T.dropWhile (/= '\"')) xs