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

Merge remote-tracking branch 'origin/merge-requests/70'

Browse Source
This commit is contained in:
Julian Ospald 2021-02-25 15:36:37 +01:00
commit 45ab69960f
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
4 changed files with 134 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

129
app/ghcup/Main.hs
View File

@ -192,10 +192,10 @@ data ChangeLogOptions = ChangeLogOptions
-- by default. For example:
--
-- > invertableSwitch "recursive" True (help "do not recurse into directories")
--
-- This example makes --recursive enabled by default, so
--
-- This example makes --recursive enabled by default, so
-- the help is shown only for --no-recursive.
invertableSwitch
invertableSwitch
:: String -- ^ long option
-> Char -- ^ short option for the non-default option
-> Bool -- ^ is switch enabled by default?
@ -363,7 +363,7 @@ com =
( command
"install-cabal"
((info
((InstallCabalLegacy <$> installOpts) <**> helper)
((InstallCabalLegacy <$> installOpts (Just Cabal)) <**> helper)
( progDesc "Install or update cabal"
<> footerDoc (Just $ text installCabalFooter)
)
@ -413,7 +413,7 @@ installParser =
"ghc"
( InstallGHC
<$> (info
(installOpts <**> helper)
(installOpts (Just GHC) <**> helper)
( progDesc "Install GHC"
<> footerDoc (Just $ text installGHCFooter)
)
@ -423,7 +423,7 @@ installParser =
"cabal"
( InstallCabal
<$> (info
(installOpts <**> helper)
(installOpts (Just Cabal) <**> helper)
( progDesc "Install Cabal"
<> footerDoc (Just $ text installCabalFooter)
)
@ -433,7 +433,7 @@ installParser =
"hls"
( InstallHLS
<$> (info
(installOpts <**> helper)
(installOpts (Just HLS) <**> helper)
( progDesc "Install haskell-languge-server"
<> footerDoc (Just $ text installHLSFooter)
)
@ -441,7 +441,7 @@ installParser =
)
)
)
<|> (Right <$> installOpts)
<|> (Right <$> installOpts Nothing)
where
installHLSFooter :: String
installHLSFooter = [s|Discussion:
@ -472,8 +472,8 @@ Examples:
ghcup install ghc -u https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-fedora27-linux.tar.xz?job=validate-x86_64-linux-fedora27 head|]
installOpts :: Parser InstallOptions
installOpts =
installOpts :: Maybe Tool -> Parser InstallOptions
installOpts tool =
(\p (u, v) b -> InstallOptions v p u b)
<$> (optional
(option
@ -495,9 +495,9 @@ installOpts =
)
)
)
<*> (Just <$> toolVersionArgument)
<*> (Just <$> toolVersionArgument True Nothing tool)
)
<|> ((,) <$> pure Nothing <*> optional toolVersionArgument)
<|> (pure (Nothing, Nothing))
)
<*> flag
False
@ -514,7 +514,7 @@ setParser =
"ghc"
( SetGHC
<$> (info
(setOpts <**> helper)
(setOpts (Just GHC) <**> helper)
( progDesc "Set GHC version"
<> footerDoc (Just $ text setGHCFooter)
)
@ -524,7 +524,7 @@ setParser =
"cabal"
( SetCabal
<$> (info
(setOpts <**> helper)
(setOpts (Just Cabal) <**> helper)
( progDesc "Set Cabal version"
<> footerDoc (Just $ text setCabalFooter)
)
@ -534,7 +534,7 @@ setParser =
"hls"
( SetHLS
<$> (info
(setOpts <**> helper)
(setOpts (Just HLS) <**> helper)
( progDesc "Set haskell-language-server version"
<> footerDoc (Just $ text setHLSFooter)
)
@ -542,7 +542,7 @@ setParser =
)
)
)
<|> (Right <$> setOpts)
<|> (Right <$> setOpts Nothing)
where
setGHCFooter :: String
setGHCFooter = [s|Discussion:
@ -559,8 +559,8 @@ setParser =
Sets the the current haskell-language-server version.|]
setOpts :: Parser SetOptions
setOpts = SetOptions <$> optional toolVersionArgument
setOpts :: Maybe Tool -> Parser SetOptions
setOpts tool = SetOptions <$> optional (toolVersionArgument False (Just ListInstalled) tool)
listOpts :: Parser ListOptions
listOpts =
@ -592,29 +592,29 @@ rmParser =
(Left <$> subparser
( command
"ghc"
(RmGHC <$> (info (rmOpts <**> helper) (progDesc "Remove GHC version")))
(RmGHC <$> (info (rmOpts (Just GHC) <**> helper) (progDesc "Remove GHC version")))
<> command
"cabal"
( RmCabal
<$> (info (versionParser' <**> helper)
<$> (info (versionParser' False (Just ListInstalled) (Just Cabal) <**> helper)
(progDesc "Remove Cabal version")
)
)
<> command
"hls"
( RmHLS
<$> (info (versionParser' <**> helper)
<$> (info (versionParser' False (Just ListInstalled) (Just HLS) <**> helper)
(progDesc "Remove haskell-language-server version")
)
)
)
)
<|> (Right <$> rmOpts)
<|> (Right <$> rmOpts Nothing)
rmOpts :: Parser RmOptions
rmOpts = RmOptions <$> versionArgument
rmOpts :: Maybe Tool -> Parser RmOptions
rmOpts tool = RmOptions <$> versionArgument False (Just ListInstalled) tool
changelogP :: Parser ChangeLogOptions
@ -636,7 +636,7 @@ changelogP =
)
)
)
<*> optional toolVersionArgument
<*> optional (toolVersionArgument True Nothing Nothing)
compileP :: Parser CompileCommand
compileP = subparser
@ -765,13 +765,72 @@ toolVersionParser = verP' <|> toolP
)
-- | same as toolVersionParser, except as an argument.
toolVersionArgument :: Parser ToolVersion
toolVersionArgument =
argument (eitherReader toolVersionEither) (metavar "VERSION|TAG")
toolVersionArgument :: Bool -> Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion
toolVersionArgument networkSensitive criteria tool =
argument (eitherReader toolVersionEither) (metavar "VERSION|TAG" <> completer tagCompleter <> foldMap (completer . versionCompleter networkSensitive criteria) tool)
versionArgument :: Parser GHCTargetVersion
versionArgument = argument (eitherReader tVersionEither) (metavar "VERSION")
versionArgument :: Bool -> Maybe ListCriteria -> Maybe Tool -> Parser GHCTargetVersion
versionArgument networkSensitive criteria tool = argument (eitherReader tVersionEither) (metavar "VERSION" <> foldMap (completer . versionCompleter networkSensitive criteria) tool)
tagCompleter :: Completer
tagCompleter =
listCompleter [
"recommended", "latest"
]
versionCompleter :: Bool -> Maybe ListCriteria -> Tool -> Completer
versionCompleter networkSensitive criteria tool =
listIOCompleter $ do
let
loggerConfig =
LoggerConfig
{ lcPrintDebug = False
, colorOutter = mempty
, rawOutter = mempty
}
runLogger =
myLoggerT loggerConfig
downloadWithUserSource = do
userConf <- runE @'[ JSONError ] ghcupConfigFile
getDownloadsF $
veitherCont (const GHCupURL) (fromMaybe GHCupURL . uUrlSource) userConf
mpFreq <-
runLogger . runE $
platformRequest
forFold mpFreq $ \pfreq -> do
dirs <- getDirs
let
simpleSettings =
Settings False False Never Curl False GHCupURL
simpleAppState =
AppState simpleSettings dirs defaultKeyBindings
runEnv =
runLogger . flip runReaderT simpleAppState
mGhcUpInfo <-
runEnv . runE $
if networkSensitive then do
downloadWithUserSource
else
catchE
(\(FileDoesNotExistError _) -> downloadWithUserSource)
readFromCache
forFold mGhcUpInfo $ \(GHCupInfo _ dls) -> do
installedVersions <-
runEnv $
listVersions dls (Just tool) criteria pfreq
return $
T.unpack . prettyVer . lVer <$> installedVersions
versionParser :: Parser GHCTargetVersion
versionParser = option
@ -779,10 +838,10 @@ versionParser = option
(short 'v' <> long "version" <> metavar "VERSION" <> help "The target version"
)
versionParser' :: Parser Version
versionParser' = argument
(eitherReader (bimap show id . version . T.pack))
(metavar "VERSION")
versionParser' :: Bool -> Maybe ListCriteria -> Maybe Tool -> Parser Version
versionParser' networkSensitive criteria tool = argument
(eitherReader (first show . version . T.pack))
(metavar "VERSION" <> foldMap (completer . versionCompleter networkSensitive criteria) tool)
tagEither :: String -> Either String Tag
@ -792,7 +851,7 @@ tagEither s' = case fmap toLower s' of
('b':'a':'s':'e':'-':ver') -> case pvp (T.pack ver') of
Right x -> Right (Base x)
Left _ -> Left [i|Invalid PVP version for base #{ver'}|]
other -> Left ([i|Unknown tag #{other}|])
other -> Left [i|Unknown tag #{other}|]
tVersionEither :: String -> Either String GHCTargetVersion

54
lib/GHCup/Download.hs
View File

@ -137,30 +137,8 @@ getDownloadsF urlSource = do
bsExt <- reThrowAll DownloadFailed $ downloadBS uri
ext <- lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bsExt)
pure (mergeGhcupInfo base ext)
where
readFromCache :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m)
=> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
readFromCache = do
AppState {dirs = Dirs {..}} <- lift ask
lift $ $(logWarn)
[i|Could not get download info, trying cached version (this may not be recent!)|]
let path = view pathL' ghcupURL
yaml_file <- (cacheDir </>) <$> urlBaseName path
bs <-
handleIO' NoSuchThing
(\_ -> throwE $ FileDoesNotExistError (toFilePath yaml_file))
$ liftIO
$ readFile yaml_file
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs)
getBase :: (MonadFail m, MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m)
=> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo
getBase =
handleIO (\_ -> readFromCache)
$ catchE @_ @'[JSONError, FileDoesNotExistError]
(\(DownloadFailed _) -> readFromCache)
$ ((reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed $ smartDl ghcupURL)
>>= (liftE . lE' @_ @_ @'[JSONError] JSONDecodeError . bimap show id . Y.decodeEither' . L.toStrict))
where
mergeGhcupInfo :: GHCupInfo -- ^ base to merge with
-> GHCupInfo -- ^ extension overwriting the base
@ -172,6 +150,32 @@ getDownloadsF urlSource = do
) base
in GHCupInfo tr new
readFromCache :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m)
=> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
readFromCache = do
AppState {dirs = Dirs {..}} <- lift ask
lift $ $(logWarn)
[i|Could not get download info, trying cached version (this may not be recent!)|]
let path = view pathL' ghcupURL
yaml_file <- (cacheDir </>) <$> urlBaseName path
bs <-
handleIO' NoSuchThing
(\_ -> throwE $ FileDoesNotExistError (toFilePath yaml_file))
$ liftIO
$ readFile yaml_file
lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs)
getBase :: (MonadFail m, MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m)
=> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo
getBase =
handleIO (\_ -> readFromCache)
$ catchE @_ @'[JSONError, FileDoesNotExistError]
(\(DownloadFailed _) -> readFromCache)
$ ((reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed $ smartDl ghcupURL)
>>= (liftE . lE' @_ @_ @'[JSONError] JSONDecodeError . bimap show id . Y.decodeEither' . L.toStrict))
where
-- First check if the json file is in the ~/.ghcup/cache dir
-- and check it's access time. If it has been accessed within the
-- last 5 minutes, just reuse it.
@ -209,8 +213,8 @@ getDownloadsF urlSource = do
then do
accessTime <-
PF.accessTimeHiRes
<$> (liftIO $ PF.getFileStatus (toFilePath json_file))
currentTime <- liftIO $ getPOSIXTime
<$> liftIO (PF.getFileStatus (toFilePath json_file))
currentTime <- liftIO getPOSIXTime
-- access time won't work on most linuxes, but we can try regardless
if (currentTime - accessTime) > 300

9
lib/GHCup/Utils.hs
View File

@ -808,3 +808,12 @@ getVersionInfo v' tool dls =
% _head
)
dls
-- Gathering monoidal values
traverseFold :: (Foldable t, Applicative m, Monoid b) => (a -> m b) -> t a -> m b
traverseFold f = foldl (\mb a -> (<>) <$> mb <*> f a) (pure mempty)
-- | Gathering monoidal values
forFold :: (Foldable t, Applicative m, Monoid b) => t a -> (a -> m b) -> m b
forFold = flip traverseFold

4
lib/GHCup/Utils/Dirs.hs
View File

@ -185,9 +185,9 @@ getDirs = do
ghcupConfigFile :: (MonadIO m)
=> Excepts '[JSONError] m UserSettings
ghcupConfigFile = do
confDir <- liftIO $ ghcupConfigDir
confDir <- liftIO ghcupConfigDir
let file = confDir </> [rel|config.yaml|]
bs <- liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ fmap Just $ readFile file
bs <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> readFile file
case bs of
Nothing -> pure defaultUserSettings
Just bs' -> lE' JSONDecodeError . bimap show id . Y.decodeEither' . L.toStrict $ bs'