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

Remove legacy handling of cabal binary

Browse Source
This commit is contained in:
Julian Ospald 2021-06-12 22:26:50 +02:00
parent a396b6044d
commit 4dcc63606e
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
2 changed files with 17 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
lib/GHCup.hs
View File

@ -878,7 +878,7 @@ listVersions :: ( MonadCatch m
listVersions lt' criteria = do listVersions lt' criteria = do
-- some annoying work to avoid too much repeated IO -- some annoying work to avoid too much repeated IO
cSet <- cabalSet cSet <- cabalSet
cabals <- getInstalledCabals' cSet cabals <- getInstalledCabals
hlsSet' <- hlsSet hlsSet' <- hlsSet
hlses <- getInstalledHLSs hlses <- getInstalledHLSs
sSet <- stackSet sSet <- stackSet

34
lib/GHCup/Utils.hs
View File

@ -87,7 +87,6 @@ import qualified Codec.Archive.Tar as Tar
import qualified Codec.Compression.BZip as BZip import qualified Codec.Compression.BZip as BZip
import qualified Codec.Compression.GZip as GZip import qualified Codec.Compression.GZip as GZip
import qualified Codec.Compression.Lzma as Lzma import qualified Codec.Compression.Lzma as Lzma
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import qualified Data.Text as T import qualified Data.Text as T
@ -253,14 +252,6 @@ getInstalledGHCs = do
getInstalledCabals :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m) getInstalledCabals :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
=> m [Either FilePath Version] => m [Either FilePath Version]
getInstalledCabals = do getInstalledCabals = do
cs <- cabalSet -- for legacy cabal
getInstalledCabals' cs
getInstalledCabals' :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
=> Maybe Version
-> m [Either FilePath Version]
getInstalledCabals' cs = do
AppState {dirs = Dirs {..}} <- ask AppState {dirs = Dirs {..}} <- ask
bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles
binDir binDir
@ -269,7 +260,7 @@ getInstalledCabals' cs = do
Just (Right r) -> pure $ Right r Just (Right r) -> pure $ Right r
Just (Left _) -> pure $ Left f Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f Nothing -> pure $ Left f
pure $ maybe vs (\x -> nub $ Right x:vs) cs pure $ nub vs
-- | Whether the given cabal version is installed. -- | Whether the given cabal version is installed.
@ -284,32 +275,21 @@ cabalSet :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadThrow m, Mon
cabalSet = do cabalSet = do
AppState {dirs = Dirs {..}} <- ask AppState {dirs = Dirs {..}} <- ask
let cabalbin = binDir </> "cabal" <> exeExt let cabalbin = binDir </> "cabal" <> exeExt
b <- handleIO (\_ -> pure False) $ liftIO $ pathIsLink cabalbin
if
| b -> do
handleIO' NoSuchThing (\_ -> pure Nothing) $ do handleIO' NoSuchThing (\_ -> pure Nothing) $ do
broken <- liftIO $ isBrokenSymlink cabalbin broken <- liftIO $ isBrokenSymlink cabalbin
if broken if broken
then pure Nothing then pure Nothing
else do else do
link <- liftIO $ getLinkTarget cabalbin link <- liftIO
case linkVersion link of $ handleIO' InvalidArgument
(\e -> pure $ Left (toException e))
$ fmap Right $ getLinkTarget cabalbin
case linkVersion =<< link of
Right v -> pure $ Just v Right v -> pure $ Just v
Left err -> do Left err -> do
$(logWarn) [i|Failed to parse cabal symlink target with: "#{err}". The symlink #{cabalbin} needs to point to valid cabal binary, such as 'cabal-3.4.0.0'.|] $(logWarn) [i|Failed to parse cabal symlink target with: "#{err}". The symlink #{cabalbin} needs to point to valid cabal binary, such as 'cabal-3.4.0.0'.|]
pure Nothing pure Nothing
| otherwise -> do -- legacy behavior
mc <- handleIO (\_ -> pure Nothing) $ fmap Just $ executeOut
cabalbin
["--numeric-version"]
Nothing
fmap join $ forM mc $ \c -> if
| not (BL.null (_stdOut c)), _exitCode c == ExitSuccess -> do
let reportedVer = fst . B.spanEnd isNewLine . BL.toStrict . _stdOut $ c
case version $ decUTF8Safe reportedVer of
Left e -> throwM e
Right r -> pure $ Just r
| otherwise -> pure Nothing
where where
-- We try to be extra permissive with link destination parsing, -- We try to be extra permissive with link destination parsing,
-- because of: -- because of: