{-|

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 :: Mode RawOpts
setupmode = String
-> [Flag RawOpts]
-> [(String, [Flag RawOpts])]
-> [Flag RawOpts]
-> ([Arg RawOpts], Maybe (Arg RawOpts))
-> Mode RawOpts
hledgerCommandMode
  $(embedFileRelative "Hledger/Cli/Commands/Setup.txt")
  []
  [(String, [Flag RawOpts])
generalflagsgroup3]
  []
  ([], Maybe (Arg RawOpts)
forall a. Maybe a
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 :: CliOpts -> Journal -> IO ()
setup _opts :: CliOpts
_opts@CliOpts{rawopts_ :: CliOpts -> RawOpts
rawopts_=RawOpts
_rawopts, reportspec_ :: CliOpts -> ReportSpec
reportspec_=ReportSpec
_rspec} Journal
_ignoredj = do
  -- This command is not given a journal and should not use _ignoredj;
  -- instead read it ourselves when we are ready.
  String -> IO ()
putStrLn String
"Checking your hledger setup.."
  color <- IO Bool
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 :: IO (Maybe (Either String Conf))
setupHledger = do
  String -> IO ()
pgroup String
"hledger"

  let
    os' :: String
os'
      | String
osString -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
"darwin" = String
"macos"
      | String
osString -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
"mingw32" = String
"windows"
      | Bool
otherwise = String
os
  mosversion <- IO (Maybe String)
getOSVersion
  let osdesc = String
os' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String
" "String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) Maybe String
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
    Maybe String
Nothing -> YNU -> String -> IO ()
p YNU
U (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"couldn't detect this binary's architecture"
    Just String
a | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
arch -> YNU -> String -> IO ()
p YNU
N (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"binary is for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
a String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", system is " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
arch String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", may run slowly"
    Just String
a -> YNU -> String -> IO ()
p YNU
Y String
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 String
e -> YNU -> String -> IO ()
p YNU
U (String
"couldn't read " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
latestHledgerVersionUrlStr String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
e)
    Right String
latestversionnumstr ->
      case String -> Maybe Version
toVersion String
latestversionnumstr of
        Maybe Version
Nothing -> YNU -> String -> IO ()
p YNU
U String
"couldn't parse latest version number"
        Just Version
latestversion -> YNU -> String -> IO ()
p
          (if HledgerBinaryInfo -> Version
hbinPackageVersion HledgerBinaryInfo
binaryinfo Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= Version
latestversion then YNU
Y else YNU
N)
          (String
"latest is " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
latestversionnumstr String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Version -> String
showVersion (HledgerBinaryInfo -> Version
hbinPackageVersion HledgerBinaryInfo
binaryinfo) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" 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
    [] -> YNU -> String -> IO ()
p YNU
N String
failmsg IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
failaction
    String
exe:[String]
_ -> do
      eerrout <- [[String]] -> IO (Either String String)
tryHledgerArgs [[String
"--version", String
"--no-conf"], [String
"--version"]]
      case eerrout of
        Left  String
err -> YNU -> String -> IO ()
p YNU
U (String
progname String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" --version failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
failaction
        Right String
out -> do
          case String -> Either String HledgerBinaryInfo
parseHledgerVersion String
out of
            Left  String
_ -> YNU -> String -> IO ()
p YNU
U (String
"couldn't parse " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
progname String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" --version: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
rstrip String
out) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitFailure
            Right HledgerBinaryInfo
pathbin -> do
              let pathversion :: String
pathversion = HledgerBinaryInfo -> String
hbinVersionOutput HledgerBinaryInfo
pathbin
              if String
pathversion String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
prognameandversion
              then YNU -> String -> IO ()
p YNU
N (String -> String
chomp (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [
                 String
""
                ,String
" A different hledger version was found in PATH: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
pathversion
                ,String
" at: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
exe
                ,String
failmsg
                ]) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
failaction
              else YNU -> String -> IO ()
p YNU
Y String
exe

  pdesc "has a system text encoding configured ?"
  let encoding = TextEncoding
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 String
f  -> (YNU
Y, String
f String -> String -> String
forall a. Semigroup a => a -> a -> a
<> if Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
mlf then String
" (overridden)" else String
"")
      Maybe String
Nothing -> (YNU
N, String
"")
  i ok msg

  pdesc "has a local config file ?"
  let
    (ok, msg) = case mlf of
      Just String
f  -> (YNU
Y, String
f)
      Maybe String
Nothing -> (YNU
N, String
"")
  i ok msg

  if (isJust muf || isJust mlf) then do
    pdesc "the config file is readable ?"
    econf <- getConf def
    case econf of
      Left String
e -> YNU -> String -> IO ()
p YNU
N String
e IO ()
-> IO (Maybe (Either String Conf))
-> IO (Maybe (Either String Conf))
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (Either String Conf) -> IO (Maybe (Either String Conf))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Conf -> Maybe (Either String Conf)
forall a. a -> Maybe a
Just (Either String Conf -> Maybe (Either String Conf))
-> Either String Conf -> Maybe (Either String Conf)
forall a b. (a -> b) -> a -> b
$ String -> Either String Conf
forall a b. a -> Either a b
Left String
e)
      Right (Conf
conf, Maybe String
_) -> do
        YNU -> String -> IO ()
p YNU
Y String
""

        -- pdesc "common general options are configured ?"
        -- --infer-costs"
        -- print --explicit --infer-costs"

        Maybe (Either String Conf) -> IO (Maybe (Either String Conf))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Either String Conf) -> IO (Maybe (Either String Conf)))
-> Maybe (Either String Conf) -> IO (Maybe (Either String Conf))
forall a b. (a -> b) -> a -> b
$ Either String Conf -> Maybe (Either String Conf)
forall a. a -> Maybe a
Just (Either String Conf -> Maybe (Either String Conf))
-> Either String Conf -> Maybe (Either String Conf)
forall a b. (a -> b) -> a -> b
$ Conf -> Either String Conf
forall a b. b -> Either a b
Right Conf
conf
  else
    return Nothing

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

setupTerminal :: Maybe (Either a Conf) -> IO ()
setupTerminal Maybe (Either a Conf)
meconf = do
  String -> IO ()
pgroup String
"terminal"
  let
    -- Find the last opt/arg matched by a predicate in the general config, if there is one.
    conflookup :: (String -> Bool) -> Maybe String
conflookup String -> Bool
predicate = case Maybe (Either a Conf)
meconf of
      Just (Right Conf
conf) -> (String -> Bool) -> [String] -> Maybe String
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find String -> Bool
predicate ([String] -> Maybe String) -> [String] -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> Conf -> [String]
confLookup String
"general" Conf
conf
      Maybe (Either a Conf)
_ -> Maybe String
forall a. Maybe a
Nothing

  String -> IO ()
pdesc String
"the NO_COLOR variable is defined ?"
  mnocolor <- String -> IO (Maybe String)
lookupEnv String
"NO_COLOR"
  case mnocolor of
    Maybe String
Nothing -> YNU -> String -> IO ()
i YNU
N String
""
    Just String
_  -> YNU -> String -> IO ()
i YNU
Y String
""

  meconfigcolor <- do
    pdesc "--color is configured by config file ?"
    let mcolorarg = (String -> Bool) -> Maybe String
conflookup (\String
a -> (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
a) [String
"--color", String
"--colour"])
    case mcolorarg of
      Maybe String
Nothing -> YNU -> String -> IO ()
i YNU
N String
"" IO ()
-> IO (Maybe (Either String YNA)) -> IO (Maybe (Either String YNA))
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (Either String YNA) -> IO (Maybe (Either String YNA))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either String YNA)
forall a. Maybe a
Nothing
      Just String
a  -> do
        YNU -> String -> IO ()
i YNU
Y String
a
        let
          arg :: String
arg = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char
'=',Char
' ']) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse String
a
        Maybe (Either String YNA) -> IO (Maybe (Either String YNA))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Either String YNA) -> IO (Maybe (Either String YNA)))
