{-# LANGUAGE CPP #-} {-# 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 GHCup.Utils.Prelude import Brick import Brick.BChan import Brick.Widgets.Border import Brick.Widgets.Border.Style import Brick.Widgets.Center import Brick.Widgets.List #if !defined(TAR) import Codec.Archive #endif import Control.Concurrent import Control.Concurrent.MVar import Control.Exception.Safe import Control.Monad.Logger import Control.Monad.Reader import Control.Monad.Trans.Resource import Data.Bool import Data.ByteString ( ByteString ) 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 HPath import HPath.IO hiding ( hideError ) import Prelude hiding ( abs, appendFile, writeFile ) import System.Exit import System.IO.Unsafe import System.Posix.Types import URI.ByteString import qualified Data.Text as T import qualified Graphics.Vty as Vty import qualified Data.Vector as V import qualified "unix-bytestring" System.Posix.IO.ByteString as SPIB data SubProcess = SubProcess { procName :: String , exited :: Maybe (Either ProcessError ()) , procId :: Maybe ProcessID , logLine :: Maybe ByteString } data AppState = AppState { lr :: LR , dls :: GHCupDownloads , pfreq :: PlatformRequest , mproc :: Maybe SubProcess } data MyAppEvent = LogLine ByteString | StartProc String | GotProcId ProcessID | EndProc (Either ProcessError ()) 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 {..} = case mproc of Just _ -> logDialog Nothing -> ( padBottom Max $ ( withBorderStyle unicode $ borderWithLabel (str "GHCup") $ (center $ renderList renderItem True lr) ) ) <=> ( withAttr "help" . txtWrap . T.pack . foldr1 (\x y -> x <> " " <> y) . (++ ["↑↓:Navigation"]) $ (fmap (\(c, s, _) -> (c : ':' : s)) keyHandlers) ) where logDialog = case mproc of Nothing -> emptyWidget Just (SubProcess name Nothing _ (Just logLine)) -> centerLayer . txtWrap . decUTF8Safe $ logLine Just (SubProcess name Nothing _ (Just logLine)) -> centerLayer . txtWrap $ "" 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) dim = if lNoBindist then updateAttrMap (const dimAttributes) . withAttr "no-bindist" else id in dim ( marks <+> ( padLeft (Pad 2) $ minHSize 20 $ ((if b then withAttr "active" else id) (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 Prerelease = withAttr "prerelease" $ str "prerelease" 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 MyAppEvent String app = App { appDraw = \st -> [ui st] , appHandleEvent = eventHandler , appStartEvent = return , appAttrMap = const defaultAttributes , appChooseCursor = neverShowCursor } defaultAttributes :: AttrMap defaultAttributes = attrMap Vty.defAttr [ ("active" , Vty.defAttr `Vty.withBackColor` Vty.blue) , ("not-installed", Vty.defAttr `Vty.withForeColor` Vty.red) , ("set" , Vty.defAttr `Vty.withForeColor` Vty.green) , ("installed" , Vty.defAttr `Vty.withForeColor` Vty.green) , ("recommended" , Vty.defAttr `Vty.withForeColor` Vty.green) , ("latest" , Vty.defAttr `Vty.withForeColor` Vty.yellow) , ("prerelease" , Vty.defAttr `Vty.withForeColor` Vty.red) , ("help" , Vty.defAttr `Vty.withStyle` Vty.italic) ] dimAttributes :: AttrMap dimAttributes = attrMap (Vty.defAttr `Vty.withStyle` Vty.dim) [ ("active" , Vty.defAttr `Vty.withBackColor` Vty.blue) , ("no-bindist", Vty.defAttr `Vty.withStyle` Vty.dim) ] eventHandler :: AppState -> BrickEvent n MyAppEvent -> 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 pfreq mproc) eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) = continue (AppState (listMoveDown lr) dls pfreq mproc) eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) = case find (\(c', _, _) -> c' == c) keyHandlers of Nothing -> continue as Just (_, _, handler) -> handler as eventHandler st (AppEvent (StartProc str')) = continue st { mproc = Just SubProcess { procName = str' , exited = Nothing , procId = Nothing , logLine = Nothing } } eventHandler st@AppState { mproc = Just sp } (AppEvent (GotProcId pid)) = continue st { mproc = Just sp { procId = Just pid } } eventHandler st@AppState { mproc = Just sp } (AppEvent (EndProc exited)) = continue st { mproc = Just sp { exited = Just exited, procId = Nothing } } eventHandler st@AppState { mproc = Just sp } (AppEvent (LogLine bs)) = continue st { mproc = Just sp { logLine = Just bs } } eventHandler st (AppEvent _) = error "noes" -- TODO 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) -> do liftIO $ forkIO $ void $ action as (ix, e) continue as -- apps <- (fmap . fmap) -- (\AppState {..} -> AppState { lr = listMoveTo ix lr, .. }) -- $ getAppState Nothing (pfreq as) -- 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 #if !defined(TAR) , ArchiveResult #endif , FileDoesNotExistError , CopyError , NoDownload , NotInstalled , BuildFailed , TagNotFound , DigestError , DownloadFailed , NoUpdate , TarDirDoesNotExist ] (run $ do case lTool of GHC -> liftE $ installGHCBin dls lVer pfreq Cabal -> liftE $ installCabalBin dls lVer pfreq GHCup -> liftE $ upgradeGHCup dls Nothing False pfreq $> () ) >>= \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 let cmd = case _rPlatform pfreq of Darwin -> "open" Linux _ -> "xdg-open" FreeBSD -> "xdg-open" exec cmd True [serializeURIRef' uri] Nothing Nothing >>= \case Right _ -> pure $ Right () Left e -> pure $ Left [i|#{e}|] uri' :: IORef (Maybe URI) {-# NOINLINE uri' #-} uri' = unsafePerformIO (newIORef Nothing) settings' :: IORef Settings {-# NOINLINE settings' #-} settings' = unsafePerformIO $ do dirs <- getDirs newIORef Settings { cache = True , noVerify = False , keepDirs = Never , downloader = Curl , verbose = False , execCb = (\_ _ _ _ _ -> liftIO $ writeFile [abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "settings'") , .. } logger' :: IORef LoggerConfig {-# NOINLINE logger' #-} logger' = unsafePerformIO (newIORef $ LoggerConfig { lcPrintDebug = False , colorOutter = \_ -> pure () , rawOutter = \_ -> pure () } ) brickMain :: Settings -> Maybe URI -> LoggerConfig -> GHCupDownloads -> PlatformRequest -> IO () brickMain _ muri _ av pfreq' = do writeIORef uri' muri s <- readIORef settings' -- logger interpreter -- writeIORef logger' l l <- readIORef logger' let runLogger = myLoggerT l eApps <- getAppState (Just av) pfreq' case eApps of Right as -> do eventChan <- newBChan 1000 let builder = Vty.mkVty Vty.defaultConfig initialVty <- builder writeIORef settings' s{ execCb = brickExecCb eventChan } customMain initialVty builder (Just eventChan) 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 :: Maybe GHCupDownloads -> PlatformRequest -> IO (Either String AppState) getAppState mg pfreq' = do muri <- readIORef uri' settings <- readIORef settings' l <- readIORef logger' let runLogger = myLoggerT l r <- runLogger . flip runReaderT settings . runE @'[JSONError, DownloadFailed, FileDoesNotExistError] $ do dls <- maybe (fmap _ghcupDownloads $ liftE $ getDownloadsF (maybe GHCupURL OwnSource muri)) pure mg lV <- lift $ listVersions dls Nothing Nothing pfreq' pure $ (AppState (list "Tool versions" (V.fromList lV) 1) dls pfreq' Nothing) case r of VRight a -> pure $ Right a VLeft e -> pure $ Left [i|#{e}|] brickExecCb :: BChan MyAppEvent -> ExecCb brickExecCb chan _ fileFd stdoutRead pState lfile = do liftIO $ writeFile [abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "brickExecCb" writeBChan chan (StartProc . T.unpack . decUTF8Safe $ lfile) readLineTilEOF lineAction stdoutRead takeMVar pState >>= \case PExited e@(Left _) -> writeBChan chan (EndProc e) _ -> error "no" where lineAction bs = do void $ SPIB.fdWrite fileFd (bs <> "\n") error "blah" writeBChan chan (LogLine bs)