ghcup-0.2.1.0: lib-opt/GHCup/OptParse/Common.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module GHCup.OptParse.Common where
import GHCup.CabalConfig
import GHCup.Command.List
import GHCup.Download
import GHCup.Hardcoded.Version
import GHCup.Input.Parsers
import GHCup.Prelude
import GHCup.Prelude.Process
import GHCup.Query.GHCupDirs
import GHCup.Query.Metadata
import GHCup.Query.System
import GHCup.System.Directory
import GHCup.Types
import GHCup.Types.Optics
import qualified GHCup.Input.Parsers as Parsers
import Control.Concurrent
import Control.Concurrent.Async
import Control.DeepSeq
import Control.Exception ( evaluate )
import Control.Exception.Safe
import Control.Monad ( forM, join )
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Data.Aeson
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.Key as KM
import qualified Data.Aeson.KeyMap as KM
#else
import qualified Data.HashMap.Strict as KM
#endif
import Data.Bifunctor
import Data.ByteString.Lazy ( ByteString )
import Data.Char
import Data.Either
import Data.Functor
import Data.List ( isPrefixOf, nub, stripPrefix )
import Data.Maybe
import Data.Variant.Excepts
import qualified Data.Vector as V
import Data.Versions
import GHC.IO.Exception
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import Safe ( lastMay )
import System.FilePath
import System.Process ( readProcess )
import Text.HTML.TagSoup hiding ( Tag )
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified System.FilePath.Posix as FP
--------------
--[ Parser ]--
--------------
parseUrlSourceP :: Parser [NewURLSource]
parseUrlSourceP =
option
(eitherReader parseUrlSource)
( short 's'
<> long "url-source"
<> metavar "<URL_SOURCE|cross|prereleases|vanilla|default>"
<> help "Alternative ghcup download info"
<> completer urlSourceCompleter
)
toolVersionTagArgument :: [ListCriteria] -> Maybe Tool -> Parser ToolVersion
toolVersionTagArgument criteria tool =
argument (eitherReader (parser tool))
(metavar (mv tool)
<> completer (tagCompleter (fromMaybe ghc tool) [])
<> foldMap (completer . versionCompleter criteria) tool)
where
mv (Just (Tool "ghc")) = "GHC_VERSION|TAG|RELEASE_DATE"
mv (Just (Tool "hls")) = "HLS_VERSION|TAG|RELEASE_DATE"
mv _ = "VERSION|TAG|RELEASE_DATE"
parser (Just (Tool "ghc")) = Parsers.ghcVersionTagEither
parser Nothing = Parsers.ghcVersionTagEither
parser _ = Parsers.toolVersionTagEither
versionParser' :: [ListCriteria] -> Maybe Tool -> Parser Version
versionParser' criteria tool = argument
(eitherReader (first show . version . T.pack))
(metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool)
ghcVersionArgument :: [ListCriteria] -> Maybe Tool -> Parser TargetVersion
ghcVersionArgument criteria tool = argument (eitherReader Parsers.ghcVersionEither)
(metavar "VERSION" <> help "Which version to install" <> foldMap (completer . versionCompleter criteria) tool)
-- https://github.com/pcapriotti/optparse-applicative/issues/148
-- | A switch that can be enabled using --foo and disabled using --no-foo.
--
-- The option modifier is applied to only the option that is *not* enabled
-- by default. For example:
--
-- > invertableSwitch "recursive" True (help "do not recurse into directories")
--
-- This example makes --recursive enabled by default, so
-- the help is shown only for --no-recursive.
invertableSwitch
:: String -- ^ long option
-> Maybe Char -- ^ short option for the non-default option
-> Bool -- ^ is switch enabled by default?
-> Mod FlagFields Bool -- ^ option modifier
-> Parser (Maybe Bool)
invertableSwitch longopt shortopt defv optmod = invertableSwitch' longopt shortopt defv
(if defv then mempty else optmod)
(if defv then optmod else mempty)
-- | Allows providing option modifiers for both --foo and --no-foo.
invertableSwitch'
:: String -- ^ long option (eg "foo")
-> Maybe Char -- ^ short option for the non-default option
-> Bool -- ^ is switch enabled by default?
-> Mod FlagFields Bool -- ^ option modifier for --foo
-> Mod FlagFields Bool -- ^ option modifier for --no-foo
-> Parser (Maybe Bool)
invertableSwitch' longopt shortopt defv enmod dismod = optional
( flag' True ( enmod <> long longopt <> if defv then mempty else maybe mempty short shortopt)
<|> flag' False (dismod <> long nolongopt <> if defv then maybe mempty short shortopt else mempty)
)
where
nolongopt = "no-" ++ longopt
------------------
--[ Completers ]--
------------------
revisionCompleter :: Completer
revisionCompleter = listCompleter ["updates", "all", "none"]
toolCompleter :: Completer
toolCompleter = listCompleter ["ghc", "cabal", "hls", "stack"]
gitFileUri :: [String] -> Completer
gitFileUri add = mkCompleter $ fileUri' (["git://"] <> add)
urlSourceCompleter :: Completer
urlSourceCompleter = mkCompleter $ urlSourceCompleter' []
urlSourceCompleter' :: [String] -> String -> IO [String]
urlSourceCompleter' add str' = do
let static = ["GHCupURL", "StackSetupURL", "cross", "prereleases", "vanilla"]
file <- fileUri' add str'
pure $ static ++ file
fileUri :: Completer
fileUri = mkCompleter $ fileUri' []
fileUri' :: [String] -> String -> IO [String]
fileUri' add = \case
"" -> do
pwd <- getCurrentDirectory
pure $ ["https://", "http://", "file:///", "file://" <> pwd <> "/"] <> add
xs
| "file:///" `isPrefixOf` xs -> fmap ("file://" <>) <$>
case stripPrefix "file://" xs of
Nothing -> pure []
Just r -> do
pwd <- getCurrentDirectory
dirs <- compgen "directory" r ["-S", "/"]
files <- filter (\f -> (f <> "/") `notElem` dirs) <$> compgen "file" r []
pure (dirs <> files <> if r `isPrefixOf` pwd then [pwd <> "/"] else [])
| xs `isPrefixOf` "file:///" -> pure ["file:///"]
| xs `isPrefixOf` "https://" -> pure ["https://"]
| xs `isPrefixOf` "http://" -> pure ["http://"]
| otherwise -> pure []
where
compgen :: String -> String -> [String] -> IO [String]
compgen action' r opts = do
let cmd = unwords $ ["compgen", "-A", action'] <> opts <> ["--", requote r]
result <- tryIO $ readProcess "bash" ["-c", cmd] ""
return . lines . fromRight [] $ result
-- | Strongly quote the string we pass to compgen.
--
-- We need to do this so bash doesn't expand out any ~ or other
-- chars we want to complete on, or emit an end of line error
-- when seeking the close to the quote.
--
-- NOTE: copied from https://hackage.haskell.org/package/optparse-applicative-0.17.0.0/docs/src/Options.Applicative.Builder.Completer.html#requote
requote :: String -> String
requote s =
let
-- Bash doesn't appear to allow "mixed" escaping
-- in bash completions. So we don't have to really
-- worry about people swapping between strong and
-- weak quotes.
unescaped =
case s of
-- It's already strongly quoted, so we
-- can use it mostly as is, but we must
-- ensure it's closed off at the end and
-- there's no single quotes in the
-- middle which might confuse bash.
('\'': rs) -> unescapeN rs
-- We're weakly quoted.
('"': rs) -> unescapeD rs
-- We're not quoted at all.
-- We need to unescape some characters like
-- spaces and quotation marks.
elsewise -> unescapeU elsewise
in
strong unescaped
where
strong ss = '\'' : foldr go "'" ss
where
-- If there's a single quote inside the
-- command: exit from the strong quote and
-- emit it the quote escaped, then resume.
go '\'' t = "'\\''" ++ t
go h t = h : t
-- Unescape a strongly quoted string
-- We have two recursive functions, as we
-- can enter and exit the strong escaping.
unescapeN = goX
where
goX ('\'' : xs) = goN xs
goX (x : xs) = x : goX xs
goX [] = []
goN ('\\' : '\'' : xs) = '\'' : goN xs
goN ('\'' : xs) = goX xs
goN (x : xs) = x : goN xs
goN [] = []
-- Unescape an unquoted string
unescapeU = goX
where
goX [] = []
goX ('\\' : x : xs) = x : goX xs
goX (x : xs) = x : goX xs
-- Unescape a weakly quoted string
unescapeD = goX
where
-- Reached an escape character
goX ('\\' : x : xs)
-- If it's true escapable, strip the
-- slashes, as we're going to strong
-- escape instead.
| x `elem` ("$`\"\\\n" :: String) = x : goX xs
| otherwise = '\\' : x : goX xs
-- We've ended quoted section, so we
-- don't recurse on goX, it's done.
goX ('"' : xs)
= xs
-- Not done, but not a special character
-- just continue the fold.
goX (x : xs)
= x : goX xs
goX []
= []
tagCompleter :: Tool -> [String] -> Completer
tagCompleter tool add = listIOCompleter $ do
dirs' <- liftIO getAllDirs
let loggerConfig = LoggerConfig
{ lcPrintDebugLvl = Nothing
, consoleOutter = mempty
, fileOutter = mempty
, fancyColors = False
}
mpFreq <- flip runReaderT loggerConfig . runE $ platformRequest
forFold mpFreq $ \pfreq -> do
let appState = LeanAppState
(defaultSettings { noNetwork = True })
dirs'
defaultKeyBindings
pfreq
loggerConfig
mGhcUpInfo <- flip runReaderT appState . runE $ getDownloadsF pfreq
case mGhcUpInfo of
VRight ghcupInfo -> do
let allTags = filter (/= Old)
$ _vmTags =<< M.elems (availableToolVersions (_ghcupDownloads ghcupInfo) tool)
pure $ nub $ (add ++) $ fmap tagToString allTags
VLeft _ -> pure (nub $ ["recommended", "latest", "latest-prerelease"] ++ add)
versionCompleter :: [ListCriteria] -> Tool -> Completer
versionCompleter criteria tool = versionCompleter' criteria tool (const True)
versionCompleter' :: [ListCriteria] -> Tool -> (Version -> Bool) -> Completer
versionCompleter' criteria tool filter' = listIOCompleter $ do
dirs' <- liftIO getAllDirs
let loggerConfig = LoggerConfig
{ lcPrintDebugLvl = Nothing
, consoleOutter = mempty
, fileOutter = mempty
, fancyColors = False
}
mpFreq <- flip runReaderT loggerConfig . runE $ platformRequest
let settings = defaultSettings { noNetwork = True }
forFold mpFreq $ \pfreq -> do
let leanAppState = LeanAppState
settings
dirs'
defaultKeyBindings
pfreq
loggerConfig
mGhcUpInfo <- flip runReaderT leanAppState . runE $ getDownloadsF pfreq
forFold mGhcUpInfo $ \ghcupInfo -> do
let appState = AppState
settings
dirs'
defaultKeyBindings
ghcupInfo
pfreq
loggerConfig
runEnv = flip runReaderT appState . runE
(VRight installedVersions) <- runEnv $ listVersions (Just [tool]) criteria ShowUpdates False False (Nothing, Nothing)
return $ fmap (T.unpack . prettyVer) . filter filter' . maybe [] (fmap lVer . snd) $ M.lookup tool installedVersions
toolDlCompleter :: Tool -> Completer
toolDlCompleter tool = mkCompleter $ \case
"" -> pure (initUrl tool <> ["https://", "http://", "file:///"])
word
| "file://" `isPrefixOf` word -> fileUri' [] word
-- downloads.haskell.org
| "https://downloads.haskell.org/" `isPrefixOf` word ->
fmap (completePrefix word) . prefixMatch (FP.takeFileName word) <$> fromHRef word
-- github releases
| "https://github.com/haskell/haskell-language-server/releases/download/" `isPrefixOf` word
, let xs = splitPath word
, (length xs == 6 && last word == '/') || (length xs == 7 && last word /= '/') ->
fmap (\x -> completePrefix word x <> "/") . prefixMatch (FP.takeFileName word) <$> getGithubReleases "haskell" "haskell-language-server"
| "https://github.com/commercialhaskell/stack/releases/download/" == word
, let xs = splitPath word
, (length xs == 6 && last word == '/') || (length xs == 7 && last word /= '/') ->
fmap (\x -> completePrefix word x <> "/") . prefixMatch (FP.takeFileName word) <$> getGithubReleases "commercialhaskell" "stack"
-- github release assets
| "https://github.com/haskell/haskell-language-server/releases/download/" `isPrefixOf` word
, let xs = splitPath word
, (length xs == 7 && last word == '/') || length xs == 8
, let rel = xs !! 6
, length rel > 1 -> do
fmap (completePrefix word) . prefixMatch (FP.takeFileName word) <$> getGithubAssets "haskell" "haskell-language-server" (init rel)
| "https://github.com/commercialhaskell/stack/releases/download/" `isPrefixOf` word
, let xs = splitPath word
, (length xs == 7 && last word == '/') || length xs == 8
, let rel = xs !! 6
, length rel > 1 -> do
fmap (completePrefix word) . prefixMatch (FP.takeFileName word) <$> getGithubAssets "commercialhaskell" "stack" (init rel)
-- github
| "https://github.com/c" `isPrefixOf` word -> pure ["https://github.com/commercialhaskell/stack/releases/download/"]
| "https://github.com/h" `isPrefixOf` word -> pure ["https://github.com/haskell/haskell-language-server/releases/download/"]
| "https://g" `isPrefixOf` word
, tool == stack -> pure ["https://github.com/commercialhaskell/stack/releases/download/"]
| "https://g" `isPrefixOf` word
, tool == hls -> pure ["https://github.com/haskell/haskell-language-server/releases/download/"]
| "https://d" `isPrefixOf` word -> pure $ filter ("https://downloads.haskell.org/" `isPrefixOf`) $ initUrl tool
| "h" `isPrefixOf` word -> pure $ initUrl tool
| word `isPrefixOf` "file:///" -> pure ["file:///"]
| word `isPrefixOf` "https://" -> pure ["https://"]
| word `isPrefixOf` "http://" -> pure ["http://"]
| otherwise -> pure []
where
initUrl :: Tool -> [String]
initUrl (Tool "ghc") = [ "https://downloads.haskell.org/~ghc/"
, "https://downloads.haskell.org/~ghcup/unofficial-bindists/ghc/"
]
initUrl (Tool "cabal") = [ "https://downloads.haskell.org/~cabal/"
, "https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal/"
]
initUrl (Tool "ghcup") = [ "https://downloads.haskell.org/~ghcup/" ]
initUrl (Tool "hls") = [ "https://github.com/haskell/haskell-language-server/releases/download/"
, "https://downloads.haskell.org/~ghcup/unofficial-bindists/haskell-language-server/"
]
initUrl (Tool "stack") = [ "https://github.com/commercialhaskell/stack/releases/download/"
, "https://downloads.haskell.org/~ghcup/unofficial-bindists/stack/"
]
initUrl _ = []
completePrefix :: String -- ^ url, e.g. 'https://github.com/haskell/haskell-languag'
-> String -- ^ match, e.g. 'haskell-language-server'
-> String -- ^ result, e.g. 'https://github.com/haskell/haskell-language-server'
completePrefix url match =
let base = FP.takeDirectory url
fn = FP.takeFileName url
in if fn `isPrefixOf` match then base <> "/" <> match else url
prefixMatch :: String -> [String] -> [String]
prefixMatch pref = filter (pref `isPrefixOf`)
fromHRef :: String -> IO [String]
fromHRef url = withCurl (FP.takeDirectory url) 2_000_000 $ \stdout ->
pure
. fmap (T.unpack . decUTF8Safe' . fromAttrib "href")
. filter isTagOpen
. filter (~== ("<a href>" :: String))
. parseTags
$ stdout
withCurl :: String -- ^ url
-> Int -- ^ delay
-> (ByteString -> IO [String]) -- ^ callback
-> IO [String]
withCurl url delay cb = do
let limit = threadDelay delay
race limit (executeOut "curl" ["-fL", url] Nothing) >>= \case
Right (CapturedProcess {_exitCode, _stdOut}) -> do
case _exitCode of
ExitSuccess ->
(try @_ @SomeException . cb $ _stdOut) >>= \case
Left _ -> pure []
Right r' -> do
r <- try @_ @SomeException
. evaluate
. force
$ r'
either (\_ -> pure []) pure r
ExitFailure _ -> pure []
Left _ -> pure []
getGithubReleases :: String
-> String
-> IO [String]
getGithubReleases owner repo = withCurl url 3_000_000 $ \stdout -> do
Just xs <- pure $ decode' @Array stdout
fmap V.toList $ forM xs $ \x -> do
(Object r) <- pure x
Just (String name) <- pure $ KM.lookup (mkval "tag_name") r
pure $ T.unpack name
where
url = "https://api.github.com/repos/" <> owner <> "/" <> repo <> "/releases"
getGithubAssets :: String
-> String
-> String
-> IO [String]
getGithubAssets owner repo tag = withCurl url 3_000_000 $ \stdout -> do
Just xs <- pure $ decode' @Object stdout
Just (Array assets) <- pure $ KM.lookup (mkval "assets") xs
fmap V.toList $ forM assets $ \val -> do
(Object asset) <- pure val
Just (String name) <- pure $ KM.lookup (mkval "name") asset
pure $ T.unpack name
where
url = "https://api.github.com/repos/" <> owner <> "/" <> repo <> "/releases/tags/" <> tag
#if MIN_VERSION_aeson(2,0,0)
mkval = KM.fromString
#else
mkval = id
#endif
checkForUpdates :: ( MonadReader env m
, HasGHCupInfo env
, HasDirs env
, HasPlatformReq env
, HasLog env
, MonadIOish m
)
=> m [(Tool, TargetVersionRev)]
checkForUpdates = do
dl@GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
pfreq <- getPlatformReq
(VRight lInstalled') <- runE $ listVersions Nothing [ListInstalled True] ShowUpdates False False (Nothing, Nothing)
let latestInstalled tool = do
(_, xs) <- M.lookup tool lInstalled'
ListResult{..} <- lastMay xs
pure $ TargetVersion lCross lVer
ghcup' <- forMM (getLatest dls ghcup) $ \(TargetVersion _ l) -> do
(Right ghcup_ver) <- pure $ version $ prettyPVP ghcUpVer
let tver = mkTVer l
let rev = maybe 0 (\(_, i, _) -> i) $ getRev dls ghcup tver Nothing
if l > ghcup_ver then pure $ Just (ghcup, TargetVersionRev tver rev) else pure Nothing
otherTools <- forM (fst <$> allAvailableTools dls) $ \t ->
forMM (getLatest dls t) $ \l -> do
let mver = latestInstalled t
let rev = maybe 0 (\(_, i, _) -> i) $ getRev dls t l Nothing
forMM mver $ \ver ->
if l > ver then pure $ Just (t, TargetVersionRev l rev) else pure Nothing
let revUpdates = mconcat $ M.toList lInstalled' <&> \(tool, (_, lrs)) -> catMaybes $
lrs <&> \ListResult{..} -> do
let tver = TargetVersion lCross lVer
(rev, _) <- either (const Nothing) pure $ getDownloadInfo tool (TargetVersionReq tver Nothing) dl pfreq
if rev > fst lRev
then Just (tool, TargetVersionRev tver rev)
else Nothing
pure $ nub (catMaybes (ghcup':otherTools) <> revUpdates)
where
forMM a f = fmap join $ forM a f
logGHCPostRm :: (MonadReader env m, HasLog env, MonadIO m) => TargetVersion -> m ()
logGHCPostRm ghcVer = do
cabalStore <- liftIO $ handleIO (\_ -> if isWindows then pure "C:\\cabal\\store" else pure "~/.cabal/store or ~/.local/state/cabal/store")
getStoreDir
let storeGhcDir = cabalStore </> ("ghc-" <> T.unpack (prettyVer $ _tvVersion ghcVer))
logInfo $ T.pack $ "After removing GHC you might also want to clean up your cabal store at: " <> storeGhcDir