Support stacks installation strategy and metadata wrt #892
This commit is contained in:
@@ -5,7 +5,6 @@
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
|
||||
{-|
|
||||
Module : GHCup.Download
|
||||
Description : Downloading
|
||||
@@ -31,6 +30,8 @@ import GHCup.Download.Utils
|
||||
#endif
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import qualified GHCup.Types.Stack as Stack
|
||||
import GHCup.Types.Stack (downloadInfoUrl, downloadInfoSha256)
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Utils.Dirs
|
||||
@@ -159,9 +160,10 @@ getBase :: ( MonadReader env m
|
||||
, MonadCatch m
|
||||
, HasLog env
|
||||
, MonadMask m
|
||||
, FromJSON j
|
||||
)
|
||||
=> URI
|
||||
-> Excepts '[DownloadFailed, GPGError, DigestError, ContentLengthError, JSONError, FileDoesNotExistError] m GHCupInfo
|
||||
-> Excepts '[DownloadFailed, GPGError, DigestError, ContentLengthError, JSONError, FileDoesNotExistError] m j
|
||||
getBase uri = do
|
||||
Settings { noNetwork, downloader, metaMode } <- lift getSettings
|
||||
|
||||
@@ -246,7 +248,7 @@ getBase uri = do
|
||||
Settings { metaCache } <- lift getSettings
|
||||
|
||||
-- for local files, let's short-circuit and ignore access time
|
||||
if | scheme == "file" -> liftE $ download uri' (Just $ over pathL' (<> ".sig") uri') Nothing Nothing (fromGHCupPath cacheDir) Nothing True
|
||||
if | scheme == "file" -> liftE $ download uri' Nothing Nothing Nothing (fromGHCupPath cacheDir) Nothing True
|
||||
| e -> do
|
||||
accessTime <- fmap utcTimeToPOSIXSeconds $ liftIO $ getAccessTime json_file
|
||||
let sinceLastAccess = utcTimeToPOSIXSeconds currentTime - accessTime
|
||||
@@ -325,6 +327,107 @@ getDownloadInfo' t v = do
|
||||
_ -> with_distro <|> without_distro_ver <|> without_distro
|
||||
)
|
||||
|
||||
getStackDownloadInfo :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, HasGHCupInfo env
|
||||
, HasLog env
|
||||
, HasPlatformReq env
|
||||
, HasSettings env
|
||||
, MonadCatch m
|
||||
, MonadFail m
|
||||
, MonadIO m
|
||||
, MonadMask m
|
||||
, MonadThrow m
|
||||
)
|
||||
=> StackSetupURLSource
|
||||
-> [String]
|
||||
-> Tool
|
||||
-> GHCTargetVersion
|
||||
-- ^ tool version
|
||||
-> Excepts
|
||||
'[NoDownload, DownloadFailed]
|
||||
m
|
||||
DownloadInfo
|
||||
getStackDownloadInfo stackSetupSource keys@(_:_) GHC tv@(GHCTargetVersion Nothing v) =
|
||||
case stackSetupSource of
|
||||
StackSetupURL -> do
|
||||
(dli :: Stack.SetupInfo) <- liftE $ reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getBase stackSetupURL
|
||||
sDli <- liftE $ stackDownloadInfo dli
|
||||
lift $ fromStackDownloadInfo sDli
|
||||
(SOwnSource exts) -> do
|
||||
(dlis :: [Stack.SetupInfo]) <- liftE $ reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ mapM (either pure getBase) exts
|
||||
dli <- lift $ mergeSetupInfo dlis
|
||||
sDli <- liftE $ stackDownloadInfo dli
|
||||
lift $ fromStackDownloadInfo sDli
|
||||
(SOwnSpec si) -> do
|
||||
sDli <- liftE $ stackDownloadInfo si
|
||||
lift $ fromStackDownloadInfo sDli
|
||||
(SAddSource exts) -> do
|
||||
base :: Stack.SetupInfo <- liftE $ reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getBase stackSetupURL
|
||||
(dlis :: [Stack.SetupInfo]) <- liftE $ reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ mapM (either pure getBase) exts
|
||||
dli <- lift $ mergeSetupInfo (base:dlis)
|
||||
sDli <- liftE $ stackDownloadInfo dli
|
||||
lift $ fromStackDownloadInfo sDli
|
||||
|
||||
where
|
||||
stackDownloadInfo :: MonadIO m => Stack.SetupInfo -> Excepts '[NoDownload] m Stack.DownloadInfo
|
||||
stackDownloadInfo dli@Stack.SetupInfo{} = do
|
||||
let siGHCs = Stack.siGHCs dli
|
||||
ghcVersionsPerKey = (`M.lookup` siGHCs) <$> (T.pack <$> keys)
|
||||
ghcVersions <- (listToMaybe . catMaybes $ ghcVersionsPerKey) ?? NoDownload tv GHC Nothing
|
||||
(Stack.gdiDownloadInfo <$> M.lookup v ghcVersions) ?? NoDownload tv GHC Nothing
|
||||
|
||||
mergeSetupInfo :: MonadFail m
|
||||
=> [Stack.SetupInfo]
|
||||
-> m Stack.SetupInfo
|
||||
mergeSetupInfo [] = fail "mergeSetupInfo: internal error: need at least one SetupInfo"
|
||||
mergeSetupInfo xs@(Stack.SetupInfo{}: _) =
|
||||
let newSevenzExe = Stack.siSevenzExe $ last xs
|
||||
newSevenzDll = Stack.siSevenzDll $ last xs
|
||||
newMsys2 = M.unionsWith (\_ a2 -> a2 ) (Stack.siMsys2 <$> xs)
|
||||
newGHCs = M.unionsWith (M.unionWith (\_ b2 -> b2)) (Stack.siGHCs <$> xs)
|
||||
newStack = M.unionsWith (M.unionWith (\_ b2 -> b2)) (Stack.siStack <$> xs)
|
||||
in pure $ Stack.SetupInfo newSevenzExe newSevenzDll newMsys2 newGHCs newStack
|
||||
|
||||
fromStackDownloadInfo :: MonadThrow m => Stack.DownloadInfo -> m DownloadInfo
|
||||
fromStackDownloadInfo Stack.DownloadInfo{..} = do
|
||||
url <- either (\e -> throwM $ ParseError (show e)) pure $ parseURI strictURIParserOptions . E.encodeUtf8 $ downloadInfoUrl
|
||||
sha256 <- maybe (throwM $ DigestMissing url) (pure . E.decodeUtf8) downloadInfoSha256
|
||||
pure $ DownloadInfo url (Just $ RegexDir "ghc-.*") sha256 Nothing Nothing
|
||||
getStackDownloadInfo _ _ t v = throwE $ NoDownload v t Nothing
|
||||
|
||||
{--
|
||||
data SetupInfo = SetupInfo
|
||||
{ siSevenzExe :: Maybe DownloadInfo
|
||||
, siSevenzDll :: Maybe DownloadInfo
|
||||
, siMsys2 :: Map Text VersionedDownloadInfo
|
||||
, siGHCs :: Map Text (Map Version GHCDownloadInfo)
|
||||
, siStack :: Map Text (Map Version DownloadInfo)
|
||||
|
||||
data VersionedDownloadInfo = VersionedDownloadInfo
|
||||
{ vdiVersion :: Version
|
||||
, vdiDownloadInfo :: DownloadInfo
|
||||
}
|
||||
}
|
||||
|
||||
data DownloadInfo = DownloadInfo
|
||||
{ downloadInfoUrl :: Text
|
||||
-- ^ URL or absolute file path
|
||||
, downloadInfoContentLength :: Maybe Int
|
||||
, downloadInfoSha1 :: Maybe ByteString
|
||||
, downloadInfoSha256 :: Maybe ByteString
|
||||
}
|
||||
|
||||
data GHCDownloadInfo = GHCDownloadInfo
|
||||
{ gdiConfigureOpts :: [Text]
|
||||
, gdiConfigureEnv :: Map Text Text
|
||||
, gdiDownloadInfo :: DownloadInfo
|
||||
}
|
||||
|
||||
|
||||
--}
|
||||
|
||||
|
||||
|
||||
-- | Tries to download from the given http or https url
|
||||
-- and saves the result in continuous memory into a file.
|
||||
@@ -352,20 +455,15 @@ download :: ( MonadReader env m
|
||||
download rawUri gpgUri eDigest eCSize dest mfn etags
|
||||
| scheme == "https" = liftE dl
|
||||
| scheme == "http" = liftE dl
|
||||
| scheme == "file"
|
||||
, Just s <- gpgScheme
|
||||
, s /= "file" = throwIO $ userError $ "gpg scheme does not match base file scheme: " <> (T.unpack . decUTF8Safe $ s)
|
||||
| scheme == "file" = do
|
||||
Settings{ gpgSetting } <- lift getSettings
|
||||
let destFile' = T.unpack . decUTF8Safe $ view pathL' rawUri
|
||||
lift $ logDebug $ "using local file: " <> T.pack destFile'
|
||||
liftE $ verify gpgSetting destFile' (pure . T.unpack . decUTF8Safe . view pathL')
|
||||
forM_ eDigest (liftE . flip checkDigest destFile')
|
||||
pure destFile'
|
||||
| otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
|
||||
|
||||
where
|
||||
scheme = view (uriSchemeL' % schemeBSL') rawUri
|
||||
gpgScheme = view (uriSchemeL' % schemeBSL') <$> gpgUri
|
||||
scheme = view (uriSchemeL' % schemeBSL') rawUri
|
||||
dl = do
|
||||
Settings{ mirrors } <- lift getSettings
|
||||
let uri = applyMirrors mirrors rawUri
|
||||
@@ -407,14 +505,30 @@ download rawUri gpgUri eDigest eCSize dest mfn etags
|
||||
else pure (\fp -> liftE . internalDL fp)
|
||||
#endif
|
||||
liftE $ downloadAction baseDestFile uri
|
||||
liftE $ verify gpgSetting baseDestFile
|
||||
(\uri' -> do
|
||||
gpgDestFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile uri' Nothing
|
||||
lift $ logDebug $ "downloading: " <> (decUTF8Safe . serializeURIRef') uri' <> " as file " <> T.pack gpgDestFile
|
||||
flip onException (lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile gpgDestFile)) $
|
||||
downloadAction gpgDestFile uri'
|
||||
pure gpgDestFile
|
||||
)
|
||||
case (gpgUri, gpgSetting) of
|
||||
(_, GPGNone) -> pure ()
|
||||
(Just gpgUri', _) -> do
|
||||
gpgDestFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile gpgUri' Nothing
|
||||
liftE $ flip onException
|
||||
(lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile gpgDestFile))
|
||||
$ catchAllE @_ @'[GPGError, ProcessError, UnsupportedScheme, DownloadFailed] @'[GPGError]
|
||||
(\e -> if gpgSetting == GPGStrict then throwE (GPGError e) else lift $ logWarn $ T.pack (prettyHFError (GPGError e))
|
||||
) $ do
|
||||
o' <- liftIO getGpgOpts
|
||||
lift $ logDebug $ "downloading: " <> (decUTF8Safe . serializeURIRef') gpgUri' <> " as file " <> T.pack gpgDestFile
|
||||
liftE $ downloadAction gpgDestFile gpgUri'
|
||||
lift $ logInfo $ "verifying signature of: " <> T.pack baseDestFile
|
||||
let args = o' ++ ["--batch", "--verify", "--quiet", "--no-tty", gpgDestFile, baseDestFile]
|
||||
cp <- lift $ executeOut "gpg" args Nothing
|
||||
case cp of
|
||||
CapturedProcess { _exitCode = ExitFailure i, _stdErr } -> do
|
||||
lift $ logDebug $ decUTF8Safe' _stdErr
|
||||
throwE (GPGError @'[ProcessError] (V (NonZeroExit i "gpg" args)))
|
||||
CapturedProcess { _stdErr } -> lift $ logDebug $ decUTF8Safe' _stdErr
|
||||
_ -> pure ()
|
||||
|
||||
forM_ eCSize (liftE . flip checkCSize baseDestFile)
|
||||
forM_ eDigest (liftE . flip checkDigest baseDestFile)
|
||||
pure baseDestFile
|
||||
|
||||
curlDL :: ( MonadCatch m
|
||||
@@ -612,41 +726,6 @@ download rawUri gpgUri eDigest eCSize dest mfn etags
|
||||
liftIO $ hideError doesNotExistErrorType $ rmFile (etagsFile fp)
|
||||
pure Nothing
|
||||
|
||||
verify :: ( MonadReader env m
|
||||
, HasLog env
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadCatch m
|
||||
, MonadMask m
|
||||
, MonadIO m
|
||||
)
|
||||
=> GPGSetting
|
||||
-> FilePath
|
||||
-> (URI -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m FilePath)
|
||||
-> Excepts '[DigestError, ContentLengthError, DownloadFailed, GPGError] m ()
|
||||
verify gpgSetting destFile' downloadAction' = do
|
||||
case (gpgUri, gpgSetting) of
|
||||
(_, GPGNone) -> pure ()
|
||||
(Just gpgUri', _) -> do
|
||||
liftE $ catchAllE @_ @'[GPGError, ProcessError, UnsupportedScheme, DownloadFailed] @'[GPGError]
|
||||
(\e -> if gpgSetting == GPGStrict then throwE (GPGError e) else lift $ logWarn $ T.pack (prettyHFError (GPGError e))
|
||||
) $ do
|
||||
o' <- liftIO getGpgOpts
|
||||
gpgDestFile <- liftE $ downloadAction' gpgUri'
|
||||
lift $ logInfo $ "verifying signature of: " <> T.pack destFile'
|
||||
let args = o' ++ ["--batch", "--verify", "--quiet", "--no-tty", gpgDestFile, destFile']
|
||||
cp <- lift $ executeOut "gpg" args Nothing
|
||||
case cp of
|
||||
CapturedProcess { _exitCode = ExitFailure i, _stdErr } -> do
|
||||
lift $ logDebug $ decUTF8Safe' _stdErr
|
||||
throwE (GPGError @'[ProcessError] (V (NonZeroExit i "gpg" args)))
|
||||
CapturedProcess { _stdErr } -> lift $ logDebug $ decUTF8Safe' _stdErr
|
||||
_ -> pure ()
|
||||
|
||||
forM_ eCSize (liftE . flip checkCSize destFile')
|
||||
forM_ eDigest (liftE . flip checkDigest destFile')
|
||||
|
||||
|
||||
|
||||
-- | Download into tmpdir or use cached version, if it exists. If filename
|
||||
-- is omitted, infers the filename from the url.
|
||||
@@ -666,7 +745,7 @@ downloadCached :: ( MonadReader env m
|
||||
downloadCached dli mfn = do
|
||||
Settings{ cache } <- lift getSettings
|
||||
case cache of
|
||||
True -> liftE $ downloadCached' dli mfn Nothing
|
||||
True -> downloadCached' dli mfn Nothing
|
||||
False -> do
|
||||
tmp <- lift withGHCupTmpDir
|
||||
liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (_dlCSize dli) (fromGHCupPath tmp) outputFileName False
|
||||
|
||||
@@ -87,6 +87,7 @@ allHFError = unlines allErrors
|
||||
, let proxy = Proxy :: Proxy ToolShadowed in format proxy
|
||||
, let proxy = Proxy :: Proxy ContentLengthError in format proxy
|
||||
, let proxy = Proxy :: Proxy DuplicateReleaseChannel in format proxy
|
||||
, let proxy = Proxy :: Proxy UnsupportedSetupCombo in format proxy
|
||||
, ""
|
||||
, "# high level errors (4000+)"
|
||||
, let proxy = Proxy :: Proxy DownloadFailed in format proxy
|
||||
@@ -99,6 +100,7 @@ allHFError = unlines allErrors
|
||||
, let proxy = Proxy :: Proxy ParseError in format proxy
|
||||
, let proxy = Proxy :: Proxy UnexpectedListLength in format proxy
|
||||
, let proxy = Proxy :: Proxy NoUrlBase in format proxy
|
||||
, let proxy = Proxy :: Proxy DigestMissing in format proxy
|
||||
, ""
|
||||
, "# orphans (800+)"
|
||||
, let proxy = Proxy :: Proxy URIParseError in format proxy
|
||||
@@ -687,6 +689,17 @@ instance Pretty DuplicateReleaseChannel where
|
||||
<> (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)."
|
||||
|
||||
data UnsupportedSetupCombo = UnsupportedSetupCombo Architecture Platform
|
||||
deriving Show
|
||||
|
||||
instance Pretty UnsupportedSetupCombo where
|
||||
pPrint (UnsupportedSetupCombo arch plat) =
|
||||
text "Could not find a compatible setup combo for:" <+> pPrint arch <+> pPrint plat
|
||||
|
||||
instance HFErrorProject UnsupportedSetupCombo where
|
||||
eBase _ = 360
|
||||
eDesc _ = "Could not find a compatible setup combo"
|
||||
|
||||
-------------------------
|
||||
--[ High-level errors ]--
|
||||
-------------------------
|
||||
@@ -821,6 +834,18 @@ instance HFErrorProject NoUrlBase where
|
||||
eBase _ = 520
|
||||
eDesc _ = "URL does not have a base filename."
|
||||
|
||||
data DigestMissing = DigestMissing URI
|
||||
deriving Show
|
||||
|
||||
instance Pretty DigestMissing where
|
||||
pPrint (DigestMissing uri) =
|
||||
text "Digest missing for:" <+> (text . T.unpack . E.decodeUtf8With E.lenientDecode . serializeURIRef') uri
|
||||
|
||||
instance Exception DigestMissing
|
||||
|
||||
instance HFErrorProject DigestMissing where
|
||||
eBase _ = 530
|
||||
eDesc _ = "An expected digest is missing."
|
||||
|
||||
|
||||
------------------------
|
||||
|
||||
@@ -26,6 +26,7 @@ import GHCup.Types
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils
|
||||
import GHCup.Platform
|
||||
import GHCup.Prelude
|
||||
import GHCup.Prelude.File
|
||||
import GHCup.Prelude.Logger
|
||||
@@ -74,6 +75,7 @@ import qualified Crypto.Hash.SHA256 as SHA256
|
||||
import qualified Data.ByteString.Base16 as B16
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
@@ -216,7 +218,9 @@ testUnpackedGHC path tver addMakeArgs = do
|
||||
lift $ logInfo $ "Testing GHC version " <> tVerToText tver <> "!"
|
||||
ghcDir <- lift $ ghcupGHCDir tver
|
||||
let ghcBinDir = fromGHCupPath ghcDir </> "bin"
|
||||
env <- liftIO $ addToPath ghcBinDir False
|
||||
env <- liftIO $ addToPath [ghcBinDir] False
|
||||
let pathVar = if isWindows then "Path" else "PATH"
|
||||
forM_ (Map.lookup pathVar . Map.fromList $ env) $ liftIO . setEnv pathVar
|
||||
|
||||
lEM $ make' (fmap T.unpack addMakeArgs)
|
||||
(Just $ fromGHCupPath path)
|
||||
@@ -512,6 +516,7 @@ installGHCBin :: ( MonadFail m
|
||||
, MonadResource m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
, Alternative m
|
||||
)
|
||||
=> GHCTargetVersion -- ^ the version to install
|
||||
-> InstallDir
|
||||
@@ -533,11 +538,23 @@ installGHCBin :: ( MonadFail m
|
||||
, ProcessError
|
||||
, UninstallFailed
|
||||
, MergeFileTreeError
|
||||
, NoCompatiblePlatform
|
||||
, ParseError
|
||||
, UnsupportedSetupCombo
|
||||
, DistroNotFound
|
||||
, NoCompatibleArch
|
||||
]
|
||||
m
|
||||
()
|
||||
installGHCBin tver installDir forceInstall addConfArgs = do
|
||||
dlinfo <- liftE $ getDownloadInfo' GHC tver
|
||||
Settings{ stackSetupSource, stackSetup } <- lift getSettings
|
||||
dlinfo <- if stackSetup
|
||||
then do
|
||||
lift $ logInfo "Using stack's setup-info to install GHC"
|
||||
pfreq <- lift getPlatformReq
|
||||
keys <- liftE $ getStackPlatformKey pfreq
|
||||
liftE $ getStackDownloadInfo stackSetupSource keys GHC tver
|
||||
else liftE $ getDownloadInfo' GHC tver
|
||||
liftE $ installGHCBindist dlinfo tver installDir forceInstall addConfArgs
|
||||
|
||||
|
||||
|
||||
@@ -23,11 +23,13 @@ import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Utils
|
||||
import GHCup.Prelude
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.Process
|
||||
import GHCup.Prelude.String.QQ
|
||||
import GHCup.Prelude.Version.QQ
|
||||
import GHCup.Prelude.MegaParsec
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
@@ -48,11 +50,18 @@ import Prelude hiding ( abs
|
||||
)
|
||||
import System.Info
|
||||
import System.OsRelease
|
||||
import System.Exit
|
||||
import System.FilePath
|
||||
import Text.PrettyPrint.HughesPJClass ( prettyShow )
|
||||
import Text.Regex.Posix
|
||||
|
||||
import qualified Text.Megaparsec as MP
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
import Data.Void
|
||||
import qualified Data.List as L
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -197,3 +206,155 @@ getLinuxDistro = do
|
||||
try_debian_version = do
|
||||
ver <- T.readFile debian_version
|
||||
pure (T.pack "debian", Just ver)
|
||||
|
||||
|
||||
getStackGhcBuilds :: (MonadReader env m, HasLog env, MonadIO m)
|
||||
=> PlatformResult
|
||||
-> Excepts '[ParseError, NoCompatiblePlatform, DistroNotFound, ProcessError] m [String]
|
||||
getStackGhcBuilds PlatformResult{..} = do
|
||||
case _platform of
|
||||
Linux _ -> do
|
||||
-- Some systems don't have ldconfig in the PATH, so make sure to look in
|
||||
-- /sbin and /usr/sbin as well
|
||||
sbinEnv <- liftIO $ addToPath sbinDirs False
|
||||
ldConfig <- lift $ executeOut' "ldconfig" ["-p"] Nothing (Just sbinEnv)
|
||||
firstWords <- case ldConfig of
|
||||
CapturedProcess ExitSuccess so _ ->
|
||||
pure . mapMaybe (listToMaybe . T.words) . T.lines . T.pack . stripNewlineEnd . T.unpack . decUTF8Safe' $ so
|
||||
CapturedProcess (ExitFailure _) _ _ ->
|
||||
-- throwE $ NonZeroExit c "ldconfig" ["-p" ]
|
||||
pure []
|
||||
let checkLib :: (MonadReader env m, HasLog env, MonadIO m) => String -> m Bool
|
||||
checkLib lib
|
||||
| libT `elem` firstWords = do
|
||||
logDebug $ "Found shared library " <> libT <> " in 'ldconfig -p' output"
|
||||
pure True
|
||||
| isWindows =
|
||||
-- Cannot parse /usr/lib on Windows
|
||||
pure False
|
||||
| otherwise = hasMatches lib usrLibDirs
|
||||
-- This is a workaround for the fact that libtinfo.so.x doesn't
|
||||
-- appear in the 'ldconfig -p' output on Arch or Slackware even
|
||||
-- when it exists. There doesn't seem to be an easy way to get the
|
||||
-- true list of directories to scan for shared libs, but this
|
||||
-- works for our particular cases.
|
||||
where
|
||||
libT = T.pack lib
|
||||
|
||||
hasMatches :: (MonadReader env m, HasLog env, MonadIO m) => String -> [FilePath] -> m Bool
|
||||
hasMatches lib dirs = do
|
||||
matches <- filterM (liftIO . doesFileExist . (</> lib)) dirs
|
||||
case matches of
|
||||
[] -> logDebug ("Did not find shared library " <> libT) >> pure False
|
||||
(path:_) -> logDebug ("Found shared library " <> libT <> " in " <> T.pack path) >> pure True
|
||||
where
|
||||
libT = T.pack lib
|
||||
|
||||
getLibc6Version :: MonadIO m
|
||||
=> Excepts '[ParseError, ProcessError] m Version
|
||||
getLibc6Version = do
|
||||
CapturedProcess{..} <- lift $ executeOut "ldd" ["--version"] Nothing
|
||||
case _exitCode of
|
||||
ExitSuccess -> either (throwE . ParseError . show) pure
|
||||
. MP.parse lddVersion "" . T.pack . stripNewlineEnd . T.unpack . decUTF8Safe' $ _stdOut
|
||||
ExitFailure c -> throwE $ NonZeroExit c "ldd" ["--version" ]
|
||||
|
||||
-- Assumes the first line of ldd has the format:
|
||||
--
|
||||
-- ldd (...) nn.nn
|
||||
--
|
||||
-- where nn.nn corresponds to the version of libc6.
|
||||
lddVersion :: MP.Parsec Void Text Version
|
||||
lddVersion = do
|
||||
skipWhile (/= ')')
|
||||
skip (== ')')
|
||||
skipSpace
|
||||
version'
|
||||
|
||||
hasMusl <- hasMatches relFileLibcMuslx86_64So1 libDirs
|
||||
mLibc6Version <- veitherToEither <$> runE getLibc6Version
|
||||
case mLibc6Version of
|
||||
Right libc6Version -> logDebug $ "Found shared library libc6 in version: " <> prettyVer libc6Version
|
||||
Left _ -> logDebug "Did not find a version of shared library libc6."
|
||||
let hasLibc6_2_32 = either (const False) (>= [vver|2.32|]) mLibc6Version
|
||||
hastinfo5 <- checkLib relFileLibtinfoSo5
|
||||
hastinfo6 <- checkLib relFileLibtinfoSo6
|
||||
hasncurses6 <- checkLib relFileLibncurseswSo6
|
||||
hasgmp5 <- checkLib relFileLibgmpSo10
|
||||
hasgmp4 <- checkLib relFileLibgmpSo3
|
||||
let libComponents = if hasMusl
|
||||
then
|
||||
[ ["musl"] ]
|
||||
else
|
||||
concat
|
||||
[ if hastinfo6 && hasgmp5
|
||||
then
|
||||
if hasLibc6_2_32
|
||||
then [["tinfo6"]]
|
||||
else [["tinfo6-libc6-pre232"]]
|
||||
else [[]]
|
||||
, [ [] | hastinfo5 && hasgmp5 ]
|
||||
, [ ["ncurses6"] | hasncurses6 && hasgmp5 ]
|
||||
, [ ["gmp4"] | hasgmp4 ]
|
||||
]
|
||||
pure $ map
|
||||
(\c -> case c of
|
||||
[] -> []
|
||||
_ -> L.intercalate "-" c)
|
||||
libComponents
|
||||
FreeBSD ->
|
||||
case _distroVersion of
|
||||
Just fVer
|
||||
| fVer >= [vers|12|] -> pure []
|
||||
_ -> pure ["ino64"]
|
||||
Darwin -> pure []
|
||||
Windows -> pure []
|
||||
where
|
||||
|
||||
relFileLibcMuslx86_64So1 :: FilePath
|
||||
relFileLibcMuslx86_64So1 = "libc.musl-x86_64.so.1"
|
||||
libDirs :: [FilePath]
|
||||
libDirs = ["/lib", "/lib64"]
|
||||
usrLibDirs :: [FilePath]
|
||||
usrLibDirs = ["/usr/lib", "/usr/lib64"]
|
||||
sbinDirs :: [FilePath]
|
||||
sbinDirs = ["/sbin", "/usr/sbin"]
|
||||
relFileLibtinfoSo5 :: FilePath
|
||||
relFileLibtinfoSo5 = "libtinfo.so.5"
|
||||
relFileLibtinfoSo6 :: FilePath
|
||||
relFileLibtinfoSo6 = "libtinfo.so.6"
|
||||
relFileLibncurseswSo6 :: FilePath
|
||||
relFileLibncurseswSo6 = "libncursesw.so.6"
|
||||
relFileLibgmpSo10 :: FilePath
|
||||
relFileLibgmpSo10 = "libgmp.so.10"
|
||||
relFileLibgmpSo3 :: FilePath
|
||||
relFileLibgmpSo3 = "libgmp.so.3"
|
||||
|
||||
getStackOSKey :: Monad m => PlatformRequest -> Excepts '[UnsupportedSetupCombo] m String
|
||||
getStackOSKey PlatformRequest { .. } =
|
||||
case (_rArch, _rPlatform) of
|
||||
(A_32 , Linux _) -> pure "linux32"
|
||||
(A_64 , Linux _) -> pure "linux64"
|
||||
(A_32 , Darwin ) -> pure "macosx"
|
||||
(A_64 , Darwin ) -> pure "macosx"
|
||||
(A_32 , FreeBSD) -> pure "freebsd32"
|
||||
(A_64 , FreeBSD) -> pure "freebsd64"
|
||||
(A_32 , Windows) -> pure "windows32"
|
||||
(A_64 , Windows) -> pure "windows64"
|
||||
(A_ARM , Linux _) -> pure "linux-armv7"
|
||||
(A_ARM64, Linux _) -> pure "linux-aarch64"
|
||||
(A_Sparc, Linux _) -> pure "linux-sparc"
|
||||
(A_ARM64, Darwin ) -> pure "macosx-aarch64"
|
||||
(A_ARM64, FreeBSD) -> pure "freebsd-aarch64"
|
||||
(arch', os') -> throwE $ UnsupportedSetupCombo arch' os'
|
||||
|
||||
getStackPlatformKey :: (MonadReader env m, Alternative m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)
|
||||
=> PlatformRequest
|
||||
-> Excepts '[UnsupportedSetupCombo, ParseError, NoCompatiblePlatform, NoCompatibleArch, DistroNotFound, ProcessError] m [String]
|
||||
getStackPlatformKey pfreq@PlatformRequest{..} = do
|
||||
osKey <- liftE $ getStackOSKey pfreq
|
||||
builds <- liftE $ getStackGhcBuilds (PlatformResult _rPlatform _rVersion)
|
||||
let builds' = (\build -> if null build then osKey else osKey <> "-" <> build) <$> builds
|
||||
logDebug $ "Potential GHC builds: " <> mconcat (L.intersperse ", " $ fmap T.pack builds')
|
||||
pure builds'
|
||||
|
||||
|
||||
@@ -120,3 +120,17 @@ verP suffix = do
|
||||
|
||||
pathSep :: MP.Parsec Void Text Char
|
||||
pathSep = MP.oneOf pathSeparators
|
||||
|
||||
skipWhile :: (Char -> Bool) -> MP.Parsec Void Text ()
|
||||
skipWhile f = void $ MP.takeWhileP Nothing f
|
||||
|
||||
skip :: (Char -> Bool) -> MP.Parsec Void Text ()
|
||||
skip f = void $ MP.satisfy f
|
||||
|
||||
skipSpace :: MP.Parsec Void Text ()
|
||||
skipSpace = void $ MP.satisfy isSpace
|
||||
|
||||
isSpace :: Char -> Bool
|
||||
isSpace c = (c == ' ') || ('\t' <= c && c <= '\r')
|
||||
{-# INLINE isSpace #-}
|
||||
|
||||
|
||||
@@ -11,6 +11,7 @@ Portability : portable
|
||||
-}
|
||||
module GHCup.Prelude.Process (
|
||||
executeOut,
|
||||
executeOut',
|
||||
execLogged,
|
||||
exec,
|
||||
toProcessError,
|
||||
|
||||
@@ -70,6 +70,16 @@ executeOut path args chdir = liftIO $ captureOutStreams $ do
|
||||
maybe (pure ()) changeWorkingDirectory chdir
|
||||
SPP.executeFile path True args Nothing
|
||||
|
||||
executeOut' :: MonadIO m
|
||||
=> FilePath -- ^ command as filename, e.g. 'ls'
|
||||
-> [String] -- ^ arguments to the command
|
||||
-> Maybe FilePath -- ^ chdir to this path
|
||||
-> Maybe [(String, String)]
|
||||
-> m CapturedProcess
|
||||
executeOut' path args chdir env = liftIO $ captureOutStreams $ do
|
||||
maybe (pure ()) changeWorkingDirectory chdir
|
||||
SPP.executeFile path True args env
|
||||
|
||||
|
||||
execLogged :: ( MonadReader env m
|
||||
, HasSettings env
|
||||
@@ -169,7 +179,7 @@ execLogged exe args chdir lfile env = do
|
||||
overwriteNthLine n str = pos1 <> moveLineUp n <> clearLine <> str <> moveLineDown n <> pos1
|
||||
|
||||
blue :: ByteString -> ByteString
|
||||
blue bs
|
||||
blue bs
|
||||
| no_color = bs
|
||||
| otherwise = "\x1b[0;34m" <> bs <> "\x1b[0m"
|
||||
|
||||
|
||||
@@ -140,8 +140,16 @@ executeOut :: MonadIO m
|
||||
-> [String] -- ^ arguments to the command
|
||||
-> Maybe FilePath -- ^ chdir to this path
|
||||
-> m CapturedProcess
|
||||
executeOut path args chdir = do
|
||||
cp <- createProcessWithMingwPath ((proc path args){ cwd = chdir })
|
||||
executeOut path args chdir = executeOut' path args chdir Nothing
|
||||
|
||||
executeOut' :: MonadIO m
|
||||
=> FilePath -- ^ command as filename, e.g. 'ls'
|
||||
-> [String] -- ^ arguments to the command
|
||||
-> Maybe FilePath -- ^ chdir to this path
|
||||
-> Maybe [(String, String)]
|
||||
-> m CapturedProcess
|
||||
executeOut' path args chdir env' = do
|
||||
cp <- createProcessWithMingwPath ((proc path args){ cwd = chdir, env = env' })
|
||||
(exit, out, err) <- liftIO $ readCreateProcessWithExitCodeBS cp ""
|
||||
pure $ CapturedProcess exit out err
|
||||
|
||||
|
||||
@@ -26,6 +26,7 @@ module GHCup.Types
|
||||
)
|
||||
where
|
||||
|
||||
import GHCup.Types.Stack ( SetupInfo )
|
||||
import {-# SOURCE #-} GHCup.Utils.Dirs ( fromGHCupPath, GHCupPath )
|
||||
|
||||
import Control.DeepSeq ( NFData, rnf )
|
||||
@@ -46,7 +47,6 @@ import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.Text as T
|
||||
import qualified GHC.Generics as GHC
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import Data.Foldable (foldMap)
|
||||
|
||||
#if !defined(BRICK)
|
||||
data Key = KEsc | KChar Char | KBS | KEnter
|
||||
@@ -58,6 +58,7 @@ data Key = KEsc | KChar Char | KBS | KEnter
|
||||
#endif
|
||||
|
||||
|
||||
|
||||
--------------------
|
||||
--[ GHCInfo Tree ]--
|
||||
--------------------
|
||||
@@ -339,10 +340,19 @@ data URLSource = GHCupURL
|
||||
| AddSource [Either GHCupInfo URI] -- ^ merge with GHCupURL
|
||||
deriving (GHC.Generic, Show)
|
||||
|
||||
data StackSetupURLSource = StackSetupURL
|
||||
| SOwnSource [Either SetupInfo URI] -- ^ complete source list
|
||||
| SOwnSpec SetupInfo
|
||||
| SAddSource [Either SetupInfo URI] -- ^ merge with GHCupURL
|
||||
deriving (Show, Eq, GHC.Generic)
|
||||
|
||||
instance NFData StackSetupURLSource
|
||||
|
||||
instance NFData URLSource
|
||||
instance NFData (URIRef Absolute) where
|
||||
rnf (URI !_ !_ !_ !_ !_) = ()
|
||||
|
||||
|
||||
data MetaMode = Strict
|
||||
| Lax
|
||||
deriving (Show, Read, Eq, GHC.Generic)
|
||||
@@ -363,11 +373,13 @@ data UserSettings = UserSettings
|
||||
, uGPGSetting :: Maybe GPGSetting
|
||||
, uPlatformOverride :: Maybe PlatformRequest
|
||||
, uMirrors :: Maybe DownloadMirrors
|
||||
, uStackSetupSource :: Maybe StackSetupURLSource
|
||||
, uStackSetup :: Maybe Bool
|
||||
}
|
||||
deriving (Show, GHC.Generic)
|
||||
|
||||
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 Nothing Nothing Nothing
|
||||
|
||||
fromSettings :: Settings -> Maybe KeyBindings -> UserSettings
|
||||
fromSettings Settings{..} Nothing =
|
||||
@@ -385,6 +397,8 @@ fromSettings Settings{..} Nothing =
|
||||
, uGPGSetting = Just gpgSetting
|
||||
, uPlatformOverride = platformOverride
|
||||
, uMirrors = Just mirrors
|
||||
, uStackSetupSource = Just stackSetupSource
|
||||
, uStackSetup = Just stackSetup
|
||||
}
|
||||
fromSettings Settings{..} (Just KeyBindings{..}) =
|
||||
let ukb = UserKeyBindings
|
||||
@@ -412,6 +426,8 @@ fromSettings Settings{..} (Just KeyBindings{..}) =
|
||||
, uGPGSetting = Just gpgSetting
|
||||
, uPlatformOverride = platformOverride
|
||||
, uMirrors = Just mirrors
|
||||
, uStackSetupSource = Just stackSetupSource
|
||||
, uStackSetup = Just stackSetup
|
||||
}
|
||||
|
||||
data UserKeyBindings = UserKeyBindings
|
||||
@@ -496,6 +512,8 @@ data Settings = Settings
|
||||
, noColor :: Bool -- this also exists in LoggerConfig
|
||||
, platformOverride :: Maybe PlatformRequest
|
||||
, mirrors :: DownloadMirrors
|
||||
, stackSetupSource :: StackSetupURLSource
|
||||
, stackSetup :: Bool
|
||||
}
|
||||
deriving (Show, GHC.Generic)
|
||||
|
||||
@@ -503,7 +521,7 @@ defaultMetaCache :: Integer
|
||||
defaultMetaCache = 300 -- 5 minutes
|
||||
|
||||
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 (DM mempty) StackSetupURL False
|
||||
|
||||
instance NFData Settings
|
||||
|
||||
@@ -749,3 +767,4 @@ instance Pretty ToolVersion where
|
||||
data BuildSystem = Hadrian
|
||||
| Make
|
||||
deriving (Show, Eq)
|
||||
|
||||
|
||||
@@ -23,6 +23,7 @@ module GHCup.Types.JSON where
|
||||
|
||||
import GHCup.Types
|
||||
import GHCup.Types.JSON.Utils
|
||||
import GHCup.Types.JSON.Versions ()
|
||||
import GHCup.Prelude.MegaParsec
|
||||
|
||||
import Control.Applicative ( (<|>) )
|
||||
@@ -112,34 +113,6 @@ instance FromJSONKey GHCTargetVersion where
|
||||
Right x -> pure x
|
||||
Left e -> fail $ "Failure in GHCTargetVersion (FromJSONKey)" <> show e
|
||||
|
||||
instance ToJSON Versioning where
|
||||
toJSON = toJSON . prettyV
|
||||
|
||||
instance FromJSON Versioning where
|
||||
parseJSON = withText "Versioning" $ \t -> case versioning t of
|
||||
Right x -> pure x
|
||||
Left e -> fail $ "Failure in GHCTargetVersion (FromJSON)" <> show e
|
||||
|
||||
instance ToJSONKey Versioning where
|
||||
toJSONKey = toJSONKeyText $ \x -> prettyV x
|
||||
|
||||
instance FromJSONKey Versioning where
|
||||
fromJSONKey = FromJSONKeyTextParser $ \t -> case versioning t of
|
||||
Right x -> pure x
|
||||
Left e -> fail $ "Failure in Versioning (FromJSONKey)" <> show e
|
||||
|
||||
instance ToJSONKey (Maybe Versioning) where
|
||||
toJSONKey = toJSONKeyText $ \case
|
||||
Just x -> prettyV x
|
||||
Nothing -> T.pack "unknown_versioning"
|
||||
|
||||
instance FromJSONKey (Maybe Versioning) where
|
||||
fromJSONKey = FromJSONKeyTextParser $ \t ->
|
||||
if t == T.pack "unknown_versioning" then pure Nothing else just t
|
||||
where
|
||||
just t = case versioning t of
|
||||
Right x -> pure $ Just x
|
||||
Left e -> fail $ "Failure in (Maybe Versioning) (FromJSONKey)" <> show e
|
||||
|
||||
instance ToJSONKey Platform where
|
||||
toJSONKey = toJSONKeyText $ \case
|
||||
@@ -176,43 +149,6 @@ instance ToJSONKey Architecture where
|
||||
instance FromJSONKey Architecture where
|
||||
fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
|
||||
|
||||
instance ToJSONKey (Maybe Version) where
|
||||
toJSONKey = toJSONKeyText $ \case
|
||||
Just x -> prettyVer x
|
||||
Nothing -> T.pack "unknown_version"
|
||||
|
||||
instance FromJSONKey (Maybe Version) where
|
||||
fromJSONKey = FromJSONKeyTextParser $ \t ->
|
||||
if t == T.pack "unknown_version" then pure Nothing else just t
|
||||
where
|
||||
just t = case version t of
|
||||
Right x -> pure $ Just x
|
||||
Left e -> fail $ "Failure in (Maybe Version) (FromJSONKey)" <> show e
|
||||
|
||||
instance ToJSON Version where
|
||||
toJSON = toJSON . prettyVer
|
||||
|
||||
instance FromJSON Version where
|
||||
parseJSON = withText "Version" $ \t -> case version t of
|
||||
Right x -> pure x
|
||||
Left e -> fail $ "Failure in Version (FromJSON)" <> show e
|
||||
|
||||
instance ToJSONKey Version where
|
||||
toJSONKey = toJSONKeyText $ \x -> prettyVer x
|
||||
|
||||
instance FromJSONKey Version where
|
||||
fromJSONKey = FromJSONKeyTextParser $ \t -> case version t of
|
||||
Right x -> pure x
|
||||
Left e -> fail $ "Failure in Version (FromJSONKey)" <> show e
|
||||
|
||||
instance ToJSON PVP where
|
||||
toJSON = toJSON . prettyPVP
|
||||
|
||||
instance FromJSON PVP where
|
||||
parseJSON = withText "PVP" $ \t -> case pvp t of
|
||||
Right x -> pure x
|
||||
Left e -> fail $ "Failure in PVP (FromJSON)" <> show e
|
||||
|
||||
instance ToJSONKey Tool where
|
||||
toJSONKey = genericToJSONKey defaultJSONKeyOptions
|
||||
|
||||
@@ -348,6 +284,7 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downlo
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
|
||||
deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
|
||||
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, constructorTagModifier = \str' -> if str' == "StackSetupURL" then str' else maybe str' T.unpack . T.stripPrefix (T.pack "S") . T.pack $ str' } ''StackSetupURLSource
|
||||
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
|
||||
|
||||
90
lib/GHCup/Types/JSON/Versions.hs
Normal file
90
lib/GHCup/Types/JSON/Versions.hs
Normal file
@@ -0,0 +1,90 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Types.JSON.Versions
|
||||
Description : GHCup Version JSON types/instances
|
||||
Copyright : (c) Julian Ospald, 2020
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
-}
|
||||
module GHCup.Types.JSON.Versions where
|
||||
|
||||
import Data.Aeson hiding (Key)
|
||||
import Data.Aeson.Types hiding (Key)
|
||||
import Data.Versions
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
instance ToJSON Versioning where
|
||||
toJSON = toJSON . prettyV
|
||||
|
||||
instance FromJSON Versioning where
|
||||
parseJSON = withText "Versioning" $ \t -> case versioning t of
|
||||
Right x -> pure x
|
||||
Left e -> fail $ "Failure in GHCTargetVersion (FromJSON)" <> show e
|
||||
|
||||
instance ToJSONKey Versioning where
|
||||
toJSONKey = toJSONKeyText $ \x -> prettyV x
|
||||
|
||||
instance FromJSONKey Versioning where
|
||||
fromJSONKey = FromJSONKeyTextParser $ \t -> case versioning t of
|
||||
Right x -> pure x
|
||||
Left e -> fail $ "Failure in Versioning (FromJSONKey)" <> show e
|
||||
|
||||
instance ToJSONKey (Maybe Versioning) where
|
||||
toJSONKey = toJSONKeyText $ \case
|
||||
Just x -> prettyV x
|
||||
Nothing -> T.pack "unknown_versioning"
|
||||
|
||||
instance FromJSONKey (Maybe Versioning) where
|
||||
fromJSONKey = FromJSONKeyTextParser $ \t ->
|
||||
if t == T.pack "unknown_versioning" then pure Nothing else just t
|
||||
where
|
||||
just t = case versioning t of
|
||||
Right x -> pure $ Just x
|
||||
Left e -> fail $ "Failure in (Maybe Versioning) (FromJSONKey)" <> show e
|
||||
|
||||
instance ToJSONKey (Maybe Version) where
|
||||
toJSONKey = toJSONKeyText $ \case
|
||||
Just x -> prettyVer x
|
||||
Nothing -> T.pack "unknown_version"
|
||||
|
||||
instance FromJSONKey (Maybe Version) where
|
||||
fromJSONKey = FromJSONKeyTextParser $ \t ->
|
||||
if t == T.pack "unknown_version" then pure Nothing else just t
|
||||
where
|
||||
just t = case version t of
|
||||
Right x -> pure $ Just x
|
||||
Left e -> fail $ "Failure in (Maybe Version) (FromJSONKey)" <> show e
|
||||
|
||||
instance ToJSON Version where
|
||||
toJSON = toJSON . prettyVer
|
||||
|
||||
instance FromJSON Version where
|
||||
parseJSON = withText "Version" $ \t -> case version t of
|
||||
Right x -> pure x
|
||||
Left e -> fail $ "Failure in Version (FromJSON)" <> show e
|
||||
|
||||
instance ToJSONKey Version where
|
||||
toJSONKey = toJSONKeyText $ \x -> prettyVer x
|
||||
|
||||
instance FromJSONKey Version where
|
||||
fromJSONKey = FromJSONKeyTextParser $ \t -> case version t of
|
||||
Right x -> pure x
|
||||
Left e -> fail $ "Failure in Version (FromJSONKey)" <> show e
|
||||
|
||||
instance ToJSON PVP where
|
||||
toJSON = toJSON . prettyPVP
|
||||
|
||||
instance FromJSON PVP where
|
||||
parseJSON = withText "PVP" $ \t -> case pvp t of
|
||||
Right x -> pure x
|
||||
Left e -> fail $ "Failure in PVP (FromJSON)" <> show e
|
||||
180
lib/GHCup/Types/Stack.hs
Normal file
180
lib/GHCup/Types/Stack.hs
Normal file
@@ -0,0 +1,180 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Types.Stack
|
||||
Description : GHCup types.Stack
|
||||
Copyright : (c) Julian Ospald, 2023
|
||||
License : LGPL-3.0
|
||||
Maintainer : hasufell@hasufell.de
|
||||
Stability : experimental
|
||||
Portability : portable
|
||||
-}
|
||||
module GHCup.Types.Stack where
|
||||
|
||||
import GHCup.Types.JSON.Versions ()
|
||||
|
||||
import Control.Applicative
|
||||
import Control.DeepSeq ( NFData )
|
||||
import Data.ByteString
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Types
|
||||
import Data.Map.Strict ( Map )
|
||||
import Data.Text ( Text )
|
||||
import Data.Text.Encoding
|
||||
import Data.Versions
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified GHC.Generics as GHC
|
||||
|
||||
|
||||
--------------------------------------
|
||||
--[ Stack download info copy pasta ]--
|
||||
--------------------------------------
|
||||
|
||||
data SetupInfo = SetupInfo
|
||||
{ siSevenzExe :: Maybe DownloadInfo
|
||||
, siSevenzDll :: Maybe DownloadInfo
|
||||
, siMsys2 :: Map Text VersionedDownloadInfo
|
||||
, siGHCs :: Map Text (Map Version GHCDownloadInfo)
|
||||
, siStack :: Map Text (Map Version DownloadInfo)
|
||||
}
|
||||
deriving (Show, Eq, GHC.Generic)
|
||||
|
||||
instance NFData SetupInfo
|
||||
|
||||
instance FromJSON SetupInfo where
|
||||
parseJSON = withObject "SetupInfo" $ \o -> do
|
||||
siSevenzExe <- o .:? "sevenzexe-info"
|
||||
siSevenzDll <- o .:? "sevenzdll-info"
|
||||
siMsys2 <- o .:? "msys2" .!= mempty
|
||||
siGHCs <- o .:? "ghc" .!= mempty
|
||||
siStack <- o .:? "stack" .!= mempty
|
||||
pure SetupInfo {..}
|
||||
|
||||
instance ToJSON SetupInfo where
|
||||
toJSON (SetupInfo {..}) = object [ "sevenzexe-info" .= siSevenzExe
|
||||
, "sevenzdll-info" .= siSevenzDll
|
||||
, "msys2" .= siMsys2
|
||||
, "ghc" .= siGHCs
|
||||
, "stack" .= siStack
|
||||
]
|
||||
|
||||
-- | For the @siGHCs@ field maps are deeply merged. For all fields the values
|
||||
-- from the first @SetupInfo@ win.
|
||||
instance Semigroup SetupInfo where
|
||||
l <> r =
|
||||
SetupInfo
|
||||
{ siSevenzExe = siSevenzExe l <|> siSevenzExe r
|
||||
, siSevenzDll = siSevenzDll l <|> siSevenzDll r
|
||||
, siMsys2 = siMsys2 l <> siMsys2 r
|
||||
, siGHCs = Map.unionWith (<>) (siGHCs l) (siGHCs r)
|
||||
, siStack = Map.unionWith (<>) (siStack l) (siStack r) }
|
||||
|
||||
instance Monoid SetupInfo where
|
||||
mempty =
|
||||
SetupInfo
|
||||
{ siSevenzExe = Nothing
|
||||
, siSevenzDll = Nothing
|
||||
, siMsys2 = Map.empty
|
||||
, siGHCs = Map.empty
|
||||
, siStack = Map.empty
|
||||
}
|
||||
mappend = (<>)
|
||||
|
||||
-- | Build of the compiler distribution (e.g. standard, gmp4, tinfo6)
|
||||
-- | Information for a file to download.
|
||||
data DownloadInfo = DownloadInfo
|
||||
{ downloadInfoUrl :: Text
|
||||
-- ^ URL or absolute file path
|
||||
, downloadInfoContentLength :: Maybe Int
|
||||
, downloadInfoSha1 :: Maybe ByteString
|
||||
, downloadInfoSha256 :: Maybe ByteString
|
||||
}
|
||||
deriving (Show, Eq, GHC.Generic)
|
||||
|
||||
instance ToJSON DownloadInfo where
|
||||
toJSON (DownloadInfo {..}) = object [ "url" .= downloadInfoUrl
|
||||
, "content-length" .= downloadInfoContentLength
|
||||
, "sha1" .= (decodeUtf8 <$> downloadInfoSha1)
|
||||
, "sha256" .= (decodeUtf8 <$> downloadInfoSha256)
|
||||
]
|
||||
|
||||
instance NFData DownloadInfo
|
||||
|
||||
instance FromJSON DownloadInfo where
|
||||
parseJSON = withObject "DownloadInfo" parseDownloadInfoFromObject
|
||||
|
||||
-- | Parse JSON in existing object for 'DownloadInfo'
|
||||
parseDownloadInfoFromObject :: Object -> Parser DownloadInfo
|
||||
parseDownloadInfoFromObject o = do
|
||||
url <- o .: "url"
|
||||
contentLength <- o .:? "content-length"
|
||||
sha1TextMay <- o .:? "sha1"
|
||||
sha256TextMay <- o .:? "sha256"
|
||||
pure
|
||||
DownloadInfo
|
||||
{ downloadInfoUrl = url
|
||||
, downloadInfoContentLength = contentLength
|
||||
, downloadInfoSha1 = fmap encodeUtf8 sha1TextMay
|
||||
, downloadInfoSha256 = fmap encodeUtf8 sha256TextMay
|
||||
}
|
||||
|
||||
data VersionedDownloadInfo = VersionedDownloadInfo
|
||||
{ vdiVersion :: Version
|
||||
, vdiDownloadInfo :: DownloadInfo
|
||||
}
|
||||
deriving (Show, Eq, GHC.Generic)
|
||||
|
||||
instance ToJSON VersionedDownloadInfo where
|
||||
toJSON (VersionedDownloadInfo {vdiDownloadInfo = DownloadInfo{..}, ..})
|
||||
= object [ "version" .= vdiVersion
|
||||
, "url" .= downloadInfoUrl
|
||||
, "content-length" .= downloadInfoContentLength
|
||||
, "sha1" .= (decodeUtf8 <$> downloadInfoSha1)
|
||||
, "sha256" .= (decodeUtf8 <$> downloadInfoSha256)
|
||||
]
|
||||
|
||||
instance NFData VersionedDownloadInfo
|
||||
|
||||
instance FromJSON VersionedDownloadInfo where
|
||||
parseJSON = withObject "VersionedDownloadInfo" $ \o -> do
|
||||
ver' <- o .: "version"
|
||||
downloadInfo <- parseDownloadInfoFromObject o
|
||||
pure VersionedDownloadInfo
|
||||
{ vdiVersion = ver'
|
||||
, vdiDownloadInfo = downloadInfo
|
||||
}
|
||||
|
||||
data GHCDownloadInfo = GHCDownloadInfo
|
||||
{ gdiConfigureOpts :: [Text]
|
||||
, gdiConfigureEnv :: Map Text Text
|
||||
, gdiDownloadInfo :: DownloadInfo
|
||||
}
|
||||
deriving (Show, Eq, GHC.Generic)
|
||||
|
||||
instance NFData GHCDownloadInfo
|
||||
|
||||
instance ToJSON GHCDownloadInfo where
|
||||
toJSON (GHCDownloadInfo {gdiDownloadInfo = DownloadInfo {..}, ..})
|
||||
= object [ "configure-opts" .= gdiConfigureOpts
|
||||
, "configure-env" .= gdiConfigureEnv
|
||||
, "url" .= downloadInfoUrl
|
||||
, "content-length" .= downloadInfoContentLength
|
||||
, "sha1" .= (decodeUtf8 <$> downloadInfoSha1)
|
||||
, "sha256" .= (decodeUtf8 <$> downloadInfoSha256)
|
||||
]
|
||||
|
||||
instance FromJSON GHCDownloadInfo where
|
||||
parseJSON = withObject "GHCDownloadInfo" $ \o -> do
|
||||
configureOpts <- o .:? "configure-opts" .!= mempty
|
||||
configureEnv <- o .:? "configure-env" .!= mempty
|
||||
downloadInfo <- parseDownloadInfoFromObject o
|
||||
pure GHCDownloadInfo
|
||||
{ gdiConfigureOpts = configureOpts
|
||||
, gdiConfigureEnv = configureEnv
|
||||
, gdiDownloadInfo = downloadInfo
|
||||
}
|
||||
|
||||
@@ -49,7 +49,6 @@ import GHCup.Prelude.Logger.Internal
|
||||
import GHCup.Prelude.MegaParsec
|
||||
import GHCup.Prelude.Process
|
||||
import GHCup.Prelude.String.QQ
|
||||
|
||||
import Codec.Archive hiding ( Directory )
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
@@ -92,7 +91,7 @@ import qualified Data.List.NonEmpty as NE
|
||||
import qualified Streamly.Prelude as S
|
||||
import Control.DeepSeq (force)
|
||||
import GHC.IO (evaluate)
|
||||
import System.Environment (getEnvironment, setEnv)
|
||||
import System.Environment (getEnvironment)
|
||||
import Data.Time (Day(..), diffDays, addDays)
|
||||
|
||||
|
||||
@@ -1321,20 +1320,27 @@ warnAboutHlsCompatibility = do
|
||||
|
||||
|
||||
|
||||
addToPath :: FilePath
|
||||
addToPath :: [FilePath]
|
||||
-> Bool -- ^ if False will prepend
|
||||
-> IO [(String, String)]
|
||||
addToPath path append = do
|
||||
cEnv <- Map.fromList <$> getEnvironment
|
||||
let paths = ["PATH", "Path"]
|
||||
curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
|
||||
{- HLINT ignore "Redundant bracket" -}
|
||||
newPath = intercalate [searchPathSeparator] (if append then (curPaths ++ [path]) else (path : curPaths))
|
||||
envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths
|
||||
pathVar = if isWindows then "Path" else "PATH"
|
||||
envWithNewPath = Map.toList $ Map.insert pathVar newPath envWithoutPath
|
||||
liftIO $ setEnv pathVar newPath
|
||||
return envWithNewPath
|
||||
addToPath paths append = do
|
||||
cEnv <- getEnvironment
|
||||
return $ addToPath' cEnv paths append
|
||||
|
||||
addToPath' :: [(String, String)]
|
||||
-> [FilePath]
|
||||
-> Bool -- ^ if False will prepend
|
||||
-> [(String, String)]
|
||||
addToPath' cEnv' newPaths append =
|
||||
let cEnv = Map.fromList cEnv'
|
||||
paths = ["PATH", "Path"]
|
||||
curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
|
||||
{- HLINT ignore "Redundant bracket" -}
|
||||
newPath = intercalate [searchPathSeparator] (if append then (curPaths ++ newPaths) else (newPaths ++ curPaths))
|
||||
envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths
|
||||
pathVar = if isWindows then "Path" else "PATH"
|
||||
envWithNewPath = Map.toList $ Map.insert pathVar newPath envWithoutPath
|
||||
in envWithNewPath
|
||||
|
||||
|
||||
-----------
|
||||
|
||||
@@ -36,6 +36,9 @@ import Data.Void (Void)
|
||||
ghcupURL :: URI
|
||||
ghcupURL = [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-0.0.8.yaml|]
|
||||
|
||||
stackSetupURL :: URI
|
||||
stackSetupURL = [uri|https://raw.githubusercontent.com/commercialhaskell/stackage-content/master/stack/stack-setup-2.yaml|]
|
||||
|
||||
-- | The current ghcup version.
|
||||
ghcUpVer :: V.PVP
|
||||
ghcUpVer = V.PVP . NE.fromList . fmap fromIntegral $ versionBranch version
|
||||
|
||||
Reference in New Issue
Block a user