hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'issue-892'

Browse Source
This commit is contained in:
Julian Ospald 2023-10-24 15:00:10 +08:00
commit 5fd0fa8d8e
No known key found for this signature in database
GPG Key ID: 4275CDA6A29BED43
24 changed files with 843 additions and 183 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
app/ghcup/BrickMain.hs
View File

@ -30,6 +30,7 @@ import Brick.Widgets.List ( listSelectedFocusedAttr
, listAttr , listAttr
) )
import Codec.Archive import Codec.Archive
import Control.Applicative
import Control.Exception.Safe import Control.Exception.Safe
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )
@ -432,7 +433,7 @@ filterVisible v t e | lInstalled e = True
(lTool e `notElem` hiddenTools) (lTool e `notElem` hiddenTools)
install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m) install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m)
=> BrickState => BrickState
-> (Int, ListResult) -> (Int, ListResult)
-> m (Either String ()) -> m (Either String ())
@ -463,6 +464,11 @@ install' _ (_, ListResult {..}) = do
, ToolShadowed , ToolShadowed
, UninstallFailed , UninstallFailed
, MergeFileTreeError , MergeFileTreeError
, NoCompatiblePlatform
, GHCup.Errors.ParseError
, UnsupportedSetupCombo
, DistroNotFound
, NoCompatibleArch
] ]
run (do run (do
@ -509,7 +515,7 @@ install' _ (_, ListResult {..}) = do
<> "Also check the logs in ~/.ghcup/logs" <> "Also check the logs in ~/.ghcup/logs"
set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m) set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m)
=> BrickState => BrickState
-> (Int, ListResult) -> (Int, ListResult)
-> m (Either String ()) -> m (Either String ())

6
app/ghcup/Main.hs
View File

@ -90,6 +90,8 @@ toSettings options = do
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 mirrors = fromMaybe (Types.mirrors defaultSettings) uMirrors
stackSetupSource = fromMaybe (Types.stackSetupSource defaultSettings) uStackSetupSource
stackSetup = fromMaybe (Types.stackSetup defaultSettings) uStackSetup
in (Settings {..}, keyBindings) in (Settings {..}, keyBindings)
#if defined(INTERNAL_DOWNLOADER) #if defined(INTERNAL_DOWNLOADER)
defaultDownloader = Internal defaultDownloader = Internal
@ -339,8 +341,8 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
, NextVerNotFound , NextVerNotFound
, NoToolVersionSet , NoToolVersionSet
] m Bool ] m Bool
alreadyInstalling (Install (Right InstallOptions{..})) (GHC, ver) = cmp' GHC instVer ver alreadyInstalling (Install (Right InstallGHCOptions{..})) (GHC, ver) = cmp' GHC instVer ver
alreadyInstalling (Install (Left (InstallGHC InstallOptions{..}))) (GHC, ver) = cmp' GHC instVer ver alreadyInstalling (Install (Left (InstallGHC InstallGHCOptions{..}))) (GHC, ver) = cmp' GHC instVer ver
alreadyInstalling (Install (Left (InstallCabal InstallOptions{..}))) (Cabal, ver) = cmp' Cabal instVer ver alreadyInstalling (Install (Left (InstallCabal InstallOptions{..}))) (Cabal, ver) = cmp' Cabal instVer ver
alreadyInstalling (Install (Left (InstallHLS InstallOptions{..}))) (HLS, ver) = cmp' HLS instVer ver alreadyInstalling (Install (Left (InstallHLS InstallOptions{..}))) (HLS, ver) = cmp' HLS instVer ver
alreadyInstalling (Install (Left (InstallStack InstallOptions{..}))) (Stack, ver) = cmp' Stack instVer ver alreadyInstalling (Install (Left (InstallStack InstallOptions{..}))) (Stack, ver) = cmp' Stack instVer ver

12
data/config.yaml
View File

@ -82,6 +82,18 @@ url-source:
# - Right: "file:///home/jule/git/ghcup-hs/ghcup-prereleases.yaml" # - Right: "file:///home/jule/git/ghcup-hs/ghcup-prereleases.yaml"
# - Right: "file:///home/jule/git/ghcup-hs/ghcup-custom.yaml" # - Right: "file:///home/jule/git/ghcup-hs/ghcup-custom.yaml"
# For stack's setup-info, this works similar, e.g.:
# stack-setup-source:
# AddSource:
# - Left:
# ghc:
# linux64-tinfo6:
# 9.4.7:
# url: "https://downloads.haskell.org/~ghc/9.4.7/ghc-9.4.7-x86_64-fedora27-linux.tar.xz"
# content-length: 179117892
# sha256: 216b76b7c6383e6ad9ba82533f323f8550e52893a8b9fa33c7b9dc4201ac766a
# This is a way to override platform detection, e.g. when you're running # This is a way to override platform detection, e.g. when you're running
# a Ubuntu derivate based on 18.04, you could do: # a Ubuntu derivate based on 18.04, you could do:
# #

32
docs/guide.md
View File

