Make parser more lax, fixes #119

Also make sure we don't print the warning message 20 times, so avoid some repeated IO.
2021-04-01 17:21:00 +02:00
parent f4201d946a
commit 7383fdd0c0
3 changed files with 101 additions and 58 deletions
--- 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
--- 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)