diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 28f1434..6541799 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -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 |] 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 diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 8722aac..7d47aa2 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -718,32 +718,39 @@ listVersions :: ( MonadCatch m -> Maybe ListCriteria -> PlatformRequest -> m [ListResult] -listVersions av lt criteria pfreq = do - case lt of - Just t -> do - -- get versions from GHCupDownloads - let avTools = availableToolVersions av t - lr <- filter' <$> forM (Map.toList avTools) (toListResult t) - - case t of - GHC -> do - slr <- strayGHCs avTools - pure (sort (slr ++ lr)) - Cabal -> do - slr <- strayCabals avTools - 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 - pure (ghcvers <> cabalvers <> hlsvers <> ghcupvers) +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 cSet cabals hlsSet' hlses) + + case t of + GHC -> do + slr <- strayGHCs avTools + pure (sort (slr ++ lr)) + Cabal -> do + slr <- strayCabals avTools cSet cabals + pure (sort (slr ++ lr)) + HLS -> do + slr <- strayHLS avTools + pure (sort (slr ++ lr)) + GHCup -> pure lr + Nothing -> do + 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) 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 diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index a633288..3a101b5 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -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)