{-|

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.Exception
import Control.Monad
-- import qualified Data.ByteString as B
import Data.Char
import Data.Default (def)
import Data.List
import qualified Data.Map as M
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.Encoding 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.Process
import Text.Printf (printf)

import Hledger hiding (setupPager)
import Hledger.Cli.CliOptions
import Hledger.Cli.Conf
import Hledger.Cli.Version
import System.IO (localeEncoding)


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"

  pdesc "is a released version ?"
  if isReleaseVersion $ hbinPackageVersion binaryinfo
  then p Y prognameandversion
  else i N prognameandversion

  pdesc "is up to date ?"
  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)
          (showVersion (hbinPackageVersion binaryinfo) <> " installed, latest is " <> latestversionnumstr)

  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 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
            pdesc "the LESS variable is defined ?"
            mLESS <- lookupEnv "LESS"
            case mLESS of
              Nothing -> i N ""
              Just _  -> i Y ""

            pdesc "the HLEDGER_LESS variable is defined ?"
            mHLEDGER_LESS <- lookupEnv "HLEDGER_LESS"
            case mHLEDGER_LESS of
              Nothing -> i N ""
              Just v  -> i Y v

            when (isNothing mHLEDGER_LESS) $ do
              pdesc "adjusting LESS variable for color etc. ?"
              usecolor <- useColorOnStdout
              i (if usecolor then Y else N) ""

  pdesc "tables will use box-drawing chars ?"
  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 ?"
  jfile <- defaultJournalPath
  -- 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
  case ej of
    Left estr -> p N (jfile <> ":\n" <> estr)
    Right j@Journal{..} -> do
      p Y jfile

      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 "all account types are detected ?"
      if null typesnotfound
      then p Y (concatMap show accttypes <> " account types detected")
      else p N (concatMap show typesnotfound <> " not found; bs/cf/is 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 (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 "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