@ -246,6 +246,38 @@ stack config set install-ghc false --global
stack config set system-ghc true --global stack config set system-ghc true --global
``` ```
### Using stack's setup-info metadata to install GHC
You can now use stack's [setup-info metadata](https://github.com/commercialhaskell/stackage-content/blob/master/stack/stack-setup-2.yaml)
to install GHC. For that, you can invoke ghcup like so:
```sh
ghcup install ghc --stack-setup 9.4.7
```
To make this permanent, you can add the following to you `~/.ghcup/config.yaml`:
```yaml
stack-setup: true
```
You can customize or add sections to the setup-info similar to how the [stack documentation](https://docs.haskellstack.org/en/stable/yaml_configuration/#setup-info) explains it. E.g. to change the 9.4.7 bindist, you might do:
```yaml
stack-setup-source:
AddSource:
- Left:
ghc:
linux64-tinfo6:
9.4.7:
url: "https://downloads.haskell.org/~ghc/9.4.7/ghc-9.4.7-x86_64-fedora27-linux.tar.xz"
content-length: 179117892
sha256: 216b76b7c6383e6ad9ba82533f323f8550e52893a8b9fa33c7b9dc4201ac766a
```
The main caveat with using this method is that there's no guarantee that GHCup will pick a compatible HLS bindist
when you try to install HLS.
### Windows ### Windows
On windows, you may find the following config options useful too: On windows, you may find the following config options useful too:

2
ghcup.cabal
View File

@ -117,7 +117,9 @@ library
GHCup.Types GHCup.Types
GHCup.Types.JSON GHCup.Types.JSON
GHCup.Types.JSON.Utils GHCup.Types.JSON.Utils
GHCup.Types.JSON.Versions
GHCup.Types.Optics GHCup.Types.Optics
GHCup.Types.Stack
GHCup.Utils GHCup.Utils
GHCup.Utils.Dirs GHCup.Utils.Dirs
GHCup.Version GHCup.Version

2
lib-opt/GHCup/OptParse.hs
View File

@ -88,7 +88,7 @@ data Options = Options
} }
data Command data Command
= Install (Either InstallCommand InstallOptions) = Install (Either InstallCommand InstallGHCOptions)
| Test TestCommand | Test TestCommand
| InstallCabalLegacy InstallOptions | InstallCabalLegacy InstallOptions
| Set (Either SetCommand SetOptions) | Set (Either SetCommand SetOptions)

4
lib-opt/GHCup/OptParse/Config.hs
View File

@ -135,7 +135,9 @@ updateSettings usl usr =
gpgSetting' = uGPGSetting usl <|> uGPGSetting usr gpgSetting' = uGPGSetting usl <|> uGPGSetting usr
platformOverride' = uPlatformOverride usl <|> uPlatformOverride usr platformOverride' = uPlatformOverride usl <|> uPlatformOverride usr
mirrors' = uMirrors usl <|> uMirrors usr mirrors' = uMirrors usl <|> uMirrors usr
in UserSettings cache' metaCache' metaMode' noVerify' verbose' keepDirs' downloader' (updateKeyBindings (uKeyBindings usl) (uKeyBindings usr)) urlSource' noNetwork' gpgSetting' platformOverride' mirrors' stackSetupSource' = uStackSetupSource usl <|> uStackSetupSource usr
stackSetup' = uStackSetup usl <|> uStackSetup usr
in UserSettings cache' metaCache' metaMode' noVerify' verbose' keepDirs' downloader' (updateKeyBindings (uKeyBindings usl) (uKeyBindings usr)) urlSource' noNetwork' gpgSetting' platformOverride' mirrors' stackSetupSource' stackSetup'
where where
updateKeyBindings :: Maybe UserKeyBindings -> Maybe UserKeyBindings -> Maybe UserKeyBindings updateKeyBindings :: Maybe UserKeyBindings -> Maybe UserKeyBindings -> Maybe UserKeyBindings
updateKeyBindings Nothing Nothing = Nothing updateKeyBindings Nothing Nothing = Nothing

42
lib-opt/GHCup/OptParse/Install.hs
View File

