434 lines
14 KiB
Haskell
434 lines
14 KiB
Haskell
{-# 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)
|
|
|
|
|