From 320d19773590905299e389cc86e2fabfcbd7acd9 Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Thu, 17 Apr 2025 04:16:13 -1000 Subject: [PATCH] imp:setup: more hledger setup tests --- hledger/Hledger/Cli/Commands/Setup.hs | 148 ++++++++++++++++++++------ 1 file changed, 115 insertions(+), 33 deletions(-) diff --git a/hledger/Hledger/Cli/Commands/Setup.hs b/hledger/Hledger/Cli/Commands/Setup.hs index 4e3b89ca7..32adfbdf2 100644 --- a/hledger/Hledger/Cli/Commands/Setup.hs +++ b/hledger/Hledger/Cli/Commands/Setup.hs @@ -1,15 +1,19 @@ {-| -Check and show the status of the hledger installation, -show extra info and hints, -and offer to fix problems where possible. +Check and show the status of the hledger installation. -} +-- {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +-- {-# LANGUAGE NamedFieldPuns #-} +-- {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} + +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} +-- {-# OPTIONS_GHC -Wno-unused-matches #-} module Hledger.Cli.Commands.Setup ( setupmode @@ -17,19 +21,25 @@ module Hledger.Cli.Commands.Setup ( ) where -import System.FilePath +import Control.Exception +import Control.Monad 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 +import Safe +import System.Directory +import System.Exit +import System.FilePath +import System.Info +import System.IO +import System.Process + import Hledger import Hledger.Cli.CliOptions -import Control.Monad -import System.Info -import System.Directory -import System.IO -import Safe --- import Text.Printf (printf) - setupmode = hledgerCommandMode $(embedFileRelative "Hledger/Cli/Commands/Setup.txt") @@ -38,23 +48,33 @@ setupmode = hledgerCommandMode hiddenflags ([], Just $ argsFlag "[QUERY]") --- | 1. Check and show the status of various aspects of the hledger installation. --- 2. Show extra info and hints on how to fix problems. --- 3. When possible, offer to help fix problems, interactively. +-- | Check and show the status of various aspects of the hledger installation. +-- Also show extra info and hints on how to fix problems. 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. - let - p ok ymsg nmsg = - putStrLn $ unwords $ if ok then ["", y, "", ymsg] else ["", n, "", nmsg] - where - y = "yes ✅" - n = "no ❌" + putStrLn "checking setup..." + setupHledger + -- setupConfig + -- setupFiles + -- setupAccounts + -- setupCommodities + -- setupTags +-- | Print a check's status, and optional messages if it's ok or not ok. +p :: Bool -> String -> String -> IO () +p ok ymsg nmsg = + putStrLn $ unwords $ if ok then ["", y, "", ymsg] else ["", n, "", nmsg] + where + y = "yes ✅" + n = "no ❌" + +setupHledger :: IO () +setupHledger = do putStrLn "hledger:" - putStr "- in PATH ?" + putStr "- is in PATH ?" pathexes <- findExecutables progname home <- getHomeDirectory appdata <- getXdgDirectory XdgData "" @@ -82,17 +102,54 @@ setup _opts@CliOpts{rawopts_=_rawopts, reportspec_=_rspec} _ignoredj = do ] p ok pathexe hint - -- putStr "- runnable ?" + -- If hledger was found in PATH, run more checks + when ok $ do - -- putStr "- up to date ?" + putStr "- runs ?" + let arg = "--version" + (exit,out,err) <- readProcessWithExitCode progname [arg] "" + let + ok = exit == ExitSuccess + hint = "'" <> progname <> " " <> arg <> "' failed: \n" <> err + p ok "" hint + let verparts = words out -- use below - -- putStr "- native binary ?" + -- If hledger runs, run more checks + when ok $ do + putStr "- is a native binary ?" + let + exearch = case drop 2 verparts of + w:_ -> w + _ -> error' "couldn't parse arch from --version output" + os' -- keep synced: Version.hs + | os == "darwin" = "mac" + | os == "mingw32" = "windows" + | otherwise = os + sysarch = os' <> "-" <> arch + ok = exearch == sysarch + hint = "installed binary is for " <> exearch <> ", system is " <> sysarch + p ok "" hint + + putStr "- is up to date ?" + elatestver <- getLatestHledgerVersion + let + latestver = case elatestver of + Left e -> error' $ "failed to detect latest hledger version: " <> e + Right v -> v + exedetailedver = case drop 1 verparts of + w:_ -> w + _ -> error' "couldn't parse detailed version from --version output" + exever = takeWhile (`elem` ("0123456789."::String)) exedetailedver + ok = splitAtElement '.' exever >= splitAtElement '.' latestver + msg + | exever == latestver = exever + | otherwise = exever <> " installed, latest release is " <> latestver + p ok msg msg -- putStr "- eget installed ?" - putStr "\n" - - -- putStrLn "config:" +setupConfig = do + putStrLn "config:" -- putStr "- user config file exists ?" -- putStr "\n" -- putStr "- local config masking user config ?" @@ -107,14 +164,16 @@ setup _opts@CliOpts{rawopts_=_rawopts, reportspec_=_rspec} _ignoredj = do -- putStr "\n" -- putStr "\n" - -- putStrLn "files:" +setupFiles = do + putStrLn "files:" -- putStr "- default journal file exists ?" -- putStr "\n" -- putStr "- default journal file readable ?" -- putStr "\n" -- putStr "\n" - -- putStrLn "accounts:" +setupAccounts = do + putStrLn "accounts:" -- putStr "- all account types declared or detected ?" -- putStr "\n" -- putStr " asset, liability, equity, revenue, expense, cash, conversion" @@ -125,16 +184,39 @@ setup _opts@CliOpts{rawopts_=_rawopts, reportspec_=_rspec} _ignoredj = do -- putStr "\n" -- putStr "\n" - -- putStrLn "commodities:" +setupCommodities = do + putStrLn "commodities:" -- putStr "- all used commodities declared ?" -- putStr "\n" -- putStr "\n" - -- putStrLn "tags:" +setupTags = do + putStrLn "tags:" -- putStr "- all used tags declared ?" -- putStr "\n" -- putStr "\n" +getLatestHledgerVersion :: IO (Either String String) +getLatestHledgerVersion = do + result <- try $ runReq defaultHttpConfig{httpConfigRedirectCount=0} $ + req GET (https "hackage.haskell.org" /: "package" /: "hledger" /: "docs" /: "") NoReqBody bsResponse mempty + case result of + Right _ -> return $ Left "no 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 "redirect response with 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 "failed to parse version from Location header" + else return $ Left $ "non-redirect status code: " ++ show status + Left err -> return $ Left $ "other exception: " ++ show err + {- | Ensure there is a journal file at the given path, creating an empty one if needed. On Windows, also ensure that the path contains no trailing dots which could cause data loss (see 'isWindowsUnsafeDotPath').