-> Maybe (Either String YNA) -> IO (Maybe (Either String YNA))
forall a b. (a -> b) -> a -> b
$ Either String YNA -> Maybe (Either String YNA)
forall a. a -> Maybe a
Just (Either String YNA -> Maybe (Either String YNA))
-> Either String YNA -> Maybe (Either String YNA)
forall a b. (a -> b) -> a -> b
$ String -> Either String YNA
parseYNA String
arg

  pdesc "hledger will use color by default ?"
  case (meconfigcolor, isJust mnocolor) of
    (Just (Right YNA
Yes), Bool
_)     -> YNU -> String -> IO ()
p YNU
Y String
""
    (Just (Right YNA
No),  Bool
_)     -> YNU -> String -> IO ()
i YNU
N String
""
    (Maybe (Either String YNA)
_,                Bool
True)  -> YNU -> String -> IO ()
i YNU
N String
""
    (Maybe (Either String YNA)
_,                Bool
False) -> YNU -> String -> IO ()
p YNU
Y String
""

  pdesc "the PAGER variable is defined ?"
  mv <- lookupEnv "PAGER"
  case mv of
    Maybe String
Nothing -> YNU -> String -> IO ()
i YNU
N String
""
    Just String
v  -> YNU -> String -> IO ()
i YNU
Y String
v

  pdesc "--pager is configured by config file ?"
  let mpagerarg = (String -> Bool) -> Maybe String
