Merge branch 'issue-751'

This commit is contained in:
Julian Ospald 2023-02-19 19:23:48 +08:00
commit e57a8abd3d
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
4 changed files with 66 additions and 19 deletions

View File

@ -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}" ]

View File

@ -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 "<JSON_VALUE | YAML_KEY>") <*> 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")
@ -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
@ -203,22 +206,50 @@ config configCommand settings userConf keybindings runLogger = case configComman
pure $ ExitFailure 65
VLeft _ -> pure $ ExitFailure 65
AddReleaseChannel uri -> do
AddReleaseChannel force uri -> do
r <- runE @'[DuplicateReleaseChannel] $ do
case urlSource settings of
AddSource xs -> do
doConfig (defaultUserSettings { uUrlSource = Just $ AddSource (xs <> [Right uri]) })
pure ExitSuccess
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
doConfig (defaultUserSettings { uUrlSource = Just $ AddSource [Right uri] })
pure ExitSuccess
lift $ doConfig (defaultUserSettings { uUrlSource = Just $ AddSource [Right uri] })
pure ()
OwnSource xs -> do
doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource (xs <> [Right uri]) })
pure ExitSuccess
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
doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource ([Left spec, Right uri]) })
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 userConf

View File

@ -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 ]--
-------------------------

View File

@ -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