Add support for mirrors wrt #357

This commit is contained in:
Julian Ospald 2022-12-04 00:15:13 +08:00
parent 109187eb6f
commit 703be0a706
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
6 changed files with 87 additions and 9 deletions

View File

@ -59,7 +59,7 @@ data ConfigCommand
--[ Parsers ]--
---------------
configP :: Parser ConfigCommand
configP = subparser
( command "init" initP
@ -133,7 +133,8 @@ updateSettings UserSettings{..} Settings{..} =
noNetwork' = fromMaybe noNetwork uNoNetwork
gpgSetting' = fromMaybe gpgSetting uGPGSetting
platformOverride' = uPlatformOverride <|> platformOverride
in Settings cache' metaCache' metaMode' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor platformOverride'
mirrors' = fromMaybe mirrors uMirrors
in Settings cache' metaCache' metaMode' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor platformOverride' mirrors'

View File

@ -89,6 +89,7 @@ toSettings options = do
noNetwork = fromMaybe (fromMaybe (Types.noNetwork defaultSettings) uNoNetwork) optNoNetwork
gpgSetting = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg
platformOverride = optPlatform <|> (uPlatformOverride <|> Types.platformOverride defaultSettings)
mirrors = fromMaybe (Types.mirrors defaultSettings) uMirrors
in (Settings {..}, keyBindings)
#if defined(INTERNAL_DOWNLOADER)
defaultDownloader = Internal

View File

@ -92,3 +92,30 @@ url-source:
# tag: Linux
# version: '18.04'
platform-override: null
# Support for mirrors. Currently there are 3 hosts you can mirror:
# - github.com (for stack and some older HLS versions)
# - raw.githubusercontent.com (for the yaml metadata)
# - downloads.haskell.org (for everything else)
#
# E.g. when we have 'https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-0.0.7.yaml'
# and the following mirror config
#
# "raw.githubusercontent.com":
# authority:
# host: "mirror.sjtu.edu.cn"
# pathPrefix: "ghcup/yaml"
#
# Then the resulting url will be 'https://mirror.sjtu.edu.cn/ghcup/yaml/haskell/ghcup-metadata/master/ghcup-0.0.7.yaml'
mirrors:
"github.com":
authority:
host: "mirror.sjtu.edu.cn"
"raw.githubusercontent.com":
authority:
host: "mirror.sjtu.edu.cn"
pathPrefix: "ghcup/yaml"
"downloads.haskell.org":
authority:
host: "mirror.sjtu.edu.cn"

View File

@ -334,19 +334,21 @@ download :: ( MonadReader env m
-> Maybe FilePath -- ^ optional filename
-> Bool -- ^ whether to read an write etags
-> Excepts '[DigestError, ContentLengthError, DownloadFailed, GPGError] m FilePath
download uri gpgUri eDigest eCSize dest mfn etags
download rawUri gpgUri eDigest eCSize dest mfn etags
| scheme == "https" = liftE dl
| scheme == "http" = liftE dl
| scheme == "file" = do
let destFile' = T.unpack . decUTF8Safe $ view pathL' uri
let destFile' = T.unpack . decUTF8Safe $ view pathL' rawUri
lift $ logDebug $ "using local file: " <> T.pack destFile'
forM_ eDigest (liftE . flip checkDigest destFile')
pure destFile'
| otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
where
scheme = view (uriSchemeL' % schemeBSL') uri
scheme = view (uriSchemeL' % schemeBSL') rawUri
dl = do
Settings{ mirrors } <- lift getSettings
let uri = applyMirrors mirrors rawUri
baseDestFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile uri mfn
lift $ logInfo $ "downloading: " <> (decUTF8Safe . serializeURIRef') uri <> " as file " <> T.pack baseDestFile
@ -749,3 +751,17 @@ getLastHeader = T.unlines . lastDef [] . filter (\x -> not (null x)) . splitOn [
tmpFile :: FilePath -> FilePath
tmpFile = (<.> "tmp")
applyMirrors :: DownloadMirrors -> URI -> URI
applyMirrors (DM ms) uri@(URI { uriAuthority = Just (Authority { authorityHost = Host host }) }) =
case M.lookup (decUTF8Safe host) ms of
Nothing -> uri
Just (DownloadMirror auth (Just prefix)) ->
uri { uriAuthority = Just auth
, uriPath = E.encodeUtf8 $ T.pack ("/" <> T.unpack prefix <> (T.unpack . decUTF8Safe . uriPath $ uri))
}
Just (DownloadMirror auth Nothing) ->
uri { uriAuthority = Just auth }
applyMirrors _ uri = uri

View File

@ -274,6 +274,23 @@ instance NFData DownloadInfo
--[ Others ]--
--------------
data DownloadMirror = DownloadMirror {
authority :: Authority
, pathPrefix :: Maybe Text
} deriving (Eq, Ord, GHC.Generic, Show)
instance NFData DownloadMirror
newtype DownloadMirrors = DM (Map Text DownloadMirror)
deriving (Eq, Ord, GHC.Generic, Show)
instance NFData DownloadMirrors
instance NFData UserInfo
instance NFData Host
instance NFData Port
instance NFData Authority
-- | How to descend into a tar archive.
data TarDir = RealDir FilePath
@ -316,12 +333,13 @@ data UserSettings = UserSettings
, uUrlSource :: Maybe URLSource
, uNoNetwork :: Maybe Bool
, uGPGSetting :: Maybe GPGSetting
, uPlatformOverride :: Maybe PlatformRequest
, uPlatformOverride :: Maybe PlatformRequest
, uMirrors :: Maybe DownloadMirrors
}
deriving (Show, GHC.Generic)
defaultUserSettings :: UserSettings
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
fromSettings :: Settings -> Maybe KeyBindings -> UserSettings
fromSettings Settings{..} Nothing =
@ -338,6 +356,7 @@ fromSettings Settings{..} Nothing =
, uUrlSource = Just urlSource
, uGPGSetting = Just gpgSetting
, uPlatformOverride = platformOverride
, uMirrors = Just mirrors
}
fromSettings Settings{..} (Just KeyBindings{..}) =
let ukb = UserKeyBindings
@ -364,6 +383,7 @@ fromSettings Settings{..} (Just KeyBindings{..}) =
, uUrlSource = Just urlSource
, uGPGSetting = Just gpgSetting
, uPlatformOverride = platformOverride
, uMirrors = Just mirrors
}
data UserKeyBindings = UserKeyBindings
@ -445,6 +465,7 @@ data Settings = Settings
, gpgSetting :: GPGSetting
, noColor :: Bool -- this also exists in LoggerConfig
, platformOverride :: Maybe PlatformRequest
, mirrors :: DownloadMirrors
}
deriving (Show, GHC.Generic)
@ -452,7 +473,7 @@ defaultMetaCache :: Integer
defaultMetaCache = 300 -- 5 minutes
defaultSettings :: Settings
defaultSettings = Settings False defaultMetaCache Lax False Never Curl False GHCupURL False GPGNone False Nothing
defaultSettings = Settings False defaultMetaCache Lax False Never Curl False GHCupURL False GPGNone False Nothing (DM mempty)
instance NFData Settings

View File

@ -29,6 +29,7 @@ import Control.Applicative ( (<|>) )
import Data.Aeson hiding (Key)
import Data.Aeson.TH
import Data.Aeson.Types hiding (Key)
import Data.ByteString ( ByteString )
import Data.List.NonEmpty ( NonEmpty(..) )
import Data.Text.Encoding as E
import Data.Versions
@ -225,6 +226,12 @@ instance FromJSON VersionCmp where
Right r -> pure r
Left e -> fail (MP.errorBundlePretty e)
instance ToJSON ByteString where
toJSON = toJSON . E.decodeUtf8With E.lenientDecode
instance FromJSON ByteString where
parseJSON = withText "ByteString" $ \t -> pure $ E.encodeUtf8 t
versionCmpToText :: VersionCmp -> T.Text
versionCmpToText (VR_gt ver') = "> " <> prettyV ver'
versionCmpToText (VR_gteq ver') = ">= " <> prettyV ver'
@ -320,6 +327,12 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupI
deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel, unwrapUnaryRecords = True } ''Port
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel, unwrapUnaryRecords = True } ''Host
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''UserInfo
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' (T.unpack . T.toLower) . T.stripPrefix (T.pack "authority") . T.pack $ str' } ''Authority
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadMirror
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadMirrors
deriveToJSON defaultOptions { fieldLabelModifier = kebab } ''Settings
deriveToJSON defaultOptions { fieldLabelModifier = drop 2 . kebab } ''KeyBindings -- move under key-bindings key
@ -356,4 +369,3 @@ instance FromJSON URLSource where
pure (AddSource r)
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings