Merge remote-tracking branch 'origin/pr/700'

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'
 
 
 

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

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"
+

lib/GHCup/Download.hs

@@ -333,19 +333,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
 
@@ -751,3 +753,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
+

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
 

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
-