conflookup (String
"--pager" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)
  meconfpager <- case mpagerarg of
    Maybe String
Nothing -> YNU -> String -> IO ()
i YNU
N String
"" IO ()
-> IO (Maybe (Either String YNA)) -> IO (Maybe (Either String YNA))
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (Either String YNA) -> IO (Maybe (Either String YNA))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either String YNA)
forall a. Maybe a
Nothing
    Just String
a  -> do
      YNU -> String -> IO ()
i YNU
Y String
a
      let arg :: String
arg = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char
'=',Char
' ']) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse String
a
      Maybe (Either String YNA) -> IO (Maybe (Either String YNA))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Either String YNA) -> IO (Maybe (Either String YNA)))
-> Maybe (Either String YNA) -> IO (Maybe (Either String YNA))
forall a b. (a -> b) -> a -> b
$ Either String YNA -> Maybe (Either String YNA)
forall a. a -> Maybe a
Just (Either String YNA -> Maybe (Either String YNA))
-> Either String YNA -> Maybe (Either String YNA)
forall a b. (a -> b) -> a -> b
$ String -> Either String YNA
parseYNA String
arg

  pdesc "hledger will use a pager when needed ?"
  mpager <- findPager
  case mpager of
    Maybe String
Nothing    -> YNU -> String -> IO ()
i YNU
N String
"no pager was found"
    Just String
pager ->
      case Maybe (Either String YNA)
meconfpager of
        Just (Right YNA
No) -> YNU -> String -> IO ()
i YNU
N String
"disabled in config file"
        Maybe (Either String YNA)
_ -> do
          YNU -> String -> IO ()
p YNU
Y String
pager

          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String
takeBaseName String
pager) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"more") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            String -> IO ()
pdesc String
"the MORE variable is defined ?"
            mv <- String -> IO (Maybe String)
lookupEnv String
"MORE"
            case mv of
              Maybe String
Nothing -> YNU -> String -> IO ()
i YNU
N String
""
              Just String
v  -> YNU -> String -> IO ()
i YNU
Y String
v

          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String
takeBaseName String
pager) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"less") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            mHLEDGER_LESS <- String -> IO (Maybe String)
lookupEnv String
"HLEDGER_LESS"
            mLESS <- lookupEnv "LESS"

            pdesc "the LESS variable is defined ?"
            case mLESS of
              Maybe String
Nothing -> YNU -> String -> IO ()
i YNU
N String
""
              Just String
