slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

imp: setup: smarter logic, more robustness

Browse Source 
- Test the hledger in PATH, not the one running
- Handle old hledger versions as well as recent ones
- Handle errors, remove early terminations
This commit is contained in:
Simon Michael 2025-04-21 15:15:54 -10:00
parent 5334e7924b
commit 4529a8c4a1
1 changed files with 186 additions and 109 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

295
hledger/Hledger/Cli/Commands/Setup.hs
View File

@ -13,6 +13,7 @@ Check and show the status of the hledger installation.
{-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-}
{-# LANGUAGE MultiWayIf #-}
-- {-# OPTIONS_GHC -Wno-unused-matches #-} -- {-# OPTIONS_GHC -Wno-unused-matches #-}
module Hledger.Cli.Commands.Setup ( module Hledger.Cli.Commands.Setup (
@ -24,31 +25,29 @@ where
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import Control.Exception import Control.Exception
import Control.Monad import Control.Monad
import Data.Functor ((<&>)) import Data.Char
import Data.List
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.Maybe import Data.Maybe
-- import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding as T
-- import qualified Data.Text.IO as T
import Network.HTTP.Client import Network.HTTP.Client
import Network.HTTP.Types (statusCode, hLocation) import Network.HTTP.Types (statusCode, hLocation)
import Network.HTTP.Req as R import Network.HTTP.Req as R
import Safe import Safe
import System.Directory import System.Directory
import System.Environment (lookupEnv)
import System.Exit import System.Exit
import System.FilePath import System.FilePath
import System.Info import System.Info
-- import System.IO
import System.Process import System.Process
import Text.Megaparsec.Error (errorBundlePretty)
import Text.Printf (printf) import Text.Printf (printf)
import Hledger import Hledger
import Hledger.Cli.CliOptions import Hledger.Cli.CliOptions
import Hledger.Cli.Conf import Hledger.Cli.Conf
import System.Environment (lookupEnv) import Hledger.Cli.Version (Version, toVersion)
import Data.Char
import Data.List
setupmode = hledgerCommandMode setupmode = hledgerCommandMode
$(embedFileRelative "Hledger/Cli/Commands/Setup.txt") $(embedFileRelative "Hledger/Cli/Commands/Setup.txt")
@ -57,31 +56,68 @@ setupmode = hledgerCommandMode
[] []
([], Nothing) ([], Nothing)
-- | Test and print the status of various aspects of the hledger installation.
-- Also show extra info and hints on how to fix problems. {- | Test and print the status of various aspects of the hledger installation.
May also show extra info and hints on how to fix problems.
The goal is to detect and show as much useful information as possible,
and to complete this task reliably regardless of what we find,
without premature termination or misformatting.
The tests are grouped into setup* routines, so named because they might do more
than just test in future.
The first group of tests checks the hledger executable found in PATH.
Note, later tests which require running hledger should use this executable,
rather than the API of the hledger currently running (in case they're different).
This hledger executable could be old; we can't assume it has modern flags/commands.
Eg its --version output may be less than usual, or it may not have the check command.
Or it may not accept -n/--no-conf, which we may need to avoid disruption from config files.
Eg there's an inconvenient bug in hledger 1.40-1.42ish: without -n, a bad config file
breaks pretty much everything, including --version, --help, and test.
So we first try hledger --version -n; if this fails, we try hledger --version.
(For absolute precision we should perhaps check the failure output for "Unknown flag: -n"..)
If we are able to detect the version, we use that to decide how and whether to run
later tests. Eg, for hledger <1.40, we won't run config tests, and won't use -n.
-}
setup :: CliOpts -> Journal -> IO () setup :: CliOpts -> Journal -> IO ()
setup _opts@CliOpts{rawopts_=_rawopts, reportspec_=_rspec} _ignoredj = do setup _opts@CliOpts{rawopts_=_rawopts, reportspec_=_rspec} _ignoredj = do
-- This command is not given a journal and should not use _ignoredj; -- This command is not given a journal and should not use _ignoredj;
-- instead detect it ourselves when we are ready. -- instead detect it ourselves when we are ready.
putStrLn "Checking your hledger setup.." putStrLn "Checking your hledger setup.."
setupHledger mversion <- setupHledger
setupConfig case mversion of
setupFile Nothing -> return ()
-- setupAccounts Just (_, version) -> do
-- setupCommodities when (supportsConfig version) setupConfig
-- setupTags setupFile version
-- setupAccounts version
-- setupCommodities version
-- setupTags version
return ()
putStr "\n" putStr "\n"
supportsIgnoreAssertions = (>= 0 :| [24]) -- hledger 0.24+ supports --ignore-assertions
supportsConfig = (>= 1 :| [40]) -- hledger 1.40+ supports config files
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
setupHledger :: IO () -- | This first test group looks for a "hledger" executable in PATH;
-- if found, tests it in various ways;
-- and if it ran successfully, returns the full --version output
-- and the numeric Version parsed from that.
setupHledger :: IO (Maybe (String, Version))
setupHledger = do setupHledger = do
pgroup "hledger" pgroup "hledger"
pdesc "is in PATH ?" pdesc "is in PATH ?"
pathexes <- findExecutables progname pathexes <- findExecutables progname
home <- getHomeDirectory home <- getHomeDirectory
appdata <- getXdgDirectory XdgData "" appdata <- getXdgDirectory XdgData ""
otherexes <- flip findExecutablesInDirectories progname $ otherexes <- flip findExecutablesInDirectories progname $
[home </> ".local/bin" [home </> ".local/bin"
,home </> ".cabal/bin" ,home </> ".cabal/bin"
@ -92,72 +128,80 @@ setupHledger = do
] ]
++ [appdata </> "local/bin" | os == "mingw32"] ++ [appdata </> "local/bin" | os == "mingw32"]
++ [appdata </> "cabal/bin" | os == "mingw32"] ++ [appdata </> "cabal/bin" | os == "mingw32"]
let case (pathexes, otherexes) of
ok = if null pathexes then N else Y ([], []) -> do
pathexe = quoteIfNeeded $ headDef (error' "showing nonexistent executable") pathexes p N $ "Move the " <> progname <> " binary to a directory in your shell's PATH"
otherexe = quoteIfNeeded $ headDef (error' "showing nonexistent executable") otherexes return Nothing
otherdir = takeDirectory otherexe ([], otherexe:_) -> do
msg let otherdir = takeDirectory otherexe
| ok == Y = pathexe p N $ unlines
| null otherexes = "Add " <> progname <> "'s directory to your shell's PATH." ["Add " <> otherdir <> " to PATH in your shell config."
| otherwise = unlines ," Eg on unix: echo 'export PATH=" <> otherdir <> ":$PATH' >> ~/.profile"
["Add " <> otherdir <> " to PATH in your shell config." ," and start a new shell session."
," Eg on unix: echo 'export PATH=" <> otherdir <> ":$PATH' >> ~/.profile" ]
," and start a new shell session." return Nothing
] (pathexe:_, _) -> do
p ok msg p Y (quoteIfNeeded pathexe)
-- If hledger was found in PATH, run more checks -- If hledger was found in PATH, do more checks
when (ok==Y) $ do
pdesc "runs ?" pdesc "runs ?"
let arg = "--version" eerrout <- tryHledgerArgs [["--version", "--no-conf"], ["--version"]]
(exit,out,err) <- readProcessWithExitCode progname [arg] "" case eerrout of
let Left err -> p N ("'" <> progname <> " --version' failed: \n" <> err) >> return Nothing
ok = if exit == ExitSuccess then Y else N Right out -> do
msg = if ok==Y then "" else "'" <> progname <> " " <> arg <> "' failed: \n" <> err p Y ""
p ok msg
-- save output, used below
let
versionstr = rstrip out
versionstrparts = words versionstr
-- If hledger runs, run more checks -- If it runs, do more checks
when (ok==Y) $ do let
pdesc "is a native binary ?" versionoutput = rstrip out
let versionwords = words versionoutput
exearch = case drop 2 versionstrparts of
w:_ -> w
_ -> error' "couldn't parse arch from --version output"
os' -- keep synced: Version.hs
| os == "darwin" = "mac"
| os == "mingw32" = "windows"
| otherwise = os
sysarch = os' <> "-" <> arch
(ok, msg)
| exearch == sysarch = (Y, versionstr)
| otherwise = (N, "installed binary is for " <> exearch <> ", system is " <> sysarch)
p ok msg
pdesc "is up to date ?" pdesc "is a native binary ?"
elatestver <- getLatestHledgerVersion let
let sysarch = os' <> "-" <> arch
(ok, msg) = case elatestver of where
Left e -> (U, "could not read " <> latestHledgerVersionUrlStr <> " : " <> e) os' -- keep synced: Version.hs
Right latestver -> | os == "darwin" = "mac"
case drop 1 versionstrparts of | os == "mingw32" = "windows"
[] -> (U, "could not parse --version output") | otherwise = os
w:_ -> (ok, msg) case drop 2 versionwords of
where exearch:_ -> if exearch == sysarch
exever = takeWhile (`elem` ("0123456789."::String)) w then p Y versionoutput
ok = if splitAtElement '.' exever >= splitAtElement '.' latestver then Y else N else p N $ "installed binary is for " <> exearch <> ", system is " <> sysarch
msg = _ -> p U $ "couldn't detect arch in --version output"
if exever == latestver
then exever pdesc "is up to date ?"
else exever <> " installed, latest is " <> latestver elatestversionnumstr <- getLatestHledgerVersion
p ok msg case elatestversionnumstr of
Right latestversionnumstr ->
case drop 1 versionwords of
[] -> p U "couldn't parse --version output" >> return Nothing
detailedversionstr:_ -> do
let
versionnumstr = takeWhile (`elem` ("0123456789." :: String)) detailedversionstr
mversion = toVersion versionnumstr
mlatestversion = toVersion latestversionnumstr
case (mversion, mlatestversion) of
(Nothing, _) -> p U "couldn't parse --version's version number" >> return Nothing
(_, Nothing) -> p U "couldn't parse latest version number" >> return Nothing
(Just version, Just latest) -> do
p (if version >= latest then Y else N) (versionnumstr <> " installed, latest is " <> latestversionnumstr)
return (Just (versionoutput, version))
Left e -> do
-- couldn't detect the latest version, but still return version info for the installed version
-- XXX duplication, refactor
case drop 1 versionwords of
[] -> p U "couldn't parse --version output" >> return Nothing
detailedversionstr:_ -> do
let
versionnumstr = takeWhile (`elem` ("0123456789." :: String)) detailedversionstr
mversion = toVersion versionnumstr
p U ("couldn't read " <> latestHledgerVersionUrlStr <> " : " <> e)
return $ case mversion of
Nothing -> Nothing
Just version -> Just (versionoutput, version)
-- pdesc "eget installed ?"
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
@ -187,12 +231,13 @@ setupConfig = do
let mf = mlf <|> muf let mf = mlf <|> muf
case mf of case mf of
Nothing -> return () Nothing -> return ()
Just f -> do Just _ -> do
pdesc "config file is readable ?" pdesc "this hledger can read the config file ?"
ecs <- readFile f <&> parseConf f . T.pack -- Test config file readability, without requiring journal file readability, forward compatibly.
case ecs of (exit, _, err) <- readProcessWithExitCode progname ["print", "-f-"] ""
Right _ -> p Y "" case exit of
Left e -> p N (errorBundlePretty e) ExitSuccess -> p Y ""
ExitFailure _ -> p N ("\n"<>err)
-- pdesc "common general options configured ?" -- pdesc "common general options configured ?"
-- --pretty --ignore-assertions --infer-costs" -- --pretty --ignore-assertions --infer-costs"
@ -200,7 +245,7 @@ setupConfig = do
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
setupFile = do setupFile version = do
pgroup "file" pgroup "file"
pdesc "a home directory journal file exists ?" pdesc "a home directory journal file exists ?"
@ -250,11 +295,21 @@ setupFile = do
else (Y, "") else (Y, "")
p ok msg p ok msg
pdesc "default journal file is readable ?" pdesc "this hledger can read default journal ?"
ej <- runExceptT $ readJournalFile definputopts jfile -- like defaultJournal -- Basic readability check: ignoring config files if it's hledger >=1.40,
case ej of -- and balance assertions if possible (can't if it's hledger <=0.23),
Right _ -> p Y "" -- try read the file (ie do the parseable and autobalanced checks pass).
Left e -> p N e let
args = concat [
["print"],
["--ignore-assertions" | supportsIgnoreAssertions version],
["--no-conf" | supportsConfig version]
]
(exit, _, err) <- readProcessWithExitCode progname args ""
case exit of
ExitSuccess -> p Y ""
ExitFailure _ -> p N ("\n"<>err)
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
@ -293,12 +348,12 @@ data YNU = Y | N | U deriving (Eq)
-- Show status, in red/green/yellow if supported. -- Show status, in red/green/yellow if supported.
instance Show YNU where instance Show YNU where
show Y = bold' (brightGreen' "yes") -- ✅ apple emojis - won't work everywhere show Y = bold' (brightGreen' "yes") -- ✅ apple emojis - won't work everywhere
show N = bold' (brightRed' "no ") -- ❌ show N = bold' (brightRed' " no") -- ❌
show U = bold' (brightYellow' " ? ") show U = bold' (brightYellow' " ? ")
-- Show status, in blue/yellow if supported. -- Show status, in blue/yellow if supported.
showInfo Y = bold' (brightBlue' "yes") -- ℹ️ showInfo Y = bold' (brightBlue' "yes") -- ℹ️
showInfo N = bold' (brightBlue' "no ") -- ℹ️ showInfo N = bold' (brightBlue' " no") -- ℹ️
showInfo U = bold' (brightYellow' " ? ") showInfo U = bold' (brightYellow' " ? ")
-- | Print a test's pass or fail status, as "yes" or "no" or "", -- | Print a test's pass or fail status, as "yes" or "no" or "",
@ -316,7 +371,7 @@ pgroup s = putStrLn $ "\n" <> bold' s
-- | Print a setup test's description, formatting and padding it to a fixed width. -- | Print a setup test's description, formatting and padding it to a fixed width.
pdesc :: String -> IO () pdesc :: String -> IO ()
pdesc s = printf "* %-38s" s pdesc s = printf "* %-40s" s
(getLatestHledgerVersion, latestHledgerVersionUrlStr) = (getLatestHledgerVersion, latestHledgerVersionUrlStr) =
-- (getLatestHledgerVersionFromHackage, "https://hackage.haskell.org/package/hledger/docs") -- (getLatestHledgerVersionFromHackage, "https://hackage.haskell.org/package/hledger/docs")
@ -345,7 +400,7 @@ getLatestHledgerVersionFromHackage = do
let packagename = take 1 $ drop 1 $ reverse $ T.splitOn "/" location let packagename = take 1 $ drop 1 $ reverse $ T.splitOn "/" location
case packagename of case packagename of
[n] -> return $ Right $ dropWhile (`notElem` ['0'..'9']) $ T.unpack n [n] -> return $ Right $ dropWhile (`notElem` ['0'..'9']) $ T.unpack n
_ -> return $ Left "could not parse Location" _ -> return $ Left "couldn't parse Location"
else return $ Left $ "HTTP status " ++ show status else return $ Left $ "HTTP status " ++ show status
Left err -> return $ Left $ "other exception: " ++ show err Left err -> return $ Left $ "other exception: " ++ show err
@ -353,15 +408,37 @@ getLatestHledgerVersionFromHackage = do
getLatestHledgerVersionFromHledgerOrg :: IO (Either String String) getLatestHledgerVersionFromHledgerOrg :: IO (Either String String)
getLatestHledgerVersionFromHledgerOrg = do getLatestHledgerVersionFromHledgerOrg = do
let url = https "hledger.org" /: "install.html" let url = https "hledger.org" /: "install.html"
result <- try $ runReq defaultHttpConfig $ do
req GET url NoReqBody bsResponse (R.responseTimeout httptimeout) result <- try $ runReq defaultHttpConfig $ req GET url NoReqBody bsResponse (R.responseTimeout httptimeout)
case result of case result of
Left (e :: R.HttpException) -> return $ Left $ show e Left (e :: R.HttpException) -> return $ Left $ show e
Right rsp -> case T.decodeUtf8' $ R.responseBody rsp of Right rsp -> case T.decodeUtf8' $ R.responseBody rsp of
Left e -> return $ Left $ show e Left e -> return $ Left $ show e
Right t -> return $ Right t -> return $
if null version then Left "could not parse version" else Right version if null version then Left "couldn't parse version" else Right version
where where
-- keep synced -- keep synced
versionline = take 1 $ dropWhile (not . ("current hledger release" `isInfixOf`)) $ lines $ T.unpack t versionline = take 1 $ dropWhile (not . ("current hledger release" `isInfixOf`)) $ lines $ T.unpack t
version = takeWhile (`elem` ("0123456789."::[Char])) $ dropWhile (not . isDigit) $ headDef "" $ versionline version = takeWhile (`elem` ("0123456789."::[Char])) $ dropWhile (not . isDigit) $ headDef "" $ versionline
-- work around potential failure on mac (& possible security issue, reported upstream)
`catch` (\(_ :: IOError) -> return $ Left "req failed (mac PATH issue ?)")
-- | Try to run the hledger in PATH with one or more sets of command line arguments.
-- Returns the output from the first set of arguments that runs successfully,
-- or the error output from the last set.
tryHledgerArgs :: [[String]] -> IO (Either String String)
tryHledgerArgs [] = pure $ Left "tryHledgerArgs: no arguments provided"
tryHledgerArgs (args:rest) = do
eresult <- runHledger args
case eresult of
Right out -> pure $ Right out
Left err -> if null rest then pure $ Left err else tryHledgerArgs rest
-- | Run the hledger in PATH with the given command line arguments,
-- returning the output on success or the error output on failure.
runHledger :: [String] -> IO (Either String String)
runHledger args = do
(exit, out, err) <- readProcessWithExitCode "hledger" args ""
pure $ case exit of
ExitSuccess -> Right out
ExitFailure _ -> Left err