Make parser more lax, fixes #119

Also make sure we don't print the warning message
20 times, so avoid some repeated IO.

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 <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
+    let mhls_ver = latestInstalled HLS
-    forM mcabal_ver $ \cabal_ver ->
+    forM mhls_ver $ \hls_ver ->
-      when (l > cabal_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

lib/GHCup.hs

@@ -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
+        ghcvers   <- go (Just GHC) cSet cabals hlsSet' hlses
-      cabalvers <- listVersions av (Just Cabal) criteria pfreq
+        cabalvers <- go (Just Cabal) cSet cabals hlsSet' hlses
-      hlsvers   <- listVersions av (Just HLS) criteria pfreq
+        hlsvers   <- go (Just HLS) cSet cabals hlsSet' hlses
-      ghcupvers <- listVersions av (Just GHCup) criteria pfreq
+        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
+  strayCabals avTools cSet cabals = do
-    cabals <- getInstalledCabals
     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 :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
-  toListResult t (v, tags) = case t of
+               => 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
+      let lSet = cSet == Just v
-      lInstalled <- cabalInstalled 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
+      let lSet = hlsSet' == Just v
-      lInstalled <- hlsInstalled v
+      let lInstalled = elem v $ rights hlses
       pure ListResult { lVer    = v
                       , lCross  = Nothing
                       , lTag    = tags

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
+      handleIO' NoSuchThing (\_ -> pure Nothing) $ do
-        broken <- isBrokenSymlink cabalbin
+        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
+            link <- liftIO $ readSymbolicLink $ toFilePath cabalbin
-            Just <$> linkVersion link
+            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 =
+  parser
-      MP.chunk "cabal-" *> version'
+    =   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)