hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Make parser more lax, fixes #119

Browse Source 
Also make sure we don't print the warning message
20 times, so avoid some repeated IO.
This commit is contained in:
Julian Ospald 2021-04-01 17:21:00 +02:00
parent f4201d946a
commit 7383fdd0c0
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
3 changed files with 101 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
app/ghcup/Main.hs
View File

@ -149,7 +149,7 @@ data SetOptions = SetOptions
}
data ListOptions = ListOptions
{ lTool :: Maybe Tool
{ loTool :: Maybe Tool
, lCriteria :: Maybe ListCriteria
, lRawFormat :: Bool
}
@ -1446,7 +1446,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
List ListOptions {..} ->
runListGHC (do
l <- listVersions dls lTool lCriteria pfreq
l <- listVersions dls loTool lCriteria pfreq
liftIO $ printListResult lRawFormat l
pure ExitSuccess
)
@ -1592,14 +1592,14 @@ Make sure to clean up #{tmpdir} afterwards.|])
ef@(ExitFailure _) -> exitWith ef
pure ()
fromVersion :: (MonadFail m, MonadReader AppState m, MonadThrow m, MonadIO m, MonadCatch m)
fromVersion :: (MonadLogger m, MonadFail m, MonadReader AppState m, MonadThrow m, MonadIO m, MonadCatch m)
=> GHCupDownloads
-> Maybe ToolVersion
-> Tool
-> Excepts '[TagNotFound, NextVerNotFound, NoToolVersionSet] m (GHCTargetVersion, Maybe VersionInfo)
fromVersion av tv = fromVersion' av (toSetToolVer tv)
fromVersion' :: (MonadFail m, MonadReader AppState m, MonadThrow m, MonadIO m, MonadCatch m)
fromVersion' :: (MonadLogger m, MonadFail m, MonadReader AppState m, MonadThrow m, MonadIO m, MonadCatch m)
=> GHCupDownloads
-> SetToolVersion
-> Tool
@ -1822,6 +1822,9 @@ checkForUpdates :: ( MonadReader AppState m
-> PlatformRequest
-> m ()
checkForUpdates dls pfreq = do
lInstalled <- listVersions dls Nothing (Just ListInstalled) pfreq
let latestInstalled tool = (fmap lVer . lastMay . filter (\lr -> lTool lr == tool)) lInstalled
forM_ (getLatest dls GHCup) $ \(l, _) -> do
(Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer
when (l > ghc_ver)
@ -1829,30 +1832,26 @@ checkForUpdates dls pfreq = do
[i|New GHCup version available: #{prettyVer l}. To upgrade, run 'ghcup upgrade'|]
forM_ (getLatest dls GHC) $ \(l, _) -> do
mghc_ver <- latestInstalled GHC
let mghc_ver = latestInstalled GHC
forM mghc_ver $ \ghc_ver ->
when (l > ghc_ver)
$ $(logWarn)
[i|New GHC version available: #{prettyVer l}. To upgrade, run 'ghcup install ghc #{prettyVer l}'|]
forM_ (getLatest dls Cabal) $ \(l, _) -> do
mcabal_ver <- latestInstalled Cabal
let mcabal_ver = latestInstalled Cabal
forM mcabal_ver $ \cabal_ver ->
when (l > cabal_ver)
$ $(logWarn)
[i|New Cabal version available: #{prettyVer l}. To upgrade, run 'ghcup install cabal #{prettyVer l}'|]
forM_ (getLatest dls HLS) $ \(l, _) -> do
mcabal_ver <- latestInstalled HLS
forM mcabal_ver $ \cabal_ver ->
when (l > cabal_ver)
let mhls_ver = latestInstalled HLS
forM mhls_ver $ \hls_ver ->
when (l > hls_ver)
$ $(logWarn)
[i|New HLS version available: #{prettyVer l}. To upgrade, run 'ghcup install hls #{prettyVer l}'|]
where
latestInstalled tool = (fmap lVer . lastMay)
<$> listVersions dls (Just tool) (Just ListInstalled) pfreq
prettyDebugInfo :: DebugInfo -> String
prettyDebugInfo DebugInfo {..} = [i|Debug Info

51
lib/GHCup.hs
View File

@ -718,32 +718,39 @@ listVersions :: ( MonadCatch m
-> Maybe ListCriteria
-> PlatformRequest
-> m [ListResult]
listVersions av lt criteria pfreq = do
listVersions av lt' criteria pfreq = do
-- some annoying work to avoid too much repeated IO
cSet <- cabalSet
cabals <- getInstalledCabals' cSet
hlsSet' <- hlsSet
hlses <- getInstalledHLSs
go lt' cSet cabals hlsSet' hlses
where
go lt cSet cabals hlsSet' hlses = do
case lt of
Just t -> do
-- get versions from GHCupDownloads
let avTools = availableToolVersions av t
lr <- filter' <$> forM (Map.toList avTools) (toListResult t)
lr <- filter' <$> forM (Map.toList avTools) (toListResult t cSet cabals hlsSet' hlses)
case t of
GHC -> do
slr <- strayGHCs avTools
pure (sort (slr ++ lr))
Cabal -> do
slr <- strayCabals avTools
slr <- strayCabals avTools cSet cabals
pure (sort (slr ++ lr))
HLS -> do
slr <- strayHLS avTools
pure (sort (slr ++ lr))
GHCup -> pure lr
Nothing -> do
ghcvers <- listVersions av (Just GHC) criteria pfreq
cabalvers <- listVersions av (Just Cabal) criteria pfreq
hlsvers <- listVersions av (Just HLS) criteria pfreq
ghcupvers <- listVersions av (Just GHCup) criteria pfreq
ghcvers <- go (Just GHC) cSet cabals hlsSet' hlses
cabalvers <- go (Just Cabal) cSet cabals hlsSet' hlses
hlsvers <- go (Just HLS) cSet cabals hlsSet' hlses
ghcupvers <- go (Just GHCup) cSet cabals hlsSet' hlses
pure (ghcvers <> cabalvers <> hlsvers <> ghcupvers)
where
strayGHCs :: (MonadCatch m, MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m)
=> Map.Map Version [Tag]
-> m [ListResult]
@ -788,15 +795,16 @@ listVersions av lt criteria pfreq = do
strayCabals :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m)
=> Map.Map Version [Tag]
-> Maybe Version
-> [Either (Path Rel) Version]
-> m [ListResult]
strayCabals avTools = do
cabals <- getInstalledCabals
strayCabals avTools cSet cabals = do
fmap catMaybes $ forM cabals $ \case
Right ver ->
case Map.lookup ver avTools of
Just _ -> pure Nothing
Nothing -> do
lSet <- fmap (== Just ver) cabalSet
let lSet = cSet == Just ver
pure $ Just $ ListResult
{ lTool = Cabal
, lVer = ver
@ -843,8 +851,15 @@ listVersions av lt criteria pfreq = do
pure Nothing
-- NOTE: this are not cross ones, because no bindists
toListResult :: (MonadReader AppState m, MonadIO m, MonadCatch m) => Tool -> (Version, [Tag]) -> m ListResult
toListResult t (v, tags) = case t of
toListResult :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
=> Tool
-> Maybe Version
-> [Either (Path Rel) Version]
-> Maybe Version
-> [Either (Path Rel) Version]
-> (Version, [Tag])
-> m ListResult
toListResult t cSet cabals hlsSet' hlses (v, tags) = case t of
GHC -> do
let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq av
let tver = mkTVer v
@ -855,8 +870,8 @@ listVersions av lt criteria pfreq = do
pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. }
Cabal -> do
let lNoBindist = isLeft $ getDownloadInfo Cabal v pfreq av
lSet <- fmap (== Just v) cabalSet
lInstalled <- cabalInstalled v
let lSet = cSet == Just v
let lInstalled = elem v $ rights cabals
pure ListResult { lVer = v
, lCross = Nothing
, lTag = tags
@ -881,8 +896,8 @@ listVersions av lt criteria pfreq = do
}
HLS -> do
let lNoBindist = isLeft $ getDownloadInfo HLS v pfreq av
lSet <- fmap (== Just v) hlsSet
lInstalled <- hlsInstalled v
let lSet = hlsSet' == Just v
let lInstalled = elem v $ rights hlses
pure ListResult { lVer = v
, lCross = Nothing
, lTag = tags

53
lib/GHCup/Utils.hs
View File

@ -249,9 +249,17 @@ getInstalledGHCs = do
-- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
getInstalledCabals :: (MonadReader AppState m, MonadIO m, MonadCatch m)
getInstalledCabals :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
=> m [Either (Path Rel) Version]
getInstalledCabals = do
cs <- cabalSet -- for legacy cabal
getInstalledCabals' cs
getInstalledCabals' :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
=> Maybe Version
-> m [Either (Path Rel) Version]
getInstalledCabals' cs = do
AppState {dirs = Dirs {..}} <- ask
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir
@ -260,32 +268,37 @@ getInstalledCabals = do
Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f
cs <- cabalSet -- for legacy cabal
pure $ maybe vs (\x -> nub $ Right x:vs) cs
-- | Whether the given cabal version is installed.
cabalInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
cabalInstalled :: (MonadLogger m, MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
cabalInstalled ver = do
vers <- fmap rights getInstalledCabals
pure $ elem ver vers
-- Return the currently set cabal version, if any.
cabalSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
cabalSet :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
cabalSet = do
AppState {dirs = Dirs {..}} <- ask
let cabalbin = binDir </> [rel|cabal|]
b <- handleIO (\_ -> pure False) $ fmap (== SymbolicLink) $ liftIO $ getFileType cabalbin
if
| b -> do
liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
broken <- isBrokenSymlink cabalbin
handleIO' NoSuchThing (\_ -> pure Nothing) $ do
broken <- liftIO $ isBrokenSymlink cabalbin
if broken
then pure Nothing
then do
$(logWarn) [i|Symlink #{cabalbin} is broken.|]
pure Nothing
else do
link <- readSymbolicLink $ toFilePath cabalbin
Just <$> linkVersion link
link <- liftIO $ readSymbolicLink $ toFilePath cabalbin
case linkVersion link of
Right v -> pure $ Just v
Left err -> do
$(logWarn) [i|Failed to parse cabal symlink target with: "#{err}". The symlink #{toFilePath cabalbin} needs to point to valid cabal binary, such as 'cabal-3.4.0.0'.|]
pure Nothing
| otherwise -> do -- legacy behavior
mc <- liftIO $ handleIO (\_ -> pure Nothing) $ fmap Just $ executeOut
cabalbin
@ -299,13 +312,29 @@ cabalSet = do
Right r -> pure $ Just r
| otherwise -> pure Nothing
where
-- We try to be extra permissive with link destination parsing,
-- because of:
-- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/119
linkVersion :: MonadThrow m => ByteString -> m Version
linkVersion bs = do
t <- throwEither $ E.decodeUtf8' bs
throwEither $ MP.parse parser "" t
where
parser =
MP.chunk "cabal-" *> version'
parser
= MP.try (stripAbsolutePath *> cabalParse)
<|> MP.try (stripRelativePath *> cabalParse)
<|> cabalParse
-- parses the version of "cabal-3.2.0.0" -> "3.2.0.0"
cabalParse = MP.chunk "cabal-" *> version'
-- parses any path component ending with path separator,
-- e.g. "foo/"
stripPathComponet = parseUntil1 "/" *> MP.chunk "/"
-- parses an absolute path up until the last path separator,
-- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo"
stripAbsolutePath = MP.chunk "/" *> MP.many (MP.try stripPathComponet)
-- parses a relative path up until the last path separator,
-- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo"
stripRelativePath = MP.many (MP.try stripPathComponet)