Compare commits
1 Commits
master
...
better-bri
Author | SHA1 | Date | |
---|---|---|---|
14168a41fe |
@ -8,6 +8,7 @@ import GHCup
|
|||||||
import GHCup.Download
|
import GHCup.Download
|
||||||
import GHCup.Types
|
import GHCup.Types
|
||||||
import GHCup.Utils.Dirs
|
import GHCup.Utils.Dirs
|
||||||
|
import GHCup.Utils.File
|
||||||
import GHCup.Utils.Logger
|
import GHCup.Utils.Logger
|
||||||
import GHCup.Utils.Version.QQ
|
import GHCup.Utils.Version.QQ
|
||||||
|
|
||||||
@ -192,7 +193,7 @@ validateTarballs dls = do
|
|||||||
where
|
where
|
||||||
downloadAll dli = do
|
downloadAll dli = do
|
||||||
dirs <- liftIO getDirs
|
dirs <- liftIO getDirs
|
||||||
let settings = Settings True False Never Curl False dirs
|
let settings = Settings True False Never Curl False dirs defExecCb
|
||||||
let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
|
let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
|
||||||
, colorOutter = B.hPut stderr
|
, colorOutter = B.hPut stderr
|
||||||
, rawOutter = (\_ -> pure ())
|
, rawOutter = (\_ -> pure ())
|
||||||
|
@ -14,8 +14,10 @@ import GHCup.Types
|
|||||||
import GHCup.Utils
|
import GHCup.Utils
|
||||||
import GHCup.Utils.File
|
import GHCup.Utils.File
|
||||||
import GHCup.Utils.Logger
|
import GHCup.Utils.Logger
|
||||||
|
import GHCup.Utils.Prelude
|
||||||
|
|
||||||
import Brick
|
import Brick
|
||||||
|
import Brick.BChan
|
||||||
import Brick.Widgets.Border
|
import Brick.Widgets.Border
|
||||||
import Brick.Widgets.Border.Style
|
import Brick.Widgets.Border.Style
|
||||||
import Brick.Widgets.Center
|
import Brick.Widgets.Center
|
||||||
@ -23,11 +25,14 @@ import Brick.Widgets.List
|
|||||||
#if !defined(TAR)
|
#if !defined(TAR)
|
||||||
import Codec.Archive
|
import Codec.Archive
|
||||||
#endif
|
#endif
|
||||||
|
import Control.Concurrent
|
||||||
|
import Control.Concurrent.MVar
|
||||||
import Control.Exception.Safe
|
import Control.Exception.Safe
|
||||||
import Control.Monad.Logger
|
import Control.Monad.Logger
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import Control.Monad.Trans.Resource
|
import Control.Monad.Trans.Resource
|
||||||
import Data.Bool
|
import Data.Bool
|
||||||
|
import Data.ByteString ( ByteString )
|
||||||
import Data.Functor
|
import Data.Functor
|
||||||
import Data.List
|
import Data.List
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
@ -37,22 +42,40 @@ import Data.String.Interpolate
|
|||||||
import Data.Vector ( Vector )
|
import Data.Vector ( Vector )
|
||||||
import Data.Versions hiding ( str )
|
import Data.Versions hiding ( str )
|
||||||
import Haskus.Utils.Variant.Excepts
|
import Haskus.Utils.Variant.Excepts
|
||||||
import Prelude hiding ( appendFile )
|
import HPath
|
||||||
|
import HPath.IO hiding ( hideError )
|
||||||
|
import Prelude hiding ( abs, appendFile, writeFile )
|
||||||
import System.Exit
|
import System.Exit
|
||||||
import System.IO.Unsafe
|
import System.IO.Unsafe
|
||||||
|
import System.Posix.Types
|
||||||
import URI.ByteString
|
import URI.ByteString
|
||||||
|
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import qualified Graphics.Vty as Vty
|
import qualified Graphics.Vty as Vty
|
||||||
import qualified Data.Vector as V
|
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 {
|
data AppState = AppState {
|
||||||
lr :: LR
|
lr :: LR
|
||||||
, dls :: GHCupDownloads
|
, dls :: GHCupDownloads
|
||||||
, pfreq :: PlatformRequest
|
, pfreq :: PlatformRequest
|
||||||
|
|
||||||
|
, mproc :: Maybe SubProcess
|
||||||
}
|
}
|
||||||
|
|
||||||
|
data MyAppEvent = LogLine ByteString
|
||||||
|
| StartProc String
|
||||||
|
| GotProcId ProcessID
|
||||||
|
| EndProc (Either ProcessError ())
|
||||||
|
|
||||||
type LR = GenericList String Vector ListResult
|
type LR = GenericList String Vector ListResult
|
||||||
|
|
||||||
|
|
||||||
@ -68,6 +91,9 @@ keyHandlers =
|
|||||||
|
|
||||||
ui :: AppState -> Widget String
|
ui :: AppState -> Widget String
|
||||||
ui AppState {..} =
|
ui AppState {..} =
|
||||||
|
case mproc of
|
||||||
|
Just _ -> logDialog
|
||||||
|
Nothing ->
|
||||||
( padBottom Max
|
( padBottom Max
|
||||||
$ ( withBorderStyle unicode
|
$ ( withBorderStyle unicode
|
||||||
$ borderWithLabel (str "GHCup")
|
$ borderWithLabel (str "GHCup")
|
||||||
@ -83,6 +109,10 @@ ui AppState {..} =
|
|||||||
)
|
)
|
||||||
|
|
||||||
where
|
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 {..} =
|
renderItem b ListResult {..} =
|
||||||
let marks = if
|
let marks = if
|
||||||
| lSet -> (withAttr "set" $ str "✔✔")
|
| lSet -> (withAttr "set" $ str "✔✔")
|
||||||
@ -121,7 +151,7 @@ minHSize :: Int -> Widget n -> Widget n
|
|||||||
minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ')
|
minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ')
|
||||||
|
|
||||||
|
|
||||||
app :: App AppState e String
|
app :: App AppState MyAppEvent String
|
||||||
app = App { appDraw = \st -> [ui st]
|
app = App { appDraw = \st -> [ui st]
|
||||||
, appHandleEvent = eventHandler
|
, appHandleEvent = eventHandler
|
||||||
, appStartEvent = return
|
, appStartEvent = return
|
||||||
@ -152,18 +182,32 @@ dimAttributes = attrMap
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
eventHandler :: AppState -> BrickEvent n e -> EventM n (Next AppState)
|
eventHandler :: AppState -> BrickEvent n MyAppEvent -> EventM n (Next AppState)
|
||||||
eventHandler st (VtyEvent (Vty.EvResize _ _)) = continue st
|
eventHandler st (VtyEvent (Vty.EvResize _ _)) = continue st
|
||||||
eventHandler st (VtyEvent (Vty.EvKey (Vty.KChar 'q') _)) = halt st
|
eventHandler st (VtyEvent (Vty.EvKey (Vty.KChar 'q') _)) = halt st
|
||||||
eventHandler st (VtyEvent (Vty.EvKey Vty.KEsc _)) = halt st
|
eventHandler st (VtyEvent (Vty.EvKey Vty.KEsc _)) = halt st
|
||||||
eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KUp) _)) =
|
eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KUp) _)) =
|
||||||
continue (AppState (listMoveUp lr) dls pfreq)
|
continue (AppState (listMoveUp lr) dls pfreq mproc)
|
||||||
eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) =
|
eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) =
|
||||||
continue (AppState (listMoveDown lr) dls pfreq)
|
continue (AppState (listMoveDown lr) dls pfreq mproc)
|
||||||
eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) =
|
eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) =
|
||||||
case find (\(c', _, _) -> c' == c) keyHandlers of
|
case find (\(c', _, _) -> c' == c) keyHandlers of
|
||||||
Nothing -> continue as
|
Nothing -> continue as
|
||||||
Just (_, _, handler) -> handler 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
|
eventHandler st _ = continue st
|
||||||
|
|
||||||
|
|
||||||
@ -174,19 +218,18 @@ withIOAction :: (AppState -> (Int, ListResult) -> IO (Either String a))
|
|||||||
-> EventM n (Next AppState)
|
-> EventM n (Next AppState)
|
||||||
withIOAction action as = case listSelectedElement (lr as) of
|
withIOAction action as = case listSelectedElement (lr as) of
|
||||||
Nothing -> continue as
|
Nothing -> continue as
|
||||||
Just (ix, e) -> suspendAndResume $ do
|
Just (ix, e) -> do
|
||||||
action as (ix, e) >>= \case
|
liftIO $ forkIO $ void $ action as (ix, e)
|
||||||
Left err -> putStrLn $ ("Error: " <> err)
|
continue as
|
||||||
Right _ -> putStrLn "Success"
|
-- apps <- (fmap . fmap)
|
||||||
apps <- (fmap . fmap)
|
-- (\AppState {..} -> AppState { lr = listMoveTo ix lr, .. })
|
||||||
(\AppState {..} -> AppState { lr = listMoveTo ix lr, .. })
|
-- $ getAppState Nothing (pfreq as)
|
||||||
$ getAppState Nothing (pfreq as)
|
-- case apps of
|
||||||
case apps of
|
-- Right nas -> do
|
||||||
Right nas -> do
|
-- putStrLn "Press enter to continue"
|
||||||
putStrLn "Press enter to continue"
|
-- _ <- getLine
|
||||||
_ <- getLine
|
-- pure nas
|
||||||
pure nas
|
-- Left err -> throwIO $ userError err
|
||||||
Left err -> throwIO $ userError err
|
|
||||||
|
|
||||||
|
|
||||||
install' :: AppState -> (Int, ListResult) -> IO (Either String ())
|
install' :: AppState -> (Int, ListResult) -> IO (Either String ())
|
||||||
@ -306,6 +349,7 @@ settings' = unsafePerformIO $ do
|
|||||||
, keepDirs = Never
|
, keepDirs = Never
|
||||||
, downloader = Curl
|
, downloader = Curl
|
||||||
, verbose = False
|
, verbose = False
|
||||||
|
, execCb = (\_ _ _ _ _ -> liftIO $ writeFile [abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "settings'")
|
||||||
, ..
|
, ..
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -321,16 +365,22 @@ logger' = unsafePerformIO
|
|||||||
|
|
||||||
|
|
||||||
brickMain :: Settings -> Maybe URI -> LoggerConfig -> GHCupDownloads -> PlatformRequest -> IO ()
|
brickMain :: Settings -> Maybe URI -> LoggerConfig -> GHCupDownloads -> PlatformRequest -> IO ()
|
||||||
brickMain s muri l av pfreq' = do
|
brickMain _ muri _ av pfreq' = do
|
||||||
writeIORef uri' muri
|
writeIORef uri' muri
|
||||||
writeIORef settings' s
|
s <- readIORef settings'
|
||||||
-- logger interpreter
|
-- logger interpreter
|
||||||
writeIORef logger' l
|
-- writeIORef logger' l
|
||||||
|
l <- readIORef logger'
|
||||||
let runLogger = myLoggerT l
|
let runLogger = myLoggerT l
|
||||||
|
|
||||||
eApps <- getAppState (Just av) pfreq'
|
eApps <- getAppState (Just av) pfreq'
|
||||||
case eApps of
|
case eApps of
|
||||||
Right as -> defaultMain app (selectLatest as) $> ()
|
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
|
Left e -> do
|
||||||
runLogger ($(logError) [i|Error building app state: #{show e}|])
|
runLogger ($(logError) [i|Error building app state: #{show e}|])
|
||||||
exitWith $ ExitFailure 2
|
exitWith $ ExitFailure 2
|
||||||
@ -359,8 +409,25 @@ getAppState mg pfreq' = do
|
|||||||
dls <- maybe (fmap _ghcupDownloads $ liftE $ getDownloadsF (maybe GHCupURL OwnSource muri)) pure mg
|
dls <- maybe (fmap _ghcupDownloads $ liftE $ getDownloadsF (maybe GHCupURL OwnSource muri)) pure mg
|
||||||
|
|
||||||
lV <- lift $ listVersions dls Nothing Nothing pfreq'
|
lV <- lift $ listVersions dls Nothing Nothing pfreq'
|
||||||
pure $ (AppState (list "Tool versions" (V.fromList lV) 1) dls pfreq')
|
pure $ (AppState (list "Tool versions" (V.fromList lV) 1) dls pfreq' Nothing)
|
||||||
|
|
||||||
case r of
|
case r of
|
||||||
VRight a -> pure $ Right a
|
VRight a -> pure $ Right a
|
||||||
VLeft e -> pure $ Left [i|#{e}|]
|
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)
|
||||||
|
|
||||||
|
|
||||||
|
@ -831,7 +831,7 @@ toSettings Options {..} = do
|
|||||||
downloader = optsDownloader
|
downloader = optsDownloader
|
||||||
verbose = optVerbose
|
verbose = optVerbose
|
||||||
dirs <- getDirs
|
dirs <- getDirs
|
||||||
pure $ Settings { .. }
|
pure $ Settings { execCb = (\_ _ _ _ _ -> liftIO $ HPath.IO.writeFile [HPath.abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "toSettings"), ..}
|
||||||
|
|
||||||
|
|
||||||
upgradeOptsP :: Parser UpgradeOpts
|
upgradeOptsP :: Parser UpgradeOpts
|
||||||
|
@ -364,6 +364,7 @@ executable ghcup
|
|||||||
, table-layout
|
, table-layout
|
||||||
, template-haskell
|
, template-haskell
|
||||||
, text
|
, text
|
||||||
|
, unix-bytestring
|
||||||
, uri-bytestring
|
, uri-bytestring
|
||||||
, utf8-string
|
, utf8-string
|
||||||
, versions
|
, versions
|
||||||
|
@ -154,7 +154,6 @@ installGHCBindist dlinfo ver (PlatformRequest {..}) = do
|
|||||||
lEM $ execLogged "./configure"
|
lEM $ execLogged "./configure"
|
||||||
False
|
False
|
||||||
(["--prefix=" <> toFilePath inst] ++ alpineArgs)
|
(["--prefix=" <> toFilePath inst] ++ alpineArgs)
|
||||||
[rel|ghc-configure|]
|
|
||||||
(Just path)
|
(Just path)
|
||||||
Nothing
|
Nothing
|
||||||
lEM $ make ["install"] (Just path)
|
lEM $ make ["install"] (Just path)
|
||||||
@ -857,7 +856,6 @@ Stage1Only = YES|]
|
|||||||
)
|
)
|
||||||
++ fmap E.encodeUtf8 aargs
|
++ fmap E.encodeUtf8 aargs
|
||||||
)
|
)
|
||||||
[rel|ghc-conf|]
|
|
||||||
(Just workdir)
|
(Just workdir)
|
||||||
(Just (("GHC", toFilePath bghcPath) : cEnv))
|
(Just (("GHC", toFilePath bghcPath) : cEnv))
|
||||||
| otherwise -> do
|
| otherwise -> do
|
||||||
@ -873,7 +871,6 @@ Stage1Only = YES|]
|
|||||||
)
|
)
|
||||||
++ fmap E.encodeUtf8 aargs
|
++ fmap E.encodeUtf8 aargs
|
||||||
)
|
)
|
||||||
[rel|ghc-conf|]
|
|
||||||
(Just workdir)
|
(Just workdir)
|
||||||
(Just cEnv)
|
(Just cEnv)
|
||||||
|
|
||||||
@ -1031,7 +1028,6 @@ compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do
|
|||||||
lEM $ execLogged "./bootstrap.sh"
|
lEM $ execLogged "./bootstrap.sh"
|
||||||
False
|
False
|
||||||
(maybe [] (\j -> ["-j", fS (show j)]) jobs)
|
(maybe [] (\j -> ["-j", fS (show j)]) jobs)
|
||||||
[rel|cabal-bootstrap|]
|
|
||||||
(Just workdir)
|
(Just workdir)
|
||||||
(Just newEnv)
|
(Just newEnv)
|
||||||
pure $ (tmp </> [rel|bin/cabal|])
|
pure $ (tmp </> [rel|bin/cabal|])
|
||||||
|
@ -13,6 +13,7 @@ module GHCup.Download.IOStreams where
|
|||||||
|
|
||||||
import GHCup.Download.Utils
|
import GHCup.Download.Utils
|
||||||
import GHCup.Errors
|
import GHCup.Errors
|
||||||
|
import GHCup.Types
|
||||||
import GHCup.Types.Optics
|
import GHCup.Types.Optics
|
||||||
import GHCup.Types.JSON ( )
|
import GHCup.Types.JSON ( )
|
||||||
import GHCup.Utils.File
|
import GHCup.Utils.File
|
||||||
|
@ -1,6 +1,10 @@
|
|||||||
|
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||||
|
|
||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE CPP #-}
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE TypeSynonymInstances #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
|
||||||
{-|
|
{-|
|
||||||
Module : GHCup.Types
|
Module : GHCup.Types
|
||||||
@ -13,11 +17,14 @@ Portability : POSIX
|
|||||||
-}
|
-}
|
||||||
module GHCup.Types where
|
module GHCup.Types where
|
||||||
|
|
||||||
|
import Control.Concurrent.MVar
|
||||||
|
import Data.ByteString ( ByteString )
|
||||||
import Data.Map.Strict ( Map )
|
import Data.Map.Strict ( Map )
|
||||||
import Data.Text ( Text )
|
import Data.Text ( Text )
|
||||||
import Data.Versions
|
import Data.Versions
|
||||||
import HPath
|
import HPath
|
||||||
import URI.ByteString
|
import URI.ByteString
|
||||||
|
import System.Posix.Types
|
||||||
|
|
||||||
import qualified GHC.Generics as GHC
|
import qualified GHC.Generics as GHC
|
||||||
|
|
||||||
@ -163,6 +170,27 @@ data URLSource = GHCupURL
|
|||||||
deriving Show
|
deriving Show
|
||||||
|
|
||||||
|
|
||||||
|
data ProcessError = NonZeroExit Int ByteString [ByteString]
|
||||||
|
| PTerminated ByteString [ByteString]
|
||||||
|
| PStopped ByteString [ByteString]
|
||||||
|
| NoSuchPid ByteString [ByteString]
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
data ProcState = PRunning ProcessID
|
||||||
|
| PExited (Either ProcessError ())
|
||||||
|
deriving Eq
|
||||||
|
|
||||||
|
type ExecCb = Bool -- verbose
|
||||||
|
-> Fd -- log file fd
|
||||||
|
-> Fd -- input fd to read from
|
||||||
|
-> MVar ProcState -- state of the producing process
|
||||||
|
-> ByteString -- log filename
|
||||||
|
-> IO ()
|
||||||
|
|
||||||
|
instance Show ExecCb where
|
||||||
|
show _ = "**ExecCb**"
|
||||||
|
|
||||||
|
|
||||||
data Settings = Settings
|
data Settings = Settings
|
||||||
{ -- set by user
|
{ -- set by user
|
||||||
cache :: Bool
|
cache :: Bool
|
||||||
@ -173,6 +201,7 @@ data Settings = Settings
|
|||||||
|
|
||||||
-- set on app start
|
-- set on app start
|
||||||
, dirs :: Dirs
|
, dirs :: Dirs
|
||||||
|
, execCb :: ExecCb
|
||||||
}
|
}
|
||||||
deriving Show
|
deriving Show
|
||||||
|
|
||||||
|
@ -550,7 +550,7 @@ make args workdir = do
|
|||||||
spaths <- catMaybes . fmap parseAbs <$> (liftIO getSearchPath)
|
spaths <- catMaybes . fmap parseAbs <$> (liftIO getSearchPath)
|
||||||
has_gmake <- isJust <$> (liftIO $ searchPath spaths [rel|gmake|])
|
has_gmake <- isJust <$> (liftIO $ searchPath spaths [rel|gmake|])
|
||||||
let mymake = if has_gmake then "gmake" else "make"
|
let mymake = if has_gmake then "gmake" else "make"
|
||||||
execLogged mymake True args [rel|ghc-make|] workdir Nothing
|
execLogged mymake True args workdir Nothing
|
||||||
|
|
||||||
|
|
||||||
-- | Try to apply patches in order. Fails with 'PatchFailed'
|
-- | Try to apply patches in order. Fails with 'PatchFailed'
|
||||||
|
@ -72,14 +72,6 @@ import qualified "unix-bytestring" System.Posix.IO.ByteString
|
|||||||
as SPIB
|
as SPIB
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
data ProcessError = NonZeroExit Int ByteString [ByteString]
|
|
||||||
| PTerminated ByteString [ByteString]
|
|
||||||
| PStopped ByteString [ByteString]
|
|
||||||
| NoSuchPid ByteString [ByteString]
|
|
||||||
deriving Show
|
|
||||||
|
|
||||||
|
|
||||||
data CapturedProcess = CapturedProcess
|
data CapturedProcess = CapturedProcess
|
||||||
{ _exitCode :: ExitCode
|
{ _exitCode :: ExitCode
|
||||||
, _stdOut :: ByteString
|
, _stdOut :: ByteString
|
||||||
@ -121,30 +113,31 @@ execLogged :: (MonadReader Settings m, MonadIO m, MonadThrow m)
|
|||||||
=> ByteString -- ^ thing to execute
|
=> ByteString -- ^ thing to execute
|
||||||
-> Bool -- ^ whether to search PATH for the thing
|
-> Bool -- ^ whether to search PATH for the thing
|
||||||
-> [ByteString] -- ^ args for the thing
|
-> [ByteString] -- ^ args for the thing
|
||||||
-> Path Rel -- ^ log filename
|
|
||||||
-> Maybe (Path Abs) -- ^ optionally chdir into this
|
-> Maybe (Path Abs) -- ^ optionally chdir into this
|
||||||
-> Maybe [(ByteString, ByteString)] -- ^ optional environment
|
-> Maybe [(ByteString, ByteString)] -- ^ optional environment
|
||||||
-> m (Either ProcessError ())
|
-> m (Either ProcessError ())
|
||||||
execLogged exe spath args lfile chdir env = do
|
execLogged exe spath args chdir env = do
|
||||||
Settings {dirs = Dirs {..}, ..} <- ask
|
Settings {dirs = Dirs {..}, ..} <- ask
|
||||||
logfile <- (logsDir </>) <$> parseRel (toFilePath lfile <> ".log")
|
logfile <- (logsDir </>) <$> parseRel (lfile <> ".log")
|
||||||
liftIO $ bracket (createFile (toFilePath logfile) newFilePerms)
|
liftIO $ bracket (createFile (toFilePath logfile) newFilePerms)
|
||||||
closeFd
|
closeFd
|
||||||
(action verbose)
|
(action verbose execCb)
|
||||||
where
|
where
|
||||||
action verbose fd = do
|
lfile = fromMaybe exe $ BS.stripPrefix "./" exe
|
||||||
|
|
||||||
|
action verbose cb fd = do
|
||||||
actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
|
actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
|
||||||
-- start the thread that logs to stdout
|
-- start the thread that logs to stdout
|
||||||
pState <- newEmptyMVar
|
pState <- newEmptyMVar
|
||||||
done <- newEmptyMVar
|
done <- newEmptyMVar
|
||||||
|
liftIO $ HPath.IO.writeFile [HPath.abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "execLogged1"
|
||||||
void
|
void
|
||||||
$ forkIO
|
$ forkIO
|
||||||
$ EX.handle (\(_ :: IOException) -> pure ())
|
$ EX.handle (\(_ :: IOException) -> pure ())
|
||||||
$ flip EX.finally (putMVar done ())
|
$ flip EX.finally (putMVar done ())
|
||||||
$ (if verbose
|
$ (do
|
||||||
then tee fd stdoutRead
|
liftIO $ HPath.IO.writeFile [HPath.abs|/home/jule/git/ghcup-hs/cb.log|] Nothing "execLogged"
|
||||||
else printToRegion fd stdoutRead 6 pState
|
cb verbose fd stdoutRead pState lfile)
|
||||||
)
|
|
||||||
|
|
||||||
-- fork the subprocess
|
-- fork the subprocess
|
||||||
pid <- SPPB.forkProcess $ do
|
pid <- SPPB.forkProcess $ do
|
||||||
@ -157,79 +150,29 @@ execLogged exe spath args lfile chdir env = do
|
|||||||
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
|
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
|
||||||
void $ SPPB.executeFile exe spath args env
|
void $ SPPB.executeFile exe spath args env
|
||||||
|
|
||||||
|
putMVar pState (PRunning pid)
|
||||||
|
|
||||||
closeFd stdoutWrite
|
closeFd stdoutWrite
|
||||||
|
|
||||||
-- wait for the subprocess to finish
|
-- wait for the subprocess to finish
|
||||||
e <- toProcessError exe args <$!> SPPB.getProcessStatus True True pid
|
e <- toProcessError exe args <$!> SPPB.getProcessStatus True True pid
|
||||||
putMVar pState (either (const False) (const True) e)
|
void $ swapMVar pState (PExited e)
|
||||||
|
|
||||||
void $ race (takeMVar done) (threadDelay (1000000 * 3))
|
void $ race (takeMVar done) (threadDelay (1000000 * 3))
|
||||||
closeFd stdoutRead
|
closeFd stdoutRead
|
||||||
|
|
||||||
pure e
|
pure e
|
||||||
|
|
||||||
tee :: Fd -> Fd -> IO ()
|
|
||||||
tee fileFd fdIn = readTilEOF lineAction fdIn
|
|
||||||
|
|
||||||
|
readLineTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m ()
|
||||||
|
readLineTilEOF ~action' fd' = go mempty
|
||||||
where
|
where
|
||||||
lineAction :: ByteString -> IO ()
|
go bs' = do
|
||||||
lineAction bs' = do
|
(bs, rest, eof) <- readLine fd' bs'
|
||||||
void $ SPIB.fdWrite fileFd (bs' <> "\n")
|
if eof
|
||||||
void $ SPIB.fdWrite stdOutput (bs' <> "\n")
|
then liftIO $ ioError (mkIOError eofErrorType "" Nothing Nothing)
|
||||||
|
else (void $ action' bs) >> go rest
|
||||||
|
|
||||||
-- Reads fdIn and logs the output in a continous scrolling area
|
|
||||||
-- of 'size' terminal lines. Also writes to a log file.
|
|
||||||
printToRegion :: Fd -> Fd -> Int -> MVar Bool -> IO ()
|
|
||||||
printToRegion fileFd fdIn size pState = do
|
|
||||||
void $ displayConsoleRegions $ do
|
|
||||||
rs <-
|
|
||||||
liftIO
|
|
||||||
. fmap Sq.fromList
|
|
||||||
. sequence
|
|
||||||
. replicate size
|
|
||||||
. openConsoleRegion
|
|
||||||
$ Linear
|
|
||||||
flip runStateT mempty
|
|
||||||
$ handle
|
|
||||||
(\(ex :: SomeException) -> do
|
|
||||||
ps <- liftIO $ takeMVar pState
|
|
||||||
when (ps == True) (forM_ rs (liftIO . closeConsoleRegion))
|
|
||||||
throw ex
|
|
||||||
)
|
|
||||||
$ readTilEOF (lineAction rs) fdIn
|
|
||||||
|
|
||||||
where
|
|
||||||
-- action to perform line by line
|
|
||||||
-- TODO: do this with vty for efficiency
|
|
||||||
lineAction :: (MonadMask m, MonadIO m)
|
|
||||||
=> Seq ConsoleRegion
|
|
||||||
-> ByteString
|
|
||||||
-> StateT (Seq ByteString) m ()
|
|
||||||
lineAction rs = \bs' -> do
|
|
||||||
void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n")
|
|
||||||
modify (swapRegs bs')
|
|
||||||
regs <- get
|
|
||||||
liftIO $ forM_ (Sq.zip regs rs) $ \(bs, r) -> setConsoleRegion r $ do
|
|
||||||
w <- consoleWidth
|
|
||||||
return
|
|
||||||
. T.pack
|
|
||||||
. color Blue
|
|
||||||
. T.unpack
|
|
||||||
. decUTF8Safe
|
|
||||||
. trim w
|
|
||||||
. (\b -> "[ " <> toFilePath lfile <> " ] " <> b)
|
|
||||||
$ bs
|
|
||||||
|
|
||||||
swapRegs :: a -> Seq a -> Seq a
|
|
||||||
swapRegs bs = \regs -> if
|
|
||||||
| Sq.length regs < size -> regs |> bs
|
|
||||||
| otherwise -> Sq.drop 1 regs |> bs
|
|
||||||
|
|
||||||
-- trim output line to terminal width
|
|
||||||
trim :: Int -> ByteString -> ByteString
|
|
||||||
trim w = \bs -> if
|
|
||||||
| BS.length bs > w && w > 5 -> BS.take (w - 4) bs <> "..."
|
|
||||||
| otherwise -> bs
|
|
||||||
|
|
||||||
-- Consecutively read from Fd in 512 chunks until we hit
|
-- Consecutively read from Fd in 512 chunks until we hit
|
||||||
-- newline or EOF.
|
-- newline or EOF.
|
||||||
@ -258,14 +201,6 @@ execLogged exe spath args lfile chdir env = do
|
|||||||
-- if rest is empty, then there was no newline, process further
|
-- if rest is empty, then there was no newline, process further
|
||||||
| otherwise -> (\(l, r, b) -> (line <> l, r, b)) <$!> go mempty
|
| otherwise -> (\(l, r, b) -> (line <> l, r, b)) <$!> go mempty
|
||||||
|
|
||||||
readTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m ()
|
|
||||||
readTilEOF ~action' fd' = go mempty
|
|
||||||
where
|
|
||||||
go bs' = do
|
|
||||||
(bs, rest, eof) <- readLine fd' bs'
|
|
||||||
if eof
|
|
||||||
then liftIO $ ioError (mkIOError eofErrorType "" Nothing Nothing)
|
|
||||||
else (void $ action' bs) >> go rest
|
|
||||||
|
|
||||||
|
|
||||||
-- | Capture the stdout and stderr of the given action, which
|
-- | Capture the stdout and stderr of the given action, which
|
||||||
@ -450,3 +385,76 @@ chmod_777 (toFilePath -> fp) = do
|
|||||||
$(logDebug) [i|chmod 777 #{fp}|]
|
$(logDebug) [i|chmod 777 #{fp}|]
|
||||||
liftIO $ setFileMode fp exe_mode
|
liftIO $ setFileMode fp exe_mode
|
||||||
|
|
||||||
|
|
||||||
|
-- | The default callback for logging/printing on 'execLogged'.
|
||||||
|
defExecCb :: ExecCb
|
||||||
|
defExecCb verbose fd stdoutRead pState lfile = if verbose
|
||||||
|
then tee fd stdoutRead
|
||||||
|
else printToRegion fd stdoutRead 6
|
||||||
|
where
|
||||||
|
tee :: Fd -> Fd -> IO ()
|
||||||
|
tee fileFd fdIn = readLineTilEOF lineAction fdIn
|
||||||
|
|
||||||
|
where
|
||||||
|
lineAction :: ByteString -> IO ()
|
||||||
|
lineAction bs' = do
|
||||||
|
void $ SPIB.fdWrite fileFd (bs' <> "\n")
|
||||||
|
void $ SPIB.fdWrite stdOutput (bs' <> "\n")
|
||||||
|
|
||||||
|
-- Reads fdIn and logs the output in a continous scrolling area
|
||||||
|
-- of 'size' terminal lines. Also writes to a log file.
|
||||||
|
printToRegion :: Fd -> Fd -> Int -> IO ()
|
||||||
|
printToRegion fileFd fdIn size = do
|
||||||
|
void $ displayConsoleRegions $ do
|
||||||
|
rs <-
|
||||||
|
liftIO
|
||||||
|
. fmap Sq.fromList
|
||||||
|
. sequence
|
||||||
|
. replicate size
|
||||||
|
. openConsoleRegion
|
||||||
|
$ Linear
|
||||||
|
flip runStateT mempty
|
||||||
|
$ handle
|
||||||
|
(\(ex :: SomeException) -> do
|
||||||
|
let closeEventually = readMVar pState >>= \case
|
||||||
|
PExited (Right _) -> forM_ rs (liftIO . closeConsoleRegion)
|
||||||
|
_ -> threadDelay 500 >> closeEventually
|
||||||
|
void $ liftIO $ race closeEventually (threadDelay (1000000 * 3))
|
||||||
|
throw ex
|
||||||
|
)
|
||||||
|
$ readLineTilEOF (lineAction rs) fdIn
|
||||||
|
|
||||||
|
where
|
||||||
|
-- action to perform line by line
|
||||||
|
-- TODO: do this with vty for efficiency
|
||||||
|
lineAction :: (MonadMask m, MonadIO m)
|
||||||
|
=> Seq ConsoleRegion
|
||||||
|
-> ByteString
|
||||||
|
-> StateT (Seq ByteString) m ()
|
||||||
|
lineAction rs = \bs' -> do
|
||||||
|
void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n")
|
||||||
|
modify (swapRegs bs')
|
||||||
|
regs <- get
|
||||||
|
liftIO $ forM_ (Sq.zip regs rs) $ \(bs, r) -> setConsoleRegion r $ do
|
||||||
|
w <- consoleWidth
|
||||||
|
return
|
||||||
|
. T.pack
|
||||||
|
. color Blue
|
||||||
|
. T.unpack
|
||||||
|
. decUTF8Safe
|
||||||
|
. trim w
|
||||||
|
. (\b -> "[ " <> lfile <> " ] " <> b)
|
||||||
|
$ bs
|
||||||
|
|
||||||
|
swapRegs :: a -> Seq a -> Seq a
|
||||||
|
swapRegs bs = \regs -> if
|
||||||
|
| Sq.length regs < size -> regs |> bs
|
||||||
|
| otherwise -> Sq.drop 1 regs |> bs
|
||||||
|
|
||||||
|
-- trim output line to terminal width
|
||||||
|
trim :: Int -> ByteString -> ByteString
|
||||||
|
trim w = \bs -> if
|
||||||
|
| BS.length bs > w && w > 5 -> BS.take (w - 4) bs <> "..."
|
||||||
|
| otherwise -> bs
|
||||||
|
|
||||||
|
|
||||||
|
Loading…
Reference in New Issue
Block a user