imp: setup: smarter logic, more robustness

- Test the hledger in PATH, not the one running
- Handle old hledger versions as well as recent ones
- Handle errors, remove early terminations

hledger/Hledger/Cli/Commands/Setup.hs

@@ -13,6 +13,7 @@ Check and show the status of the hledger installation.
 
 {-# OPTIONS_GHC -Wno-name-shadowing #-}
 {-# OPTIONS_GHC -Wno-unused-top-binds #-}
+{-# LANGUAGE MultiWayIf #-}
 -- {-# OPTIONS_GHC -Wno-unused-matches #-}
 
 module Hledger.Cli.Commands.Setup (
@@ -24,31 +25,29 @@ where
 import Control.Applicative ((<|>))
 import Control.Exception
 import Control.Monad
-import Data.Functor ((<&>))
+import Data.Char
+import Data.List
+import Data.List.NonEmpty (NonEmpty ((:|)))
 import Data.Maybe
--- import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
--- import qualified Data.Text.IO as T
 import Network.HTTP.Client
 import Network.HTTP.Types (statusCode, hLocation)
 import Network.HTTP.Req as R
 import Safe
 import System.Directory
+import System.Environment (lookupEnv)
 import System.Exit
 import System.FilePath
 import System.Info
--- import System.IO
 import System.Process
-import Text.Megaparsec.Error (errorBundlePretty)
 import Text.Printf (printf)
 
 import Hledger
 import Hledger.Cli.CliOptions
 import Hledger.Cli.Conf
-import System.Environment (lookupEnv)
+import Hledger.Cli.Version (Version, toVersion)
-import Data.Char
+
-import Data.List
 
 setupmode = hledgerCommandMode
   $(embedFileRelative "Hledger/Cli/Commands/Setup.txt")
@@ -57,24 +56,61 @@ setupmode = hledgerCommandMode
   []
   ([], 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 _opts@CliOpts{rawopts_=_rawopts, reportspec_=_rspec} _ignoredj = do
   -- This command is not given a journal and should not use _ignoredj;
   -- instead detect it ourselves when we are ready.
   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"
 
+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
   pgroup "hledger"
 
@@ -92,72 +128,80 @@ setupHledger = do
     ]
     ++ [appdata </> "local/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."
-      | otherwise = unlines
         ["Add " <> otherdir <> " to PATH in your shell config."
         ,"  Eg on unix: echo 'export PATH=" <> otherdir <> ":$PATH' >> ~/.profile"
         ,"  and start a new shell session."
         ]
-  p ok msg
+      return Nothing
+    (pathexe:_, _) -> do
+      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 ?"
-    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
+          -- If it runs, do more checks
-    let
+          let
-      versionstr = rstrip out
+            versionoutput = rstrip out
-      versionstrparts = words versionstr
+            versionwords = words versionoutput
 
-    -- If hledger runs, run more checks
-    when (ok==Y) $ do
           pdesc "is a native binary ?"
           let
-        exearch = case drop 2 versionstrparts of
+            sysarch = os' <> "-" <> arch
-          w:_ -> w
+              where
-          _   -> error' "couldn't parse arch from --version output"
                 os' -- keep synced: Version.hs
                   | os == "darwin" = "mac"
                   | os == "mingw32" = "windows"
                   | otherwise = os
-        sysarch = os' <> "-" <> arch
+          case drop 2 versionwords of
-        (ok, msg)
+            exearch:_ -> if exearch == sysarch
-          | exearch == sysarch = (Y, versionstr)
+              then p Y versionoutput
-          | otherwise = (N, "installed binary is for " <> exearch <> ", system is " <> sysarch)
+              else p N $ "installed binary is for " <> exearch <> ", system is " <> sysarch
-      p ok msg
+            _ -> p U $ "couldn't detect arch in --version output"
 
           pdesc "is up to date ?"
-      elatestver <- getLatestHledgerVersion
+          elatestversionnumstr <- getLatestHledgerVersion
+          case elatestversionnumstr of
+            Right latestversionnumstr ->
+              case drop 1 versionwords of
+                []  -> p U "couldn't parse --version output" >> return Nothing
+                detailedversionstr:_ -> do
                   let
-        (ok, msg) = case elatestver of
+                    versionnumstr  = takeWhile (`elem` ("0123456789." :: String)) detailedversionstr
-          Left e -> (U, "could not read " <> latestHledgerVersionUrlStr <> " : " <> e)
+                    mversion       = toVersion versionnumstr
-          Right latestver ->
+                    mlatestversion = toVersion latestversionnumstr
-            case drop 1 versionstrparts of
+                  case (mversion, mlatestversion) of
-              []  -> (U, "could not parse --version output")
+                    (Nothing, _) -> p U "couldn't parse --version's version number" >> return Nothing
-              w:_ -> (ok, msg)
+                    (_, Nothing) -> p U "couldn't parse latest version number" >> return Nothing
-                where
+                    (Just version, Just latest) -> do
-                  exever = takeWhile (`elem` ("0123456789."::String)) w
+                      p (if version >= latest then Y else N) (versionnumstr <> " installed, latest is " <> latestversionnumstr)
-                  ok = if splitAtElement '.' exever >= splitAtElement '.' latestver then Y else N
+                      return (Just (versionoutput, version))
-                  msg =
+            Left e -> do
-                    if exever == latestver 
+              -- couldn't detect the latest version, but still return version info for the installed version
-                    then exever 
+              -- XXX duplication, refactor
-                    else exever <> " installed, latest is " <> latestver
+              case drop 1 versionwords of
-      p ok msg
+                []  -> 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
   case mf of
     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 ?"
   -- --pretty --ignore-assertions --infer-costs"
@@ -200,7 +245,7 @@ setupConfig = do
 
 ------------------------------------------------------------------------------
 
-setupFile = do
+setupFile version = do
   pgroup "file"
 
   pdesc "a home directory journal file exists ?"
@@ -250,11 +295,21 @@ setupFile = do
           else (Y, "")
       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)
+
 
 ------------------------------------------------------------------------------
 
@@ -316,7 +371,7 @@ 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 "* %-38s" s
+pdesc s = printf "* %-40s" s
 
 (getLatestHledgerVersion, latestHledgerVersionUrlStr) =
   -- (getLatestHledgerVersionFromHackage, "https://hackage.haskell.org/package/hledger/docs")
@@ -345,7 +400,7 @@ getLatestHledgerVersionFromHackage = 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 "could not parse Location"
+                _   -> return $ Left "couldn't parse Location"
         else return $ Left $ "HTTP status " ++ show status
     Left err -> return $ Left $ "other exception: " ++ show err
 
@@ -353,15 +408,37 @@ getLatestHledgerVersionFromHackage = do
 getLatestHledgerVersionFromHledgerOrg :: IO (Either String String)
 getLatestHledgerVersionFromHledgerOrg = do
   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
       Left (e :: R.HttpException) -> return $ Left $ show e
       Right rsp -> case T.decodeUtf8' $ R.responseBody rsp of
         Left e  -> return $ Left $ show e
         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
             -- 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 "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