@ -50,7 +50,7 @@ import qualified Data.Text as T
---------------- ----------------
data InstallCommand = InstallGHC InstallOptions data InstallCommand = InstallGHC InstallGHCOptions
| InstallCabal InstallOptions | InstallCabal InstallOptions
| InstallHLS InstallOptions | InstallHLS InstallOptions
| InstallStack InstallOptions | InstallStack InstallOptions
@ -63,6 +63,15 @@ data InstallCommand = InstallGHC InstallOptions
--[ Options ]-- --[ Options ]--
--------------- ---------------
data InstallGHCOptions = InstallGHCOptions
{ instVer :: Maybe ToolVersion
, instBindist :: Maybe URI
, instSet :: Bool
, isolateDir :: Maybe FilePath
, forceInstall :: Bool
, addConfArgs :: [T.Text]
, useStackSetup :: Maybe Bool
} deriving (Eq, Show)
data InstallOptions = InstallOptions data InstallOptions = InstallOptions
{ instVer :: Maybe ToolVersion { instVer :: Maybe ToolVersion
@ -93,14 +102,14 @@ installCabalFooter = [s|Discussion:
--[ Parsers ]-- --[ Parsers ]--
--------------- ---------------
installParser :: Parser (Either InstallCommand InstallOptions) installParser :: Parser (Either InstallCommand InstallGHCOptions)
installParser = installParser =
(Left <$> subparser (Left <$> subparser
( command ( command
"ghc" "ghc"
( InstallGHC ( InstallGHC
<$> info <$> info
(installOpts (Just GHC) <**> helper) (installGHCOpts <**> helper)
( progDesc "Install GHC" ( progDesc "Install GHC"
<> footerDoc (Just $ text installGHCFooter) <> footerDoc (Just $ text installGHCFooter)
) )
@ -134,7 +143,7 @@ installParser =
) )
) )
) )
<|> (Right <$> installOpts Nothing) <|> (Right <$> installGHCOpts)
where where
installHLSFooter :: String installHLSFooter :: String
installHLSFooter = [s|Discussion: installHLSFooter = [s|Discussion:
@ -210,6 +219,12 @@ installOpts tool =
Just GHC -> False Just GHC -> False
Just _ -> True Just _ -> True
installGHCOpts :: Parser InstallGHCOptions
installGHCOpts =
(\InstallOptions{..} b -> let useStackSetup = b in InstallGHCOptions{..})
<$> installOpts (Just GHC)
<*> invertableSwitch "stack-setup" (Just 's') False (help "Set as active version after install")
@ -291,6 +306,11 @@ type InstallGHCEffects = '[ AlreadyInstalled
, UninstallFailed , UninstallFailed
, UnknownArchive , UnknownArchive
, InstallSetError , InstallSetError
, NoCompatiblePlatform
, GHCup.Errors.ParseError
, UnsupportedSetupCombo
, DistroNotFound
, NoCompatibleArch
] ]
runInstGHC :: AppState runInstGHC :: AppState
@ -308,21 +328,21 @@ runInstGHC appstate' =
------------------- -------------------
install :: Either InstallCommand InstallOptions -> Settings -> IO AppState -> (ReaderT LeanAppState IO () -> IO ()) -> IO ExitCode install :: Either InstallCommand InstallGHCOptions -> Settings -> IO AppState -> (ReaderT LeanAppState IO () -> IO ()) -> IO ExitCode
install installCommand settings getAppState' runLogger = case installCommand of install installCommand settings getAppState' runLogger = case installCommand of
(Right iopts) -> do (Right iGHCopts) -> do
runLogger (logWarn "This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.") runLogger (logWarn "This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.")
installGHC iopts installGHC iGHCopts
(Left (InstallGHC iopts)) -> installGHC iopts (Left (InstallGHC iGHCopts)) -> installGHC iGHCopts
(Left (InstallCabal iopts)) -> installCabal iopts (Left (InstallCabal iopts)) -> installCabal iopts
(Left (InstallHLS iopts)) -> installHLS iopts (Left (InstallHLS iopts)) -> installHLS iopts
(Left (InstallStack iopts)) -> installStack iopts (Left (InstallStack iopts)) -> installStack iopts
where where
installGHC :: InstallOptions -> IO ExitCode installGHC :: InstallGHCOptions -> IO ExitCode
installGHC InstallOptions{..} = do installGHC InstallGHCOptions{..} = do
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState' s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
(case instBindist of (case instBindist of
Nothing -> runInstGHC s' $ do Nothing -> runInstGHC s'{ settings = maybe settings (\b -> settings {stackSetup = b}) useStackSetup } $ do
(v, vi) <- liftE $ fromVersion instVer GHC (v, vi) <- liftE $ fromVersion instVer GHC
liftE $ runBothE' (installGHCBin liftE $ runBothE' (installGHCBin
v v

16
lib-opt/GHCup/OptParse/Run.hs
View File

@ -187,6 +187,11 @@ type RunEffects = '[ AlreadyInstalled
, ProcessError , ProcessError
, UninstallFailed , UninstallFailed
, MergeFileTreeError , MergeFileTreeError
, NoCompatiblePlatform
, GHCup.Errors.ParseError
, UnsupportedSetupCombo
, DistroNotFound
, NoCompatibleArch
] ]
runLeanRUN :: (MonadUnliftIO m, MonadIO m) runLeanRUN :: (MonadUnliftIO m, MonadIO m)
@ -226,6 +231,7 @@ run :: forall m .
, MonadCatch m , MonadCatch m
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
, Alternative m
) )
=> RunOptions => RunOptions
-> IO AppState -> IO AppState
@ -255,7 +261,9 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
liftIO $ putStr tmp liftIO $ putStr tmp
pure ExitSuccess pure ExitSuccess
(cmd:args) -> do (cmd:args) -> do
newEnv <- liftIO $ addToPath tmp runAppendPATH newEnv <- liftIO $ addToPath [tmp] runAppendPATH
let pathVar = if isWindows then "Path" else "PATH"
forM_ (Map.lookup pathVar . Map.fromList $ newEnv) $ liftIO . setEnv pathVar
#ifndef IS_WINDOWS #ifndef IS_WINDOWS
void $ liftIO $ SPP.executeFile cmd True args (Just newEnv) void $ liftIO $ SPP.executeFile cmd True args (Just newEnv)
pure ExitSuccess pure ExitSuccess
@ -329,6 +337,7 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
, MonadThrow m , MonadThrow m
, MonadIO m , MonadIO m
, MonadCatch m , MonadCatch m
, Alternative m
) )
=> Toolchain => Toolchain
-> FilePath -> FilePath
@ -354,6 +363,11 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
, CopyError , CopyError
, UninstallFailed , UninstallFailed
, MergeFileTreeError , MergeFileTreeError
, NoCompatiblePlatform
, GHCup.Errors.ParseError
, UnsupportedSetupCombo
, DistroNotFound
, NoCompatibleArch
] (ResourceT (ReaderT AppState m)) () ] (ResourceT (ReaderT AppState m)) ()
installToolChainFull Toolchain{..} tmp = do installToolChainFull Toolchain{..} tmp = do
case ghcVer of case ghcVer of

185
lib/GHCup/Download.hs
View File

