slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

imp: setup: version check: add a timeout, improve error output

Browse Source
This commit is contained in:
Simon Michael 2025-04-19 14:37:20 -10:00
parent 15173eeeb0
commit 97e2e8572f
1 changed files with 20 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
hledger/Hledger/Cli/Commands/Setup.hs
View File

@ -32,7 +32,7 @@ import qualified Data.Text.Encoding as T
-- import qualified Data.Text.IO as T -- import qualified Data.Text.IO as T
import Network.HTTP.Client import Network.HTTP.Client
import Network.HTTP.Types (statusCode, hLocation) import Network.HTTP.Types (statusCode, hLocation)
import Network.HTTP.Req import Network.HTTP.Req as R
import Safe import Safe
import System.Directory import System.Directory
import System.Exit import System.Exit
@ -163,18 +163,20 @@ setupHledger = do
pdesc "is up to date ?" pdesc "is up to date ?"
elatestver <- getLatestHledgerVersion elatestver <- getLatestHledgerVersion
let let
latestver = case elatestver of (ok,msg) = case elatestver of
Left e -> error' $ "failed to detect latest hledger version: " <> e Left e -> (False, "could not check latest version: " <> e)
Right v -> v Right latestver ->
exedetailedver = case drop 1 verparts of case drop 1 verparts of
w:_ -> w [] -> (False, "could not parse --version output")
_ -> error' "couldn't parse detailed version from --version output" w:_ -> (ok, msg)
exever = takeWhile (`elem` ("0123456789."::String)) exedetailedver where
ok = splitAtElement '.' exever >= splitAtElement '.' latestver exever = takeWhile (`elem` ("0123456789."::String)) w
msg ok = splitAtElement '.' exever >= splitAtElement '.' latestver
| exever == latestver = exever msg =
| otherwise = exever <> " installed, latest release is " <> latestver if exever == latestver
p ok msg msg then exever
else exever <> " installed, latest release is " <> latestver
w ok msg msg
-- pdesc "eget installed ?" -- pdesc "eget installed ?"
@ -294,10 +296,13 @@ setupTags = do
-- pdesc "\n" -- pdesc "\n"
-- pdesc "\n" -- pdesc "\n"
-- | 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 times out after 10 seconds.
getLatestHledgerVersion :: IO (Either String String) getLatestHledgerVersion :: IO (Either String String)
getLatestHledgerVersion = do getLatestHledgerVersion = do
result <- try $ runReq defaultHttpConfig{httpConfigRedirectCount=0} $ result <- try $ runReq defaultHttpConfig{httpConfigRedirectCount=0} $
req HEAD (https "hackage.haskell.org" /: "package" /: "hledger" /: "docs" /: "") NoReqBody bsResponse mempty req HEAD (https "hackage.haskell.org" /: "package" /: "hledger" /: "docs" /: "") NoReqBody bsResponse (R.responseTimeout 10000000) -- 10s
case result of case result of
Right _ -> return $ Left "no redirect" Right _ -> return $ Left "no redirect"
Left (VanillaHttpException (HttpExceptionRequest _ (StatusCodeException rsp _))) -> do Left (VanillaHttpException (HttpExceptionRequest _ (StatusCodeException rsp _))) -> do
@ -312,6 +317,6 @@ getLatestHledgerVersion = do
case packagename of case packagename of
[n] -> return $ Right $ dropWhile (`notElem` ['0'..'9']) $ T.unpack n [n] -> return $ Right $ dropWhile (`notElem` ['0'..'9']) $ T.unpack n
_ -> return $ Left "failed to parse version from Location header" _ -> return $ Left "failed to parse version from Location header"
else return $ Left $ "non-redirect status code: " ++ show status else return $ Left $ "expected redirect, got HTTP status " ++ show status
Left err -> return $ Left $ "other exception: " ++ show err Left err -> return $ Left $ "other exception: " ++ show err