hledger-1.52: Hledger/Cli/Commands/Setup.hs
{-|
Check and show the status of the hledger installation.
-}
{-
Old design notes:
## Goals
- Make getting started with hledger and PTA easier and quicker, to
(a) make this practical for more people (non techies, busy techies..)
(b) free up more time and energy for learning and doing PTA and finance
Subgoals:
- Reduce the special knowledge and docs needed after install, to get a standard setup working (especially on windows)
- Help with discovery and setup of advanced quality of life terminal features
- Assist with setting up a first or new journal file
- Deliver relevant install/setup/config expertise more efficiently, freeing up dev and support time
## Design
Why a built in command and not a shell script, haskell script, or docs ?
So it is available and runs reliably anywhere a hledger executable runs, and so it can detect more context-specific advice.
(Optionally use shell or haskell scripts for prototyping, if that's helpful)
## Setup checks
Somewhat ordered.
These deal with the complexities of terminals, the shell, GHC, hledger, and the user's machine, locale, and data.
Initially just informational hints.
Later, add automated or interactive diagnosis and repair attempts,
and semi-persistent state (invalidated at suitable times).
These checks are a necessary evil/stopgap; long term, automate/replace/remove them whenever possible.
-}
-- {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
-- {-# LANGUAGE NamedFieldPuns #-}
-- {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
-- {-# OPTIONS_GHC -Wno-unused-matches #-}
module Hledger.Cli.Commands.Setup (
setupmode
,setup
)
where
import Control.Concurrent (rtsSupportsBoundThreads)
import Control.Exception
import Control.Monad
-- import Data.ByteString qualified as B
import Data.Char
import Data.Default (def)
import Data.List
import Data.Map qualified as M
import Data.Maybe
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Version qualified (showVersion)
import Network.HTTP.Client
import Network.HTTP.Types (statusCode, hLocation)
import Network.HTTP.Req as R
import Safe
import System.Directory
import System.Environment (getEnvironment, lookupEnv)
import System.Exit
import System.FilePath
import System.Info
import System.Process
import Text.Printf (printf)
import Hledger
import Hledger.Cli.CliOptions
import Hledger.Cli.Conf
import Hledger.Cli.Version
import System.IO (localeEncoding, stdout, hFlush)
setupmode = hledgerCommandMode
$(embedFileRelative "Hledger/Cli/Commands/Setup.txt")
[]
[generalflagsgroup3]
[]
([], Nothing)
{- | 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.
This is the second version of setup. If it finds that the currently
running hledger is not the one installed in PATH (by comparing --version output),
it refuses to proceed further until that has been done.
This means it can rely on all the latest features and use the hledger API
within this process, simplifying things greatly.
-}
setup :: CliOpts -> Journal -> IO ()
setup _opts@CliOpts{rawopts_=_rawopts, reportspec_=_rspec} _ignoredj = do
-- This command is not given a journal and should not use _ignoredj;
-- instead read it ourselves when we are ready.
putStrLn "Checking your hledger setup.."
color <- useColorOnStdout
when color $
putStrLn $ "Legend: " <> intercalate ", " [
good "good"
,neutral "neutral"
,warning "unknown"
,bad "warning"
]
meconf <- setupHledger
setupTerminal meconf
setupJournal meconf
putStr "\n"
------------------------------------------------------------------------------
-- Returns Nothing if no config file was found,
-- or Just the read error or config if it was found.
setupHledger :: IO (Maybe (Either String Conf))
setupHledger = do
pgroup "hledger"
let
os'
| os=="darwin" = "macos"
| os=="mingw32" = "windows"
| otherwise = os
mosversion <- getOSVersion
let osdesc = os' <> maybe "" (" "<>) mosversion
pdesc "is running on"
putStrLn $ " " <> osdesc <> " on " <> arch
pdesc "is built with a supported compiler/RTS"
p (if rtsSupportsBoundThreads then Y else N) $
compilerName <> " " <> Data.Version.showVersion fullCompilerVersion
<> if rtsSupportsBoundThreads then ", using threaded RTS" else ", RTS does not have threads enabled"
pdesc "is a native binary for this machine ?"
case hbinArch binaryinfo of
Nothing -> p U $ "couldn't detect this binary's architecture"
Just a | a /= arch -> p N $ "binary is for " <> a <> ", system is " <> arch <> ", may run slowly"
Just a -> p Y a
pdesc "is a released version ?"
if isReleaseVersion $ hbinPackageVersion binaryinfo
then p Y prognameandversion
else i N prognameandversion
pdesc "is up to date ? checking latest..." >> hFlush stdout
elatestversionnumstr <- getLatestHledgerVersion
case elatestversionnumstr of
Left e -> p U ("couldn't read " <> latestHledgerVersionUrlStr <> " " <> e)
Right latestversionnumstr ->
case toVersion latestversionnumstr of
Nothing -> p U "couldn't parse latest version number"
Just latestversion -> p
(if hbinPackageVersion binaryinfo >= latestversion then Y else N)
("latest is " <> latestversionnumstr <> ", " <> showVersion (hbinPackageVersion binaryinfo) <> " is installed")
pdesc "is installed in PATH (this version) ?"
pathexes <- findExecutables progname
let
(failaction, failmsg) =
-- (exitFailure , "Please install this hledger in PATH then run setup again.")
(return () , " Some of this info may not apply to that hledger version. Continuing anyway..")
case pathexes of
[] -> p N failmsg >> failaction
exe:_ -> do
eerrout <- tryHledgerArgs [["--version", "--no-conf"], ["--version"]]
case eerrout of
Left err -> p U (progname <> " --version failed: " <> err) >> failaction
Right out -> do
case parseHledgerVersion out of
Left _ -> p U ("couldn't parse " <> progname <> " --version: " <> rstrip out) >> exitFailure
Right pathbin -> do
let pathversion = hbinVersionOutput pathbin
if pathversion /= prognameandversion
then p N (chomp $ unlines [
""
," A different hledger version was found in PATH: " <> pathversion
," at: " <> exe
,failmsg
]) >> failaction
else p Y exe
pdesc "has a system text encoding configured ?"
let encoding = localeEncoding -- the initial system encoding
if map toLower (show encoding) == "ascii"
then p N (show encoding <> ", please configure an encoding for non-ascii data")
else p Y (show encoding <> ", data files must use this encoding")
-- pdesc "can handle UTF-8 text ?"
-- let
-- eAcuteUtf8 = B.pack [0xC3, 0xA9]
-- eAcuteLatin1 = B.pack [0xE9]
-- case T.decodeUtf8' eAcuteUtf8 of
-- Left _ -> p N "hledger's docs and examples use UTF-8"
-- Right t -> p Y (T.unpack t)
-- pdesc "can report text decoding failures ?"
-- i U (T.unpack $ T.decodeUtf8 eAcuteLatin1)
pdesc "has a user config file ?"
muf <- activeUserConfFile
mlf <- activeLocalConfFile
let
(ok, msg) = case muf of
Just f -> (Y, f <> if isJust mlf then " (overridden)" else "")
Nothing -> (N, "")
i ok msg
pdesc "has a local config file ?"
let
(ok, msg) = case mlf of
Just f -> (Y, f)
Nothing -> (N, "")
i ok msg
if (isJust muf || isJust mlf) then do
pdesc "the config file is readable ?"
econf <- getConf def
case econf of
Left e -> p N e >> return (Just $ Left e)
Right (conf, _) -> do
p Y ""
-- pdesc "common general options are configured ?"
-- --infer-costs"
-- print --explicit --infer-costs"
return $ Just $ Right conf
else
return Nothing
------------------------------------------------------------------------------
setupTerminal meconf = do
pgroup "terminal"
let
-- Find the last opt/arg matched by a predicate in the general config, if there is one.
conflookup predicate = case meconf of
Just (Right conf) -> find predicate $ reverse $ confLookup "general" conf
_ -> Nothing
pdesc "the NO_COLOR variable is defined ?"
mnocolor <- lookupEnv "NO_COLOR"
case mnocolor of
Nothing -> i N ""
Just _ -> i Y ""
meconfigcolor <- do
pdesc "--color is configured by config file ?"
let mcolorarg = conflookup (\a -> any (`isPrefixOf` a) ["--color", "--colour"])
case mcolorarg of
Nothing -> i N "" >> return Nothing
Just a -> do
i Y a
let
arg = reverse $ takeWhile (`notElem` ['=',' ']) $ reverse a
return $ Just $ parseYNA arg
pdesc "hledger will use color by default ?"
case (meconfigcolor, isJust mnocolor) of
(Just (Right Yes), _) -> p Y ""
(Just (Right No), _) -> i N ""
(_, True) -> i N ""
(_, False) -> p Y ""
pdesc "the PAGER variable is defined ?"
mv <- lookupEnv "PAGER"
case mv of
Nothing -> i N ""
Just v -> i Y v
pdesc "--pager is configured by config file ?"
let mpagerarg = conflookup ("--pager" `isPrefixOf`)
meconfpager <- case mpagerarg of
Nothing -> i N "" >> return Nothing
Just a -> do
i Y a
let arg = reverse $ takeWhile (`notElem` ['=',' ']) $ reverse a
return $ Just $ parseYNA arg
pdesc "hledger will use a pager when needed ?"
mpager <- findPager
case mpager of
Nothing -> i N "no pager was found"
Just pager ->
case meconfpager of
Just (Right No) -> i N "disabled in config file"
_ -> do
p Y pager
when (map toLower (takeBaseName pager) == "more") $ do
pdesc "the MORE variable is defined ?"
mv <- lookupEnv "MORE"
case mv of
Nothing -> i N ""
Just v -> i Y v
when (map toLower (takeBaseName pager) == "less") $ do
mHLEDGER_LESS <- lookupEnv "HLEDGER_LESS"
mLESS <- lookupEnv "LESS"
pdesc "the LESS variable is defined ?"
case mLESS of
Nothing -> i N ""
Just v -> i Y $ v <> if isJust mHLEDGER_LESS then " (overridden)" else ""
pdesc "the HLEDGER_LESS variable is defined ?"
case mHLEDGER_LESS of
Nothing -> i N ""
Just v -> i Y v
when (isNothing mHLEDGER_LESS) $ do
pdesc "adjusting LESS var for consistent UX ?"
usecolor <- useColorOnStdout
i Y $ lessVarValue mHLEDGER_LESS mLESS usecolor
pdesc "less is working with these options ?"
usecolor <- useColorOnStdout
let newlessvar = lessVarValue mHLEDGER_LESS mLESS usecolor
env <- getEnvironment
let customEnv = ("LESS", newlessvar) : filter ((/= "LESS") . fst) env
lessHasError <- lessIsWorking (Just customEnv)
if lessHasError
then p N "less --version shows a problem, check LESS/HLEDGER_LESS settings"
else p Y ""
pdesc "box-drawing chars are used by default ?"
if isJust $ conflookup ("--pretty"==)
then p Y ""
else i N "you can use --pretty to enable them"
-- pdesc "bash shell completions are installed ?" >> p U ""
-- pdesc "zsh shell completions are installed ?" >> p U ""
------------------------------------------------------------------------------
setupJournal meconf = do
pgroup "journal"
let
-- Find the last opt/arg matched by a predicate in the general config, if there is one.
conflookup predicate = case meconf of
Just (Right conf) -> find predicate $ reverse $ confLookup "general" conf
_ -> Nothing
-- pdesc "a home directory journal file exists ?"
-- mh <- getHomeSafe
-- (ok,msg) <- case mh of
-- Just h -> do
-- let f = h </> journalDefaultFilename
-- e <- doesFileExist f
-- return (if e then Y else N, if e then f else "")
-- Nothing -> return (N, "")
-- i ok msg
pdesc "the LEDGER_FILE variable is defined ?"
mf <- lookupEnv journalEnvVar
let
(ok, msg) = case mf of
Just f -> (Y, f)
Nothing -> (N, "")
i ok msg
-- case mf of
-- Nothing -> return ()
-- Just f -> do
-- pdesc "$LEDGER_FILE journal exists ?"
-- e <- doesFileExist f
-- i e "" ""
-- when (isJust mh && isJust mf) $ do
-- pdesc "$LEDGER_FILE is masking home journal ?"
-- i Y ""
pdesc "a default journal file is readable ?"
ef <- defaultJournalPathSafely
-- let
-- args = concat [
-- ["print"],
-- ["--ignore-assertions" | supportsIgnoreAssertions version],
-- ["--no-conf" | supportsConfigFiles version]
-- ]
-- (exit, _, err) <- readProcessWithExitCode progname args ""
-- XXX can this ignore assertions and config files, like the above ?
ej <- defaultJournalSafely
let trim s = either (const s) id $ regexReplace (toRegex' "^Error: ") "" s
case (ef, ej) of
(Left err, _) -> p N $ trim err
(Right f, Left err) -> p N (f <> ":\n" <> trim err)
(Right f, Right j@Journal{..}) -> do
p Y f
pdesc "it includes additional files ?"
let numfiles = length jfiles
if numfiles > 1
then i Y (show (numfiles - 1) <> " files")
else i N ""
pdesc "all commodities are declared ?"
let
numcommodities = length $ journalCommodities j
undeclaredcommodities = journalCommoditiesUsed j \\ journalCommoditiesDeclared j
if null undeclaredcommodities
then p Y (show numcommodities <> " commodities")
else p N (show (length undeclaredcommodities) <> " undeclared commodities")
let
accttypes = [Asset, Liability, Equity, Revenue, Expense, Cash, Conversion]
typesdeclaredorinferred = nub $ M.elems jaccounttypes
typesnotfound = filter (not.(`elem` typesdeclaredorinferred)) accttypes
acctswithdeclaredorinferredtype = nub (M.keys jaccounttypes)
numaccts = length $ journalAccountNames j
untypedaccts = journalAccountNames j \\ acctswithdeclaredorinferredtype
undeclaredaccts = journalAccountNamesUsed j \\ journalAccountNamesDeclared j
-- hasdeclaredaccts t = case M.lookup t jdeclaredaccounttypes of
-- Just (_ : _) -> True
-- _ -> False
-- pdesc "Asset accounts declared ?"
-- if hasdeclaredaccts Asset then i Y "" else i N ""
-- pdesc "Liability accounts declared ?"
-- if hasdeclaredaccts Liability then i Y "" else i N ""
-- pdesc "Equity accounts declared ?"
-- if hasdeclaredaccts Equity then i Y "" else i N ""
-- pdesc "Revenue accounts declared ?"
-- if hasdeclaredaccts Revenue then i Y "" else i N ""
-- pdesc "Expense accounts declared ?"
-- if hasdeclaredaccts Expense then i Y "" else i N ""
-- pdesc "Cash accounts declared ?"
-- if hasdeclaredaccts Cash then i Y "" else i N ""
-- pdesc "Conversion accounts declared ?"
-- if hasdeclaredaccts Conversion then i Y "" else i N "" -- ("--infer-equity will use a default conversion account name")
-- XXX hard to detect accounts where type was inferred from name
-- unless arealltypesdeclared $ do
-- let
-- acctswithdeclaredtype = concat (M.elems jdeclaredaccounttypes)
-- acctswithinferredtype = acctswithdeclaredorinferredtype \\ acctswithdeclaredtype
-- arealltypesdeclared = all hasdeclaredaccts accttypes
-- typesinferredfromnames =
-- if arealltypesdeclared then []
-- else sort $ nub $ catMaybes $ map (flip M.lookup jaccounttypes) acctswithinferredtype
-- pdesc "types detected from account names ?"
-- if null typesinferredfromnames then i N "" else i Y (concatMap show typesinferredfromnames)
pdesc "all accounts are declared ?"
if null undeclaredaccts then p Y (show numaccts <> " accounts") else i N (show (length undeclaredaccts) <> " undeclared accounts")
pdesc "all accounts have types ?"
if null untypedaccts then p Y "" else i N (show (length untypedaccts) <> " accounts without types")
pdesc "accounts of all types exist ?"
if null typesnotfound
then p Y (concatMap show accttypes <> " accounts detected")
else p N (concatMap show typesnotfound <> " accounts not found; some reports may not work")
pdesc "commodities/accounts are being checked ?"
let strict = isJust $ conflookup (\a -> any (==a) ["-s", "--strict"])
if strict
then i Y "commodities and accounts must be declared"
else i N "you can use -s to check them"
pdesc "balance assertions are being checked ?"
let ignoreassertions = isJust $ conflookup (\a -> any (==a) ["-I", "--ignore-assertions"])
if
| ignoreassertions && not strict -> i N "you can use -s to check them"
| not strict -> i Y "you can use -I to ignore them"
| otherwise -> i Y "can't ignore assertions (-s in config file)"
------------------------------------------------------------------------------
-- Test a hledger version for support of various features.
ver >=! str = ver >= (fromJust $ toVersion str)
supportsIgnoreAssertions = (>=! "0.24") -- --ignore-assertions (2014)
supportsCommodityDirective = (>=! "1.0") -- commodity directive (2016)
supportsPretty = (>=! "1.2") -- --pretty, to use box-drawing characters (2017)
supportsAccountDirective = (>=! "1.9") -- account directive (2018)
supportsAccountTypes = (>=! "1.13") -- ALERX account types, type: tag (2019)
supportsCashAccountType = (>=! "1.19") -- C/Cash account type (2020)
supportsBasicColor = (>=! "1.19") -- basic color detection/control (2020)
supportsConversionAccountType = (>=! "1.25") -- V/Conversion account type, accounts --types (2022)
supportsConfigFiles = (>=! "1.40") -- config files (2024)
supportsColor = (>=! "1.41") -- robust color detection/control (2024)
supportsPager = (>=! "1.41") -- use a pager for all output (2024)
supportsBashCompletions = (>=! "1.41") -- up to date bash shell completions (2024)
-- yes, no, unknown
data YNU = Y | N | U deriving (Eq)
-- ANSI styles
good = bold' . brightGreen'
neutral = bold' . brightBlue'
warning = bold' . brightYellow'
bad = bold' . brightRed'
-- Show status, in red/green/yellow if supported.
instance Show YNU where
show Y = good "yes" -- ✅ apple emojis - won't work everywhere
show N = bad " no" -- ❌
show U = warning " ?"
-- Show status, in blue/yellow if supported.
showInfo Y = neutral "yes" -- ℹ️
showInfo N = neutral " no" -- ℹ️
showInfo U = warning " ?"
-- | Print a test's pass or fail status, as "yes" or "no" or "",
-- in green/red if supported, and the (possibly empty) provided message.
p :: YNU -> String -> IO ()
p ok msg = putStrLn $ unwords ["", show ok, "", msg]
-- | Like p, but display the status as info, in neutral blue.
i :: YNU -> String -> IO ()
i ok msg = putStrLn $ unwords ["", showInfo ok, "", msg]
-- | Print a setup test groups heading.
pgroup :: String -> IO ()
pgroup s = putStrLn $ "\n" <> bold' s
-- | Print a setup test's description, formatting and padding it to a fixed width.
pdesc :: String -> IO ()
pdesc s = printf "* %-40s" s
(getLatestHledgerVersion, latestHledgerVersionUrlStr) =
-- (getLatestHledgerVersionFromHackage, "https://hackage.haskell.org/package/hledger/docs")
(getLatestHledgerVersionFromHledgerOrg, "https://hledger.org/install.html")
httptimeout = 10000000 -- 10s
-- | Get the current hledger release version from the internet.
-- Currently requests the latest doc page from Hackage and inspects the redirect path.
-- Should catch all normal errors, and time out after 10 seconds.
getLatestHledgerVersionFromHackage :: IO (Either String String)
getLatestHledgerVersionFromHackage = do
let url = https "hackage.haskell.org" /: "package" /: "hledger" /: "docs" /: ""
result <- try $ runReq defaultHttpConfig{httpConfigRedirectCount=0} $
req HEAD url NoReqBody bsResponse (R.responseTimeout httptimeout)
case result of
Right _ -> return $ Left "expected a redirect"
Left (VanillaHttpException (HttpExceptionRequest _ (StatusCodeException rsp _))) -> do
let status = statusCode $ responseStatus rsp
if status >= 300 && status < 400
then do
let locationHeader = lookup hLocation (responseHeaders rsp)
case fmap T.decodeUtf8 locationHeader of
Nothing -> return $ Left "no Location header"
Just location -> do
let packagename = take 1 $ drop 1 $ reverse $ T.splitOn "/" location
case packagename of
[n] -> return $ Right $ dropWhile (`notElem` ['0'..'9']) $ T.unpack n
_ -> return $ Left "couldn't parse Location"
else return $ Left $ "HTTP status " ++ show status
Left err -> return $ Left $ "other exception: " ++ show err
-- | Like the above, but get the version from the first number on the hledger.org Install page.
getLatestHledgerVersionFromHledgerOrg :: IO (Either String String)
getLatestHledgerVersionFromHledgerOrg = do
let url = https "hledger.org" /: "install.html"
do
result <- try $ runReq defaultHttpConfig $ req GET url NoReqBody bsResponse (R.responseTimeout httptimeout)
case result of
Left (_ :: R.HttpException) -> return $ Left "(HTTP failure)"
Right rsp -> case T.decodeUtf8' $ R.responseBody rsp of
Left e -> return $ Left $ show e
Right t -> return $
if null version then Left "couldn't parse version" else Right version
where
-- keep synced
versionline = take 1 $ dropWhile (not . ("current hledger release" `isInfixOf`)) $ lines $ T.unpack t
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 $ "(IO error" <> if os=="darwin" then " - mac PATH issue ?)" else ")")
-- | 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
-- | Get the operating system version string, if possible.
-- Uses platform-specific commands to detect the OS version.
getOSVersion :: IO (Maybe String)
getOSVersion = case os of
"darwin" -> tryCommand "sw_vers" ["-productVersion"]
"mingw32" -> tryCommand "cmd" ["/c", "ver"]
"linux" -> tryCommand "uname" ["-r"]
_ -> return Nothing
where
tryCommand cmd args =
(Just . strip <$> readProcess cmd args "")
`catch` (\(_ :: SomeException) -> return Nothing)