Compare commits

..

3 Commits

8 changed files with 19 additions and 95 deletions

View File

@@ -17,6 +17,8 @@ task:
S3_HOST: ENCRYPTED[ce961780a33159f7d1d8046956b5ac6ebc3bfc8149428e5f538576cda51d9f3d0c35b79cdd1e325793639ff6e31f889d] S3_HOST: ENCRYPTED[ce961780a33159f7d1d8046956b5ac6ebc3bfc8149428e5f538576cda51d9f3d0c35b79cdd1e325793639ff6e31f889d]
install_script: pkg install -y ghc hs-cabal-install git bash misc/compat10x misc/compat11x misc/compat12x gmake install_script: pkg install -y ghc hs-cabal-install git bash misc/compat10x misc/compat11x misc/compat12x gmake
script: script:
- tzsetup Etc/GMT
- adjkerntz -a
- bash .github/scripts/build.sh - bash .github/scripts/build.sh
- bash .github/scripts/test.sh - bash .github/scripts/test.sh
binaries_artifacts: binaries_artifacts:

View File

@@ -88,28 +88,28 @@ download_cabal_cache() {
case "${RUNNER_OS}" in case "${RUNNER_OS}" in
"Linux") "Linux")
case "${ARCH}" in case "${ARCH}" in
"32") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/i386-linux-cabal-cache "32") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental5/i386-linux-cabal-cache
;; ;;
"64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/x86_64-linux-cabal-cache "64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental5/x86_64-linux-cabal-cache
;; ;;
"ARM64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/aarch64-linux-cabal-cache "ARM64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental5/aarch64-linux-cabal-cache
;; ;;
"ARM") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/armv7-linux-cabal-cache "ARM") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental5/armv7-linux-cabal-cache
;; ;;
esac esac
;; ;;
"FreeBSD") "FreeBSD")
url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/x86_64-portbld-freebsd-cabal-cache url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental5/x86_64-portbld-freebsd-cabal-cache
;; ;;
"Windows") "Windows")
exe=".exe" exe=".exe"
url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/x86_64-mingw64-cabal-cache url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental5/x86_64-mingw64-cabal-cache
;; ;;
"macOS") "macOS")
case "${ARCH}" in case "${ARCH}" in
"ARM64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/aarch64-apple-darwin-cabal-cache "ARM64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental5/aarch64-apple-darwin-cabal-cache
;; ;;
"64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental4/x86_64-apple-darwin-cabal-cache "64") url=https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-cache/experimental5/x86_64-apple-darwin-cabal-cache
;; ;;
esac esac
;; ;;

View File

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

View File

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

View File