v  -> YNU -> String -> IO ()
i YNU
Y (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
v String -> String -> String
forall a. Semigroup a => a -> a -> a
<> if Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
mHLEDGER_LESS then String
" (overridden)" else String
""

            pdesc "the HLEDGER_LESS variable is defined ?"
            case mHLEDGER_LESS of
              Maybe String
Nothing -> YNU -> String -> IO ()
i YNU
N String
""
              Just String
v  -> YNU -> String -> IO ()
i YNU
Y String
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 = Maybe String -> Maybe String -> Bool -> String
lessVarValue Maybe String
mHLEDGER_LESS Maybe String
mLESS Bool
usecolor
            env <- getEnvironment
            let customEnv = (String
"LESS", String
newlessvar) (String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
: ((String, String) -> Bool)
-> [(String, String)] -> [(String, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"LESS") (String -> Bool)
-> ((String, String) -> String) -> (String, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> a
fst) [(String, String)]
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 :: Maybe (Either a Conf) -> IO ()
setupJournal Maybe (Either a Conf)
meconf = do
  String -> IO ()
pgroup String
"journal"
  let
    -- Find the last opt/arg matched by a predicate in the general config, if there is one.
    conflookup :: (String -> Bool) -> Maybe String
conflookup String -> Bool
predicate = case Maybe (Either a Conf)
meconf of
      Just (Right Conf
conf) -> (String -> Bool) -> [String] -> Maybe String
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find String -> Bool
predicate ([String] -> Maybe String) -> [String] -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> Conf -> [String]
confLookup String
"general" Conf
conf
      Maybe (Either a Conf)
_ -> Maybe String
forall a. Maybe a
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

  String -> IO ()
pdesc String
"the LEDGER_FILE variable is defined ?"
  mf <- String -> IO (Maybe String)
lookupEnv String
journalEnvVar
  let
    (ok, msg) = case mf of
      Just String
f  -> (YNU
Y, String
f)
      Maybe String
Nothing -> (YNU
N, String
"")
  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 String
s = (String -> String)
-> (String -> String) -> Either String String -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> String -> String
forall a b. a -> b -> a
const String
s) String -> String
forall a. a -> a
id (Either String String -> String) -> Either String String -> String
forall a b. (a -> b) -> a -> b
$ Regexp -> String -> String -> Either String String
regexReplace (Text -> Regexp
toRegex' Text
"^Error: ") String
"" String
s
  case (ef, ej) of
    (Left String
err, Either String Journal
_) -> YNU -> String -> IO ()
p YNU
N (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String
trim String
err
    (Right String
f, Left String
err) -> YNU -> String -> IO ()
p YNU
N (String
f String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
trim String
err)
    (Right String
f, Right j :: Journal
j@Journal{[(String, String)]
[(String, Text)]
[(Text, AccountDeclarationInfo)]
[(Text, TagDeclarationInfo)]
[(Text, PayeeDeclarationInfo)]
[Text]
[MarketPrice]
[PriceDirective]
[TimeclockEntry]
[PeriodicTransaction]
[TransactionModifier]
[Transaction]
[AccountAlias]
Maybe Char
Maybe Year
Maybe (Text, AmountStyle)
Text
Map Text [Tag]
Map Text Commodity
Map Text AmountStyle
Map Text AccountType
Map AccountType [Text]
POSIXTime
jparsedefaultyear :: Maybe Year
jparsedefaultcommodity :: Maybe (Text, AmountStyle)
jparsedecimalmark :: Maybe Char
jparseparentaccounts :: [Text]
jparsealiases :: [AccountAlias]
jparsetimeclockentries :: [TimeclockEntry]
jincludefilestack :: [(String, String)]
jdeclaredpayees :: [(Text, PayeeDeclarationInfo)]
jdeclaredtags :: [(Text, TagDeclarationInfo)]
jdeclaredaccounts :: [(Text, AccountDeclarationInfo)]
jdeclaredaccounttags :: Map Text [Tag]
jdeclaredaccounttypes :: Map AccountType [Text]
jaccounttypes :: Map Text AccountType
jdeclaredcommodities :: Map Text Commodity
jdeclaredcommoditytags :: Map Text [Tag]
jinferredcommoditystyles :: Map Text AmountStyle
jglobalcommoditystyles :: Map Text AmountStyle
jpricedirectives :: [PriceDirective]
jinferredmarketprices :: [MarketPrice]
jtxnmodifiers :: [TransactionModifier]
jperiodictxns :: [PeriodicTransaction]
jtxns :: [Transaction]
jfinalcommentlines :: Text
jfiles :: [(String, Text)]
jlastreadtime :: POSIXTime
jlastreadtime :: Journal -> POSIXTime
jfiles :: Journal -> [(String, Text)]
jfinalcommentlines :: Journal -> Text
jtxns :: Journal -> [Transaction]
jperiodictxns :: Journal -> [PeriodicTransaction]
jtxnmodifiers :: Journal -> [TransactionModifier]
jinferredmarketprices :: Journal -> [MarketPrice]
jpricedirectives :: Journal -> [PriceDirective]
jglobalcommoditystyles :: Journal -> Map Text AmountStyle
jinferredcommoditystyles :: Journal -> Map Text AmountStyle
jdeclaredcommoditytags :: Journal -> Map Text [Tag]
jdeclaredcommodities :: Journal -> Map Text Commodity
jaccounttypes :: Journal -> Map Text AccountType
jdeclaredaccounttypes :: Journal -> Map AccountType [Text]
jdeclaredaccounttags :: Journal -> Map Text [Tag]
jdeclaredaccounts :: Journal -> [(Text, AccountDeclarationInfo)]
jdeclaredtags :: Journal -> [(Text, TagDeclarationInfo)]
jdeclaredpayees :: Journal -> [(Text, PayeeDeclarationInfo)]
jincludefilestack :: Journal -> [(String, String)]
jparsetimeclockentries :: Journal -> [TimeclockEntry]
jparsealiases :: Journal -> [AccountAlias]
jparseparentaccounts :: Journal -> [Text]
jparsedecimalmark :: Journal -> Maybe Char
jparsedefaultcommodity :: Journal -> Maybe (Text, AmountStyle)
jparsedefaultyear :: Journal -> Maybe Year
..}) -> do
      YNU -> String -> IO ()
p YNU
Y String
f

      String -> IO ()
pdesc String
"it includes additional files ?"
      let numfiles :: Int
numfiles = [(String, Text)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, Text)]
jfiles
      if Int
numfiles Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
      then YNU -> String -> IO ()
i YNU
Y (Int -> String
forall a. Show a => a -> String
show (Int
numfiles Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" files")
      else YNU -> String -> IO ()
i YNU
N String
""

      String -> IO ()
pdesc String
"all commodities are declared ?"
      let
        numcommodities :: Int
numcommodities = Set Text -> Int
forall a. Set a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Set Text -> Int) -> Set Text -> Int
forall a b. (a -> b) -> a -> b
$ Journal -> Set Text
journalCommodities Journal
j
        undeclaredcommodities :: [Text]
undeclaredcommodities = Journal -> [Text]
journalCommoditiesUsed Journal
j [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
\\ Journal -> [Text]
journalCommoditiesDeclared Journal
j
      if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
undeclaredcommodities
      then YNU -> String -> IO ()
p YNU
Y (Int -> String
forall a. Show a => a -> String
show Int
numcommodities String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" commodities")
      else YNU -> String -> IO ()
p YNU
N (Int -> String
forall a. Show a => a -> String
show ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
undeclaredcommodities) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" undeclared commodities")

      let
        accttypes :: [AccountType]
accttypes = [AccountType
Asset, AccountType
Liability, AccountType
Equity, AccountType
Revenue, AccountType
Expense, AccountType
Cash, AccountType
Conversion]
        typesdeclaredorinferred :: [AccountType]
typesdeclaredorinferred = [AccountType] -> [AccountType]
forall a. Eq a => [a] -> [a]
nub ([AccountType] -> [AccountType]) -> [AccountType] -> [AccountType]
forall a b. (a -> b) -> a -> b
$ Map Text AccountType -> [AccountType]
forall k a. Map k a -> [a]
M.elems Map Text AccountType
jaccounttypes
        typesnotfound :: [AccountType]
typesnotfound = (AccountType -> Bool) -> [AccountType] -> [AccountType]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool) -> (AccountType -> Bool) -> AccountType -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(AccountType -> [AccountType] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [AccountType]
typesdeclaredorinferred)) [AccountType]
accttypes
        acctswithdeclaredorinferredtype :: [Text]
