Merge branch 'issue-892'
This commit is contained in:
commit
5fd0fa8d8e
@ -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 ())
|
||||||
|
@ -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
|
||||||
|
@ -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:
|
||||||
#
|
#
|
||||||
|
@ -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:
|
||||||
|
@ -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
|
||||||
|
@ -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)
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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."
|
||||||
|
|
||||||
|
|
||||||
------------------------
|
------------------------
|
||||||
|
@ -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
|
||||||
|
|
||||||
|
|
||||||
|
@ -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'
|
||||||
|
|
||||||
|
@ -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 #-}
|
||||||
|
|
||||||
|
@ -11,6 +11,7 @@ Portability : portable
|
|||||||
-}
|
-}
|
||||||
module GHCup.Prelude.Process (
|
module GHCup.Prelude.Process (
|
||||||
executeOut,
|
executeOut,
|
||||||
|
executeOut',
|
||||||
execLogged,
|
execLogged,
|
||||||
exec,
|
exec,
|
||||||
toProcessError,
|
toProcessError,
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
|
||||||
|
@ -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)
|
||||||
|
|
||||||
|
@ -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
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.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
|
|
||||||
|
|
||||||
|
|
||||||
-----------
|
-----------
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
Loading…
Reference in New Issue
Block a user