Improve stack metadata support wrt #892
This commit is contained in:
@@ -31,10 +31,10 @@ import GHCup.Download.Utils
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import qualified GHCup.Types.Stack as Stack
|
||||
import GHCup.Types.Stack (downloadInfoUrl, downloadInfoSha256)
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Platform
|
||||
import GHCup.Prelude
|
||||
import GHCup.Prelude.File
|
||||
import GHCup.Prelude.Logger.Internal
|
||||
@@ -56,6 +56,7 @@ import Data.ByteString ( ByteString )
|
||||
import Data.CaseInsensitive ( mk )
|
||||
#endif
|
||||
import Data.Maybe
|
||||
import Data.Either
|
||||
import Data.List
|
||||
import Data.Time.Clock
|
||||
import Data.Time.Clock.POSIX
|
||||
@@ -113,24 +114,71 @@ getDownloadsF :: ( FromJSONKey Tool
|
||||
, MonadFail m
|
||||
, MonadMask m
|
||||
)
|
||||
=> Excepts
|
||||
'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
|
||||
=> PlatformRequest
|
||||
-> Excepts
|
||||
'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError, StackPlatformDetectError]
|
||||
m
|
||||
GHCupInfo
|
||||
getDownloadsF = do
|
||||
getDownloadsF pfreq@(PlatformRequest arch plat _) = do
|
||||
Settings { urlSource } <- lift getSettings
|
||||
case urlSource of
|
||||
GHCupURL -> liftE $ getBase ghcupURL
|
||||
(OwnSource exts) -> do
|
||||
ext <- liftE $ mapM (either pure getBase) exts
|
||||
mergeGhcupInfo ext
|
||||
(OwnSpec av) -> pure av
|
||||
(AddSource exts) -> do
|
||||
base <- liftE $ getBase ghcupURL
|
||||
ext <- liftE $ mapM (either pure getBase) exts
|
||||
mergeGhcupInfo (base:ext)
|
||||
|
||||
let newUrlSources = fromURLSource urlSource
|
||||
infos <- liftE $ mapM dl' newUrlSources
|
||||
keys <- if any isRight infos
|
||||
then liftE . reThrowAll @_ @_ @'[StackPlatformDetectError] StackPlatformDetectError $ getStackPlatformKey pfreq
|
||||
else pure []
|
||||
ghcupInfos <- fmap catMaybes $ forM infos $ \case
|
||||
Left gi -> pure (Just gi)
|
||||
Right si -> pure $ fromStackSetupInfo si keys
|
||||
mergeGhcupInfo ghcupInfos
|
||||
where
|
||||
|
||||
dl' :: ( FromJSONKey Tool
|
||||
, FromJSONKey Version
|
||||
, FromJSON VersionInfo
|
||||
, MonadReader env m
|
||||
, HasSettings env
|
||||
, HasDirs env
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
, HasLog env
|
||||
, MonadThrow m
|
||||
, MonadFail m
|
||||
, MonadMask m
|
||||
)
|
||||
=> NewURLSource
|
||||
-> Excepts
|
||||
'[DownloadFailed, GPGError, DigestError, ContentLengthError, JSONError, FileDoesNotExistError]
|
||||
m (Either GHCupInfo Stack.SetupInfo)
|
||||
dl' NewGHCupURL = fmap Left $ liftE $ getBase @GHCupInfo ghcupURL
|
||||
dl' NewStackSetupURL = fmap Right $ liftE $ getBase @Stack.SetupInfo stackSetupURL
|
||||
dl' (NewGHCupInfo gi) = pure (Left gi)
|
||||
dl' (NewSetupInfo si) = pure (Right si)
|
||||
dl' (NewURI uri) = catchE @JSONError (\(JSONDecodeError _) -> Right <$> getBase @Stack.SetupInfo uri)
|
||||
$ fmap Left $ getBase @GHCupInfo uri
|
||||
|
||||
fromStackSetupInfo :: MonadThrow m
|
||||
=> Stack.SetupInfo
|
||||
-> [String]
|
||||
-> m GHCupInfo
|
||||
fromStackSetupInfo (Stack.siGHCs -> ghcDli) keys = do
|
||||
let ghcVersionsPerKey = (`M.lookup` ghcDli) <$> (T.pack <$> keys)
|
||||
ghcVersions = fromMaybe mempty . listToMaybe . catMaybes $ ghcVersionsPerKey
|
||||
(ghcupInfo' :: M.Map GHCTargetVersion DownloadInfo) <-
|
||||
M.mapKeys mkTVer <$> M.traverseMaybeWithKey (\_ a -> pure $ fromStackDownloadInfo a) ghcVersions
|
||||
let ghcupDownloads' = M.singleton GHC (M.map fromDownloadInfo ghcupInfo')
|
||||
pure (GHCupInfo mempty ghcupDownloads' mempty)
|
||||
where
|
||||
fromDownloadInfo :: DownloadInfo -> VersionInfo
|
||||
fromDownloadInfo dli = let aspec = M.singleton arch (M.singleton plat (M.singleton Nothing dli))
|
||||
in VersionInfo [] Nothing Nothing Nothing Nothing aspec Nothing Nothing Nothing
|
||||
|
||||
fromStackDownloadInfo :: MonadThrow m => Stack.GHCDownloadInfo -> m DownloadInfo
|
||||
fromStackDownloadInfo (Stack.GHCDownloadInfo { gdiDownloadInfo = 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
|
||||
|
||||
|
||||
mergeGhcupInfo :: MonadFail m
|
||||
=> [GHCupInfo]
|
||||
-> m GHCupInfo
|
||||
@@ -142,6 +190,7 @@ getDownloadsF = do
|
||||
in pure $ GHCupInfo newToolReqs newDownloads newGlobalTools
|
||||
|
||||
|
||||
|
||||
yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath
|
||||
yamlFromCache uri = do
|
||||
Dirs{..} <- getDirs
|
||||
@@ -152,7 +201,7 @@ etagsFile :: FilePath -> FilePath
|
||||
etagsFile = (<.> "etags")
|
||||
|
||||
|
||||
getBase :: ( MonadReader env m
|
||||
getBase :: forall j m env . ( MonadReader env m
|
||||
, HasDirs env
|
||||
, HasSettings env
|
||||
, MonadFail m
|
||||
@@ -327,106 +376,6 @@ getDownloadInfo' t v = do
|
||||
_ -> with_distro <|> without_distro_ver <|> without_distro
|
||||
)
|
||||
|
||||
getStackDownloadInfo :: ( MonadReader env m
|
||||
, HasDirs env
|
||||
, HasGHCupInfo env
|
||||
, HasLog env
|
||||
, HasPlatformReq env
|
||||
, HasSettings env
|
||||
, MonadCatch m
|
||||
, MonadFail m
|
||||
, MonadIO m
|
||||
, MonadMask m
|
||||
, MonadThrow m
|
||||
)
|
||||
=> StackSetupURLSource
|
||||
-> [String]
|
||||
-> Tool
|
||||
-> GHCTargetVersion
|
||||
-- ^ tool version
|
||||
-> Excepts
|
||||
'[NoDownload, DownloadFailed]
|
||||
m
|
||||
DownloadInfo
|
||||
getStackDownloadInfo stackSetupSource keys@(_:_) GHC tv@(GHCTargetVersion Nothing v) =
|
||||
case stackSetupSource of
|
||||
StackSetupURL -> do
|
||||
(dli :: Stack.SetupInfo) <- liftE $ reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getBase stackSetupURL
|
||||
sDli <- liftE $ stackDownloadInfo dli
|
||||
lift $ fromStackDownloadInfo sDli
|
||||
(SOwnSource exts) -> do
|
||||
(dlis :: [Stack.SetupInfo]) <- liftE $ reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ mapM (either pure getBase) exts
|
||||
dli <- lift $ mergeSetupInfo dlis
|
||||
sDli <- liftE $ stackDownloadInfo dli
|
||||
lift $ fromStackDownloadInfo sDli
|
||||
(SOwnSpec si) -> do
|
||||
sDli <- liftE $ stackDownloadInfo si
|
||||
lift $ fromStackDownloadInfo sDli
|
||||
(SAddSource exts) -> do
|
||||
base :: Stack.SetupInfo <- liftE $ reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getBase stackSetupURL
|
||||
(dlis :: [Stack.SetupInfo]) <- liftE $ reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ mapM (either pure getBase) exts
|
||||
dli <- lift $ mergeSetupInfo (base:dlis)
|
||||
sDli <- liftE $ stackDownloadInfo dli
|
||||
lift $ fromStackDownloadInfo sDli
|
||||
|
||||
where
|
||||
stackDownloadInfo :: MonadIO m => Stack.SetupInfo -> Excepts '[NoDownload] m Stack.DownloadInfo
|
||||
stackDownloadInfo dli@Stack.SetupInfo{} = do
|
||||
let siGHCs = Stack.siGHCs dli
|
||||
ghcVersionsPerKey = (`M.lookup` siGHCs) <$> (T.pack <$> keys)
|
||||
ghcVersions <- (listToMaybe . catMaybes $ ghcVersionsPerKey) ?? NoDownload tv GHC Nothing
|
||||
(Stack.gdiDownloadInfo <$> M.lookup v ghcVersions) ?? NoDownload tv GHC Nothing
|
||||
|
||||
mergeSetupInfo :: MonadFail m
|
||||
=> [Stack.SetupInfo]
|
||||
-> m Stack.SetupInfo
|
||||
mergeSetupInfo [] = fail "mergeSetupInfo: internal error: need at least one SetupInfo"
|
||||
mergeSetupInfo xs@(Stack.SetupInfo{}: _) =
|
||||
let newSevenzExe = Stack.siSevenzExe $ last xs
|
||||
newSevenzDll = Stack.siSevenzDll $ last xs
|
||||
newMsys2 = M.unionsWith (\_ a2 -> a2 ) (Stack.siMsys2 <$> xs)
|
||||
newGHCs = M.unionsWith (M.unionWith (\_ b2 -> b2)) (Stack.siGHCs <$> xs)
|
||||
newStack = M.unionsWith (M.unionWith (\_ b2 -> b2)) (Stack.siStack <$> xs)
|
||||
in pure $ Stack.SetupInfo newSevenzExe newSevenzDll newMsys2 newGHCs newStack
|
||||
|
||||
fromStackDownloadInfo :: MonadThrow m => Stack.DownloadInfo -> m DownloadInfo
|
||||
fromStackDownloadInfo Stack.DownloadInfo{..} = do
|
||||
url <- either (\e -> throwM $ ParseError (show e)) pure $ parseURI strictURIParserOptions . E.encodeUtf8 $ downloadInfoUrl
|
||||
sha256 <- maybe (throwM $ DigestMissing url) (pure . E.decodeUtf8) downloadInfoSha256
|
||||
pure $ DownloadInfo url (Just $ RegexDir "ghc-.*") sha256 Nothing Nothing
|
||||
getStackDownloadInfo _ _ t v = throwE $ NoDownload v t Nothing
|
||||
|
||||
{--
|
||||
data SetupInfo = SetupInfo
|
||||
{ siSevenzExe :: Maybe DownloadInfo
|
||||
, siSevenzDll :: Maybe DownloadInfo
|
||||
, siMsys2 :: Map Text VersionedDownloadInfo
|
||||
, siGHCs :: Map Text (Map Version GHCDownloadInfo)
|
||||
, siStack :: Map Text (Map Version DownloadInfo)
|
||||
|
||||
data VersionedDownloadInfo = VersionedDownloadInfo
|
||||
{ vdiVersion :: Version
|
||||
, vdiDownloadInfo :: DownloadInfo
|
||||
}
|
||||
}
|
||||
|
||||
data DownloadInfo = DownloadInfo
|
||||
{ downloadInfoUrl :: Text
|
||||
-- ^ URL or absolute file path
|
||||
, downloadInfoContentLength :: Maybe Int
|
||||
, downloadInfoSha1 :: Maybe ByteString
|
||||
, downloadInfoSha256 :: Maybe ByteString
|
||||
}
|
||||
|
||||
data GHCDownloadInfo = GHCDownloadInfo
|
||||
{ gdiConfigureOpts :: [Text]
|
||||
, gdiConfigureEnv :: Map Text Text
|
||||
, gdiDownloadInfo :: DownloadInfo
|
||||
}
|
||||
|
||||
|
||||
--}
|
||||
|
||||
|
||||
|
||||
-- | Tries to download from the given http or https url
|
||||
|
||||
@@ -676,18 +676,18 @@ instance HFErrorProject ContentLengthError where
|
||||
eBase _ = 340
|
||||
eDesc _ = "File content length verification failed"
|
||||
|
||||
data DuplicateReleaseChannel = DuplicateReleaseChannel URI
|
||||
data DuplicateReleaseChannel = DuplicateReleaseChannel NewURLSource
|
||||
deriving Show
|
||||
|
||||
instance HFErrorProject DuplicateReleaseChannel where
|
||||
eBase _ = 350
|
||||
eDesc _ = "Duplicate release channel detected when adding URI.\nGiving up. You can use '--force' to remove and append the duplicate URI (this may change order/semantics)."
|
||||
eDesc _ = "Duplicate release channel detected when adding new source.\nGiving up. You can use '--force' to remove and append the duplicate source (this may change order/semantics)."
|
||||
|
||||
instance Pretty DuplicateReleaseChannel where
|
||||
pPrint (DuplicateReleaseChannel uri) =
|
||||
pPrint (DuplicateReleaseChannel source) =
|
||||
text $ "Duplicate release channel detected when adding: \n "
|
||||
<> (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)."
|
||||
<> show source
|
||||
<> "\nGiving up. You can use '--force' to remove and append the duplicate source (this may change order/semantics)."
|
||||
|
||||
data UnsupportedSetupCombo = UnsupportedSetupCombo Architecture Platform
|
||||
deriving Show
|
||||
@@ -787,6 +787,22 @@ instance HFErrorProject GHCupSetError where
|
||||
eNum (GHCupSetError xs) = 9000 + eNum xs
|
||||
eDesc _ = "Setting the current version failed."
|
||||
|
||||
-- | Executing stacks platform detection failed.
|
||||
data StackPlatformDetectError = forall es . (ToVariantMaybe StackPlatformDetectError es, PopVariant StackPlatformDetectError es, Show (V es), Pretty (V es), HFErrorProject (V es)) => StackPlatformDetectError (V es)
|
||||
|
||||
instance Pretty StackPlatformDetectError where
|
||||
pPrint (StackPlatformDetectError reason) =
|
||||
case reason of
|
||||
VMaybe (_ :: StackPlatformDetectError) -> pPrint reason
|
||||
_ -> text "Running stack platform detection logic failed:" <+> pPrint reason
|
||||
|
||||
deriving instance Show StackPlatformDetectError
|
||||
|
||||
instance HFErrorProject StackPlatformDetectError where
|
||||
eBase _ = 6000
|
||||
eNum (StackPlatformDetectError xs) = 6000 + eNum xs
|
||||
eDesc _ = "Running stack platform detection logic failed."
|
||||
|
||||
|
||||
---------------------------------------------
|
||||
--[ True Exceptions (e.g. for MonadThrow) ]--
|
||||
|
||||
@@ -26,7 +26,6 @@ import GHCup.Types
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils
|
||||
import GHCup.Platform
|
||||
import GHCup.Prelude
|
||||
import GHCup.Prelude.File
|
||||
import GHCup.Prelude.Logger
|
||||
@@ -547,14 +546,7 @@ installGHCBin :: ( MonadFail m
|
||||
m
|
||||
()
|
||||
installGHCBin tver installDir forceInstall addConfArgs = do
|
||||
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
|
||||
dlinfo <- liftE $ getDownloadInfo' GHC tver
|
||||
liftE $ installGHCBindist dlinfo tver installDir forceInstall addConfArgs
|
||||
|
||||
|
||||
|
||||
@@ -23,7 +23,7 @@ import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Types.JSON ( )
|
||||
import GHCup.Utils
|
||||
import GHCup.Utils.Dirs
|
||||
import GHCup.Prelude
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.Process
|
||||
@@ -348,7 +348,7 @@ getStackOSKey PlatformRequest { .. } =
|
||||
(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)
|
||||
getStackPlatformKey :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)
|
||||
=> PlatformRequest
|
||||
-> Excepts '[UnsupportedSetupCombo, ParseError, NoCompatiblePlatform, NoCompatibleArch, DistroNotFound, ProcessError] m [String]
|
||||
getStackPlatformKey pfreq@PlatformRequest{..} = do
|
||||
|
||||
@@ -43,6 +43,10 @@ import Control.Monad.Reader
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Text.PrettyPrint.HughesPJClass ( Pretty )
|
||||
import qualified Data.Text as T
|
||||
import System.Environment (getEnvironment)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import System.FilePath
|
||||
import Data.List (intercalate)
|
||||
|
||||
|
||||
|
||||
@@ -88,3 +92,25 @@ throwSomeE :: forall es' es a m. (Monad m, LiftVariant es' es) => V es' -> Excep
|
||||
{-# INLINABLE throwSomeE #-}
|
||||
throwSomeE = Excepts . pure . VLeft . liftVariant
|
||||
#endif
|
||||
|
||||
addToPath :: [FilePath]
|
||||
-> Bool -- ^ if False will prepend
|
||||
-> IO [(String, String)]
|
||||
addToPath paths append = do
|
||||
cEnv <- getEnvironment
|
||||
return $ addToPath' cEnv paths append
|
||||
|
||||
addToPath' :: [(String, String)]
|
||||
-> [FilePath]
|
||||
-> Bool -- ^ if False will prepend
|
||||
-> [(String, String)]
|
||||
addToPath' cEnv' newPaths append =
|
||||
let cEnv = Map.fromList cEnv'
|
||||
paths = ["PATH", "Path"]
|
||||
curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
|
||||
{- HLINT ignore "Redundant bracket" -}
|
||||
newPath = intercalate [searchPathSeparator] (if append then (curPaths ++ newPaths) else (newPaths ++ curPaths))
|
||||
envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths
|
||||
pathVar = if isWindows then "Path" else "PATH"
|
||||
envWithNewPath = Map.toList $ Map.insert pathVar newPath envWithoutPath
|
||||
in envWithNewPath
|
||||
|
||||
@@ -201,7 +201,7 @@ instance Pretty Tag where
|
||||
pPrint (Base pvp'') = text ("base-" ++ T.unpack (prettyPVP pvp''))
|
||||
pPrint (UnknownTag t ) = text t
|
||||
pPrint LatestPrerelease = text "latest-prerelease"
|
||||
pPrint LatestNightly = text "latest-prerelease"
|
||||
pPrint LatestNightly = text "latest-prerelease"
|
||||
pPrint Old = mempty
|
||||
|
||||
data Architecture = A_64
|
||||
@@ -342,18 +342,35 @@ instance Pretty TarDir where
|
||||
|
||||
-- | Where to fetch GHCupDownloads from.
|
||||
data URLSource = GHCupURL
|
||||
| OwnSource [Either GHCupInfo URI] -- ^ complete source list
|
||||
| OwnSpec GHCupInfo
|
||||
| AddSource [Either GHCupInfo URI] -- ^ merge with GHCupURL
|
||||
deriving (GHC.Generic, Show)
|
||||
| StackSetupURL
|
||||
| OwnSource [Either (Either GHCupInfo SetupInfo) URI] -- ^ complete source list
|
||||
| OwnSpec (Either GHCupInfo SetupInfo)
|
||||
| AddSource [Either (Either GHCupInfo SetupInfo) URI] -- ^ merge with GHCupURL
|
||||
| SimpleList [NewURLSource]
|
||||
deriving (Eq, 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)
|
||||
data NewURLSource = NewGHCupURL
|
||||
| NewStackSetupURL
|
||||
| NewGHCupInfo GHCupInfo
|
||||
| NewSetupInfo SetupInfo
|
||||
| NewURI URI
|
||||
deriving (Eq, GHC.Generic, Show)
|
||||
|
||||
instance NFData StackSetupURLSource
|
||||
instance NFData NewURLSource
|
||||
|
||||
fromURLSource :: URLSource -> [NewURLSource]
|
||||
fromURLSource GHCupURL = [NewGHCupURL]
|
||||
fromURLSource StackSetupURL = [NewStackSetupURL]
|
||||
fromURLSource (OwnSource arr) = convert' <$> arr
|
||||
fromURLSource (AddSource arr) = NewGHCupURL:(convert' <$> arr)
|
||||
fromURLSource (SimpleList arr) = arr
|
||||
fromURLSource (OwnSpec (Left gi)) = [NewGHCupInfo gi]
|
||||
fromURLSource (OwnSpec (Right si)) = [NewSetupInfo si]
|
||||
|
||||
convert' :: Either (Either GHCupInfo SetupInfo) URI -> NewURLSource
|
||||
convert' (Left (Left gi)) = NewGHCupInfo gi
|
||||
convert' (Left (Right si)) = NewSetupInfo si
|
||||
convert' (Right uri) = NewURI uri
|
||||
|
||||
instance NFData URLSource
|
||||
instance NFData (URIRef Absolute) where
|
||||
@@ -380,13 +397,11 @@ data UserSettings = UserSettings
|
||||
, uGPGSetting :: Maybe GPGSetting
|
||||
, uPlatformOverride :: Maybe PlatformRequest
|
||||
, uMirrors :: Maybe DownloadMirrors
|
||||
, uStackSetupSource :: Maybe StackSetupURLSource
|
||||
, uStackSetup :: Maybe Bool
|
||||
}
|
||||
deriving (Show, GHC.Generic)
|
||||
|
||||
defaultUserSettings :: UserSettings
|
||||
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
|
||||
fromSettings :: Settings -> Maybe KeyBindings -> UserSettings
|
||||
fromSettings Settings{..} Nothing =
|
||||
@@ -404,8 +419,6 @@ fromSettings Settings{..} Nothing =
|
||||
, uGPGSetting = Just gpgSetting
|
||||
, uPlatformOverride = platformOverride
|
||||
, uMirrors = Just mirrors
|
||||
, uStackSetupSource = Just stackSetupSource
|
||||
, uStackSetup = Just stackSetup
|
||||
}
|
||||
fromSettings Settings{..} (Just KeyBindings{..}) =
|
||||
let ukb = UserKeyBindings
|
||||
@@ -433,8 +446,6 @@ fromSettings Settings{..} (Just KeyBindings{..}) =
|
||||
, uGPGSetting = Just gpgSetting
|
||||
, uPlatformOverride = platformOverride
|
||||
, uMirrors = Just mirrors
|
||||
, uStackSetupSource = Just stackSetupSource
|
||||
, uStackSetup = Just stackSetup
|
||||
}
|
||||
|
||||
data UserKeyBindings = UserKeyBindings
|
||||
@@ -523,8 +534,6 @@ data Settings = Settings
|
||||
, noColor :: Bool -- this also exists in LoggerConfig
|
||||
, platformOverride :: Maybe PlatformRequest
|
||||
, mirrors :: DownloadMirrors
|
||||
, stackSetupSource :: StackSetupURLSource
|
||||
, stackSetup :: Bool
|
||||
}
|
||||
deriving (Show, GHC.Generic)
|
||||
|
||||
@@ -532,7 +541,7 @@ defaultMetaCache :: Integer
|
||||
defaultMetaCache = 300 -- 5 minutes
|
||||
|
||||
defaultSettings :: Settings
|
||||
defaultSettings = Settings False defaultMetaCache Lax False Never Curl False GHCupURL False GPGNone False Nothing (DM mempty) StackSetupURL False
|
||||
defaultSettings = Settings False defaultMetaCache Lax False Never Curl False GHCupURL False GPGNone False Nothing (DM mempty)
|
||||
|
||||
instance NFData Settings
|
||||
|
||||
|
||||
@@ -22,6 +22,7 @@ Portability : portable
|
||||
module GHCup.Types.JSON where
|
||||
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Stack (SetupInfo)
|
||||
import GHCup.Types.JSON.Utils
|
||||
import GHCup.Types.JSON.Versions ()
|
||||
import GHCup.Prelude.MegaParsec
|
||||
@@ -32,7 +33,9 @@ import Data.Aeson.TH
|
||||
import Data.Aeson.Types hiding (Key)
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.List.NonEmpty ( NonEmpty(..) )
|
||||
import Data.Maybe
|
||||
import Data.Text.Encoding as E
|
||||
import Data.Foldable
|
||||
import Data.Versions
|
||||
import Data.Void
|
||||
import URI.ByteString
|
||||
@@ -278,13 +281,29 @@ instance FromJSONKey (Maybe VersionRange) where
|
||||
Left e -> fail $ "Failure in (Maybe VersionRange) (FromJSONKey)" <> MP.errorBundlePretty e
|
||||
|
||||
|
||||
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requirements
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
|
||||
deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
|
||||
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, constructorTagModifier = \str' -> if str' == "StackSetupURL" then str' else maybe str' T.unpack . T.stripPrefix (T.pack "S") . T.pack $ str' } ''StackSetupURLSource
|
||||
|
||||
instance FromJSON GHCupInfo where
|
||||
parseJSON = withObject "GHCupInfo" $ \o -> do
|
||||
toolRequirements' <- o .:? "toolRequirements"
|
||||
globalTools' <- o .:? "globalTools"
|
||||
ghcupDownloads' <- o .: "ghcupDownloads"
|
||||
pure (GHCupInfo (fromMaybe mempty toolRequirements') ghcupDownloads' (fromMaybe mempty globalTools'))
|
||||
|
||||
deriveToJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
|
||||
|
||||
instance ToJSON NewURLSource where
|
||||
toJSON NewGHCupURL = String "GHCupURL"
|
||||
toJSON NewStackSetupURL = String "StackSetupURL"
|
||||
toJSON (NewGHCupInfo gi) = object [ "ghcup-info" .= gi ]
|
||||
toJSON (NewSetupInfo si) = object [ "setup-info" .= si ]
|
||||
toJSON (NewURI uri) = toJSON uri
|
||||
|
||||
instance ToJSON URLSource where
|
||||
toJSON = toJSON . fromURLSource
|
||||
|
||||
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key
|
||||
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Modifier
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel, unwrapUnaryRecords = True } ''Port
|
||||
@@ -297,13 +316,29 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downlo
|
||||
instance FromJSON URLSource where
|
||||
parseJSON v =
|
||||
parseGHCupURL v
|
||||
<|> parseStackURL v
|
||||
<|> parseOwnSourceLegacy v
|
||||
<|> parseOwnSourceNew1 v
|
||||
<|> parseOwnSourceNew2 v
|
||||
<|> parseOwnSpec v
|
||||
<|> legacyParseAddSource v
|
||||
<|> newParseAddSource v
|
||||
-- new since Stack SetupInfo
|
||||
<|> parseOwnSpecNew v
|
||||
<|> parseOwnSourceNew3 v
|
||||
<|> newParseAddSource2 v
|
||||
-- more lenient versions
|
||||
<|> parseOwnSpecLenient v
|
||||
<|> parseOwnSourceLenient v
|
||||
<|> parseAddSourceLenient v
|
||||
-- simplified list
|
||||
<|> parseNewUrlSource v
|
||||
<|> parseNewUrlSource' v
|
||||
where
|
||||
convert'' :: Either GHCupInfo URI -> Either (Either GHCupInfo SetupInfo) URI
|
||||
convert'' (Left gi) = Left (Left gi)
|
||||
convert'' (Right uri) = Right uri
|
||||
|
||||
parseOwnSourceLegacy = withObject "URLSource" $ \o -> do
|
||||
r :: URI <- o .: "OwnSource"
|
||||
pure (OwnSource [Right r])
|
||||
@@ -312,20 +347,85 @@ instance FromJSON URLSource where
|
||||
pure (OwnSource (fmap Right r))
|
||||
parseOwnSourceNew2 = withObject "URLSource" $ \o -> do
|
||||
r :: [Either GHCupInfo URI] <- o .: "OwnSource"
|
||||
pure (OwnSource r)
|
||||
pure (OwnSource (convert'' <$> r))
|
||||
parseOwnSpec = withObject "URLSource" $ \o -> do
|
||||
r :: GHCupInfo <- o .: "OwnSpec"
|
||||
pure (OwnSpec r)
|
||||
pure (OwnSpec $ Left r)
|
||||
parseGHCupURL = withObject "URLSource" $ \o -> do
|
||||
_ :: [Value] <- o .: "GHCupURL"
|
||||
pure GHCupURL
|
||||
parseStackURL = withObject "URLSource" $ \o -> do
|
||||
_ :: [Value] <- o .: "StackSetupURL"
|
||||
pure StackSetupURL
|
||||
legacyParseAddSource = withObject "URLSource" $ \o -> do
|
||||
r :: Either GHCupInfo URI <- o .: "AddSource"
|
||||
pure (AddSource [r])
|
||||
pure (AddSource [convert'' r])
|
||||
newParseAddSource = withObject "URLSource" $ \o -> do
|
||||
r :: [Either GHCupInfo URI] <- o .: "AddSource"
|
||||
pure (AddSource (convert'' <$> r))
|
||||
|
||||
-- new since Stack SetupInfo
|
||||
parseOwnSpecNew = withObject "URLSource" $ \o -> do
|
||||
r :: Either GHCupInfo SetupInfo <- o .: "OwnSpec"
|
||||
pure (OwnSpec r)
|
||||
parseOwnSourceNew3 = withObject "URLSource" $ \o -> do
|
||||
r :: [Either (Either GHCupInfo SetupInfo) URI] <- o .: "OwnSource"
|
||||
pure (OwnSource r)
|
||||
newParseAddSource2 = withObject "URLSource" $ \o -> do
|
||||
r :: [Either (Either GHCupInfo SetupInfo) URI] <- o .: "AddSource"
|
||||
pure (AddSource r)
|
||||
|
||||
-- more lenient versions
|
||||
parseOwnSpecLenient = withObject "URLSource" $ \o -> do
|
||||
spec :: Object <- o .: "OwnSpec"
|
||||
OwnSpec <$> lenientInfoParser spec
|
||||
parseOwnSourceLenient = withObject "URLSource" $ \o -> do
|
||||
mown :: Array <- o .: "OwnSource"
|
||||
OwnSource . toList <$> mapM lenientInfoUriParser mown
|
||||
parseAddSourceLenient = withObject "URLSource" $ \o -> do
|
||||
madd :: Array <- o .: "AddSource"
|
||||
AddSource . toList <$> mapM lenientInfoUriParser madd
|
||||
|
||||
-- simplified
|
||||
parseNewUrlSource = withArray "URLSource" $ \a -> do
|
||||
SimpleList . toList <$> mapM parseJSON a
|
||||
parseNewUrlSource' v' = SimpleList .(:[]) <$> parseJSON v'
|
||||
|
||||
|
||||
lenientInfoUriParser :: Value -> Parser (Either (Either GHCupInfo SetupInfo) URI)
|
||||
lenientInfoUriParser (Object o) = Left <$> lenientInfoParser o
|
||||
lenientInfoUriParser v@(String _) = Right <$> parseJSON v
|
||||
lenientInfoUriParser _ = fail "Unexpected json in lenientInfoUriParser"
|
||||
|
||||
|
||||
lenientInfoParser :: Object -> Parser (Either GHCupInfo SetupInfo)
|
||||
lenientInfoParser o = do
|
||||
setup_info :: Maybe Object <- o .:? "setup-info"
|
||||
case setup_info of
|
||||
Nothing -> do
|
||||
r <- parseJSON (Object o)
|
||||
pure $ Left r
|
||||
Just setup_info' -> do
|
||||
r <- parseJSON (Object setup_info')
|
||||
pure $ Right r
|
||||
|
||||
instance FromJSON NewURLSource where
|
||||
parseJSON v = uri v <|> url v <|> gi v <|> si v
|
||||
where
|
||||
uri = withText "NewURLSource" $ \t -> NewURI <$> parseJSON (String t)
|
||||
url = withText "NewURLSource" $ \t -> case T.unpack t of
|
||||
"GHCupURL" -> pure NewGHCupURL
|
||||
"StackSetupURL" -> pure NewStackSetupURL
|
||||
t' -> fail $ "Unexpected text value in NewURLSource: " <> t'
|
||||
gi = withObject "NewURLSource" $ \o -> do
|
||||
ginfo :: GHCupInfo <- o .: "ghcup-info"
|
||||
pure $ NewGHCupInfo ginfo
|
||||
|
||||
si = withObject "NewURLSource" $ \o -> do
|
||||
sinfo :: SetupInfo <- o .: "setup-info"
|
||||
pure $ NewSetupInfo sinfo
|
||||
|
||||
|
||||
instance FromJSON KeyCombination where
|
||||
parseJSON v = proper v <|> simple v
|
||||
where
|
||||
|
||||
@@ -89,9 +89,9 @@ import qualified Data.Text.Encoding as E
|
||||
import qualified Text.Megaparsec as MP
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Streamly.Prelude as S
|
||||
|
||||
import Control.DeepSeq (force)
|
||||
import GHC.IO (evaluate)
|
||||
import System.Environment (getEnvironment)
|
||||
import Data.Time (Day(..), diffDays, addDays)
|
||||
|
||||
|
||||
@@ -1320,29 +1320,6 @@ warnAboutHlsCompatibility = do
|
||||
|
||||
|
||||
|
||||
addToPath :: [FilePath]
|
||||
-> Bool -- ^ if False will prepend
|
||||
-> IO [(String, String)]
|
||||
addToPath paths append = do
|
||||
cEnv <- getEnvironment
|
||||
return $ addToPath' cEnv paths append
|
||||
|
||||
addToPath' :: [(String, String)]
|
||||
-> [FilePath]
|
||||
-> Bool -- ^ if False will prepend
|
||||
-> [(String, String)]
|
||||
addToPath' cEnv' newPaths append =
|
||||
let cEnv = Map.fromList cEnv'
|
||||
paths = ["PATH", "Path"]
|
||||
curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
|
||||
{- HLINT ignore "Redundant bracket" -}
|
||||
newPath = intercalate [searchPathSeparator] (if append then (curPaths ++ newPaths) else (newPaths ++ curPaths))
|
||||
envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths
|
||||
pathVar = if isWindows then "Path" else "PATH"
|
||||
envWithNewPath = Map.toList $ Map.insert pathVar newPath envWithoutPath
|
||||
in envWithNewPath
|
||||
|
||||
|
||||
-----------
|
||||
--[ Git ]--
|
||||
-----------
|
||||
|
||||
Reference in New Issue
Block a user