@ -5,7 +5,6 @@
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-| {-|
Module : GHCup.Download Module : GHCup.Download
Description : Downloading Description : Downloading
@ -31,6 +30,8 @@ import GHCup.Download.Utils
#endif #endif
import GHCup.Errors import GHCup.Errors
import GHCup.Types import GHCup.Types
import qualified GHCup.Types.Stack as Stack
import GHCup.Types.Stack (downloadInfoUrl, downloadInfoSha256)
import GHCup.Types.Optics import GHCup.Types.Optics
import GHCup.Types.JSON ( ) import GHCup.Types.JSON ( )
import GHCup.Utils.Dirs import GHCup.Utils.Dirs
@ -159,9 +160,10 @@ getBase :: ( MonadReader env m
, MonadCatch m , MonadCatch m
, HasLog env , HasLog env
, MonadMask m , MonadMask m
, FromJSON j
) )
=> URI => URI
-> Excepts '[DownloadFailed, GPGError, DigestError, ContentLengthError, JSONError, FileDoesNotExistError] m GHCupInfo -> Excepts '[DownloadFailed, GPGError, DigestError, ContentLengthError, JSONError, FileDoesNotExistError] m j
getBase uri = do getBase uri = do
Settings { noNetwork, downloader, metaMode } <- lift getSettings Settings { noNetwork, downloader, metaMode } <- lift getSettings
@ -246,7 +248,7 @@ getBase uri = do
Settings { metaCache } <- lift getSettings Settings { metaCache } <- lift getSettings
-- for local files, let's short-circuit and ignore access time -- 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 | e -> do
accessTime <- fmap utcTimeToPOSIXSeconds $ liftIO $ getAccessTime json_file accessTime <- fmap utcTimeToPOSIXSeconds $ liftIO $ getAccessTime json_file
let sinceLastAccess = utcTimeToPOSIXSeconds currentTime - accessTime let sinceLastAccess = utcTimeToPOSIXSeconds currentTime - accessTime
@ -325,6 +327,107 @@ getDownloadInfo' t v = do
_ -> with_distro <|> without_distro_ver <|> without_distro _ -> 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 -- | Tries to download from the given http or https url
-- and saves the result in continuous memory into a file. -- 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 download rawUri gpgUri eDigest eCSize dest mfn etags
| scheme == "https" = liftE dl | scheme == "https" = liftE dl
| scheme == "http" = 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 | scheme == "file" = do
Settings{ gpgSetting } <- lift getSettings
let destFile' = T.unpack . decUTF8Safe $ view pathL' rawUri let destFile' = T.unpack . decUTF8Safe $ view pathL' rawUri
lift $ logDebug $ "using local file: " <> T.pack destFile' 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' pure destFile'
| otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme) | otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
where where
scheme = view (uriSchemeL' % schemeBSL') rawUri scheme = view (uriSchemeL' % schemeBSL') rawUri
gpgScheme = view (uriSchemeL' % schemeBSL') <$> gpgUri
dl = do dl = do
Settings{ mirrors } <- lift getSettings Settings{ mirrors } <- lift getSettings
let uri = applyMirrors mirrors rawUri let uri = applyMirrors mirrors rawUri
@ -407,14 +505,30 @@ download rawUri gpgUri eDigest eCSize dest mfn etags
else pure (\fp -> liftE . internalDL fp) else pure (\fp -> liftE . internalDL fp)
#endif #endif
liftE $ downloadAction baseDestFile uri liftE $ downloadAction baseDestFile uri
liftE $ verify gpgSetting baseDestFile case (gpgUri, gpgSetting) of
(\uri' -> do (_, GPGNone) -> pure ()
gpgDestFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile uri' Nothing (Just gpgUri', _) -> do
lift $ logDebug $ "downloading: " <> (decUTF8Safe . serializeURIRef') uri' <> " as file " <> T.pack gpgDestFile gpgDestFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile gpgUri' Nothing
flip onException (lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile gpgDestFile)) $ liftE $ flip onException
downloadAction gpgDestFile uri' (lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile gpgDestFile))
pure 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 pure baseDestFile
curlDL :: ( MonadCatch m curlDL :: ( MonadCatch m
@ -612,41 +726,6 @@ download rawUri gpgUri eDigest eCSize dest mfn etags
liftIO $ hideError doesNotExistErrorType $ rmFile (etagsFile fp) liftIO $ hideError doesNotExistErrorType $ rmFile (etagsFile fp)
pure Nothing 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 -- | Download into tmpdir or use cached version, if it exists. If filename
-- is omitted, infers the filename from the url. -- is omitted, infers the filename from the url.
@ -666,7 +745,7 @@ downloadCached :: ( MonadReader env m
downloadCached dli mfn = do downloadCached dli mfn = do
Settings{ cache } <- lift getSettings Settings{ cache } <- lift getSettings
case cache of case cache of
True -> liftE $ downloadCached' dli mfn Nothing True -> downloadCached' dli mfn Nothing
False -> do False -> do
tmp <- lift withGHCupTmpDir tmp <- lift withGHCupTmpDir
liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (_dlCSize dli) (fromGHCupPath tmp) outputFileName False liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (_dlCSize dli) (fromGHCupPath tmp) outputFileName False

25
lib/GHCup/Errors.hs
View File

@ -87,6 +87,7 @@ allHFError = unlines allErrors
, let proxy = Proxy :: Proxy ToolShadowed in format proxy , let proxy = Proxy :: Proxy ToolShadowed in format proxy
, let proxy = Proxy :: Proxy ContentLengthError in format proxy , let proxy = Proxy :: Proxy ContentLengthError in format proxy
, let proxy = Proxy :: Proxy DuplicateReleaseChannel in format proxy , let proxy = Proxy :: Proxy DuplicateReleaseChannel in format proxy
, let proxy = Proxy :: Proxy UnsupportedSetupCombo in format proxy
, "" , ""
, "# high level errors (4000+)" , "# high level errors (4000+)"
, let proxy = Proxy :: Proxy DownloadFailed in format proxy , 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 ParseError in format proxy
, let proxy = Proxy :: Proxy UnexpectedListLength in format proxy , let proxy = Proxy :: Proxy UnexpectedListLength in format proxy
, let proxy = Proxy :: Proxy NoUrlBase in format proxy , let proxy = Proxy :: Proxy NoUrlBase in format proxy
, let proxy = Proxy :: Proxy DigestMissing in format proxy
, "" , ""
, "# orphans (800+)" , "# orphans (800+)"
, let proxy = Proxy :: Proxy URIParseError in format proxy , let proxy = Proxy :: Proxy URIParseError in format proxy
@ -687,6 +689,17 @@ instance Pretty DuplicateReleaseChannel where
<> (T.unpack . E.decodeUtf8With E.lenientDecode . serializeURIRef') uri <> (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)." <> "\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 ]-- --[ High-level errors ]--
------------------------- -------------------------
@ -821,6 +834,18 @@ instance HFErrorProject NoUrlBase where
eBase _ = 520 eBase _ = 520
eDesc _ = "URL does not have a base filename." 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."
------------------------ ------------------------

21
lib/GHCup/GHC.hs
View File

@ -26,6 +26,7 @@ import GHCup.Types
import GHCup.Types.JSON ( ) import GHCup.Types.JSON ( )
import GHCup.Types.Optics import GHCup.Types.Optics
import GHCup.Utils import GHCup.Utils
import GHCup.Platform
import GHCup.Prelude import GHCup.Prelude
import GHCup.Prelude.File import GHCup.Prelude.File
import GHCup.Prelude.Logger 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.Base16 as B16
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import qualified Data.Map.Strict as Map
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.IO as T import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as E import qualified Data.Text.Encoding as E
@ -216,7 +218,9 @@ testUnpackedGHC path tver addMakeArgs = do
lift $ logInfo $ "Testing GHC version " <> tVerToText tver <> "!" lift $ logInfo $ "Testing GHC version " <> tVerToText tver <> "!"
ghcDir <- lift $ ghcupGHCDir tver ghcDir <- lift $ ghcupGHCDir tver
let ghcBinDir = fromGHCupPath ghcDir </> "bin" 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) lEM $ make' (fmap T.unpack addMakeArgs)
(Just $ fromGHCupPath path) (Just $ fromGHCupPath path)
@ -512,6 +516,7 @@ installGHCBin :: ( MonadFail m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
, Alternative m
) )
=> GHCTargetVersion -- ^ the version to install => GHCTargetVersion -- ^ the version to install
-> InstallDir -> InstallDir
@ -533,11 +538,23 @@ installGHCBin :: ( MonadFail m
, ProcessError , ProcessError
, UninstallFailed , UninstallFailed
, MergeFileTreeError , MergeFileTreeError
, NoCompatiblePlatform
, ParseError
, UnsupportedSetupCombo
, DistroNotFound
, NoCompatibleArch
] ]
m m
() ()
installGHCBin tver installDir forceInstall addConfArgs = do 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 liftE $ installGHCBindist dlinfo tver installDir forceInstall addConfArgs

163
lib/GHCup/Platform.hs
View File

@ -23,11 +23,13 @@ import GHCup.Errors
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics import GHCup.Types.Optics
import GHCup.Types.JSON ( ) import GHCup.Types.JSON ( )
import GHCup.Utils.Dirs import GHCup.Utils
import GHCup.Prelude import GHCup.Prelude
import GHCup.Prelude.Logger import GHCup.Prelude.Logger
import GHCup.Prelude.Process import GHCup.Prelude.Process
import GHCup.Prelude.String.QQ import GHCup.Prelude.String.QQ
import GHCup.Prelude.Version.QQ
import GHCup.Prelude.MegaParsec
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )
@ -48,11 +50,18 @@ import Prelude hiding ( abs
) )
import System.Info import System.Info
import System.OsRelease import System.OsRelease
import System.Exit
import System.FilePath
import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.PrettyPrint.HughesPJClass ( prettyShow )
import Text.Regex.Posix import Text.Regex.Posix
import qualified Text.Megaparsec as MP
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.IO 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 try_debian_version = do
ver <- T.readFile debian_version ver <- T.readFile debian_version
pure (T.pack "debian", Just ver) 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'