acctswithdeclaredorinferredtype = [Text] -> [Text]
forall a. Eq a => [a] -> [a]
nub (Map Text AccountType -> [Text]
forall k a. Map k a -> [k]
M.keys Map Text AccountType
jaccounttypes)
        numaccts :: Int
numaccts = [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Text] -> Int) -> [Text] -> Int
forall a b. (a -> b) -> a -> b
$ Journal -> [Text]
journalAccountNames Journal
j
        untypedaccts :: [Text]
untypedaccts = Journal -> [Text]
journalAccountNames Journal
j [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Text]
acctswithdeclaredorinferredtype
        undeclaredaccts :: [Text]
undeclaredaccts = Journal -> [Text]
journalAccountNamesUsed Journal
j [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
\\ Journal -> [Text]
journalAccountNamesDeclared Journal
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)

      String -> IO ()
pdesc String
"all accounts are declared ?"
      if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
undeclaredaccts then YNU -> String -> IO ()
p YNU
Y (Int -> String
forall a. Show a => a -> String
show Int
numaccts String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" accounts") else YNU -> String -> IO ()
i YNU
N (Int -> String
forall a. Show a => a -> String
show ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
undeclaredaccts) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" undeclared accounts")

      String -> IO ()
pdesc String
"all accounts have types ?"
      if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
untypedaccts then YNU -> String -> IO ()
p YNU
Y String
"" else YNU -> String -> IO ()
i YNU
N (Int -> String
forall a. Show a => a -> String
show ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
untypedaccts) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" accounts without types")

      String -> IO ()
pdesc String
"accounts of all types exist ?"
      if [AccountType] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AccountType]
typesnotfound
      then YNU -> String -> IO ()
p YNU
Y ((AccountType -> String) -> [AccountType] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AccountType -> String
forall a. Show a => a -> String
show [AccountType]
accttypes String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" accounts detected")
      else YNU -> String -> IO ()
p YNU
N ((AccountType -> String) -> [AccountType] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AccountType -> String
forall a. Show a => a -> String
show [AccountType]
typesnotfound String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" accounts not found; some reports may not work")

      String -> IO ()
pdesc String
"commodities/accounts are being checked ?"
      let strict :: Bool
strict = Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> Maybe String -> Bool
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> Maybe String
conflookup (\String
a -> (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
a) [String
"-s", String
"--strict"])
      if Bool
strict
      then YNU -> String -> IO ()
