mirror of https://github.com/voidlizard/hbs2
56 lines
1.3 KiB
Haskell
56 lines
1.3 KiB
Haskell
{-# Language TemplateHaskell #-}
|
|
{-# Language AllowAmbiguousTypes #-}
|
|
module HBS2.Git.Client.Progress where
|
|
|
|
import HBS2.Git.Client.Prelude
|
|
import HBS2.Git.Data.RefLog
|
|
import HBS2.Git.Data.LWWBlock
|
|
|
|
import HBS2.Git.Data.Tx.Git
|
|
|
|
data Progress a =
|
|
Progress
|
|
{ _progressState :: a
|
|
, _progressTotal :: Maybe a
|
|
}
|
|
deriving (Eq,Generic)
|
|
|
|
makeLenses 'Progress
|
|
|
|
class HasProgress a where
|
|
onProgress :: MonadIO m => a -> ProgressEvent -> m ()
|
|
|
|
data ProgressEvent =
|
|
ImportIdle
|
|
| ImportWaitLWW Int (LWWRefKey 'HBS2Basic)
|
|
| ImportRefLogStart RefLogId
|
|
| ImportRefLogDone RefLogId (Maybe HashRef)
|
|
| ImportWaitTx HashRef
|
|
| ImportScanTx HashRef
|
|
| ImportApplyTx HashRef
|
|
| ImportApplyTxError HashRef (Maybe String)
|
|
| ImportReadBundleChunk BundleMeta (Progress Int)
|
|
| ImportSetQuiet Bool
|
|
| ImportAllDone
|
|
| ExportWriteObject (Progress Int)
|
|
|
|
|
|
data AnyProgress = forall a . HasProgress a => AnyProgress a
|
|
|
|
instance HasProgress AnyProgress where
|
|
onProgress (AnyProgress e) = onProgress e
|
|
|
|
instance HasProgress () where
|
|
onProgress _ _ = pure ()
|
|
|
|
newtype ProgressQ = ProgressQ (TQueue ProgressEvent)
|
|
|
|
instance HasProgress ProgressQ where
|
|
onProgress (ProgressQ q) ev = atomically (writeTQueue q ev)
|
|
|
|
newProgressQ :: MonadUnliftIO m => m ProgressQ
|
|
newProgressQ = ProgressQ <$> newTQueueIO
|
|
|
|
|
|
|