14
lib/GHCup/Prelude/MegaParsec.hs
View File

@ -120,3 +120,17 @@ verP suffix = do
pathSep :: MP.Parsec Void Text Char pathSep :: MP.Parsec Void Text Char
pathSep = MP.oneOf pathSeparators 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 #-}

1
lib/GHCup/Prelude/Process.hs
View File

@ -11,6 +11,7 @@ Portability : portable
-} -}
module GHCup.Prelude.Process ( module GHCup.Prelude.Process (
executeOut, executeOut,
executeOut',
execLogged, execLogged,
exec, exec,
toProcessError, toProcessError,

10
lib/GHCup/Prelude/Process/Posix.hs
View File

@ -70,6 +70,16 @@ executeOut path args chdir = liftIO $ captureOutStreams $ do
maybe (pure ()) changeWorkingDirectory chdir maybe (pure ()) changeWorkingDirectory chdir
SPP.executeFile path True args Nothing 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 execLogged :: ( MonadReader env m
, HasSettings env , HasSettings env

12
lib/GHCup/Prelude/Process/Windows.hs
View File

@ -140,8 +140,16 @@ executeOut :: MonadIO m
-> [String] -- ^ arguments to the command -> [String] -- ^ arguments to the command
-> Maybe FilePath -- ^ chdir to this path -> Maybe FilePath -- ^ chdir to this path
-> m CapturedProcess -> m CapturedProcess
executeOut path args chdir = do executeOut path args chdir = executeOut' path args chdir Nothing
cp <- createProcessWithMingwPath ((proc path args){ cwd = chdir })
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 "" (exit, out, err) <- liftIO $ readCreateProcessWithExitCodeBS cp ""
pure $ CapturedProcess exit out err pure $ CapturedProcess exit out err

25
lib/GHCup/Types.hs
View File

@ -26,6 +26,7 @@ module GHCup.Types
) )
where where
import GHCup.Types.Stack ( SetupInfo )
import {-# SOURCE #-} GHCup.Utils.Dirs ( fromGHCupPath, GHCupPath ) import {-# SOURCE #-} GHCup.Utils.Dirs ( fromGHCupPath, GHCupPath )
import Control.DeepSeq ( NFData, rnf ) import Control.DeepSeq ( NFData, rnf )
@ -46,7 +47,6 @@ import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T import qualified Data.Text as T
import qualified GHC.Generics as GHC import qualified GHC.Generics as GHC
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
import Data.Foldable (foldMap)
#if !defined(BRICK) #if !defined(BRICK)
data Key = KEsc | KChar Char | KBS | KEnter data Key = KEsc | KChar Char | KBS | KEnter
@ -58,6 +58,7 @@ data Key = KEsc | KChar Char | KBS | KEnter
#endif #endif
-------------------- --------------------
--[ GHCInfo Tree ]-- --[ GHCInfo Tree ]--
-------------------- --------------------
@ -339,10 +340,19 @@ data URLSource = GHCupURL
| AddSource [Either GHCupInfo URI] -- ^ merge with GHCupURL | AddSource [Either GHCupInfo URI] -- ^ merge with GHCupURL
deriving (GHC.Generic, Show) 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 URLSource
instance NFData (URIRef Absolute) where instance NFData (URIRef Absolute) where
rnf (URI !_ !_ !_ !_ !_) = () rnf (URI !_ !_ !_ !_ !_) = ()
data MetaMode = Strict data MetaMode = Strict
| Lax | Lax
deriving (Show, Read, Eq, GHC.Generic) deriving (Show, Read, Eq, GHC.Generic)
@ -363,11 +373,13 @@ data UserSettings = UserSettings
, uGPGSetting :: Maybe GPGSetting , uGPGSetting :: Maybe GPGSetting
, uPlatformOverride :: Maybe PlatformRequest , uPlatformOverride :: Maybe PlatformRequest
, uMirrors :: Maybe DownloadMirrors , uMirrors :: Maybe DownloadMirrors
, uStackSetupSource :: Maybe StackSetupURLSource
, uStackSetup :: Maybe Bool
} }
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 Nothing Nothing Nothing
fromSettings :: Settings -> Maybe KeyBindings -> UserSettings fromSettings :: Settings -> Maybe KeyBindings -> UserSettings
fromSettings Settings{..} Nothing = fromSettings Settings{..} Nothing =
@ -385,6 +397,8 @@ fromSettings Settings{..} Nothing =
, uGPGSetting = Just gpgSetting , uGPGSetting = Just gpgSetting
, uPlatformOverride = platformOverride , uPlatformOverride = platformOverride
, uMirrors = Just mirrors , uMirrors = Just mirrors
, uStackSetupSource = Just stackSetupSource
, uStackSetup = Just stackSetup
} }
fromSettings Settings{..} (Just KeyBindings{..}) = fromSettings Settings{..} (Just KeyBindings{..}) =
let ukb = UserKeyBindings let ukb = UserKeyBindings
@ -412,6 +426,8 @@ fromSettings Settings{..} (Just KeyBindings{..}) =
, uGPGSetting = Just gpgSetting , uGPGSetting = Just gpgSetting
, uPlatformOverride = platformOverride , uPlatformOverride = platformOverride
, uMirrors = Just mirrors , uMirrors = Just mirrors
, uStackSetupSource = Just stackSetupSource
, uStackSetup = Just stackSetup
} }
data UserKeyBindings = UserKeyBindings data UserKeyBindings = UserKeyBindings
@ -496,6 +512,8 @@ data Settings = Settings
, noColor :: Bool -- this also exists in LoggerConfig , noColor :: Bool -- this also exists in LoggerConfig
, platformOverride :: Maybe PlatformRequest , platformOverride :: Maybe PlatformRequest
, mirrors :: DownloadMirrors , mirrors :: DownloadMirrors
, stackSetupSource :: StackSetupURLSource
, stackSetup :: Bool
} }
deriving (Show, GHC.Generic) deriving (Show, GHC.Generic)
@ -503,7 +521,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 (DM mempty) StackSetupURL False
instance NFData Settings instance NFData Settings
@ -749,3 +767,4 @@ instance Pretty ToolVersion where
data BuildSystem = Hadrian data BuildSystem = Hadrian
| Make | Make
deriving (Show, Eq) deriving (Show, Eq)