i YNU
Y String
"commodities and accounts must be declared"
      else YNU -> String -> IO ()
i YNU
N String
"you can use -s to check them"

      String -> IO ()
pdesc String
"balance assertions are being checked ?"
      let ignoreassertions :: Bool
ignoreassertions = Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> Maybe String -> Bool
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> Maybe String
conflookup (\String
a -> (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
a) [String
"-I", String
"--ignore-assertions"])
      if 
        | Bool
ignoreassertions Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
strict -> YNU -> String -> IO ()
i YNU
N String
"you can use -s to check them"
        | Bool -> Bool
not Bool
strict -> YNU -> String -> IO ()
i YNU
Y String
"you can use -I to ignore them"
        | Bool
otherwise -> YNU -> String -> IO ()
i YNU
Y String
"can't ignore assertions (-s in config file)"

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

-- Test a hledger version for support of various features.
Version
ver >=! :: Version -> String -> Bool
>=! String
str = Version
ver Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= (Maybe Version -> Version
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Version -> Version) -> Maybe Version -> Version
forall a b. (a -> b) -> a -> b
$ String -> Maybe Version
toVersion String
str)
supportsIgnoreAssertions :: Version -> Bool
supportsIgnoreAssertions = (Version -> String -> Bool
>=! String
"0.24") -- --ignore-assertions (2014)
supportsCommodityDirective :: Version -> Bool
supportsCommodityDirective = (Version -> String -> Bool
>=! String
"1.0") -- commodity directive (2016)
supportsPretty :: Version -> Bool
supportsPretty = (Version -> String -> Bool
>=! String
"1.2") -- --pretty, to use box-drawing characters (2017)
supportsAccountDirective :: Version -> Bool
supportsAccountDirective = (Version -> String -> Bool
>=! String
"1.9") -- account directive (2018)
supportsAccountTypes :: Version -> Bool
supportsAccountTypes = (Version -> String -> Bool
>=! String
"1.13") -- ALERX account types, type: tag (2019)
supportsCashAccountType :: Version -> Bool
supportsCashAccountType = (Version -> String -> Bool
>=! String
"1.19") -- C/Cash account type (2020)
supportsBasicColor :: Version -> Bool
supportsBasicColor = (Version -> String -> Bool
>=! String
"1.19") -- basic color detection/control (2020)
supportsConversionAccountType :: Version -> Bool
supportsConversionAccountType = (Version -> String -> Bool
>=! String
"1.25") -- V/Conversion account type, accounts --types (2022)
supportsConfigFiles :: Version -> Bool
supportsConfigFiles = (Version -> String -> Bool
>=! String
"1.40") -- config files (2024)
supportsColor :: Version -> Bool
supportsColor = (Version -> String -> Bool
>=! String
"1.41") -- robust color detection/control (2024)
supportsPager :: Version -> Bool
supportsPager = (Version -> String -> Bool
>=! String
"1.41") -- use a pager for all output (2024)
supportsBashCompletions :: Version -> Bool
supportsBashCompletions = (Version -> String -> Bool
>=! String
"1.41") -- up to date bash shell completions (2024)

-- yes, no, unknown
data YNU = Y | N | U deriving (YNU -> YNU -> Bool
(YNU -> YNU -> Bool) -> (YNU -> YNU -> Bool) -> Eq YNU
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: YNU -> YNU -> Bool
== :: YNU -> YNU -> Bool
$c/= :: YNU -> YNU -> Bool
/= :: YNU -> YNU -> Bool
Eq)

-- ANSI styles
good :: String -> String
good    = String -> String
bold' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
brightGreen'
neutral :: String -> String
neutral = String -> String
bold' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
brightBlue'
warning :: String -> String
warning = String -> String
bold' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
brightYellow'
bad :: String -> String
bad     = String -> String
bold' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
brightRed'

-- Show status, in red/green/yellow if supported.
instance Show YNU where
  show :: YNU -> String
show YNU
Y = String -> String
good    String
"yes"    -- ✅ apple emojis - won't work everywhere
  show YNU
N = String -> String
bad     String
" no"    -- ❌
  show YNU
U = String -> String
warning String
"  ?"

-- Show status, in blue/yellow if supported.
showInfo :: YNU -> String
showInfo YNU
Y = String -> String
neutral String
"yes"  -- ℹ️
showInfo YNU
N = String -> String
neutral String
" no"  -- ℹ️
showInfo YNU
U = String -> String
warning String
"  ?"

-- | 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 :: YNU -> String -> IO ()
p YNU
ok String
msg = String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"", YNU -> String
forall a. Show a => a -> String
show YNU
ok, String
"", String
msg]

