ilyakooo0/urbit
1
0
Fork 0
mirror of https://github.com/ilyakooo0/urbit.git synced 2024-11-28 11:40:11 +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.
--

71
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
, _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,16 +108,32 @@ 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
}

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"

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

@ -71,7 +71,7 @@ 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)
@ -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)