diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,15 @@ # Revision history for ghcup +## 0.1.19.1 -- 2023-2-19 + +* Fix GHCup on JFS/ReiserFS and other filesystem that don't support `d_type`, fixes [#766](https://github.com/haskell/ghcup-hs/issues/766) +* Don't fail on setModificationTime, fixes [#784](https://github.com/haskell/ghcup-hs/issues/784) and many GitHub actions issues +* Make armv7/aarch64 linux binaries more portable (built on Debian buster) +* Improve usability on 'ghcup config add-release-channel', fixes [#751](https://github.com/haskell/ghcup-hs/issues/751) +* Make version shortcuts work with 'ghcup set', fixes [#757](https://github.com/haskell/ghcup-hs/issues/757) +* Don't implicitly smuggle in config options in `ghcup config set` wrt [#775](https://github.com/haskell/ghcup-hs/issues/775) +* Fix build on unix with -ftui + ## 0.1.19.0 -- 2023-1-13 * restore proper support for FreeBSD and Linux armv7 diff --git a/app/ghcup/GHCup/OptParse/Config.hs b/app/ghcup/GHCup/OptParse/Config.hs --- a/app/ghcup/GHCup/OptParse/Config.hs +++ b/app/ghcup/GHCup/OptParse/Config.hs @@ -51,7 +51,7 @@ = ShowConfig | SetConfig String (Maybe String) | InitConfig - | AddReleaseChannel URI + | AddReleaseChannel Bool URI @@ -59,7 +59,7 @@ --[ Parsers ]-- --------------- - + configP :: Parser ConfigCommand configP = subparser ( command "init" initP @@ -74,7 +74,7 @@ showP = info (pure ShowConfig) (progDesc "Show current config (default)") setP = info argsP (progDesc "Set config KEY to VALUE (or specify as single json value)" <> footerDoc (Just $ text configSetFooter)) argsP = SetConfig <$> argument str (metavar "") <*> optional (argument str (metavar "YAML_VALUE")) - addP = info (AddReleaseChannel <$> argument (eitherReader uriParser) (metavar "URI" <> completer fileUri)) + addP = info (AddReleaseChannel <$> switch (long "force" <> help "Delete existing entry (if any) and append instead of failing") <*> argument (eitherReader uriParser) (metavar "URI" <> completer fileUri)) (progDesc "Add a release channel from a URI") @@ -120,21 +120,38 @@ formatConfig = UTF8.toString . Y.encode -updateSettings :: UserSettings -> Settings -> Settings -updateSettings UserSettings{..} Settings{..} = - let cache' = fromMaybe cache uCache - metaCache' = fromMaybe metaCache uMetaCache - metaMode' = fromMaybe metaMode uMetaMode - noVerify' = fromMaybe noVerify uNoVerify - keepDirs' = fromMaybe keepDirs uKeepDirs - downloader' = fromMaybe downloader uDownloader - verbose' = fromMaybe verbose uVerbose - urlSource' = fromMaybe urlSource uUrlSource - noNetwork' = fromMaybe noNetwork uNoNetwork - gpgSetting' = fromMaybe gpgSetting uGPGSetting - platformOverride' = uPlatformOverride <|> platformOverride - mirrors' = fromMaybe mirrors uMirrors - in Settings cache' metaCache' metaMode' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor platformOverride' mirrors' +updateSettings :: UserSettings -> UserSettings -> UserSettings +updateSettings usl usr = + let cache' = uCache usl <|> uCache usr + metaCache' = uMetaCache usl <|> uMetaCache usr + metaMode' = uMetaMode usl <|> uMetaMode usr + noVerify' = uNoVerify usl <|> uNoVerify usr + verbose' = uVerbose usl <|> uVerbose usr + keepDirs' = uKeepDirs usl <|> uKeepDirs usr + downloader' = uDownloader usl <|> uDownloader usr + urlSource' = uUrlSource usl <|> uUrlSource usr + noNetwork' = uNoNetwork usl <|> uNoNetwork usr + gpgSetting' = uGPGSetting usl <|> uGPGSetting usr + platformOverride' = uPlatformOverride usl <|> uPlatformOverride usr + mirrors' = uMirrors usl <|> uMirrors usr + in UserSettings cache' metaCache' metaMode' noVerify' verbose' keepDirs' downloader' (updateKeyBindings (uKeyBindings usl) (uKeyBindings usr)) urlSource' noNetwork' gpgSetting' platformOverride' mirrors' + where + updateKeyBindings :: Maybe UserKeyBindings -> Maybe UserKeyBindings -> Maybe UserKeyBindings + updateKeyBindings Nothing Nothing = Nothing + updateKeyBindings (Just kbl) Nothing = Just kbl + updateKeyBindings Nothing (Just kbr) = Just kbr + updateKeyBindings (Just kbl) (Just kbr) = + Just $ UserKeyBindings { + kUp = kUp kbl <|> kUp kbr + , kDown = kDown kbl <|> kDown kbr + , kQuit = kQuit kbl <|> kQuit kbr + , kInstall = kInstall kbl <|> kInstall kbr + , kUninstall = kUninstall kbl <|> kUninstall kbr + , kSet = kSet kbl <|> kSet kbr + , kChangelog = kChangelog kbl <|> kChangelog kbr + , kShowAll = kShowAll kbl <|> kShowAll kbr + , kShowAllTools = kShowAllTools kbl <|> kShowAllTools kbr + } @@ -142,6 +159,9 @@ --[ Entrypoint ]-- ------------------ +data Duplicate = Duplicate -- ^ there is a duplicate somewhere in the middle + | NoDuplicate -- ^ there is no duplicate + | DuplicateLast -- ^ there's a duplicate, but it's the last element config :: forall m. ( Monad m @@ -151,10 +171,11 @@ ) => ConfigCommand -> Settings + -> UserSettings -> KeyBindings -> (ReaderT LeanAppState m () -> m ()) -> m ExitCode -config configCommand settings keybindings runLogger = case configCommand of +config configCommand settings userConf keybindings runLogger = case configCommand of InitConfig -> do path <- getConfigFilePath liftIO $ writeFile path $ formatConfig $ fromSettings settings (Just keybindings) @@ -185,27 +206,55 @@ pure $ ExitFailure 65 VLeft _ -> pure $ ExitFailure 65 - AddReleaseChannel uri -> do - case urlSource settings of - AddSource xs -> do - doConfig (defaultUserSettings { uUrlSource = Just $ AddSource (xs <> [Right uri]) }) - pure ExitSuccess - GHCupURL -> do - doConfig (defaultUserSettings { uUrlSource = Just $ AddSource [Right uri] }) - pure ExitSuccess - OwnSource xs -> do - doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource (xs <> [Right uri]) }) - pure ExitSuccess - OwnSpec spec -> do - doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource ([Left spec, Right uri]) }) + AddReleaseChannel force uri -> do + r <- runE @'[DuplicateReleaseChannel] $ do + case urlSource settings of + AddSource xs -> do + case checkDuplicate xs (Right uri) of + Duplicate + | not force -> throwE (DuplicateReleaseChannel uri) + DuplicateLast -> pure () + _ -> lift $ doConfig (defaultUserSettings { uUrlSource = Just $ AddSource (appendUnique xs (Right uri)) }) + GHCupURL -> do + lift $ doConfig (defaultUserSettings { uUrlSource = Just $ AddSource [Right uri] }) + pure () + OwnSource xs -> do + case checkDuplicate xs (Right uri) of + Duplicate + | not force -> throwE (DuplicateReleaseChannel uri) + DuplicateLast -> pure () + _ -> lift $ doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource (appendUnique xs (Right uri)) }) + OwnSpec spec -> do + lift $ doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource [Left spec, Right uri] }) + pure () + case r of + VRight _ -> do pure ExitSuccess + VLeft e -> do + runLogger $ logError $ T.pack $ prettyHFError e + pure $ ExitFailure 15 where + checkDuplicate :: Eq a => [a] -> a -> Duplicate + checkDuplicate xs a + | last xs == a = DuplicateLast + | a `elem` xs = Duplicate + | otherwise = NoDuplicate + + -- appends the element to the end of the list, but also removes it from the existing list + appendUnique :: Eq a => [a] -> a -> [a] + appendUnique xs' e = go xs' + where + go [] = [e] + go (x:xs) + | x == e = go xs -- skip + | otherwise = x : go xs + doConfig :: MonadIO m => UserSettings -> m () doConfig usersettings = do - let settings' = updateSettings usersettings settings + let settings' = updateSettings usersettings userConf path <- liftIO getConfigFilePath - liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings) + liftIO $ writeFile path $ formatConfig $ settings' runLogger $ logDebug $ T.pack $ show settings' pure () diff --git a/app/ghcup/GHCup/OptParse/Set.hs b/app/ghcup/GHCup/OptParse/Set.hs --- a/app/ghcup/GHCup/OptParse/Set.hs +++ b/app/ghcup/GHCup/OptParse/Set.hs @@ -259,7 +259,7 @@ -> m (VEither eff GHCTargetVersion)) -> (ReaderT LeanAppState m () -> m ()) -> m ExitCode -set setCommand runAppState runLeanAppState runLogger = case setCommand of +set setCommand runAppState _ runLogger = case setCommand of (Right sopts) -> do runLogger (logWarn "This is an old-style command for setting GHC. Use 'ghcup set ghc' instead.") setGHC' sopts @@ -271,10 +271,7 @@ where setGHC' :: SetOptions -> m ExitCode - setGHC' SetOptions{ sToolVer } = - case sToolVer of - (SetGHCVersion v) -> runSetGHC runLeanAppState (liftE $ setGHC v SetGHCOnly Nothing >> pure v) - _ -> runSetGHC runAppState (do + setGHC' SetOptions{ sToolVer } = runSetGHC runAppState (do v <- liftE $ fst <$> fromVersion' sToolVer GHC liftE $ setGHC v SetGHCOnly Nothing ) @@ -291,10 +288,7 @@ setCabal' :: SetOptions -> m ExitCode - setCabal' SetOptions{ sToolVer } = - case sToolVer of - (SetToolVersion v) -> runSetCabal runLeanAppState (liftE $ setCabal v >> pure (mkTVer v)) - _ -> runSetCabal runAppState (do + setCabal' SetOptions{ sToolVer } = runSetCabal runAppState (do v <- liftE $ fst <$> fromVersion' sToolVer Cabal liftE $ setCabal (_tvVersion v) pure v @@ -311,10 +305,7 @@ setHLS' :: SetOptions -> m ExitCode - setHLS' SetOptions{ sToolVer } = - case sToolVer of - (SetToolVersion v) -> runSetHLS runLeanAppState (liftE $ setHLS v SetHLSOnly Nothing >> pure (mkTVer v)) - _ -> runSetHLS runAppState (do + setHLS' SetOptions{ sToolVer } = runSetHLS runAppState (do v <- liftE $ fst <$> fromVersion' sToolVer HLS liftE $ setHLS (_tvVersion v) SetHLSOnly Nothing pure v @@ -332,10 +323,7 @@ setStack' :: SetOptions -> m ExitCode - setStack' SetOptions{ sToolVer } = - case sToolVer of - (SetToolVersion v) -> runSetStack runLeanAppState (liftE $ setStack v >> pure (mkTVer v)) - _ -> runSetStack runAppState (do + setStack' SetOptions{ sToolVer } = runSetStack runAppState (do v <- liftE $ fst <$> fromVersion' sToolVer Stack liftE $ setStack (_tvVersion v) pure v diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -63,7 +63,7 @@ -toSettings :: Options -> IO (Settings, KeyBindings) +toSettings :: Options -> IO (Settings, KeyBindings, UserSettings) toSettings options = do noColor <- isJust <$> lookupEnv "NO_COLOR" userConf <- runE @'[ JSONError ] ghcupConfigFile >>= \case @@ -73,7 +73,7 @@ pure defaultUserSettings _ -> do die "Unexpected error!" - pure $ mergeConf options userConf noColor + pure $ (\(s', k) -> (s', k, userConf)) $ mergeConf options userConf noColor where mergeConf :: Options -> UserSettings -> Bool -> (Settings, KeyBindings) mergeConf Options{..} UserSettings{..} noColor = @@ -176,7 +176,7 @@ -- create ~/.ghcup dir ensureDirectories dirs - (settings, keybindings) <- toSettings opt + (settings, keybindings, userConf) <- toSettings opt -- logger interpreter logfile <- runReaderT initGHCupFileLogging dirs @@ -303,7 +303,7 @@ Rm rmCommand -> rm rmCommand runAppState runLogger DInfo -> dinfo runAppState runLogger Compile compileCommand -> compile compileCommand settings dirs runAppState runLogger - Config configCommand -> config configCommand settings keybindings runLogger + Config configCommand -> config configCommand settings userConf keybindings runLogger Whereis whereisOptions whereisCommand -> whereis whereisCommand whereisOptions runAppState leanAppstate runLogger Upgrade uOpts force' fatal -> upgrade uOpts force' fatal dirs runAppState runLogger diff --git a/ghcup.cabal b/ghcup.cabal --- a/ghcup.cabal +++ b/ghcup.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: ghcup -version: 0.1.19.0 +version: 0.1.19.1 license: LGPL-3.0-only license-file: LICENSE copyright: Julian Ospald 2020 diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -263,8 +263,12 @@ dlWithMod modTime json_file = do let (dir, fn) = splitFileName json_file f <- liftE $ download uri' (Just $ over pathL' (<> ".sig") uri') Nothing Nothing dir (Just fn) True - liftIO $ setModificationTime f modTime - liftIO $ setAccessTime f modTime + + -- make these failures non-fatal, also see: + -- https://github.com/actions/runner-images/issues/7061 + handleIO (\e -> logWarn $ "setModificationTime failed with: " <> T.pack (displayException e)) $ liftIO $ setModificationTime f modTime + handleIO (\e -> logWarn $ "setAccessTime failed with: " <> T.pack (displayException e)) $ liftIO $ setAccessTime f modTime + pure f diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -35,6 +35,8 @@ import qualified Data.Map.Strict as M import qualified Data.Text as T +import qualified Data.Text.Encoding as E +import qualified Data.Text.Encoding.Error as E import Data.Data (Proxy(..)) @@ -82,6 +84,7 @@ , let proxy = Proxy :: Proxy HadrianNotFound in format proxy , let proxy = Proxy :: Proxy ToolShadowed in format proxy , let proxy = Proxy :: Proxy ContentLengthError in format proxy + , let proxy = Proxy :: Proxy DuplicateReleaseChannel in format proxy , "" , "# high level errors (4000+)" , let proxy = Proxy :: Proxy DownloadFailed in format proxy @@ -639,6 +642,19 @@ instance HFErrorProject ContentLengthError where eBase _ = 340 eDesc _ = "File content length verification failed" + +data DuplicateReleaseChannel = DuplicateReleaseChannel URI + deriving Show + +instance HFErrorProject DuplicateReleaseChannel where + eBase _ = 350 + eDesc _ = "Duplicate release channel detected when adding URI.\nGiving up. You can use '--force' to remove and append the duplicate URI (this may change order/semantics)." + +instance Pretty DuplicateReleaseChannel where + pPrint (DuplicateReleaseChannel uri) = + text $ "Duplicate release channel detected when adding: \n " + <> (T.unpack . E.decodeUtf8With E.lenientDecode . serializeURIRef') uri + <> "\nGiving up. You can use '--force' to remove and append the duplicate URI (this may change order/semantics)." ------------------------- --[ High-level errors ]-- diff --git a/lib/GHCup/Prelude/File/Posix.hs b/lib/GHCup/Prelude/File/Posix.hs --- a/lib/GHCup/Prelude/File/Posix.hs +++ b/lib/GHCup/Prelude/File/Posix.hs @@ -279,11 +279,11 @@ -- | Create an 'Unfold' of directory contents. unfoldDirContents :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath (FD.DirType, FilePath) -unfoldDirContents = U.bracket (liftIO . openDirStream) (liftIO . closeDirStream) (Unfold step return) +unfoldDirContents = U.bracket (liftIO . openDirStreamPortable) (liftIO . closeDirStreamPortable) (Unfold step return) where {-# INLINE [0] step #-} step dirstream = do - (typ, e) <- liftIO $ readDirEnt dirstream + (typ, e) <- liftIO $ readDirEntPortable dirstream return $ if | null e -> D.Stop | "." == e -> D.Skip dirstream @@ -308,8 +308,8 @@ step (_, Nothing, []) = return D.Stop step (topdir, Just (cdir, dirstream, finalizer), dirs) = flip onException (runIOFinalizer finalizer) $ do - (dt, f) <- liftIO $ readDirEnt dirstream - if | FD.dtUnknown == dt -> do + (dt, f) <- liftIO $ readDirEntPortable dirstream + if | f == "" -> do runIOFinalizer finalizer return $ D.Skip (topdir, Nothing, dirs) | f == "." || f == ".." @@ -323,8 +323,8 @@ acquire dir = withRunInIO $ \run -> mask_ $ run $ do - dirstream <- liftIO $ openDirStream dir - ref <- newIOFinalizer (liftIO $ closeDirStream dirstream) + dirstream <- liftIO $ openDirStreamPortable dir + ref <- newIOFinalizer (liftIO $ closeDirStreamPortable dirstream) return (dirstream, ref) getDirectoryContentsRecursiveBFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m) diff --git a/lib/GHCup/Prelude/File/Posix/Traversals.hs b/lib/GHCup/Prelude/File/Posix/Traversals.hs deleted file mode 100644 --- a/lib/GHCup/Prelude/File/Posix/Traversals.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE CApiFFI #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wall #-} - - -module GHCup.Prelude.File.Posix.Traversals ( --- lower-level stuff - readDirEnt -, unpackDirStream -) where - - -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>)) -#endif -import GHCup.Prelude.File.Posix.Foreign - -import Unsafe.Coerce (unsafeCoerce) -import Foreign.C.Error -import Foreign.C.String -import Foreign.C.Types -import Foreign.Ptr -import Foreign.Storable -import System.Posix -import Foreign (alloca) -import System.Posix.Internals (peekFilePath) - - - - - ----------------------------------------------------------- --- dodgy stuff - -data {-# CTYPE "DIR" #-} CDir -data {-# CTYPE "struct dirent" #-} CDirent - --- Posix doesn't export DirStream, so to re-use that type we need to use --- unsafeCoerce. It's just a newtype, so this is a legitimate usage. --- ugly trick. -unpackDirStream :: DirStream -> Ptr CDir -unpackDirStream = unsafeCoerce - --- the __hscore_* functions are defined in the unix package. We can import them and let --- the linker figure it out. -foreign import ccall unsafe "__hscore_readdir" - c_readdir :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt - -foreign import ccall unsafe "__hscore_free_dirent" - c_freeDirEnt :: Ptr CDirent -> IO () - -foreign import ccall unsafe "__hscore_d_name" - c_name :: Ptr CDirent -> IO CString - -foreign import capi unsafe "dirutils.h __posixdir_d_type" - c_type :: Ptr CDirent -> IO DirType - ----------------------------------------------------------- --- less dodgy but still lower-level - - -readDirEnt :: DirStream -> IO (DirType, FilePath) -readDirEnt (unpackDirStream -> dirp) = - alloca $ \ptr_dEnt -> loop ptr_dEnt - where - loop ptr_dEnt = do - resetErrno - r <- c_readdir dirp ptr_dEnt - if r == 0 - then do - dEnt <- peek ptr_dEnt - if dEnt == nullPtr - then return (dtUnknown, mempty) - else do - dName <- c_name dEnt >>= peekFilePath - dType <- c_type dEnt - c_freeDirEnt dEnt - return (dType, dName) - else do - errno <- getErrno - if errno == eINTR - then loop ptr_dEnt - else do - let (Errno eo) = errno - if eo == 0 - then return (dtUnknown, mempty) - else throwErrno "readDirEnt" - diff --git a/lib/GHCup/Prelude/File/Posix/Traversals.hsc b/lib/GHCup/Prelude/File/Posix/Traversals.hsc new file mode 100644 --- /dev/null +++ b/lib/GHCup/Prelude/File/Posix/Traversals.hsc @@ -0,0 +1,139 @@ +{-# LANGUAGE CApiFFI #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wall #-} + + +module GHCup.Prelude.File.Posix.Traversals ( +-- lower-level stuff + readDirEnt +, readDirEntPortable +, openDirStreamPortable +, closeDirStreamPortable +, unpackDirStream +, DirStreamPortable +) where + +#include +#include +#include +#include +#include +#include + + +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>)) +#endif +import GHCup.Prelude.File.Posix.Foreign + +import Unsafe.Coerce (unsafeCoerce) +import Foreign.C.Error +import Foreign.C.String +import Foreign.C.Types +import Foreign.Ptr +import Foreign.Storable +import System.Posix +import Foreign (alloca) +import System.Posix.Internals (peekFilePath) +import System.FilePath + + + + + +---------------------------------------------------------- +-- dodgy stuff + +data {-# CTYPE "DIR" #-} CDir +data {-# CTYPE "struct dirent" #-} CDirent + +-- Posix doesn't export DirStream, so to re-use that type we need to use +-- unsafeCoerce. It's just a newtype, so this is a legitimate usage. +-- ugly trick. +unpackDirStream :: DirStream -> Ptr CDir +unpackDirStream = unsafeCoerce + +-- the __hscore_* functions are defined in the unix package. We can import them and let +-- the linker figure it out. +foreign import ccall unsafe "__hscore_readdir" + c_readdir :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt + +foreign import ccall unsafe "__hscore_free_dirent" + c_freeDirEnt :: Ptr CDirent -> IO () + +foreign import ccall unsafe "__hscore_d_name" + c_name :: Ptr CDirent -> IO CString + +foreign import capi unsafe "dirutils.h __posixdir_d_type" + c_type :: Ptr CDirent -> IO DirType + +---------------------------------------------------------- +-- less dodgy but still lower-level + + +readDirEnt :: DirStream -> IO (DirType, FilePath) +readDirEnt (unpackDirStream -> dirp) = + alloca $ \ptr_dEnt -> loop ptr_dEnt + where + loop ptr_dEnt = do + resetErrno + r <- c_readdir dirp ptr_dEnt + if r == 0 + then do + dEnt <- peek ptr_dEnt + if dEnt == nullPtr + then return (dtUnknown, mempty) + else do + dName <- c_name dEnt >>= peekFilePath + dType <- c_type dEnt + c_freeDirEnt dEnt + return (dType, dName) + else do + errno <- getErrno + if errno == eINTR + then loop ptr_dEnt + else do + let (Errno eo) = errno + if eo == 0 + then return (dtUnknown, mempty) + else throwErrno "readDirEnt" + + +newtype DirStreamPortable = DirStreamPortable (FilePath, DirStream) + +openDirStreamPortable :: FilePath -> IO DirStreamPortable +openDirStreamPortable fp = do + dirs <- openDirStream fp + pure $ DirStreamPortable (fp, dirs) + +closeDirStreamPortable :: DirStreamPortable -> IO () +closeDirStreamPortable (DirStreamPortable (_, dirs)) = closeDirStream dirs + +readDirEntPortable :: DirStreamPortable -> IO (DirType, FilePath) +readDirEntPortable (DirStreamPortable (basedir, dirs)) = do + (dt, fp) <- readDirEnt dirs + case (dt, fp) of + (DirType #{const DT_BLK}, _) -> pure (dt, fp) + (DirType #{const DT_CHR}, _) -> pure (dt, fp) + (DirType #{const DT_DIR}, _) -> pure (dt, fp) + (DirType #{const DT_FIFO}, _) -> pure (dt, fp) + (DirType #{const DT_LNK}, _) -> pure (dt, fp) + (DirType #{const DT_REG}, _) -> pure (dt, fp) + (DirType #{const DT_SOCK}, _) -> pure (dt, fp) + (DirType #{const DT_UNKNOWN}, _) -> pure (dt, fp) + (_, _) + | fp /= "" -> do + stat <- getSymbolicLinkStatus (basedir fp) + pure $ (, fp) $ if | isBlockDevice stat -> DirType #{const DT_BLK} + | isCharacterDevice stat -> DirType #{const DT_CHR} + | isDirectory stat -> DirType #{const DT_DIR} + | isNamedPipe stat -> DirType #{const DT_FIFO} + | isSymbolicLink stat -> DirType #{const DT_LNK} + | isRegularFile stat -> DirType #{const DT_REG} + | isSocket stat -> DirType #{const DT_SOCK} + | otherwise -> DirType #{const DT_UNKNOWN} + diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -66,7 +66,7 @@ , _ghcupDownloads :: GHCupDownloads , _globalTools :: Map GlobalTool DownloadInfo } - deriving (Show, GHC.Generic) + deriving (Show, GHC.Generic, Eq) instance NFData GHCupInfo @@ -87,7 +87,7 @@ { _distroPKGs :: [Text] , _notes :: Text } - deriving (Show, GHC.Generic) + deriving (Show, GHC.Generic, Eq) instance NFData Requirements diff --git a/test/GHCup/Prelude/File/Posix/TraversalsSpec.hs b/test/GHCup/Prelude/File/Posix/TraversalsSpec.hs --- a/test/GHCup/Prelude/File/Posix/TraversalsSpec.hs +++ b/test/GHCup/Prelude/File/Posix/TraversalsSpec.hs @@ -24,11 +24,11 @@ -- https://github.com/haskell/ghcup-hs/issues/415 describe "GHCup.Prelude.File.Posix.Traversals" $ do it "readDirEnt" $ do - dirstream <- liftIO $ openDirStream "test/data" - (dt1, fp1) <- readDirEnt dirstream - (dt2, fp2) <- readDirEnt dirstream - (dt3, fp3) <- readDirEnt dirstream - (dt4, fp4) <- readDirEnt dirstream + dirstream <- liftIO $ openDirStreamPortable "test/data" + (dt1, fp1) <- readDirEntPortable dirstream + (dt2, fp2) <- readDirEntPortable dirstream + (dt3, fp3) <- readDirEntPortable dirstream + (dt4, fp4) <- readDirEntPortable dirstream let xs = sortOn snd [ (dt1, fp1), (dt2, fp2) , (dt3, fp3), (dt4, fp4) ]