-- | Like p, but display the status as info, in neutral blue.
i :: YNU -> String -> IO ()
i :: YNU -> String -> IO ()
i YNU
ok String
msg = String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"", YNU -> String
showInfo YNU
ok, String
"", String
msg]

-- | Print a setup test groups heading.
pgroup :: String -> IO ()
pgroup :: String -> IO ()
pgroup String
s = String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
bold' String
s

-- | Print a setup test's description, formatting and padding it to a fixed width.
pdesc :: String -> IO ()
pdesc :: String -> IO ()
pdesc String
s = String -> String -> IO ()
forall r. PrintfType r => String -> r
printf String
"* %-40s" String
s

(IO (Either String String)
getLatestHledgerVersion, String
latestHledgerVersionUrlStr) =
  -- (getLatestHledgerVersionFromHackage, "https://hackage.haskell.org/package/hledger/docs")
  (IO (Either String String)
getLatestHledgerVersionFromHledgerOrg, String
"https://hledger.org/install.html")

httptimeout :: Int
httptimeout = Int
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 :: IO (Either String String)
getLatestHledgerVersionFromHackage = do
  let url :: Url 'Https
url = Text -> Url 'Https
https Text
"hackage.haskell.org" Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"package" Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"hledger" Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"docs" Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
""
  result <- IO BsResponse -> IO (Either HttpException BsResponse)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO BsResponse -> IO (Either HttpException BsResponse))
-> IO BsResponse -> IO (Either HttpException BsResponse)
forall a b. (a -> b) -> a -> b
$ HttpConfig -> Req BsResponse -> IO BsResponse
forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
runReq HttpConfig
defaultHttpConfig{httpConfigRedirectCount=0} (Req BsResponse -> IO BsResponse)
-> Req BsResponse -> IO BsResponse
forall a b. (a -> b) -> a -> b
$
    HEAD
-> Url 'Https
-> NoReqBody
-> Proxy BsResponse
-> Option 'Https
-> Req BsResponse
forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
 HttpResponse response,
 HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req HEAD
HEAD Url 'Https
url NoReqBody
NoReqBody Proxy BsResponse
bsResponse (Int -> Option 'Https
forall (scheme :: Scheme). Int -> Option scheme
R.responseTimeout Int
httptimeout)
  case result of
    Right BsResponse
