From f575dcdad666e8de01e2e5cc7b0faf5eee4cb3b0 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sun, 12 Feb 2023 19:58:08 +0800 Subject: [PATCH 1/3] Improve usability on 'ghcup config add-release-channel' Fixes #751 (or so I hope). --- app/ghcup/GHCup/OptParse/Config.hs | 48 ++++++++++++++++++++---------- lib/GHCup/Errors.hs | 16 ++++++++++ lib/GHCup/Types.hs | 4 +-- 3 files changed, 51 insertions(+), 17 deletions(-) diff --git a/app/ghcup/GHCup/OptParse/Config.hs b/app/ghcup/GHCup/OptParse/Config.hs index 7d48cb3..e7de50e 100644 --- a/app/ghcup/GHCup/OptParse/Config.hs +++ b/app/ghcup/GHCup/OptParse/Config.hs @@ -51,7 +51,7 @@ data ConfigCommand = ShowConfig | SetConfig String (Maybe String) | InitConfig - | AddReleaseChannel URI + | AddReleaseChannel Bool URI @@ -74,7 +74,7 @@ configP = subparser 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") @@ -203,22 +203,40 @@ config configCommand settings userConf keybindings runLogger = case configComman 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 + when (not force && Right uri `elem` xs) $ throwE (DuplicateReleaseChannel uri) + lift $ doConfig (defaultUserSettings { uUrlSource = Just $ AddSource (appendUnique xs (Right uri)) }) + pure () + GHCupURL -> do + lift $ doConfig (defaultUserSettings { uUrlSource = Just $ AddSource [Right uri] }) + pure () + OwnSource xs -> do + when (not force && Right uri `elem` xs) $ throwE (DuplicateReleaseChannel uri) + lift $ doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource (appendUnique xs (Right uri)) }) + pure () + 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 + -- 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 userConf diff --git a/lib/GHCup/Errors.hs b/lib/GHCup/Errors.hs index d87a227..09e7a31 100644 --- a/lib/GHCup/Errors.hs +++ b/lib/GHCup/Errors.hs @@ -35,6 +35,8 @@ import URI.ByteString 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 @@ allHFError = unlines allErrors , 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 @@ -640,6 +643,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/Types.hs b/lib/GHCup/Types.hs index 8a9b918..bdd58d4 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -66,7 +66,7 @@ data GHCupInfo = GHCupInfo , _ghcupDownloads :: GHCupDownloads , _globalTools :: Map GlobalTool DownloadInfo } - deriving (Show, GHC.Generic) + deriving (Show, GHC.Generic, Eq) instance NFData GHCupInfo @@ -87,7 +87,7 @@ data Requirements = Requirements { _distroPKGs :: [Text] , _notes :: Text } - deriving (Show, GHC.Generic) + deriving (Show, GHC.Generic, Eq) instance NFData Requirements From 9c464ec9fca617ad7f23a7958cf5f8f9ce97efde Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sun, 19 Feb 2023 17:25:14 +0800 Subject: [PATCH 2/3] Don't fail if the duplicate is the last element --- app/ghcup/GHCup/OptParse/Config.hs | 25 +++++++++++++++++++------ 1 file changed, 19 insertions(+), 6 deletions(-) diff --git a/app/ghcup/GHCup/OptParse/Config.hs b/app/ghcup/GHCup/OptParse/Config.hs index e7de50e..07a3f76 100644 --- a/app/ghcup/GHCup/OptParse/Config.hs +++ b/app/ghcup/GHCup/OptParse/Config.hs @@ -159,6 +159,9 @@ updateSettings usl usr = --[ 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 @@ -207,16 +210,20 @@ config configCommand settings userConf keybindings runLogger = case configComman r <- runE @'[DuplicateReleaseChannel] $ do case urlSource settings of AddSource xs -> do - when (not force && Right uri `elem` xs) $ throwE (DuplicateReleaseChannel uri) - lift $ doConfig (defaultUserSettings { uUrlSource = Just $ AddSource (appendUnique xs (Right uri)) }) - pure () + 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 - when (not force && Right uri `elem` xs) $ throwE (DuplicateReleaseChannel uri) - lift $ doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource (appendUnique xs (Right uri)) }) - pure () + 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 () @@ -228,6 +235,12 @@ config configCommand settings userConf keybindings runLogger = case configComman 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' From 72f8e5334473284d16de263f22388ddbe993b786 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sun, 19 Feb 2023 17:32:28 +0800 Subject: [PATCH 3/3] Fix CI --- .github/scripts/test.sh | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/scripts/test.sh b/.github/scripts/test.sh index 8b4f3e2..2befec2 100644 --- a/.github/scripts/test.sh +++ b/.github/scripts/test.sh @@ -190,7 +190,7 @@ sha=$(sha_sum "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml") # invalidate access time timer, which is 5minutes, so we re-download touch -a -m -t '199901010101' "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml" # redownload same file with some newlines added -raw_eghcup -s https://www.haskell.org/ghcup/exp/ghcup-${JSON_VERSION}.yaml list +raw_eghcup -s https://raw.githubusercontent.com/haskell/ghcup-metadata/exp/ghcup-0.0.7.yaml list # snapshot new yaml and etags file etag2=$(cat "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml.etags") sha2=$(sha_sum "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml") @@ -200,7 +200,7 @@ sha2=$(sha_sum "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml") # invalidate access time timer, which is 5minutes, but don't expect a re-download touch -a -m -t '199901010101' "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml" # this time, we expect the same hash and etag -raw_eghcup -s https://www.haskell.org/ghcup/exp/ghcup-${JSON_VERSION}.yaml list +raw_eghcup -s https://raw.githubusercontent.com/haskell/ghcup-metadata/exp/ghcup-0.0.7.yaml list etag3=$(cat "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml.etags") sha3=$(sha_sum "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml") [ "${etag2}" = "${etag3}" ]