mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
voidlizard
parent
61cccbd5d5
commit
2e0c0fc879
|
|
@ -185,129 +185,3 @@ silence = do
|
|||
setLoggingOff @WARN
|
||||
setLoggingOff @NOTICE
|
||||
|
||||
|
||||
-- runGitCLI mempty $ do
|
||||
-- env <- ask
|
||||
|
||||
-- flip runContT pure do
|
||||
|
||||
-- lift $ withGitEnv (env & set gitApplyHeads False) do
|
||||
|
||||
-- debug $ red "run" <+> pretty args
|
||||
|
||||
-- sto <- asks _storage
|
||||
-- ip <- asks _progress
|
||||
|
||||
-- importRepoWait puk
|
||||
-- `catch` (\(_ :: ImportRefLogNotFound) -> do
|
||||
-- onProgress ip ImportAllDone
|
||||
-- let url = headMay (catMaybes [ parseURL a | a <- args]) <&> AsBase58
|
||||
-- pause @'Seconds 0.25
|
||||
-- liftIO $ hFlush stderr
|
||||
-- liftIO $ hPutDoc stderr $ ""
|
||||
-- <> ul (yellow "Reference" <+> pretty url <+> yellow "is not available yet.") <> line
|
||||
-- <> "If you sure it's a new one -- make sure you've added the key to hbs2-keyman and then run"
|
||||
-- <> line <> line
|
||||
-- <> "hbs2-keyman update" <> line <> line
|
||||
-- <> "git" <+> pretty hbs2Name <+> "export --new" <+> pretty url <> line <> line
|
||||
-- <> "to init the reflog first." <> line
|
||||
-- <> "Pushing to an existing reflog as a new one may cause unwanted data duplication." <> line
|
||||
-- <> line
|
||||
-- <> "Note: what ever pushed -- can not be unpushed" <> line
|
||||
-- <> "If it's not a new reflog --- just wait until it became available"
|
||||
-- liftIO exitFailure
|
||||
-- )
|
||||
-- `catch` ( \(ImportTxApplyError h) -> do
|
||||
-- onProgress ip ImportAllDone
|
||||
-- pause @'Seconds 0.25
|
||||
-- liftIO $ hFlush stderr
|
||||
-- liftIO $ hPutDoc stderr $ red "Can not apply tx" <+> pretty h <> line <> line
|
||||
-- <> "It means you don't have a key do decrypt this tx or the data is not completely downloaded yet"
|
||||
-- <> line
|
||||
|
||||
-- liftIO exitFailure
|
||||
-- )
|
||||
|
||||
-- void $ runExceptT do
|
||||
|
||||
-- tpush <- newTQueueIO -- @(GitRef, Maybe GitHash)
|
||||
|
||||
-- flip fix Plain $ \next s -> do
|
||||
|
||||
-- eof <- done
|
||||
|
||||
-- when eof $ pure ()
|
||||
|
||||
-- cmd <- ExceptT (try @_ @IOError (getLine <&> words))
|
||||
|
||||
-- debug $ "C:" <+> pretty cmd
|
||||
|
||||
-- case cmd of
|
||||
|
||||
-- [] | s == Plain -> do
|
||||
-- onProgress ip (ImportSetQuiet True)
|
||||
-- pure ()
|
||||
|
||||
-- [] | s == Push -> do
|
||||
-- refs <- atomically (STM.flushTQueue tpush)
|
||||
-- <&> HM.toList . HM.fromList
|
||||
|
||||
-- importRepoWait puk
|
||||
-- export puk refs
|
||||
-- sendLine ""
|
||||
-- next Plain
|
||||
|
||||
-- ["capabilities"] -> do
|
||||
-- debug $ "send capabilities"
|
||||
-- sendLine "push"
|
||||
-- sendLine "fetch"
|
||||
-- sendLine ""
|
||||
-- next Plain
|
||||
|
||||
-- ("list" : _) -> do
|
||||
|
||||
|
||||
-- -- FIXME: may-cause-reference-inconsistency
|
||||
-- -- надо брать max(head) для lwwref
|
||||
-- -- а не максимальную транзу, накаченную на репо
|
||||
-- r' <- runMaybeT do
|
||||
-- -- tx <- selectMaxAppliedTx >>= lift . toMPlus <&> fst
|
||||
|
||||
-- -- (_,rh) <- TX.readRepoHeadFromTx sto tx >>= lift . toMPlus
|
||||
-- rh <- liftIO (withGitEnv env (readActualRepoHeadFor puk))
|
||||
-- >>= toMPlus
|
||||
|
||||
-- pure (view repoHeadRefs rh)
|
||||
|
||||
-- let r = fromMaybe mempty r'
|
||||
|
||||
-- forM_ (fmap (show . formatRef) r) sendLine
|
||||
|
||||
-- sendLine ""
|
||||
|
||||
-- next Plain
|
||||
|
||||
-- ("push" : pargs : _ ) -> do
|
||||
-- (fromRef, toRef) <- orThrowUser "can't parse push" (parsePush pargs)
|
||||
|
||||
-- r <- readProcess (setStderr closed $ shell [qc|git rev-parse {pretty $ fromRef}|])
|
||||
-- <&> headDef "" . LBS8.words . view _2
|
||||
-- <&> fromStringMay @GitHash . LBS8.unpack
|
||||
|
||||
-- let val = const r =<< fromRef
|
||||
|
||||
-- atomically $ writeTQueue tpush (toRef, val)
|
||||
|
||||
-- sendLine [qc|ok {pretty toRef}|]
|
||||
-- next Push
|
||||
|
||||
-- _ -> next Plain
|
||||
|
||||
-- pure ()
|
||||
|
||||
-- `finally` liftIO do
|
||||
-- hPutStrLn stdout "" >> hFlush stdout
|
||||
-- -- notice $ red "BYE"
|
||||
-- hPutStrLn stderr ""
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -30,6 +30,7 @@ import Data.HashPSQ qualified as HPSQ
|
|||
import Data.HashPSQ (HashPSQ)
|
||||
import Data.HashSet (HashSet)
|
||||
import Data.HashSet qualified as HS
|
||||
import Data.HashMap.Strict qualified as HM
|
||||
import Data.List qualified as L
|
||||
import Data.List (sortBy)
|
||||
import Data.List.Split (chunksOf)
|
||||
|
|
@ -53,19 +54,35 @@ data ECC =
|
|||
| ECCWrite Int FilePath Handle Result
|
||||
| ECCFinalize Int Bool FilePath Handle Result
|
||||
|
||||
|
||||
export :: forall m . HBS2GitPerks m => Git3 m ()
|
||||
export = do
|
||||
none
|
||||
|
||||
exportEntries :: forall m . (HBS2GitPerks m) => Id -> MakeDictM C (Git3 m) ()
|
||||
exportEntries prefix = do
|
||||
entry $ bindMatch (prefix <> "export") $ nil_ $ \syn -> lift $ connectedDo do
|
||||
let (opts, argz) = splitOpts [("--dry",0),("--ref",1)] syn
|
||||
let (opts, argz) = splitOpts [("--dry",0),("--ref",1),("--set",2),("--del",1)] syn
|
||||
|
||||
let dry = or [ True | ListVal [StringLike "--dry"] <- opts ]
|
||||
|
||||
let hd = headDef "HEAD" [ x | StringLike x <- argz]
|
||||
h <- gitRevParseThrow hd
|
||||
|
||||
let refs = [ gitNormaliseRef (fromString x)
|
||||
| ListVal [StringLike "--ref", StringLike x] <- opts
|
||||
]
|
||||
refs' <- S.toList_ $ for opts $ \case
|
||||
ListVal [StringLike "--ref", StringLike x] -> do
|
||||
S.yield (gitNormaliseRef (fromString x), h)
|
||||
|
||||
ListVal [StringLike "--set", StringLike x, StringLike what] -> do
|
||||
y <- gitRevParseThrow what
|
||||
S.yield $ (gitNormaliseRef (fromString x), y)
|
||||
|
||||
ListVal [StringLike "--del", StringLike x] -> do
|
||||
S.yield $ (gitNormaliseRef (fromString x), GitHash (BS.replicate 20 0))
|
||||
|
||||
_ -> none
|
||||
|
||||
let refs = HM.toList $ HM.fromList refs'
|
||||
|
||||
tn <- getNumCapabilities
|
||||
|
||||
|
|
@ -197,7 +214,7 @@ exportEntries prefix = do
|
|||
writeTBQueue sourceQ (Just e)
|
||||
|
||||
when (commit == lastCommit) do
|
||||
writeRefSection sourceQ commit refs
|
||||
writeRefSectionSome sourceQ refs
|
||||
|
||||
t0 <- getTimeCoarse
|
||||
ContT $ withAsync $ do
|
||||
|
|
@ -245,7 +262,7 @@ exportEntries prefix = do
|
|||
|
||||
when (exported == 0 && not (L.null refs)) do
|
||||
notice $ "no new segments, but refs" <+> pretty lastCommit
|
||||
writeRefSection sourceQ lastCommit refs
|
||||
writeRefSectionSome sourceQ refs
|
||||
atomically $ modifyTVar _exported succ
|
||||
|
||||
atomically do
|
||||
|
|
@ -264,18 +281,16 @@ exportEntries prefix = do
|
|||
touch path
|
||||
liftIO (IO.appendFile path (show $ e <> line))
|
||||
|
||||
writeRefSection sourceQ commit refs = do
|
||||
|
||||
writeRefSectionSome :: forall m1 . MonadIO m1 => TBQueue (Maybe LBS.ByteString) -> [(GitRef, GitHash)] -> m1 ()
|
||||
writeRefSectionSome sourceQ refsAndCommits = do
|
||||
ts <- liftIO $ getPOSIXTime <&> round
|
||||
|
||||
let brefs = [ LBS8.pack (show $ pretty ts <+> pretty commit <+> pretty x)
|
||||
| x <- refs
|
||||
let brefs = [ LBS8.pack (show $ pretty ts <+> pretty commit <+> pretty ref)
|
||||
| (ref, commit) <- refsAndCommits
|
||||
] & LBS8.unlines
|
||||
|
||||
let sha1 = gitHashBlobPure brefs
|
||||
|
||||
-- debug $ green "THIS IS THE LAST COMMIT BLOCK" <+> pretty commit <+> "ADDING REF INFO" <+> pretty sha1
|
||||
|
||||
let e = [ Builder.byteString (coerce sha1)
|
||||
, Builder.char8 'R'
|
||||
, Builder.lazyByteString brefs
|
||||
|
|
@ -284,6 +299,26 @@ exportEntries prefix = do
|
|||
atomically do
|
||||
writeTBQueue sourceQ (Just e)
|
||||
|
||||
-- writeRefSection sourceQ commit refs = do
|
||||
|
||||
-- ts <- liftIO $ getPOSIXTime <&> round
|
||||
|
||||
-- let brefs = [ LBS8.pack (show $ pretty ts <+> pretty commit <+> pretty x)
|
||||
-- | x <- refs
|
||||
-- ] & LBS8.unlines
|
||||
|
||||
-- let sha1 = gitHashBlobPure brefs
|
||||
|
||||
-- -- debug $ green "THIS IS THE LAST COMMIT BLOCK" <+> pretty commit <+> "ADDING REF INFO" <+> pretty sha1
|
||||
|
||||
-- let e = [ Builder.byteString (coerce sha1)
|
||||
-- , Builder.char8 'R'
|
||||
-- , Builder.lazyByteString brefs
|
||||
-- ] & Builder.toLazyByteString . mconcat
|
||||
|
||||
-- atomically do
|
||||
-- writeTBQueue sourceQ (Just e)
|
||||
|
||||
segmentWriter env bytes_ sourceQ hbs2Q = flip runReaderT env do
|
||||
maxW <- getPackedSegmetSize
|
||||
level <- getCompressionLevel
|
||||
|
|
|
|||
Loading…
Reference in New Issue