67
lib/GHCup/Types/JSON.hs
View File

@ -23,6 +23,7 @@ module GHCup.Types.JSON where
import GHCup.Types import GHCup.Types
import GHCup.Types.JSON.Utils import GHCup.Types.JSON.Utils
import GHCup.Types.JSON.Versions ()
import GHCup.Prelude.MegaParsec import GHCup.Prelude.MegaParsec
import Control.Applicative ( (<|>) ) import Control.Applicative ( (<|>) )
@ -112,34 +113,6 @@ instance FromJSONKey GHCTargetVersion where
Right x -> pure x Right x -> pure x
Left e -> fail $ "Failure in GHCTargetVersion (FromJSONKey)" <> show e 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 instance ToJSONKey Platform where
toJSONKey = toJSONKeyText $ \case toJSONKey = toJSONKeyText $ \case
@ -176,43 +149,6 @@ instance ToJSONKey Architecture where
instance FromJSONKey Architecture where instance FromJSONKey Architecture where
fromJSONKey = genericFromJSONKey defaultJSONKeyOptions 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 instance ToJSONKey Tool where
toJSONKey = genericToJSONKey defaultJSONKeyOptions toJSONKey = genericToJSONKey defaultJSONKeyOptions
@ -348,6 +284,7 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downlo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource 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 { 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 } ''Port

