From 94b323a8e8ff9812d105477d801a2740afc9a359 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 11 Dec 2020 12:03:40 -0400 Subject: [PATCH] use TotalSize more extensively --- Messages/JSON.hs | 4 ++-- Messages/Progress.hs | 15 ++++++++------- P2P/Protocol.hs | 4 ++-- Types/Messages.hs | 3 +-- Types/Transferrer.hs | 36 ++++++++++++++++++++++++------------ Utility/Metered.hs | 21 +++++++++++---------- 6 files changed, 48 insertions(+), 35 deletions(-) diff --git a/Messages/JSON.hs b/Messages/JSON.hs index d423f62e9d..2b9f6d77a4 100644 --- a/Messages/JSON.hs +++ b/Messages/JSON.hs @@ -134,7 +134,7 @@ complete v _ = add v (Just (HM.empty, True)) -- Show JSON formatted progress, including the current state of the JSON -- object for the action being performed. -progress :: Maybe Object -> Maybe Integer -> BytesProcessed -> IO () +progress :: Maybe Object -> Maybe TotalSize -> BytesProcessed -> IO () progress maction msize bytesprocessed = case j of Object o -> emit $ case maction of @@ -144,7 +144,7 @@ progress maction msize bytesprocessed = where n = fromBytesProcessed bytesprocessed :: Integer j = case msize of - Just size -> object + Just (TotalSize size) -> object [ "byte-progress" .= n , "percent-progress" .= showPercentage 2 (percentage size n) , "total-size" .= size diff --git a/Messages/Progress.hs b/Messages/Progress.hs index 8fd056e901..a315a39220 100644 --- a/Messages/Progress.hs +++ b/Messages/Progress.hs @@ -29,20 +29,20 @@ import Control.Monad.IO.Class (MonadIO) {- Class of things from which a size can be gotten to display a progress - meter. -} class MeterSize t where - getMeterSize :: t -> Annex (Maybe FileSize) + getMeterSize :: t -> Annex (Maybe TotalSize) instance MeterSize t => MeterSize (Maybe t) where getMeterSize Nothing = pure Nothing getMeterSize (Just t) = getMeterSize t instance MeterSize FileSize where - getMeterSize = pure . Just + getMeterSize = pure . Just . TotalSize instance MeterSize Key where - getMeterSize = pure . fromKey keySize + getMeterSize = pure . fmap TotalSize . fromKey keySize instance MeterSize InodeCache where - getMeterSize = pure . Just . inodeCacheFileSize + getMeterSize = pure . Just . TotalSize . inodeCacheFileSize instance MeterSize KeySource where getMeterSize = maybe (pure Nothing) getMeterSize . inodeCache @@ -55,12 +55,13 @@ data KeySizer = KeySizer Key (Annex (Maybe RawFilePath)) instance MeterSize KeySizer where getMeterSize (KeySizer k getsrcfile) = case fromKey keySize k of - Just sz -> return (Just sz) + Just sz -> return (Just (TotalSize sz)) Nothing -> do srcfile <- getsrcfile case srcfile of Nothing -> return Nothing - Just f -> catchMaybeIO $ liftIO $ getFileSize f + Just f -> catchMaybeIO $ liftIO $ + TotalSize <$> getFileSize f {- Shows a progress meter while performing an action. - The action is passed the meter and a callback to use to update the meter. @@ -79,7 +80,7 @@ metered' :: (Monad m, MonadIO m, MonadMask m) => MessageState -> Maybe MeterUpdate - -> Maybe FileSize + -> Maybe TotalSize -> m () -- ^ this should run showOutput -> (Meter -> MeterUpdate -> m a) diff --git a/P2P/Protocol.hs b/P2P/Protocol.hs index a1aa66b581..13d5ea8c3f 100644 --- a/P2P/Protocol.hs +++ b/P2P/Protocol.hs @@ -281,7 +281,7 @@ data LocalF c -- present, runs the protocol action with False. | WaitRefChange (ChangedRefs -> c) -- ^ Waits for one or more git refs to change and returns them.a - | UpdateMeterTotalSize Meter Integer c + | UpdateMeterTotalSize Meter TotalSize c -- ^ Updates the total size of a Meter, for cases where the size is -- not known until the data is being received. | RunValidityCheck (Annex Validity) (Validity -> c) @@ -548,7 +548,7 @@ receiveContent mm p sizer storer mkmsg = do Just (DATA len@(Len l)) -> do local $ case mm of Nothing -> return () - Just m -> updateMeterTotalSize m (n+l) + Just m -> updateMeterTotalSize m (TotalSize (n+l)) ver <- net getProtocolVersion let validitycheck = if ver >= ProtocolVersion 1 then net receiveMessage >>= \case diff --git a/Types/Messages.hs b/Types/Messages.hs index 16d1d24993..d2493d4177 100644 --- a/Types/Messages.hs +++ b/Types/Messages.hs @@ -9,7 +9,6 @@ module Types.Messages where import qualified Utility.Aeson as Aeson import Utility.Metered -import Utility.FileSize import Control.Concurrent import System.Console.Regions (ConsoleRegion) @@ -69,7 +68,7 @@ newMessageState = do data SerializedOutput = OutputMessage S.ByteString | OutputError String - | StartProgressMeter (Maybe FileSize) + | StartProgressMeter (Maybe TotalSize) | UpdateProgressMeter BytesProcessed | EndProgressMeter | StartPrompt diff --git a/Types/Transferrer.hs b/Types/Transferrer.hs index f4b38e7c75..afeda7c5eb 100644 --- a/Types/Transferrer.hs +++ b/Types/Transferrer.hs @@ -12,6 +12,7 @@ import Types.Messages import Git.Types (RemoteName) import qualified Utility.SimpleProtocol as Proto import Utility.Format +import Utility.Metered (TotalSize(..)) import Data.Char @@ -84,7 +85,7 @@ instance Proto.Sendable TransferResponse where ["om", Proto.serialize (encode_c (decodeBS m))] formatMessage (TransferOutput (OutputError e)) = ["oe", Proto.serialize (encode_c e)] - formatMessage (TransferOutput (StartProgressMeter (Just n))) = + formatMessage (TransferOutput (StartProgressMeter (Just (TotalSize n)))) = ["ops", Proto.serialize n] formatMessage (TransferOutput (StartProgressMeter Nothing)) = ["opsx"] @@ -104,17 +105,28 @@ instance Proto.Sendable TransferResponse where ["f"] instance Proto.Receivable TransferResponse where - parseCommand "om" = Proto.parse1 (TransferOutput . OutputMessage . encodeBS . decode_c) - parseCommand "oe" = Proto.parse1 (TransferOutput . OutputError . decode_c) - parseCommand "ops" = Proto.parse1 (TransferOutput . StartProgressMeter . Just) - parseCommand "opsx" = Proto.parse0 (TransferOutput (StartProgressMeter Nothing)) - parseCommand "op" = Proto.parse1 (TransferOutput . UpdateProgressMeter) - parseCommand "ope" = Proto.parse0 (TransferOutput EndProgressMeter) - parseCommand "oprs" = Proto.parse0 (TransferOutput StartPrompt) - parseCommand "opre" = Proto.parse0 (TransferOutput EndPrompt) - parseCommand "oj" = Proto.parse1 (TransferOutput . JSONObject . encodeBL . decode_c) - parseCommand "t" = Proto.parse0 (TransferResult True) - parseCommand "f" = Proto.parse0 (TransferResult False) + parseCommand "om" = Proto.parse1 $ + TransferOutput . OutputMessage . encodeBS . decode_c + parseCommand "oe" = Proto.parse1 $ + TransferOutput . OutputError . decode_c + parseCommand "ops" = Proto.parse1 $ + TransferOutput . StartProgressMeter . Just . TotalSize + parseCommand "opsx" = Proto.parse0 $ + TransferOutput (StartProgressMeter Nothing) + parseCommand "op" = Proto.parse1 $ + TransferOutput . UpdateProgressMeter + parseCommand "ope" = Proto.parse0 $ + TransferOutput EndProgressMeter + parseCommand "oprs" = Proto.parse0 $ + TransferOutput StartPrompt + parseCommand "opre" = Proto.parse0 $ + TransferOutput EndPrompt + parseCommand "oj" = Proto.parse1 $ + TransferOutput . JSONObject . encodeBL . decode_c + parseCommand "t" = Proto.parse0 $ + TransferResult True + parseCommand "f" = Proto.parse0 $ + TransferResult False parseCommand _ = Proto.parseFail instance Proto.Sendable TransferSerializedOutputResponse where diff --git a/Utility/Metered.hs b/Utility/Metered.hs index b4e4024a67..1715f0bf77 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -242,6 +242,7 @@ data OutputHandler = OutputHandler type ProgressParser = String -> (Maybe BytesProcessed, Maybe TotalSize, String) newtype TotalSize = TotalSize Integer + deriving (Show, Eq) {- Runs a command and runs a ProgressParser on its output, in order - to update a meter. @@ -281,8 +282,8 @@ commandMeterExitCode' progressparser oh mmeter meterupdate cmd params mkprocess let s = decodeBS b let (mbytes, mtotalsize, buf') = progressparser (buf++s) sendtotalsize' <- case (sendtotalsize, mtotalsize) of - (Just meter, Just (TotalSize n)) -> do - setMeterTotalSize meter n + (Just meter, Just t) -> do + setMeterTotalSize meter t return Nothing _ -> return sendtotalsize case mbytes of @@ -368,7 +369,7 @@ rateLimitMeterUpdate delta (Meter totalsizev _ _ _) meterupdate = do return $ mu lastupdate where mu lastupdate n@(BytesProcessed i) = readMVar totalsizev >>= \case - Just t | i >= t -> meterupdate n + Just (TotalSize t) | i >= t -> meterupdate n _ -> do now <- getPOSIXTime prev <- takeMVar lastupdate @@ -378,19 +379,19 @@ rateLimitMeterUpdate delta (Meter totalsizev _ _ _) meterupdate = do meterupdate n else putMVar lastupdate prev -data Meter = Meter (MVar (Maybe Integer)) (MVar MeterState) (MVar String) DisplayMeter +data Meter = Meter (MVar (Maybe TotalSize)) (MVar MeterState) (MVar String) DisplayMeter data MeterState = MeterState { meterBytesProcessed :: BytesProcessed , meterTimeStamp :: POSIXTime } deriving (Show) -type DisplayMeter = MVar String -> Maybe Integer -> MeterState -> MeterState -> IO () +type DisplayMeter = MVar String -> Maybe TotalSize -> MeterState -> MeterState -> IO () -type RenderMeter = Maybe Integer -> MeterState -> MeterState -> String +type RenderMeter = Maybe TotalSize -> MeterState -> MeterState -> String -- | Make a meter. Pass the total size, if it's known. -mkMeter :: Maybe Integer -> DisplayMeter -> IO Meter +mkMeter :: Maybe TotalSize -> DisplayMeter -> IO Meter mkMeter totalsize displaymeter = do ts <- getPOSIXTime Meter @@ -399,7 +400,7 @@ mkMeter totalsize displaymeter = do <*> newMVar "" <*> pure displaymeter -setMeterTotalSize :: Meter -> Integer -> IO () +setMeterTotalSize :: Meter -> TotalSize -> IO () setMeterTotalSize (Meter totalsizev _ _ _) = void . swapMVar totalsizev . Just -- | Updates the meter, displaying it if necessary. @@ -446,7 +447,7 @@ bandwidthMeter mtotalsize (MeterState (BytesProcessed old) before) (MeterState ( where amount = roughSize' memoryUnits True 2 new percentamount = case mtotalsize of - Just totalsize -> + Just (TotalSize totalsize) -> let p = showPercentage 0 $ percentage totalsize (min new totalsize) in p ++ replicate (6 - length p) ' ' ++ amount @@ -458,7 +459,7 @@ bandwidthMeter mtotalsize (MeterState (BytesProcessed old) before) (MeterState ( transferred = max 0 (new - old) duration = max 0 (now - before) estimatedcompletion = case mtotalsize of - Just totalsize + Just (TotalSize totalsize) | bytespersecond > 0 -> Just $ fromDuration $ Duration $ (totalsize - new) `div` bytespersecond