diff --git a/publish.cabal b/publish.cabal --- a/publish.cabal +++ b/publish.cabal @@ -1,13 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.35.1. -- -- see: https://github.com/sol/hpack --- --- hash: bdc6778c7664e65e93e74b73702eef01ef70d5f056eaeca667c9ff73a6e095bd name: publish -version: 2.2.3 +version: 2.5.3 synopsis: Publishing tools for papers, books, and presentations description: Tools for rendering markdown-centric documents into PDFs. There are two programs: @@ -26,12 +24,12 @@ bug-reports: https://github.com/aesiniath/publish/issues author: Andrew Cowie maintainer: Andrew Cowie -copyright: © 2016-2021 Athae Eredh Siniath and Others +copyright: © 2016-2023 Athae Eredh Siniath and Others license: MIT license-file: LICENSE -tested-with: - GHC == 8.10.7 build-type: Simple +tested-with: + GHC == 9.2.5 source-repository head type: git @@ -50,7 +48,8 @@ , bytestring , chronologique , core-data - , core-program >=0.2.12 + , core-program >=0.6.5 + , core-telemetry >=0.2.7 , core-text >=0.3.4 , deepseq , directory @@ -58,6 +57,7 @@ , megaparsec , pandoc >=2.11 , pandoc-types >=1.22 + , safe-exceptions , template-haskell , text , typed-process @@ -83,7 +83,8 @@ , bytestring , chronologique , core-data - , core-program >=0.2.12 + , core-program >=0.6.5 + , core-telemetry >=0.2.7 , core-text >=0.3.4 , deepseq , directory @@ -91,6 +92,7 @@ , megaparsec , pandoc >=2.11 , pandoc-types >=1.22 + , safe-exceptions , template-haskell , text , typed-process @@ -118,7 +120,8 @@ , bytestring , chronologique , core-data - , core-program >=0.2.12 + , core-program >=0.6.5 + , core-telemetry >=0.2.7 , core-text >=0.3.4 , deepseq , directory @@ -127,6 +130,7 @@ , megaparsec , pandoc >=2.11 , pandoc-types >=1.22 + , safe-exceptions , template-haskell , text , typed-process diff --git a/src/FormatDocument.hs b/src/FormatDocument.hs --- a/src/FormatDocument.hs +++ b/src/FormatDocument.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -41,12 +42,8 @@ getFragmentName :: Program None FilePath getFragmentName = do - params <- getCommandLine - - let fragment = case lookupArgument "document" params of - Nothing -> error "invalid" - Just file -> file - return fragment + fragment <- queryArgument "document" + pure (fromRope fragment) loadFragment :: FilePath -> Program None Pandoc loadFragment file = @@ -83,12 +80,10 @@ let contents' = pandocToMarkdown doc result = file ++ "~tmp" in do - params <- getCommandLine - - let mode = case lookupOptionFlag "inplace" params of - Just False -> error "Invalid State" - Just True -> Inplace - Nothing -> Console + mode <- + queryOptionFlag "inplace" >>= \case + True -> pure Inplace + False -> pure Console case mode of Inplace -> liftIO $ do diff --git a/src/PandocToMarkdown.hs b/src/PandocToMarkdown.hs --- a/src/PandocToMarkdown.hs +++ b/src/PandocToMarkdown.hs @@ -9,6 +9,7 @@ tableToMarkdown, ) where +import qualified Control.Exception.Safe as Safe (impureThrow) import Core.System.Base import Core.Text import Data.Foldable (foldl') @@ -275,7 +276,7 @@ headerToMarkdown :: TableHead -> Rope headerToMarkdown (TableHead _ [row]) = rowToMarkdown row - headerToMarkdown _ = impureThrow (NotSafe "What do we do with this TableHead?") + headerToMarkdown _ = Safe.impureThrow (NotSafe "What do we do with this TableHead?") columnToMarkdown :: (Alignment, ColWidth) -> Rope columnToMarkdown (align, col) = @@ -317,13 +318,13 @@ cellToMarkdown (Cell _ _ (RowSpan 1) (ColSpan 1) [block]) = convert block cellToMarkdown _ = - impureThrow (NotSafe "Multiple Blocks encountered") + Safe.impureThrow (NotSafe "Multiple Blocks encountered") convert :: Block -> Rope convert (Plain inlines) = plaintextToMarkdown 100000 inlines convert _ = - impureThrow (NotSafe "Incorrect Block type encountered") + Safe.impureThrow (NotSafe "Incorrect Block type encountered") data NotSafe = NotSafe String deriving (Show) diff --git a/src/RenderDocument.hs b/src/RenderDocument.hs --- a/src/RenderDocument.hs +++ b/src/RenderDocument.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -6,15 +8,16 @@ program, ) where +import Control.Exception.Safe qualified as Safe import Control.Monad (filterM, forM_, forever, void) import Core.Data import Core.Program import Core.System +import Core.Telemetry import Core.Text import Data.Char (isSpace) -import qualified Data.List as List (dropWhileEnd, null) -import Data.Maybe (isJust) -import qualified Data.Text.IO as T +import Data.List qualified as List (dropWhileEnd, null) +import Data.Text.IO qualified as T import Environment (Bookfile (..), Env (..)) import LatexOutputReader (parseOutputForError) import LatexPreamble (beginning, ending, preamble) @@ -50,7 +53,7 @@ writeLaTeX, writerTopLevelDivision, ) -import Utilities (ensureDirectory, execProcess, ifNewer, isNewer) +import Utilities (ensureDirectory, ifNewer, isNewer) data Mode = Once | Cycle @@ -58,11 +61,10 @@ program :: Program Env () program = do - params <- getCommandLine - (mode, copy) <- extractMode params + (mode, copy) <- extractMode info "Identify .book file" - bookfile <- extractBookFile params + bookfile <- extractBookFile case mode of Once -> do @@ -74,47 +76,59 @@ renderDocument :: (Mode, Copy) -> FilePath -> Program Env [FilePath] renderDocument (mode, copy) file = do - info "Read .book file" - book <- processBookFile file + setServiceName "render" + beginTrace $ do + encloseSpan "Render document" $ do + telemetry + [ metric "bookfile" file + ] - info "Setup temporary directory" - setupTargetFile file - setupPreambleFile - validatePreamble book + book <- encloseSpan "Setup" $ do + info "Read .book file" + book <- processBookFile file - let preambles = preamblesFrom book - let fragments = fragmentsFrom book - let trailers = trailersFrom book + info "Setup temporary directory" + setupTargetFile file + setupPreambleFile + validatePreamble book - info "Convert preamble fragments and begin marker to LaTeX" - mapM_ processFragment preambles - setupBeginningFile + pure book - info "Convert document fragments to LaTeX" - mapM_ processFragment fragments + let preambles = preamblesFrom book + let fragments = fragmentsFrom book + let trailers = trailersFrom book - info "Convert end marker and trailing fragments to LaTeX" - setupEndingFile - mapM_ processFragment trailers + encloseSpan "Convert fragments" $ do + info "Convert preamble fragments and begin marker to LaTeX" + mapM_ processFragment preambles + setupBeginningFile - info "Write intermediate LaTeX file" - produceResult + info "Convert document fragments to LaTeX" + mapM_ processFragment fragments - info "Render document to PDF" - catch - ( do - renderPDF - case copy of - InstallPdf -> copyHere - NoCopyPdf -> return () - ) - ( \(e :: ExitCode) -> case mode of - Once -> throw e - Cycle -> return () - ) + info "Convert end marker and trailing fragments to LaTeX" + setupEndingFile + mapM_ processFragment trailers - return (uniqueList file preambles fragments trailers) + info "Write intermediate LaTeX file" + produceResult + encloseSpan "Render LaTeX to PDF" $ do + info "Render document to PDF" + catch + ( do + renderPDF + case copy of + InstallPdf -> copyHere + NoCopyPdf -> return () + ) + ( \(e :: ExitCode) -> case mode of + Once -> throw e + Cycle -> return () + ) + + pure (uniqueList file preambles fragments trailers) + -- -- Quickly reduce the fragment names to a unique list so we don't waste -- inotify watches. @@ -124,69 +138,70 @@ let files = insertElement file (intoSet trailers <> (intoSet preambles <> intoSet fragments)) in fromSet files -extractMode :: Parameters -> Program Env (Mode, Copy) -extractMode params = - let mode = case lookupOptionFlag "watch" params of - Just False -> error "Invalid State" - Just True -> Cycle - Nothing -> Once - copy = case lookupOptionFlag "no-copy" params of - Just False -> error "Invalid State" - Just True -> NoCopyPdf - Nothing -> InstallPdf - in return (mode, copy) +extractMode :: Program Env (Mode, Copy) +extractMode = do + mode <- + queryOptionFlag "watch" >>= \case + True -> pure Cycle + False -> pure Once + copy <- + queryOptionFlag "no-copy" >>= \case + True -> pure NoCopyPdf + False -> pure InstallPdf + + pure (mode, copy) + {- For the situation where the .book file is in a location other than '.' then chdir there first, so any relative paths within _it_ are handled properly, as are inotify watches later if they are employed. -} -extractBookFile :: Parameters -> Program Env FilePath -extractBookFile params = - let (relative, bookfile) = case lookupArgument "bookfile" params of - Nothing -> error "invalid" - Just file -> splitFileName file - in do - debugS "relative" relative - debugS "bookfile" bookfile - probe <- liftIO $ do - changeWorkingDirectory relative - doesFileExist bookfile - case probe of - True -> return bookfile - False -> do - write ("error: specified .book file \"" <> intoRope bookfile <> "\" not found.") - throw (userError "no such file") +extractBookFile :: Program Env FilePath +extractBookFile = do + file <- queryArgument "bookfile" + let (relative, bookfile) = splitFileName (fromRope file) + debugS "relative" relative + debugS "bookfile" bookfile + probe <- liftIO $ do + changeWorkingDirectory relative + doesFileExist bookfile + case probe of + True -> return bookfile + False -> do + write ("error: specified .book file \"" <> intoRope bookfile <> "\" not found.") + throw (userError "no such file") + setupTargetFile :: FilePath -> Program Env () setupTargetFile file = do env <- getApplicationState let start = startingDirectoryFrom env let dotfile = start ++ "/.target" - params <- getCommandLine - tmpdir <- case lookupOptionValue "temp" params of - Just dir -> do - -- Append a slash so that /tmp/booga is taken as a directory. - -- Otherwise, you end up ensuring /tmp exists. - ensureDirectory (dir ++ "/") - return dir - Nothing -> - liftIO $ - catch - ( do - dir' <- readFile dotfile - let dir = trim dir' - probe <- doesDirectoryExist dir - if probe - then return dir - else throw boom - ) - ( \(_ :: IOError) -> do - dir <- mkdtemp "/tmp/publish-" - writeFile dotfile (dir ++ "\n") - return dir - ) + tmpdir <- + queryOptionValue "temp" >>= \case + Just dir -> do + -- Append a slash so that /tmp/booga is taken as a directory. + -- Otherwise, you end up ensuring /tmp exists. + ensureDirectory (fromRope dir ++ "/") + return (fromRope dir) + Nothing -> + liftIO $ + Safe.catch + ( do + dir' <- readFile dotfile + let dir = trim dir' + probe <- doesDirectoryExist dir + if probe + then return dir + else Safe.throw boom + ) + ( \(_ :: IOError) -> do + dir <- mkdtemp "/tmp/publish-" + writeFile dotfile (dir ++ "\n") + return dir + ) debugS "tmpdir" tmpdir let master = tmpdir ++ "/" ++ base ++ ".tex" @@ -211,17 +226,16 @@ env <- getApplicationState let tmpdir = tempDirectoryFrom env - params <- getCommandLine - first <- case lookupOptionFlag "builtin-preamble" params of - Nothing -> return [] - Just True -> do - let name = "00_Preamble.latex" - let target = tmpdir ++ "/" ++ name - liftIO $ - withFile target WriteMode $ \handle -> do - hWrite handle preamble - return [name] - Just _ -> invalid + first <- + queryOptionFlag "builtin-preamble" >>= \case + False -> return [] + True -> do + let name = "00_Preamble.latex" + let target = tmpdir ++ "/" ++ name + liftIO $ + withFile target WriteMode $ \handle -> do + hWrite handle preamble + return [name] let env' = env{intermediateFilenamesFrom = first} setApplicationState env' @@ -233,10 +247,10 @@ -} validatePreamble :: Bookfile -> Program Env () validatePreamble book = do - params <- getCommandLine let preambles = preamblesFrom book - let builtin = isJust (lookupOptionFlag "builtin-preamble" params) + builtin <- queryOptionFlag "builtin-preamble" + if List.null preambles && not builtin then do write "error: no preamble\n" @@ -363,48 +377,57 @@ { writerTopLevelDivision = TopLevelSection } in do - env <- getApplicationState - let tmpdir = tempDirectoryFrom env - file' = replaceExtension file ".latex" - target = tmpdir ++ "/" ++ file' - files = intermediateFilenamesFrom env + encloseSpan "convertMarkdown" $ do + env <- getApplicationState + let tmpdir = tempDirectoryFrom env + file' = replaceExtension file ".latex" + target = tmpdir ++ "/" ++ file' + files = intermediateFilenamesFrom env - ensureDirectory target - ifNewer file target $ do - debugS "target" target - liftIO $ do - contents <- T.readFile file + ensureDirectory target + ifNewer file target $ do + debugS "target" target + liftIO $ do + contents <- T.readFile file - latex <- runIOorExplode $ do - parsed <- readMarkdown readingOptions contents - writeLaTeX writingOptions parsed + latex <- runIOorExplode $ do + parsed <- readMarkdown readingOptions contents + writeLaTeX writingOptions parsed - withFile target WriteMode $ \handle -> do - T.hPutStrLn handle latex - T.hPutStr handle "\n" + withFile target WriteMode $ \handle -> do + T.hPutStrLn handle latex + T.hPutStr handle "\n" - let env' = env{intermediateFilenamesFrom = file' : files} - setApplicationState env' + let env' = env{intermediateFilenamesFrom = file' : files} + setApplicationState env' + telemetry + [ metric "file" file + ] + {- If a source fragment is already LaTeX, simply copy it through to the target file. -} passthroughLaTeX :: FilePath -> Program Env () passthroughLaTeX file = do - env <- getApplicationState - let tmpdir = tempDirectoryFrom env - target = tmpdir ++ "/" ++ file - files = intermediateFilenamesFrom env + encloseSpan "passthroughLaTeX" $ do + env <- getApplicationState + let tmpdir = tempDirectoryFrom env + target = tmpdir ++ "/" ++ file + files = intermediateFilenamesFrom env - ensureDirectory target - ifNewer file target $ do - debugS "target" target - liftIO $ do - copyFileWithMetadata file target + ensureDirectory target + ifNewer file target $ do + debugS "target" target + liftIO $ do + copyFileWithMetadata file target - let env' = env{intermediateFilenamesFrom = file : files} - setApplicationState env' + let env' = env{intermediateFilenamesFrom = file : files} + setApplicationState env' + telemetry + [ metric "file" file + ] {- Images in SVG format need to be converted to PDF to be able to be @@ -413,45 +436,53 @@ -} convertImage :: FilePath -> Program Env () convertImage file = do - env <- getApplicationState - let tmpdir = tempDirectoryFrom env - basepath = dropExtension file - target = tmpdir ++ "/" ++ basepath ++ ".pdf" - buffer = tmpdir ++ "/" ++ basepath ++ "~tmp.pdf" - inkscape = - [ "inkscape" - , "--export-type=pdf" - , "--export-filename=" ++ buffer - , file + encloseSpan "convertImage" $ do + telemetry + [ metric "file" file ] + env <- getApplicationState + let tmpdir = tempDirectoryFrom env + basepath = dropExtension file + target = tmpdir ++ "/" ++ basepath ++ ".pdf" + buffer = tmpdir ++ "/" ++ basepath ++ "~tmp.pdf" + inkscape = + [ "inkscape" + , "--export-type=pdf" + , "--export-filename=" ++ buffer + , file + ] - ifNewer file target $ do - debugS "target" target - (exit, out, err) <- do - ensureDirectory target - execProcess inkscape + ifNewer file target $ do + debugS "target" target + (exit, out, err) <- do + ensureDirectory target + readProcess (fmap intoRope inkscape) - case exit of - ExitFailure _ -> do - info "Image processing failed" - debug "stderr" (intoRope err) - debug "stdout" (intoRope out) - write ("error: Unable to convert " <> intoRope file <> " from SVG to PDF") - throw exit - ExitSuccess -> liftIO $ do - renameFile buffer target + case exit of + ExitFailure _ -> do + info "Image processing failed" + debug "stderr" (intoRope err) + debug "stdout" (intoRope out) + write ("error: Unable to convert " <> intoRope file <> " from SVG to PDF") + throw exit + ExitSuccess -> liftIO $ do + renameFile buffer target passthroughImage :: FilePath -> Program Env () passthroughImage file = do - env <- getApplicationState - let tmpdir = tempDirectoryFrom env - target = tmpdir ++ "/" ++ file + encloseSpan "passthroughImage" $ do + telemetry + [ metric "file" file + ] + env <- getApplicationState + let tmpdir = tempDirectoryFrom env + target = tmpdir ++ "/" ++ file - ensureDirectory target - ifNewer file target $ do - debugS "target" target - liftIO $ do - copyFileWithMetadata file target + ensureDirectory target + ifNewer file target $ do + debugS "target" target + liftIO $ do + copyFileWithMetadata file target {- Finish up by writing the intermediate "master" file. @@ -470,38 +501,40 @@ let (path, name) = splitFileName file hPutStrLn handle ("\\subimport{" ++ path ++ "}{" ++ name ++ "}") -getUserID :: Program a String +getUserID :: Program a Rope getUserID = liftIO $ do uid <- getEffectiveUserID gid <- getEffectiveGroupID - return (show uid ++ ":" ++ show gid) + return (intoRope (show uid ++ ":" ++ show gid)) renderPDF :: Program Env () renderPDF = do env <- getApplicationState - let master = masterFilenameFrom env - tmpdir = tempDirectoryFrom env + let master = intoRope (masterFilenameFrom env) + tmpdir = intoRope (tempDirectoryFrom env) user <- getUserID - params <- getCommandLine - let command = case lookupOptionValue "docker" params of + command <- + queryOptionValue "docker" >>= \case Just image -> - [ "docker" - , "run" - , "--rm=true" - , "--volume=" ++ tmpdir ++ ":" ++ tmpdir - , "--user=" ++ user - , image - , "latexmk" - ] + pure + [ "docker" + , "run" + , "--rm=true" + , "--volume=" <> tmpdir <> ":" <> tmpdir + , "--user=" <> user + , intoRope image + , "latexmk" + ] Nothing -> - [ "latexmk" - ] - options = + pure + [ "latexmk" + ] + let options = [ "-lualatex" - , "-output-directory=" ++ tmpdir + , "-output-directory=" <> tmpdir , "-interaction=nonstopmode" , "-halt-on-error" , "-file-line-error" @@ -510,13 +543,13 @@ ] latexmk = command ++ options - (exit, out, err) <- execProcess latexmk + (exit, out, err) <- readProcess latexmk case exit of ExitFailure _ -> do info "Render failed" - debug "stderr" (intoRope err) - debug "stdout" (intoRope out) - write (parseOutputForError tmpdir out) + debug "stderr" err + debug "stdout" out + write (parseOutputForError (fromRope tmpdir) out) throw exit ExitSuccess -> return () @@ -537,3 +570,7 @@ info "Complete" False -> do info "Result unchanged" + + telemetry + [ metric "changed" changed + ] diff --git a/src/RenderMain.hs b/src/RenderMain.hs --- a/src/RenderMain.hs +++ b/src/RenderMain.hs @@ -6,6 +6,7 @@ module Main where import Core.Program +import Core.Telemetry import Core.Text import Environment (initial) import RenderDocument (program) @@ -83,4 +84,6 @@ ] ) - executeWith context program + context' <- initializeTelemetry [consoleExporter, structuredExporter, honeycombExporter] context + + executeWith context' program diff --git a/src/Utilities.hs b/src/Utilities.hs --- a/src/Utilities.hs +++ b/src/Utilities.hs @@ -4,7 +4,6 @@ module Utilities ( ensureDirectory, - execProcess, ifNewer, isNewer, ) where @@ -13,17 +12,13 @@ import Control.Monad (when) import Core.Program import Core.System -import Core.Text -import qualified Data.List as List (intercalate) import System.Directory ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getModificationTime, ) -import System.Exit (ExitCode (..)) import System.FilePath.Posix (takeDirectory) -import System.Process.Typed (closed, proc, readProcess, setStdin) {- Some source files live in subdirectories. Replicate that directory @@ -36,28 +31,6 @@ probe <- doesDirectoryExist subdir when (not probe) $ do createDirectoryIfMissing True subdir - -{- -Thin wrapper around **typed-process**'s `readProcess` so that the command -to be executed can be logged. Bit of an annoyance that the command and the -arguments have to be specified to `proc` separately, but that's _execvp(3)_ -for you. - -TODO this could potentially move to the **unbeliever** library --} -execProcess :: [String] -> Program t (ExitCode, Rope, Rope) -execProcess [] = error "No command provided" -execProcess (cmd : args) = - let task = proc cmd args - task' = setStdin closed task - command = List.intercalate " " (cmd : args) - in do - debugS "command" command - - (exit, out, err) <- liftIO $ do - readProcess task' - - return (exit, intoRope out, intoRope err) {- | If the source file is newer than the target file, then run an action. For diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -1,17 +1,18 @@ +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} import CheckBookfileParser import CheckTableProperties import CompareFragments -import Core.System +import Control.Exception.Safe qualified as Safe import Test.Hspec main :: IO () main = do - finally (hspec suite) (putStrLn ".") + Safe.finally (hspec suite) (putStrLn ".") suite :: Spec suite = do - checkTableProperties - checkByComparingFragments - checkBookfileParser + checkTableProperties + checkByComparingFragments + checkBookfileParser