90
lib/GHCup/Types/JSON/Versions.hs Normal file
View 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
View 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
}

24
lib/GHCup/Utils.hs
View File

@ -49,7 +49,6 @@ import GHCup.Prelude.Logger.Internal
import GHCup.Prelude.MegaParsec import GHCup.Prelude.MegaParsec
import GHCup.Prelude.Process import GHCup.Prelude.Process
import GHCup.Prelude.String.QQ import GHCup.Prelude.String.QQ
import Codec.Archive hiding ( Directory ) import Codec.Archive hiding ( Directory )
import Control.Applicative import Control.Applicative
import Control.Exception.Safe import Control.Exception.Safe
@ -92,7 +91,7 @@ import qualified Data.List.NonEmpty as NE
import qualified Streamly.Prelude as S import qualified Streamly.Prelude as S
import Control.DeepSeq (force) import Control.DeepSeq (force)
import GHC.IO (evaluate) import GHC.IO (evaluate)
import System.Environment (getEnvironment, setEnv) import System.Environment (getEnvironment)
import Data.Time (Day(..), diffDays, addDays) import Data.Time (Day(..), diffDays, addDays)
@ -1321,20 +1320,27 @@ warnAboutHlsCompatibility = do
addToPath :: FilePath addToPath :: [FilePath]
-> Bool -- ^ if False will prepend -> Bool -- ^ if False will prepend
-> IO [(String, String)] -> IO [(String, String)]
addToPath path append = do addToPath paths append = do
cEnv <- Map.fromList <$> getEnvironment cEnv <- getEnvironment
let paths = ["PATH", "Path"] 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 curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
{- HLINT ignore "Redundant bracket" -} {- HLINT ignore "Redundant bracket" -}
newPath = intercalate [searchPathSeparator] (if append then (curPaths ++ [path]) else (path : curPaths)) newPath = intercalate [searchPathSeparator] (if append then (curPaths ++ newPaths) else (newPaths ++ curPaths))
envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths
pathVar = if isWindows then "Path" else "PATH" pathVar = if isWindows then "Path" else "PATH"
envWithNewPath = Map.toList $ Map.insert pathVar newPath envWithoutPath envWithNewPath = Map.toList $ Map.insert pathVar newPath envWithoutPath
liftIO $ setEnv pathVar newPath in envWithNewPath
return envWithNewPath
----------- -----------

3
lib/GHCup/Version.hs
View File

@ -36,6 +36,9 @@ import Data.Void (Void)
ghcupURL :: URI ghcupURL :: URI
ghcupURL = [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-0.0.8.yaml|] 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. -- | The current ghcup version.
ghcUpVer :: V.PVP ghcUpVer :: V.PVP
ghcUpVer = V.PVP . NE.fromList . fmap fromIntegral $ versionBranch version ghcUpVer = V.PVP . NE.fromList . fmap fromIntegral $ versionBranch version

54
test/optparse-test/InstallTest.hs
View File

