imp:setup: more hledger setup tests

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').