@@ -92,30 +92,3 @@ url-source:
# tag: Linux # tag: Linux
# version: '18.04' # version: '18.04'
platform-override: null 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,21 +334,19 @@ download :: ( MonadReader env m
-> Maybe FilePath -- ^ optional filename -> Maybe FilePath -- ^ optional filename
-> Bool -- ^ whether to read an write etags -> Bool -- ^ whether to read an write etags
-> Excepts '[DigestError, ContentLengthError, DownloadFailed, GPGError] m FilePath -> Excepts '[DigestError, ContentLengthError, DownloadFailed, GPGError] m FilePath
download rawUri gpgUri eDigest eCSize dest mfn etags download uri gpgUri eDigest eCSize dest mfn etags
| scheme == "https" = liftE dl | scheme == "https" = liftE dl
| scheme == "http" = liftE dl | scheme == "http" = liftE dl
| scheme == "file" = do | scheme == "file" = do
let destFile' = T.unpack . decUTF8Safe $ view pathL' rawUri let destFile' = T.unpack . decUTF8Safe $ view pathL' uri
lift $ logDebug $ "using local file: " <> T.pack destFile' lift $ logDebug $ "using local file: " <> T.pack destFile'
forM_ eDigest (liftE . flip checkDigest destFile') forM_ eDigest (liftE . flip checkDigest destFile')
pure destFile' pure destFile'
| otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme) | otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
where where
scheme = view (uriSchemeL' % schemeBSL') rawUri scheme = view (uriSchemeL' % schemeBSL') uri
dl = do dl = do
Settings{ mirrors } <- lift getSettings
let uri = applyMirrors mirrors rawUri
baseDestFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile uri mfn baseDestFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile uri mfn
lift $ logInfo $ "downloading: " <> (decUTF8Safe . serializeURIRef') uri <> " as file " <> T.pack baseDestFile lift $ logInfo $ "downloading: " <> (decUTF8Safe . serializeURIRef') uri <> " as file " <> T.pack baseDestFile
@@ -751,17 +749,3 @@ getLastHeader = T.unlines . lastDef [] . filter (\x -> not (null x)) . splitOn [
tmpFile :: FilePath -> FilePath tmpFile :: FilePath -> FilePath
tmpFile = (<.> "tmp") 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,23 +274,6 @@ instance NFData DownloadInfo
--[ Others ]-- --[ 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. -- | How to descend into a tar archive.
data TarDir = RealDir FilePath data TarDir = RealDir FilePath
@@ -333,13 +316,12 @@ data UserSettings = UserSettings
, uUrlSource :: Maybe URLSource , uUrlSource :: Maybe URLSource
, uNoNetwork :: Maybe Bool , uNoNetwork :: Maybe Bool
, uGPGSetting :: Maybe GPGSetting , uGPGSetting :: Maybe GPGSetting
, uPlatformOverride :: Maybe PlatformRequest , uPlatformOverride :: Maybe PlatformRequest
, uMirrors :: Maybe DownloadMirrors
} }
deriving (Show, GHC.Generic) deriving (Show, GHC.Generic)
defaultUserSettings :: UserSettings defaultUserSettings :: UserSettings
defaultUserSettings = UserSettings Nothing 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
fromSettings :: Settings -> Maybe KeyBindings -> UserSettings fromSettings :: Settings -> Maybe KeyBindings -> UserSettings
fromSettings Settings{..} Nothing = fromSettings Settings{..} Nothing =
@@ -356,7 +338,6 @@ fromSettings Settings{..} Nothing =
, uUrlSource = Just urlSource , uUrlSource = Just urlSource
, uGPGSetting = Just gpgSetting , uGPGSetting = Just gpgSetting
, uPlatformOverride = platformOverride , uPlatformOverride = platformOverride
, uMirrors = Just mirrors
} }
fromSettings Settings{..} (Just KeyBindings{..}) = fromSettings Settings{..} (Just KeyBindings{..}) =
let ukb = UserKeyBindings let ukb = UserKeyBindings
@@ -383,7 +364,6 @@ fromSettings Settings{..} (Just KeyBindings{..}) =
, uUrlSource = Just urlSource , uUrlSource = Just urlSource
, uGPGSetting = Just gpgSetting , uGPGSetting = Just gpgSetting
, uPlatformOverride = platformOverride , uPlatformOverride = platformOverride
, uMirrors = Just mirrors
} }
data UserKeyBindings = UserKeyBindings data UserKeyBindings = UserKeyBindings
@@ -465,7 +445,6 @@ data Settings = Settings
, gpgSetting :: GPGSetting , gpgSetting :: GPGSetting
, noColor :: Bool -- this also exists in LoggerConfig , noColor :: Bool -- this also exists in LoggerConfig
, platformOverride :: Maybe PlatformRequest , platformOverride :: Maybe PlatformRequest
, mirrors :: DownloadMirrors
} }
deriving (Show, GHC.Generic) deriving (Show, GHC.Generic)
@@ -473,7 +452,7 @@ defaultMetaCache :: Integer
defaultMetaCache = 300 -- 5 minutes defaultMetaCache = 300 -- 5 minutes
defaultSettings :: Settings defaultSettings :: Settings
defaultSettings = Settings False defaultMetaCache Lax False Never Curl False GHCupURL False GPGNone False Nothing (DM mempty) defaultSettings = Settings False defaultMetaCache Lax False Never Curl False GHCupURL False GPGNone False Nothing
instance NFData Settings instance NFData Settings

View File

@@ -29,7 +29,6 @@ import Control.Applicative ( (<|>) )
import Data.Aeson hiding (Key) import Data.Aeson hiding (Key)
import Data.Aeson.TH import Data.Aeson.TH
import Data.Aeson.Types hiding (Key) import Data.Aeson.Types hiding (Key)
import Data.ByteString ( ByteString )
import Data.List.NonEmpty ( NonEmpty(..) ) import Data.List.NonEmpty ( NonEmpty(..) )
import Data.Text.Encoding as E import Data.Text.Encoding as E
import Data.Versions import Data.Versions
@@ -226,12 +225,6 @@ instance FromJSON VersionCmp where
Right r -> pure r Right r -> pure r
Left e -> fail (MP.errorBundlePretty e) 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 :: VersionCmp -> T.Text
versionCmpToText (VR_gt ver') = "> " <> prettyV ver' versionCmpToText (VR_gt ver') = "> " <> prettyV ver'
versionCmpToText (VR_gteq ver') = ">= " <> prettyV ver' versionCmpToText (VR_gteq ver') = ">= " <> prettyV ver'
@@ -327,12 +320,6 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupI
deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key 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 = \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 = kebab } ''Settings
deriveToJSON defaultOptions { fieldLabelModifier = drop 2 . kebab } ''KeyBindings -- move under key-bindings key deriveToJSON defaultOptions { fieldLabelModifier = drop 2 . kebab } ''KeyBindings -- move under key-bindings key
@@ -369,3 +356,4 @@ instance FromJSON URLSource where
pure (AddSource r) pure (AddSource r)
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings