urbit/shrub
1
1
Fork 0
mirror of https://github.com/urbit/shrub.git synced 2024-12-25 04:52:06 +03:00
Code Issues Packages Projects Releases Wiki Activity

fix progress bar in daemon mode

Browse Source
This commit is contained in:
Isaac Visintainer 2020-02-03 17:27:16 -08:00
parent e25d30163d
commit 98fa24908a
6 changed files with 96 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
pkg/hs/terminal-progress-bar/src/System/ProgressBar.hs
View File

@ -220,9 +220,10 @@ killProgressBar _ = pure ()
hPutProgressBar :: HasLogFunc e => Style s -> Progress s -> Timing -> RIO e ()
hPutProgressBar style progress timing = do
logSticky (display (renderProgressBar style progress timing))
let barStr = (display (renderProgressBar style progress timing))
logSticky barStr
when (progressFinished progress) $ do
logStickyDone ""
logStickyDone barStr
-- | Renders a progress bar.
--

73
pkg/hs/urbit-king/lib/Urbit/King/App.hs
View File

@ -5,10 +5,10 @@ module Urbit.King.App
( App
, runApp
, runAppLogFile
, runAppLogHandle
, runAppNoLog
, runPierApp
, HasConfigDir(..)
, HasStderrLogFunc(..)
) where
import Urbit.King.Config
@ -21,8 +21,14 @@ import System.Directory (createDirectoryIfMissing, getHomeDirectory)
class HasConfigDir a where
configDirL ∷ Lens' a FilePath
class HasStderrLogFunc a where
stderrLogFuncL :: Lens' a LogFunc
--------------------------------------------------------------------------------
data App = App
{ _appLogFunc :: !LogFunc
{ _appLogFunc :: !LogFunc
, _appStderrLogFunc :: !LogFunc
}
makeLenses ''App
@ -30,22 +36,31 @@ makeLenses ''App
instance HasLogFunc App where
logFuncL = appLogFunc
runAppLogHandle :: Handle -> RIO App a -> IO a
runAppLogHandle logHandle inner = do
logOptions <- logOptionsHandle logHandle True
instance HasStderrLogFunc App where
stderrLogFuncL = appStderrLogFunc
runApp :: RIO App a -> IO a
runApp inner = do
logOptions <- logOptionsHandle stderr True
<&> setLogUseTime True
<&> setLogUseLoc False
withLogFunc logOptions $ \logFunc ->
go (App logFunc)
where
go app = runRIO app inner
runApp :: RIO App a -> IO a
runApp = runAppLogHandle stdout
runRIO (App logFunc logFunc) inner
runAppLogFile :: RIO App a -> IO a
runAppLogFile inner = withLogFileHandle (\h -> runAppLogHandle h inner)
runAppLogFile inner =
withLogFileHandle $ \h -> do
logOptions <- logOptionsHandle h True
<&> setLogUseTime True
<&> setLogUseLoc False
stderrLogOptions <- logOptionsHandle stderr True
<&> setLogUseTime False
<&> setLogUseLoc False
withLogFunc stderrLogOptions $ \stderrLogFunc ->
withLogFunc logOptions $ \logFunc ->
runRIO (App logFunc stderrLogFunc) inner
withLogFileHandle :: (Handle -> IO a) -> IO a
withLogFileHandle act = do
@ -58,20 +73,26 @@ withLogFileHandle act = do
runAppNoLog :: RIO App a -> IO a
runAppNoLog act =
withFile "/dev/null" AppendMode $ \handle ->
runAppLogHandle handle act
withFile "/dev/null" AppendMode $ \handle -> do
logOptions <- logOptionsHandle handle True
withLogFunc logOptions $ \logFunc ->
runRIO (App logFunc logFunc) act
--------------------------------------------------------------------------------
-- | A PierApp is like an App, except that it also provides a PierConfig
data PierApp = PierApp
{ _pierAppLogFunc :: !LogFunc
, _pierAppStderrLogFunc :: !LogFunc
, _pierAppPierConfig :: !PierConfig
, _pierAppNetworkConfig :: !NetworkConfig
}
makeLenses ''PierApp
instance HasStderrLogFunc PierApp where
stderrLogFuncL = pierAppStderrLogFunc
instance HasLogFunc PierApp where
logFuncL = pierAppLogFunc
@ -87,17 +108,33 @@ instance HasConfigDir PierApp where
runPierApp :: PierConfig -> NetworkConfig -> Bool -> RIO PierApp a -> IO a
runPierApp pierConfig networkConfig daemon inner =
if daemon
then exec stderr
else withLogFileHandle exec
then execStderr
else withLogFileHandle execFile
where
exec logHandle = do
logOptions <- logOptionsHandle logHandle True
execStderr = do
logOptions <- logOptionsHandle stderr True
<&> setLogUseTime True
<&> setLogUseLoc False
withLogFunc logOptions $ \logFunc ->
go $ PierApp { _pierAppLogFunc = logFunc
, _pierAppStderrLogFunc = logFunc
, _pierAppPierConfig = pierConfig
, _pierAppNetworkConfig = networkConfig
}
execFile logHandle = do
logOptions <- logOptionsHandle logHandle True
<&> setLogUseTime True
<&> setLogUseLoc False
logStderrOptions <- logOptionsHandle stderr True
<&> setLogUseTime False
<&> setLogUseLoc False
withLogFunc logStderrOptions $ \logStderr ->
withLogFunc logOptions $ \logFunc ->
go $ PierApp { _pierAppLogFunc = logFunc
, _pierAppStderrLogFunc = logStderr
, _pierAppPierConfig = pierConfig
, _pierAppNetworkConfig = networkConfig
}
go app = runRIO app inner

2
pkg/hs/urbit-king/lib/Urbit/King/CLI.hs
View File

@ -235,7 +235,7 @@ opts = do
oExit <- switch $ short 'x'
<> long "exit"
<> help "Exit immediatly"
<> help "Exit immediately"
<> hidden
oDryRun <- switch $ long "dry-run"

39
pkg/hs/urbit-king/lib/Urbit/King/Main.hs
View File

@ -71,25 +71,25 @@ import Control.Lens ((&))
import System.Process (system)
import Text.Show.Pretty (pPrint)
import Urbit.King.App (runApp, runAppLogFile, runAppNoLog, runPierApp)
import Urbit.King.App (HasConfigDir(..))
import Urbit.King.App (HasConfigDir(..), HasStderrLogFunc(..))
import Urbit.Noun.Conversions (cordToUW)
import Urbit.Time (Wen)
import Urbit.Vere.LockFile (lockFile)
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Network.HTTP.Client as C
import qualified System.Environment as Sys
import qualified System.Posix.Signals as Sys
import qualified System.ProgressBar as PB
import qualified System.Random as Sys
import qualified Urbit.King.CLI as CLI
import qualified Urbit.King.EventBrowser as EventBrowser
import qualified Urbit.Ob as Ob
import qualified Urbit.Vere.Log as Log
import qualified Urbit.Vere.Pier as Pier
import qualified Urbit.Vere.Serf as Serf
import qualified Urbit.Vere.Term as Term
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Network.HTTP.Client as C
import qualified System.Environment as Sys
import qualified System.Posix.Signals as Sys
import qualified System.ProgressBar as PB
import qualified System.Random as Sys
import qualified Urbit.King.CLI as CLI
import qualified Urbit.King.EventBrowser as EventBrowser
import qualified Urbit.Ob as Ob
import qualified Urbit.Vere.Log as Log
import qualified Urbit.Vere.Pier as Pier
import qualified Urbit.Vere.Serf as Serf
import qualified Urbit.Vere.Term as Term
--------------------------------------------------------------------------------
@ -137,7 +137,7 @@ toNetworkConfig CLI.Opts{..} = NetworkConfig
}
tryBootFromPill :: ( HasLogFunc e, HasNetworkConfig e, HasPierConfig e
, HasConfigDir e
, HasConfigDir e, HasStderrLogFunc e
)
=> Bool -> Pill -> Bool -> Serf.Flags -> Ship
-> LegacyBootEvent
@ -177,8 +177,8 @@ runOrExitImmediately getPier oExit mStart =
runPier sls = do
runRAcquire $ Pier.pier sls mStart
tryPlayShip :: ( HasLogFunc e, HasNetworkConfig e, HasPierConfig e
, HasConfigDir e
tryPlayShip :: ( HasStderrLogFunc e, HasLogFunc e, HasNetworkConfig e
, HasPierConfig e, HasConfigDir e
)
=> Bool -> Bool -> Maybe Word64 -> Serf.Flags -> MVar () -> RIO e ()
tryPlayShip exitImmediately fullReplay playFrom flags mStart = do
@ -277,7 +277,8 @@ collectAllFx top = do
--------------------------------------------------------------------------------
replayPartEvs :: ∀e. HasLogFunc e => FilePath -> Word64 -> RIO e ()
replayPartEvs :: ∀e. (HasStderrLogFunc e, HasLogFunc e)
=> FilePath -> Word64 -> RIO e ()
replayPartEvs top last = do
logTrace $ display $ pack @Text top
fetchSnapshot

6
pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs
View File

@ -19,7 +19,7 @@ import Control.Monad.Trans.Maybe
import Data.Text (append)
import System.Posix.Files (ownerModes, setFileMode)
import Urbit.King.App (HasConfigDir(..))
import Urbit.King.App (HasConfigDir(..), HasStderrLogFunc(..))
import Urbit.Vere.Ames (ames)
import Urbit.Vere.Behn (behn)
import Urbit.Vere.Clay (clay)
@ -93,7 +93,7 @@ writeJobs log !jobs = do
-- Boot a new ship. ------------------------------------------------------------
booted :: (HasPierConfig e, HasLogFunc e)
booted :: (HasPierConfig e, HasStderrLogFunc e, HasLogFunc e)
=> Pill -> Bool -> Serf.Flags -> Ship -> LegacyBootEvent
-> RAcquire e (Serf e, EventLog, SerfState)
booted pill lite flags ship boot = do
@ -127,7 +127,7 @@ booted pill lite flags ship boot = do
-- Resume an existing ship. ----------------------------------------------------
resumed :: (HasPierConfig e, HasLogFunc e)
resumed :: (HasStderrLogFunc e, HasPierConfig e, HasLogFunc e)
=> Maybe Word64 -> Serf.Flags
-> RAcquire e (Serf e, EventLog, SerfState)
resumed event flags = do

22
pkg/hs/urbit-king/lib/Urbit/Vere/Serf.hs
View File

@ -26,6 +26,7 @@ import Foreign.Marshal.Alloc (alloca)
import Foreign.Ptr (castPtr)
import Foreign.Storable (peek, poke)
import System.Exit (ExitCode)
import Urbit.King.App (HasStderrLogFunc(..))
import qualified Data.ByteString.Unsafe as BS
import qualified Data.Conduit.Combinators as CC
@ -365,8 +366,7 @@ updateProgressBar count startMsg = \case
-- We only construct the progress bar on the first time that we
-- process an event so that we don't display an empty progress
-- bar when the snapshot is caught up to the log.
logTrace $ display startMsg
let style = defStyle { stylePostfix = exact }
let style = defStyle { stylePrefix = msg (fromStrict startMsg) }
pb <- newProgressBar style 10 (Progress 0 count ())
pure (Just pb)
Just pb -> do
@ -381,7 +381,13 @@ data BootExn = ShipAlreadyBooted
deriving stock (Eq, Ord, Show)
deriving anyclass (Exception)
bootFromSeq :: ∀e. HasLogFunc e => Serf e -> BootSeq -> RIO e ([Job], SerfState)
logStderr :: HasStderrLogFunc e => RIO LogFunc a -> RIO e a
logStderr action = do
logFunc <- view stderrLogFuncL
runRIO logFunc action
bootFromSeq :: ∀e. (HasStderrLogFunc e, HasLogFunc e)
=> Serf e -> BootSeq -> RIO e ([Job], SerfState)
bootFromSeq serf (BootSeq ident nocks ovums) = do
handshake serf ident >>= \case
ss@(SerfState 1 (Mug 0)) -> loop [] ss Nothing bootSeqFns
@ -392,12 +398,12 @@ bootFromSeq serf (BootSeq ident nocks ovums) = do
-> RIO e ([Job], SerfState)
loop acc ss pb = \case
[] -> do
pb <- updateProgressBar 0 bootMsg pb
pb <- logStderr (updateProgressBar 0 bootMsg pb)
pure (reverse acc, ss)
x:xs -> do
wen <- io Time.now
job <- pure $ x (ssNextEv ss) (ssLastMug ss) wen
pb <- updateProgressBar (1 + length xs) bootMsg pb
pb <- logStderr (updateProgressBar (1 + length xs) bootMsg pb)
(job, ss) <- bootJob serf job
loop (job:acc) ss pb xs
@ -416,7 +422,7 @@ bootFromSeq serf (BootSeq ident nocks ovums) = do
The ship is booted, but it is behind. shove events to the worker
until it is caught up.
-}
replayJobs :: HasLogFunc e
replayJobs :: (HasStderrLogFunc e, HasLogFunc e)
=> Serf e -> Int -> SerfState -> ConduitT Job Void (RIO e) SerfState
replayJobs serf lastEv = go Nothing
where
@ -424,7 +430,7 @@ replayJobs serf lastEv = go Nothing
await >>= \case
Nothing -> pure ss
Just job -> do
pb <- lift $ updatePb ss pb
pb <- lift $ logStderr (updatePb ss pb)
played <- lift $ replayJob serf job
go pb played
@ -435,7 +441,7 @@ replayJobs serf lastEv = go Nothing
updateProgressBar start msg
replay :: HasLogFunc e
replay :: (HasStderrLogFunc e, HasLogFunc e)
=> Serf e -> Log.EventLog -> Maybe Word64 -> RIO e SerfState
replay serf log last = do
ss <- handshake serf (Log.identity log)