_ -> Either String String -> IO (Either String String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. a -> Either a b
Left String
"expected a redirect"
    Left (VanillaHttpException (HttpExceptionRequest Request
_ (StatusCodeException Response ()
rsp ByteString
_))) -> do
      let status :: Int
status = Status -> Int
statusCode (Status -> Int) -> Status -> Int
forall a b. (a -> b) -> a -> b
$ Response () -> Status
forall body. Response body -> Status
responseStatus Response ()
rsp
      if Int
status Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
300 Bool -> Bool -> Bool
&& Int
status Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
400
        then do
          let locationHeader :: Maybe ByteString
locationHeader = HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hLocation (Response () -> [(HeaderName, ByteString)]
forall body. Response body -> [(HeaderName, ByteString)]
responseHeaders Response ()
rsp)
          case (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
T.decodeUtf8 Maybe ByteString
locationHeader of
            Maybe Text
Nothing       -> Either String String -> IO (Either String String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. a -> Either a b
Left String
"no Location header"
            Just Text
location -> do
              let packagename :: [Text]
packagename = Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take Int
1 ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
1 ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"/" Text
location
              case [Text]
packagename of
                [Text
n] -> Either String String -> IO (Either String String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. b -> Either a b
Right (String -> Either String String) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char
'0'..Char
'9']) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
n
                [Text]
_   -> Either String String -> IO (Either String String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. a -> Either a b
Left String
"couldn't parse Location"
        else Either String String -> IO (Either String String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. a -> Either a b
Left (String -> Either String String) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ String
"HTTP status " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
status
    Left HttpException
err -> Either String String -> IO (Either String String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. a -> Either a b
Left (String -> Either String String) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ String
"other exception: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ HttpException -> String
forall a. Show a => a -> String
show HttpException
err

-- | Like the above, but get the version from the first number on the hledger.org Install page.
getLatestHledgerVersionFromHledgerOrg :: IO (Either String String)
getLatestHledgerVersionFromHledgerOrg :: IO (Either String String)
getLatestHledgerVersionFromHledgerOrg = do
  let url :: Url 'Https
url = Text -> Url 'Https
https Text
"hledger.org" Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"install.html"
  do
    result <- IO BsResponse -> IO (Either HttpException BsResponse)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO BsResponse -> IO (Either HttpException BsResponse))
-> IO BsResponse -> IO (Either HttpException BsResponse)
forall a b. (a -> b) -> a -> b
$ HttpConfig -> Req BsResponse -> IO BsResponse
forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
runReq HttpConfig
defaultHttpConfig (Req BsResponse -> IO BsResponse)
-> Req BsResponse -> IO BsResponse
forall a b. (a -> b) -> a -> b
$ GET
-> Url 'Https
-> NoReqBody
-> Proxy BsResponse
-> Option 'Https
-> Req BsResponse
forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
 HttpResponse response,
 HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req GET
GET Url 'Https
url NoReqBody
NoReqBody Proxy BsResponse
bsResponse (Int -> Option 'Https
forall (scheme :: Scheme). Int -> Option scheme
R.responseTimeout Int
httptimeout)
    case result of
      Left (HttpException
_ :: R.HttpException) -> Either String String -> IO (Either String String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. a -> Either a b
Left String
"(HTTP failure)"
      Right BsResponse
rsp -> case ByteString -> Either UnicodeException Text
T.decodeUtf8' (ByteString -> Either UnicodeException Text)
-> ByteString -> Either UnicodeException Text
forall a b. (a -> b) -> a -> b
$ BsResponse -> HttpResponseBody BsResponse
forall response.
HttpResponse response =>
response -> HttpResponseBody response
R.responseBody BsResponse
rsp of
        Left UnicodeException
e  -> Either String String -> IO (Either String String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. a -> Either a b
Left (String -> Either String String) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ UnicodeException -> String
forall a. Show a => a -> String
show UnicodeException
e
        Right Text
t -> Either String String -> IO (Either String String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$
          if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
version then String -> Either String String
forall a b. a -> Either a b
Left String
"couldn't parse version" else String -> Either String String
forall a b. b -> Either a b
Right String
version
          where
            -- keep synced
            versionline :: [String]
versionline = Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
1 ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"current hledger release" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf`)) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t
            version :: String
version = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"0123456789."::[Char])) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isDigit) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. a -> [a] -> a
headDef String
"" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String]
versionline
  -- work around potential failure on mac (& possible security issue, reported upstream)
  IO (Either String String)
-> (IOError -> IO (Either String String))
-> IO (Either String String)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(IOError
_ :: IOError) -> Either String String -> IO (Either String String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. a -> Either a b
Left (String -> Either String String) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ String
"(IO error" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> if String
osString -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
"darwin" then String
" - mac PATH issue ?)" else String
")")

-- | 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 :: [[String]] -> IO (Either String String)
tryHledgerArgs [] = Either String String -> IO (Either String String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. a -> Either a b
Left String
"tryHledgerArgs: no arguments provided"
tryHledgerArgs ([String]
args:[[String]]
rest) = do
  eresult <- [String] -> IO (Either String String)
runHledger [String]
args
  case eresult of
    Right String
out -> Either String String -> IO (Either String String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. b -> Either a b
Right String
out
    Left String
err -> if [[String]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[String]]
rest then Either String String -> IO (Either String String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. a -> Either a b
Left String
err else [[String]] -> IO (Either String String)
tryHledgerArgs [[String]]
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 :: [String] -> IO (Either String String)
runHledger [String]
args = do
  (exit, out, err) <- String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
"hledger" [String]
args String
""
  pure $ case exit of
    ExitCode
ExitSuccess -> String -> Either String String
forall a b. b -> Either a b
Right String
out
    ExitFailure Int
_ -> String -> Either String String
forall a b. a -> Either a b
Left String
err

-- | Get the operating system version string, if possible.
-- Uses platform-specific commands to detect the OS version.
getOSVersion :: IO (Maybe String)
getOSVersion :: IO (Maybe String)
getOSVersion = case String
os of
  String
"darwin"  -> String -> [String] -> IO (Maybe String)
tryCommand String
"sw_vers" [String
"-productVersion"]
  String
"mingw32" -> String -> [String] -> IO (Maybe String)
tryCommand String
"cmd" [String
"/c", String
"ver"]
  String
"linux"   -> String -> [String] -> IO (Maybe String)
tryCommand String
"uname" [String
"-r"]
  String
_         -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
  where
    tryCommand :: String -> [String] -> IO (Maybe String)
tryCommand String
cmd [String]
args =
      (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> (String -> String) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
strip (String -> Maybe String) -> IO String -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO String
readProcess String
cmd [String]
args String
"")
      IO (Maybe String)
-> (SomeException -> IO (Maybe String)) -> IO (Maybe String)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(SomeException
_ :: SomeException) -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing)