diff --git a/app/ghcup/GHCup/OptParse/Config.hs b/app/ghcup/GHCup/OptParse/Config.hs index 26b6428..d3d96dc 100644 --- a/app/ghcup/GHCup/OptParse/Config.hs +++ b/app/ghcup/GHCup/OptParse/Config.hs @@ -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' diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 5b3f669..4a64431 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -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 diff --git a/data/config.yaml b/data/config.yaml index 09b56a5..0659e0c 100644 --- a/data/config.yaml +++ b/data/config.yaml @@ -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" + diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 65018f3..01bca6d 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -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 + diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index f1d5897..2fe84eb 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -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 diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index e6c8865..9a0f3b3 100644 --- a/lib/GHCup/Types/JSON.hs +++ b/lib/GHCup/Types/JSON.hs @@ -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 -