diff --git a/.gitlab/before_script/linux/alpine/install_deps.sh b/.gitlab/before_script/linux/alpine/install_deps.sh index 54c71f0..655bbbb 100755 --- a/.gitlab/before_script/linux/alpine/install_deps.sh +++ b/.gitlab/before_script/linux/alpine/install_deps.sh @@ -18,12 +18,14 @@ apk add --no-cache \ tar \ perl -ln -s libncurses.so /usr/lib/libtinfo.so -ln -s libncursesw.so.6 /usr/lib/libtinfow.so.6 +ln -sf libncurses.so /usr/lib/libtinfo.so +ln -sf libncursesw.so.6 /usr/lib/libtinfow.so.6 +ln -sf libtinfow.so.6 /usr/lib/libtinfow.so + if [ "${BIT}" = "32" ] ; then - curl -sSfL https://downloads.haskell.org/~ghcup/0.1.4/i386-linux-ghcup-0.1.4 > ./ghcup-bin + curl -sSfL https://downloads.haskell.org/~ghcup/0.1.5/i386-linux-ghcup-0.1.5 > ./ghcup-bin else - curl -sSfL https://downloads.haskell.org/~ghcup/0.1.4/x86_64-linux-ghcup-0.1.4 > ./ghcup-bin + curl -sSfL https://downloads.haskell.org/~ghcup/0.1.5/x86_64-linux-ghcup-0.1.5 > ./ghcup-bin fi chmod +x ghcup-bin ./ghcup-bin upgrade @@ -57,7 +59,8 @@ apk add --no-cache \ openssl-dev \ openssl-libs-static \ xz \ - xz-dev - + xz-dev \ + ncurses-static +ln -sf libncursesw.a /usr/lib/libtinfow.a diff --git a/.gitlab/script/ghcup_release.sh b/.gitlab/script/ghcup_release.sh index b19c238..402fbe4 100755 --- a/.gitlab/script/ghcup_release.sh +++ b/.gitlab/script/ghcup_release.sh @@ -16,16 +16,24 @@ git describe ecabal update if [ "${OS}" = "LINUX" ] ; then - ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static' + if [ "${BIT}" = "32" ] ; then + ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static' + else + ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static' -ftui + fi elif [ "${OS}" = "FREEBSD" ] ; then ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections' --constraint="zlib static" else - ecabal build -w ghc-${GHC_VERSION} --constraint="zlib static" --constraint="lzma static" + ecabal build -w ghc-${GHC_VERSION} --constraint="zlib static" --constraint="lzma static" -ftui fi mkdir out cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" . ver=$(./ghcup --numeric-version) -strip -s ./ghcup +if [ "${OS}" = "DARWIN" ] ; then + strip ./ghcup +else + strip -s ./ghcup +fi cp ghcup out/${ARTIFACT}-${ver} diff --git a/.gitlab/script/ghcup_version.sh b/.gitlab/script/ghcup_version.sh index 02f7f3b..952fab8 100755 --- a/.gitlab/script/ghcup_version.sh +++ b/.gitlab/script/ghcup_version.sh @@ -21,9 +21,9 @@ git describe --always ecabal update if [ "${OS}" = "DARWIN" ] ; then - ecabal build -w ghc-${GHC_VERSION} + ecabal build -w ghc-${GHC_VERSION} -ftui else - ecabal build -w ghc-${GHC_VERSION} -finternal-downloader + ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui fi cp "$(ecabal new-exec --enable-tests --verbose=0 --offline sh -- -c 'command -v ghcup')" . diff --git a/3rdparty/libarchive/c/autoconf-linux/config.h b/3rdparty/libarchive/c/autoconf-linux/config.h index 1c58dfb..8441ce1 100644 --- a/3rdparty/libarchive/c/autoconf-linux/config.h +++ b/3rdparty/libarchive/c/autoconf-linux/config.h @@ -260,7 +260,7 @@ /* #undef HAVE_ACL_IS_TRIVIAL_NP */ /* Define to 1 if you have the header file. */ -#define HAVE_ACL_LIBACL_H 1 +/* #undef HAVE_ACL_LIBACL_H */ /* Define to 1 if the system has the type `acl_permset_t'. */ /* #undef HAVE_ACL_PERMSET_T */ @@ -453,6 +453,7 @@ /* #undef HAVE_EXPAT_H */ /* Define to 1 if you have the header file. */ +/* #undef HAVE_EXT2FS_EXT2_FS_H */ /* Define to 1 if you have the `extattr_get_fd' function. */ /* #undef HAVE_EXTATTR_GET_FD */ @@ -605,7 +606,7 @@ /* #undef HAVE_LCHFLAGS */ /* Define to 1 if you have the `lchmod' function. */ -/* #undef HAVE_LCHMOD */ +#define HAVE_LCHMOD 1 /* Define to 1 if you have the `lchown' function. */ #define HAVE_LCHOWN 1 @@ -1030,7 +1031,7 @@ #define HAVE_STRUCT_TM_TM_GMTOFF 1 /* Define to 1 if `__tm_gmtoff' is a member of `struct tm'. */ -/* #undef HAVE_STRUCT_TM___TM_GMTOFF */ +#define HAVE_STRUCT_TM___TM_GMTOFF 1 /* Define to 1 if the system has the type `struct vfsconf'. */ /* #undef HAVE_STRUCT_VFSCONF */ @@ -1042,9 +1043,10 @@ #define HAVE_SYMLINK 1 /* Define to 1 if you have the header file. */ +/* #undef HAVE_SYS_ACL_H */ /* Define to 1 if you have the header file. */ -#define HAVE_SYS_CDEFS_H 1 +/* #undef HAVE_SYS_CDEFS_H */ /* Define to 1 if you have the header file, and it defines `DIR'. */ @@ -1202,7 +1204,7 @@ #define HAVE_WMEMMOVE 1 /* Define to 1 if you have a working EXT2_IOC_GETFLAGS */ -#define HAVE_WORKING_EXT2_IOC_GETFLAGS 1 +/* #undef HAVE_WORKING_EXT2_IOC_GETFLAGS */ /* Define to 1 if you have a working FS_IOC_GETFLAGS */ #define HAVE_WORKING_FS_IOC_GETFLAGS 1 @@ -1289,7 +1291,7 @@ #define STDC_HEADERS 1 /* Define to 1 if strerror_r returns char *. */ -#define STRERROR_R_CHAR_P 1 +/* #undef STRERROR_R_CHAR_P */ /* Define to 1 if you can safely include both and . */ #define TIME_WITH_SYS_TIME 1 diff --git a/README.md b/README.md index 3fcae8b..1f6cfc2 100644 --- a/README.md +++ b/README.md @@ -40,7 +40,13 @@ export PATH="$HOME/.cabal/bin:$HOME/.ghcup/bin:$PATH" See `ghcup --help`. -Common use cases are: +For the simple interactive TUI, run: + +```sh +ghcup tui +``` + +For the full functionality via cli: ```sh # list available ghc/cabal versions diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs new file mode 100644 index 0000000..2b3c272 --- /dev/null +++ b/app/ghcup/BrickMain.hs @@ -0,0 +1,318 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} + +module BrickMain where + +import GHCup +import GHCup.Download +import GHCup.Errors +import GHCup.Types +import GHCup.Utils +import GHCup.Utils.File +import GHCup.Utils.Logger + +import Brick +import Brick.Widgets.Border +import Brick.Widgets.Border.Style +import Brick.Widgets.Center +import Brick.Widgets.List +import Codec.Archive +import Control.Exception.Safe +import Control.Monad.Logger +import Control.Monad.Reader +import Control.Monad.Trans.Resource +import Data.Bool +import Data.Functor +import Data.List +import Data.Maybe +import Data.Char +import Data.IORef +import Data.String.Interpolate +import Data.Vector ( Vector ) +import Data.Versions hiding ( str ) +import Haskus.Utils.Variant.Excepts +import Prelude hiding ( appendFile ) +import System.Exit +import System.IO.Unsafe +import URI.ByteString + +import qualified Data.Text as T +import qualified Graphics.Vty as Vty +import qualified Data.Vector as V + + +data AppState = AppState { + lr :: LR + , dls :: GHCupDownloads +} + +type LR = GenericList String Vector ListResult + + +keyHandlers :: [(Char, String, AppState -> EventM n (Next AppState))] +keyHandlers = + [ ('q', "Quit" , halt) + , ('i', "Install" , withIOAction install') + , ('u', "Uninstall", withIOAction del') + , ('s', "Set" , withIOAction set') + , ('c', "ChangeLog", withIOAction changelog') + ] + + +ui :: AppState -> Widget String +ui AppState {..} = + ( padBottom Max + $ ( withBorderStyle unicode + $ borderWithLabel (str "GHCup") + $ (center $ renderList renderItem True lr) + ) + ) + <=> ( withAttr "help" + $ foldr1 (\x y -> x <+> str " " <+> y) + . (++ [str "↑↓:Navigation"]) + $ (fmap (\(c, s, _) -> str (c : ':' : s)) keyHandlers) + ) + + where + renderItem b ListResult {..} = + let marks = if + | lSet -> (withAttr "set" $ str "✔✔") + | lInstalled -> (withAttr "installed" $ str "✓ ") + | otherwise -> (withAttr "not-installed" $ str "✗ ") + ver = case lCross of + Nothing -> T.unpack . prettyVer $ lVer + Just c -> T.unpack (c <> "-" <> prettyVer lVer) + in ( marks + <+> ( padLeft (Pad 2) + $ minHSize 20 + $ (withAttr + (bool "inactive" "active" b) + (str $ (fmap toLower . show $ lTool) <> " " <> ver) + ) + ) + <+> (padLeft (Pad 1) $ if null lTag + then emptyWidget + else + foldr1 (\x y -> x <+> str "," <+> y) + $ (fmap printTag $ sort lTag) + ) + ) + + printTag Recommended = withAttr "recommended" $ str "recommended" + printTag Latest = withAttr "latest" $ str "latest" + printTag (Base pvp'') = str ("base-" ++ T.unpack (prettyPVP pvp'')) + printTag (UnknownTag t ) = str t + + +minHSize :: Int -> Widget n -> Widget n +minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ') + + +app :: App AppState e String +app = App { appDraw = \st -> [ui st] + , appHandleEvent = eventHandler + , appStartEvent = return + , appAttrMap = const theMap + , appChooseCursor = neverShowCursor + } + where + theMap = attrMap + Vty.defAttr + [ ("active" , bg Vty.blue) + , ("not-installed", fg Vty.red) + , ("set" , fg Vty.green) + , ("installed" , fg Vty.green) + , ("recommended" , fg Vty.green) + , ("latest" , fg Vty.yellow) + , ("help" , Vty.defAttr `Vty.withStyle` Vty.italic) + ] + + +eventHandler :: AppState -> BrickEvent n e -> EventM n (Next AppState) +eventHandler st (VtyEvent (Vty.EvResize _ _)) = continue st +eventHandler st (VtyEvent (Vty.EvKey (Vty.KChar 'q') _)) = halt st +eventHandler st (VtyEvent (Vty.EvKey Vty.KEsc _)) = halt st +eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KUp) _)) = + continue (AppState (listMoveUp lr) dls) +eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) = + continue (AppState (listMoveDown lr) dls) +eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) = + case find (\(c', _, _) -> c' == c) keyHandlers of + Nothing -> continue as + Just (_, _, handler) -> handler as +eventHandler st _ = continue st + + +-- | Suspend the current UI and run an IO action in terminal. If the +-- IO action returns a Left value, then it's thrown as userError. +withIOAction :: (AppState -> (Int, ListResult) -> IO (Either String a)) + -> AppState + -> EventM n (Next AppState) +withIOAction action as = case listSelectedElement (lr as) of + Nothing -> continue as + Just (ix, e) -> suspendAndResume $ do + r <- action as (ix, e) + case r of + Left err -> throwIO $ userError err + Right _ -> do + apps <- (fmap . fmap) + (\AppState {..} -> AppState { lr = listMoveTo ix lr, .. }) + getAppState + case apps of + Right nas -> do + putStrLn "Press enter to continue" + _ <- getLine + pure nas + Left err -> throwIO $ userError err + + +install' :: AppState -> (Int, ListResult) -> IO (Either String ()) +install' AppState {..} (_, ListResult {..}) = do + settings <- readIORef settings' + l <- readIORef logger' + let runLogger = myLoggerT l + + let + run = + runLogger + . flip runReaderT settings + . runResourceT + . runE + @'[AlreadyInstalled, UnknownArchive, ArchiveResult, DistroNotFound, FileDoesNotExistError, CopyError, NoCompatibleArch, NoDownload, NotInstalled, NoCompatiblePlatform, BuildFailed, TagNotFound, DigestError, DownloadFailed, NoUpdate] + + (run $ do + case lTool of + GHC -> liftE $ installGHCBin dls lVer Nothing + Cabal -> liftE $ installCabalBin dls lVer Nothing + GHCup -> liftE $ upgradeGHCup dls Nothing False $> () + ) + >>= \case + VRight _ -> pure $ Right () + VLeft (V (AlreadyInstalled _ _)) -> pure $ Right () + VLeft (V (BuildFailed _ e)) -> + pure $ Left [i|Build failed with #{e}|] + VLeft (V NoDownload) -> + pure $ Left [i|No available version for #{prettyVer lVer}|] + VLeft (V NoUpdate) -> pure $ Right () + VLeft e -> pure $ Left [i|#{e} +Also check the logs in ~/.ghcup/logs|] + + +set' :: AppState -> (Int, ListResult) -> IO (Either String ()) +set' _ (_, ListResult {..}) = do + settings <- readIORef settings' + l <- readIORef logger' + let runLogger = myLoggerT l + + let run = + runLogger + . flip runReaderT settings + . runE @'[FileDoesNotExistError, NotInstalled, TagNotFound] + + (run $ do + case lTool of + GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly $> () + Cabal -> liftE $ setCabal lVer $> () + GHCup -> pure () + ) + >>= \case + VRight _ -> pure $ Right () + VLeft e -> pure $ Left [i|#{e}|] + + +del' :: AppState -> (Int, ListResult) -> IO (Either String ()) +del' _ (_, ListResult {..}) = do + settings <- readIORef settings' + l <- readIORef logger' + let runLogger = myLoggerT l + + let run = runLogger . flip runReaderT settings . runE @'[NotInstalled] + + (run $ do + case lTool of + GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> () + Cabal -> liftE $ rmCabalVer lVer $> () + GHCup -> pure () + ) + >>= \case + VRight _ -> pure $ Right () + VLeft e -> pure $ Left [i|#{e}|] + + +changelog' :: AppState -> (Int, ListResult) -> IO (Either String ()) +changelog' AppState {..} (_, ListResult {..}) = do + case getChangeLog dls lTool (Left lVer) of + Nothing -> pure $ Left + [i|Could not find ChangeLog for #{lTool}, version #{prettyVer lVer}|] + Just uri -> do + exec "xdg-open" True [serializeURIRef' uri] Nothing Nothing >>= \case + Right _ -> pure $ Right () + Left e -> pure $ Left [i|#{e}|] + + +settings' :: IORef Settings +{-# NOINLINE settings' #-} +settings' = unsafePerformIO + (newIORef Settings { cache = True + , noVerify = False + , keepDirs = Never + , downloader = Curl + } + ) + + +logger' :: IORef LoggerConfig +{-# NOINLINE logger' #-} +logger' = unsafePerformIO + (newIORef $ LoggerConfig { lcPrintDebug = False + , colorOutter = \_ -> pure () + , rawOutter = \_ -> pure () + } + ) + + +brickMain :: Settings -> LoggerConfig -> IO () +brickMain s l = do + writeIORef settings' s + -- logger interpreter + writeIORef logger' l + let runLogger = myLoggerT l + + eApps <- getAppState + case eApps of + Right as -> defaultMain app (selectLatest as) $> () + Left e -> do + runLogger ($(logError) [i|Error building app state: #{show e}|]) + exitWith $ ExitFailure 2 + where + selectLatest :: AppState -> AppState + selectLatest AppState {..} = + (\ix -> AppState { lr = listMoveTo ix lr, .. }) + . fromJust + . V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag) + $ (listElements lr) + + +getAppState :: IO (Either String AppState) +getAppState = do + settings <- readIORef settings' + l <- readIORef logger' + let runLogger = myLoggerT l + + r <- + runLogger + . flip runReaderT settings + . runE + @'[JSONError, DownloadFailed, FileDoesNotExistError, NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] + $ do + (GHCupInfo _ dls) <- liftE $ getDownloadsF GHCupURL + + lV <- liftE $ listVersions dls Nothing Nothing + pure $ (AppState (list "Tool versions" (V.fromList lV) 1) dls) + + case r of + VRight a -> pure $ Right a + VLeft e -> pure $ Left [i|#{e}|] diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 00aaef0..1f78140 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -10,6 +10,10 @@ module Main where +#if defined(BRICK) +import BrickMain ( brickMain ) +#endif + import GHCup import GHCup.Download import GHCup.Errors @@ -95,6 +99,9 @@ data Command | Upgrade UpgradeOpts Bool | ToolRequirements | ChangeLog ChangeLogOptions +#if defined(BRICK) + | Interactive +#endif data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal | ToolTag Tag @@ -223,7 +230,20 @@ opts = com :: Parser Command com = subparser +#if defined(BRICK) ( command + "tui" + ( (\_ -> Interactive) + <$> (info + helper + ( progDesc "Start the interactive GHCup UI" + ) + ) + ) + <> command +#else + ( command +#endif "install" ( Install <$> (info @@ -870,11 +890,12 @@ Report bugs at |] -- logger interpreter logfile <- initGHCupFileLogging [rel|ghcup.log|] - let runLogger = myLoggerT LoggerConfig + let loggerConfig = LoggerConfig { lcPrintDebug = optVerbose , colorOutter = B.hPut stderr , rawOutter = appendFile logfile } + let runLogger = myLoggerT loggerConfig ------------------------- @@ -910,7 +931,6 @@ Report bugs at |] @'[ FileDoesNotExistError , NotInstalled , TagNotFound - , TagNotFound ] let @@ -923,7 +943,7 @@ Report bugs at |] let runListGHC = runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] - let runRmGHC = + let runRm = runLogger . flip runReaderT settings . runE @'[NotInstalled] let runDebugInfo = @@ -1107,7 +1127,7 @@ Report bugs at |] pure $ ExitFailure 14 let rmGHC' RmOptions{..} = - (runRmGHC $ do + (runRm $ do liftE $ rmGHCVer ghcVer ) >>= \case @@ -1117,7 +1137,7 @@ Report bugs at |] pure $ ExitFailure 7 let rmCabal' tv = - (runSetCabal $ do + (runRm $ do liftE $ rmCabalVer tv ) >>= \case @@ -1129,6 +1149,9 @@ Report bugs at |] res <- case optCommand of +#if defined(BRICK) + Interactive -> liftIO $ brickMain settings loggerConfig >> pure ExitSuccess +#endif Install (Right iopts) -> do runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|]) installGHC iopts diff --git a/ghcup.cabal b/ghcup.cabal index d3ef251..b7b103d 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -21,6 +21,11 @@ source-repository head type: git location: https://gitlab.haskell.org/haskell/ghcup-hs.git +flag tui + description: Build the brick powered tui (ghcup tui) + default: False + manual: True + flag internal-downloader description: Compile the internal downloader, which links against OpenSSL default: False @@ -50,6 +55,9 @@ common base16-bytestring common binary build-depends: binary >=0.8.6.0 +common brick + build-depends: brick >=0.54 + common bytestring build-depends: bytestring >=0.10 @@ -158,7 +166,6 @@ common string-interpolate common table-layout build-depends: table-layout >=0.8 - common template-haskell build-depends: template-haskell >=2.7 @@ -198,6 +205,9 @@ common vector common versions build-depends: versions >=3.5 +common vty + build-depends: vty >=5.28.2 + common word8 build-depends: word8 >=0.1.3 @@ -350,6 +360,13 @@ executable ghcup if flag(internal-downloader) cpp-options: -DINTERNAL_DOWNLOADER + if flag(tui) + import: + brick + , vector + , vty + other-modules: BrickMain + cpp-options: -DBRICK executable ghcup-gen import: diff --git a/lib/GHCup.hs b/lib/GHCup.hs index cb110ef..c9adfd0 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -927,6 +927,8 @@ upgradeGHCup dls mtarget force = do `unionFileModes` ownerExecuteMode `unionFileModes` groupExecuteMode `unionFileModes` otherExecuteMode + binDir <- liftIO $ ghcupBinDir + liftIO $ createDirIfMissing newDirPerms binDir case mtarget of Nothing -> do dest <- liftIO $ ghcupBinDir