@ -2,6 +2,9 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-}
module InstallTest where module InstallTest where
@ -13,6 +16,8 @@ import Data.Versions
import Data.List.NonEmpty (NonEmpty ((:|))) import Data.List.NonEmpty (NonEmpty ((:|)))
import GHCup.OptParse.Install as Install import GHCup.OptParse.Install as Install
import URI.ByteString.QQ import URI.ByteString.QQ
import URI.ByteString
import Data.Text (Text)
-- Some interests: -- Some interests:
-- install ghc *won't* select `set as activate version` as default -- install ghc *won't* select `set as activate version` as default
@ -26,37 +31,52 @@ installTests = testGroup "install"
(buildTestTree installParseWith) (buildTestTree installParseWith)
[ ("old-style", oldStyleCheckList) [ ("old-style", oldStyleCheckList)
, ("ghc", installGhcCheckList) , ("ghc", installGhcCheckList)
, ("cabal", installCabalCheckList) , ("cabal", (fmap . fmap . fmap) toGHCOptions installCabalCheckList)
, ("hls", installHlsCheckList) , ("hls", (fmap . fmap . fmap) toGHCOptions installHlsCheckList)
, ("stack", installStackCheckList) , ("stack", (fmap . fmap . fmap) toGHCOptions installStackCheckList)
] ]
toGHCOptions :: InstallOptions -> InstallGHCOptions
toGHCOptions InstallOptions{..}
= InstallGHCOptions instVer
instBindist
instSet
isolateDir
forceInstall
addConfArgs
Nothing
defaultOptions :: InstallOptions defaultOptions :: InstallOptions
defaultOptions = InstallOptions Nothing Nothing False Nothing False [] defaultOptions = InstallOptions Nothing Nothing False Nothing False []
defaultGHCOptions :: InstallGHCOptions
defaultGHCOptions = InstallGHCOptions Nothing Nothing False Nothing False [] Nothing
-- | Don't set as active version -- | Don't set as active version
mkInstallOptions :: ToolVersion -> InstallOptions mkInstallOptions :: ToolVersion -> InstallGHCOptions
mkInstallOptions ver = InstallOptions (Just ver) Nothing False Nothing False [] mkInstallOptions ver = InstallGHCOptions (Just ver) Nothing False Nothing False [] Nothing
-- | Set as active version -- | Set as active version
mkInstallOptions' :: ToolVersion -> InstallOptions mkInstallOptions' :: ToolVersion -> InstallOptions
mkInstallOptions' ver = InstallOptions (Just ver) Nothing True Nothing False [] mkInstallOptions' ver = InstallOptions (Just ver) Nothing True Nothing False []
oldStyleCheckList :: [(String, Either InstallCommand InstallOptions)] oldStyleCheckList :: [(String, Either InstallCommand InstallGHCOptions)]
oldStyleCheckList = oldStyleCheckList =
("install", Right defaultOptions) ("install", Right defaultGHCOptions)
: ("install --set", Right defaultOptions{instSet = True}) : ("install --set", Right (defaultGHCOptions{instSet = True} :: InstallGHCOptions))
: ("install --force", Right defaultOptions{forceInstall = True}) : ("install --force", Right (defaultGHCOptions{forceInstall = True} :: InstallGHCOptions))
#ifdef IS_WINDOWS #ifdef IS_WINDOWS
: ("install -i C:\\\\", Right defaultOptions{Install.isolateDir = Just "C:\\\\"}) : ("install -i C:\\\\", Right (defaultGHCOptions{Install.isolateDir = Just "C:\\\\"} :: InstallGHCOptions))
#else #else
: ("install -i /", Right defaultOptions{Install.isolateDir = Just "/"}) : ("install -i /", Right (defaultGHCOptions{Install.isolateDir = Just "/"} :: InstallGHCOptions))
#endif #endif
: ("install -u https://gitlab.haskell.org/ghc/ghc/-/jobs/artifacts/master/raw/ghc-x86_64-linux-fedora33-release.tar.xz head" : ("install -u https://gitlab.haskell.org/ghc/ghc/-/jobs/artifacts/master/raw/ghc-x86_64-linux-fedora33-release.tar.xz head"
, Right defaultOptions , Right (defaultGHCOptions
{ instBindist = Just [uri|https://gitlab.haskell.org/ghc/ghc/-/jobs/artifacts/master/raw/ghc-x86_64-linux-fedora33-release.tar.xz|] { instBindist = Just [uri|https://gitlab.haskell.org/ghc/ghc/-/jobs/artifacts/master/raw/ghc-x86_64-linux-fedora33-release.tar.xz|]
, instVer = Just $ GHCVersion $ GHCTargetVersion Nothing $(versionQ "head") , instVer = Just $ GHCVersion $ GHCTargetVersion Nothing $(versionQ "head")
} } :: InstallGHCOptions)
) )
: mapSecond : mapSecond
(Right . mkInstallOptions) (Right . mkInstallOptions)
@ -108,9 +128,9 @@ oldStyleCheckList =
) )
] ]
installGhcCheckList :: [(String, Either InstallCommand InstallOptions)] installGhcCheckList :: [(String, Either InstallCommand InstallGHCOptions)]
installGhcCheckList = installGhcCheckList =
("install ghc", Left $ InstallGHC defaultOptions) ("install ghc", Left $ InstallGHC defaultGHCOptions)
: mapSecond (Left . InstallGHC . mkInstallOptions) : mapSecond (Left . InstallGHC . mkInstallOptions)
[ ("install ghc 9.2", GHCVersion [ ("install ghc 9.2", GHCVersion
$ GHCTargetVersion $ GHCTargetVersion
@ -151,7 +171,7 @@ installGhcCheckList =
installCabalCheckList :: [(String, Either InstallCommand InstallOptions)] installCabalCheckList :: [(String, Either InstallCommand InstallOptions)]
installCabalCheckList = installCabalCheckList =
("install cabal", Left $ InstallCabal defaultOptions{instSet = True}) ("install cabal", Left $ InstallCabal (defaultOptions{instSet = True} :: InstallOptions))
: mapSecond (Left . InstallCabal . mkInstallOptions') : mapSecond (Left . InstallCabal . mkInstallOptions')
[ ("install cabal 3.10", ToolVersion $(versionQ "3.10")) [ ("install cabal 3.10", ToolVersion $(versionQ "3.10"))
, ("install cabal next", ToolVersion $(versionQ "next")) , ("install cabal next", ToolVersion $(versionQ "next"))
@ -197,7 +217,7 @@ installStackCheckList =
, ("install stack stack-2.9", ToolVersion $(versionQ "stack-2.9")) , ("install stack stack-2.9", ToolVersion $(versionQ "stack-2.9"))
] ]
installParseWith :: [String] -> IO (Either InstallCommand InstallOptions) installParseWith :: [String] -> IO (Either InstallCommand InstallGHCOptions)
installParseWith args = do installParseWith args = do
Install a <- parseWith args Install a <- parseWith args
pure a pure a