mirror of https://github.com/voidlizard/hbs2
620 lines
22 KiB
Haskell
620 lines
22 KiB
Haskell
module HBS2.Git3.Run where
|
|
|
|
import HBS2.Git3.Prelude
|
|
import HBS2.Data.Log.Structured
|
|
|
|
import HBS2.CLI.Run.Internal.Merkle (getTreeContents)
|
|
import HBS2.Data.Detect hiding (Blob)
|
|
import HBS2.System.Dir
|
|
|
|
import HBS2.Git3.Git
|
|
import HBS2.Git3.Export
|
|
import HBS2.Git3.Import
|
|
import HBS2.Git3.State
|
|
import HBS2.Git3.Repo qualified as Repo
|
|
import HBS2.Git3.Repo
|
|
import HBS2.Git3.Logger
|
|
import HBS2.Net.Auth.GroupKeySymm
|
|
|
|
import Data.Config.Suckless.Script
|
|
import Data.Config.Suckless.Almost.RPC
|
|
|
|
import Codec.Compression.Zstd.Lazy qualified as ZstdL
|
|
|
|
import Codec.Compression.Zlib qualified as Zlib
|
|
|
|
import Data.HashPSQ qualified as HPSQ
|
|
|
|
import Data.Maybe
|
|
import Data.ByteString.Lazy.Char8 qualified as LBS8
|
|
import Data.ByteString.Lazy qualified as LBS
|
|
import Data.ByteString qualified as BS
|
|
import Network.ByteOrder qualified as N
|
|
import Text.InterpolatedString.Perl6 (qc)
|
|
import Data.HashSet qualified as HS
|
|
import Data.HashSet (HashSet)
|
|
import Data.HashMap.Strict (HashMap)
|
|
import Data.HashMap.Strict qualified as HM
|
|
import Data.Fixed
|
|
import Data.Either
|
|
import Lens.Micro.Platform
|
|
|
|
import Streaming.Prelude qualified as S
|
|
|
|
import System.Exit qualified as Q
|
|
import Control.Concurrent.STM qualified as STM
|
|
import System.Directory (setCurrentDirectory)
|
|
import System.TimeIt
|
|
import System.IO (hPrint)
|
|
|
|
import UnliftIO.Concurrent
|
|
|
|
{- HLINT ignore "Functor law" -}
|
|
|
|
theDict :: forall m . ( HBS2GitPerks m
|
|
) => Dict C (Git3 m)
|
|
theDict = do
|
|
makeDict @C do
|
|
-- TODO: write-man-entries
|
|
myEntries
|
|
entry $ bindValue "best" (mkInt 22)
|
|
hidden $ internalEntries
|
|
|
|
where
|
|
|
|
myEntries = hidePrefixes ["test", "debug", "segment", "reflog:index"] do
|
|
entry $ bindMatch "--help" $ nil_ $ \case
|
|
HelpEntryBound what -> do
|
|
helpEntry what
|
|
quit
|
|
|
|
[ StringLike x ] -> helpList True (Just x) >> quit
|
|
|
|
_ -> helpList True Nothing >> quit
|
|
|
|
hidden do
|
|
entry $ bindMatch "--help-all" $ nil_ $ \case
|
|
[ StringLike x ] -> helpList False (Just x) >> quit
|
|
_ -> helpList False Nothing >> quit
|
|
|
|
brief "set zstd compression level" do
|
|
examples [qc|
|
|
compression best ; sets compression level to best (22)
|
|
compression 4 ; sets low compression level (faster)
|
|
compression ; prints compression level
|
|
|] do
|
|
entry $ bindMatch "compression" $ nil_ $ \case
|
|
[ LitIntVal n ] -> lift do
|
|
setCompressionLevel (fromIntegral n)
|
|
|
|
[] -> lift do
|
|
co <- getCompressionLevel
|
|
liftIO $ print $ pretty co
|
|
|
|
_ -> throwIO (BadFormException @C nil)
|
|
|
|
entry $ bindMatch "segment" $ nil_ $ \case
|
|
[ LitIntVal n ] -> lift do
|
|
setPackedSegmedSize (fromIntegral n)
|
|
|
|
_ -> throwIO (BadFormException @C nil)
|
|
|
|
entry $ bindMatch "quiet" $ nil_ $ const $ lift do
|
|
silence
|
|
|
|
entry $ bindMatch "index-block-size" $ nil_ \case
|
|
[ LitIntVal size ]-> lift do
|
|
setIndexBlockSize (fromIntegral size)
|
|
|
|
_ -> throwIO (BadFormException @C nil)
|
|
|
|
entry $ bindMatch "git:tree:ls" $ nil_ $ const do
|
|
r <- gitReadTree "HEAD"
|
|
for_ r $ \GitTreeEntry{..} -> do
|
|
liftIO $ print $ pretty gitEntryHash
|
|
<+> pretty gitEntryType
|
|
<+> pretty gitEntrySize
|
|
<+> pretty gitEntryName
|
|
|
|
entry $ bindMatch "debug" $ nil_ $ const do
|
|
setLogging @DEBUG $ toStderr . logPrefix "[debug] "
|
|
|
|
-- hidden do
|
|
|
|
entry $ bindMatch "test:git:normalize-ref" $ nil_ \case
|
|
[ StringLike s ] -> display $ mkStr @C (show $ pretty $ gitNormaliseRef (fromString s))
|
|
_ -> throwIO (BadFormException @C nil)
|
|
|
|
entry $ bindMatch "test:hbs2:peer:poke" $ nil_ $ \syn -> do
|
|
peer <- getClientAPI @PeerAPI @UNIX
|
|
r <- callRpcWaitRetry @RpcPoke (TimeoutSec 0.5) 2 peer () >>= orThrowUser "hbs2-peer not found"
|
|
notice $ pretty r
|
|
|
|
hidden do
|
|
entry $ bindMatch "git:hash:blob" $ nil_ $ const $ liftIO do
|
|
co <- LBS.hGetContents stdin
|
|
print $ pretty $ gitHashBlobPure co
|
|
|
|
entry $ bindMatch "zlib:deflate" $ nil_ $ const $ liftIO do
|
|
LBS.hGetContents stdin <&> Zlib.decompress >>= LBS.hPutStr stdout
|
|
|
|
entry $ bindMatch "test:git:read-commit-chain" $ nil_ $ \syn -> lift do
|
|
(mpath, hss) <- case syn of
|
|
[ HashLike s ] -> pure (Nothing, s)
|
|
[ StringLike path , HashLike s ] -> pure (Just path, s)
|
|
[ StringLike path ] -> pure (Just path, "HEAD")
|
|
[] -> pure (Nothing, "HEAD")
|
|
_ -> throwIO (BadFormException @C nil)
|
|
|
|
void $ flip runContT pure do
|
|
|
|
liftIO $ mapM_ setCurrentDirectory mpath
|
|
|
|
idx <- lift openIndex
|
|
|
|
let req h = lift $ indexEntryLookup idx h <&> isNothing
|
|
|
|
-- let hss = headDef "HEAD" [ x | StringLike x <- snd (splitOpts [] syn) ]
|
|
h <- gitRevParseThrow hss
|
|
r <- lift $ readCommitChainHPSQ req Nothing h dontHandle
|
|
|
|
for_ (HPSQ.toList r) $ \(k,_,_) -> do
|
|
liftIO $ print $ pretty k
|
|
|
|
entry $ bindMatch "test:git:log:list" $ nil_ $ \syn -> do
|
|
let (_, argz) = splitOpts [] syn
|
|
|
|
let fs = [fn | StringLike fn <- argz]
|
|
|
|
for_ fs $ \f -> do
|
|
lbs <- liftIO$ LBS.readFile f
|
|
runConsumeLBS (ZstdL.decompress lbs) $ readLogFileLBS () $ \h s _ -> do
|
|
liftIO $ print $ "object" <+> pretty h <+> pretty s
|
|
|
|
|
|
entry $ bindMatch "reflog:index:search" $ nil_ $ \syn -> lift $ connectedDo do
|
|
|
|
let (_, argz) = splitOpts [] syn
|
|
|
|
hash <- case argz of
|
|
[ x@StringLike{}, GitHashLike h ] -> do
|
|
resolveRepoKeyThrow [x] >>= setGitRepoKey
|
|
waitRepo Nothing =<< getGitRepoKeyThrow
|
|
pure h
|
|
|
|
_ -> throwIO $ BadFormException @C nil
|
|
|
|
idx <- openIndex
|
|
|
|
answ <- indexEntryLookup idx hash
|
|
|
|
for_ answ $ \bs -> do
|
|
let a = coerce (BS.take 32 bs) :: HashRef
|
|
liftIO $ print $ pretty a
|
|
|
|
entry $ bindMatch "test:segment:dump" $ nil_ $ \syn -> lift do
|
|
sto <- getStorage
|
|
let (_, argz) = splitOpts [] syn
|
|
tree <- headMay [ x | HashLike x <- argz ] & orThrowUser "tree hash required"
|
|
|
|
lbs <- runExceptT (getTreeContents sto tree) >>= orThrowPassIO
|
|
|
|
runConsumeLBS (ZstdL.decompress lbs) $ readLogFileLBS () $ \h s obs -> do
|
|
let (t, body) = LBS.splitAt 1 obs
|
|
|
|
let tp = fromStringMay @(Short GitObjectType) (LBS8.unpack t)
|
|
& maybe Blob coerce
|
|
|
|
liftIO $ print $ pretty h <+> fill 8 (viaShow tp) <+> pretty s
|
|
|
|
entry $ bindMatch "test:segment:dump:pack" $ nil_ $ \syn -> lift do
|
|
let (opts, argz) = splitOpts [ ("--dir",1)] syn
|
|
let dir = headDef "." [ p | ListVal [StringLike "--dir", StringLike p] <- opts ]
|
|
let trees = [ x | HashLike x <- argz ]
|
|
for_ trees $ \tree -> do
|
|
writeAsGitPack dir tree
|
|
|
|
entry $ bindMatch "reflog:index:list:count" $ nil_ $ const $ lift $ connectedDo do
|
|
idx <- openIndex
|
|
num_ <- newIORef 0
|
|
enumEntries idx $ \_ -> void $ atomicModifyIORef num_ (\x -> (succ x, x))
|
|
readIORef num_ >>= liftIO . print . pretty
|
|
|
|
entry $ bindMatch "reflog:index:list" $ nil_ $ const $ lift $ connectedDo do
|
|
files <- listObjectIndexFiles
|
|
for_ files $ \(ifn,_) -> do
|
|
lbs <- liftIO $ LBS.readFile ifn
|
|
|
|
void $ runConsumeLBS lbs $ readSections $ \s ss -> do
|
|
|
|
let (sha1, blake) = LBS.splitAt 20 ss
|
|
& over _1 (coerce @_ @GitHash . LBS.toStrict)
|
|
& over _2 (coerce @_ @HashRef . LBS.toStrict)
|
|
|
|
liftIO $ hPrint stdout $ pretty sha1 <+> pretty blake
|
|
|
|
entry $ bindMatch "reflog:index:check" $ nil_ $ \case
|
|
[ StringLike fn ] -> lift do
|
|
bs <- liftIO $ mmapFileByteString fn Nothing
|
|
|
|
unless (validateSorted bs) do
|
|
error "malformed"
|
|
|
|
_ -> throwIO (BadFormException @C nil)
|
|
|
|
entry $ bindMatch "reflog:index:compact" $ nil_ $ \_ -> lift $ connectedDo do
|
|
size <- getIndexBlockSize
|
|
compactIndex size
|
|
|
|
entry $ bindMatch "reflog:index:path" $ nil_ $ const $ lift $ connectedDo do
|
|
indexPath >>= liftIO . print . pretty
|
|
|
|
-- let entriesListOf lbs = S.toList_ $ runConsumeLBS lbs $ readSections $ \s ss -> do
|
|
entry $ bindMatch "reflog:index:files" $ nil_ $ \syn -> lift $ connectedDo do
|
|
files <- listObjectIndexFiles
|
|
cur <- pwd
|
|
for_ files $ \(f',s) -> do
|
|
let f = makeRelative cur f'
|
|
liftIO $ print $ fill 10 (pretty s) <+> pretty f
|
|
|
|
entry $ bindMatch "reflog:index:list:tx" $ nil_ $ \syn -> lift $ connectedDo do
|
|
resolveRepoKeyThrow syn >>= setGitRepoKey
|
|
waitRepo Nothing =<< getGitRepoKeyThrow
|
|
r <- newIORef ( mempty :: HashSet HashRef )
|
|
index <- openIndex
|
|
enumEntries index $ \bs -> do
|
|
let h = coerce $ BS.take 32 $ BS.drop 20 bs
|
|
-- here <- readIORef r <&> HS.member h
|
|
-- unless here do
|
|
atomicModifyIORef' r ( \x -> (HS.insert h x, ()))
|
|
z <- readIORef r <&> HS.toList
|
|
for_ z $ \h ->do
|
|
liftIO $ print $ pretty h
|
|
|
|
entry $ bindMatch "reflog:index:build" $ nil_ $ \syn -> lift $ connectedDo do
|
|
resolveRepoKeyThrow syn >>= setGitRepoKey
|
|
waitRepo Nothing =<< getGitRepoKeyThrow
|
|
updateReflogIndex
|
|
|
|
entry $ bindMatch "test:reflog:index:lookup" $ nil_ \case
|
|
[ GitHashLike h ] -> lift do
|
|
idx <- openIndex
|
|
what <- indexEntryLookup idx h >>= orThrowUser "object not found"
|
|
liftIO $ print $ pretty ( coerce @_ @HashRef what )
|
|
|
|
_ -> throwIO (BadFormException @C nil)
|
|
|
|
entry $ bindMatch "git:commit:list:objects:new" $ nil_ $ \case
|
|
[ StringLike what ] -> lift $ connectedDo do
|
|
|
|
commit <- gitRevParseThrow what
|
|
|
|
updateReflogIndex
|
|
|
|
idx <- openIndex
|
|
|
|
-- let req h = lift $ indexEntryLookup idx h <&> isNothing
|
|
|
|
flip runContT pure do
|
|
cap <- liftIO getNumCapabilities
|
|
gitCatBatchQ <- contWorkerPool cap do
|
|
che <- ContT withGitCat
|
|
pure $ gitReadObjectMaybe che
|
|
|
|
new_ <- newTQueueIO
|
|
c1 <- newCacheFixedHPSQ 1000
|
|
|
|
(_,self) <- lift $ gitCatBatchQ commit
|
|
>>= orThrow (GitReadError (show $ pretty commit))
|
|
|
|
tree <- gitReadCommitTree self
|
|
|
|
-- читаем только те объекты, которые не в индексе
|
|
hashes <- gitReadTreeObjectsOnly commit
|
|
<&> ([commit,tree]<>)
|
|
>>= lift . indexFilterNewObjects idx . HS.fromList
|
|
--
|
|
atomically $ mapM_ (writeTQueue new_) hashes
|
|
atomically (STM.flushTQueue new_) >>= liftIO . print . pretty . length
|
|
|
|
_ -> throwIO (BadFormException @C nil)
|
|
|
|
entry $ bindMatch "git:list:objects:new" $ nil_ $ \syn -> lift $ connectedDo do
|
|
let (opts,argz) = splitOpts [] syn
|
|
|
|
let what = headDef "HEAD" [ x | StringLike x <- argz ]
|
|
|
|
h0 <- gitRevParseThrow what
|
|
|
|
no_ <- newTVarIO 0
|
|
|
|
void $ flip runContT pure do
|
|
|
|
lift updateReflogIndex
|
|
|
|
idx <- lift openIndex
|
|
let req h = lift $ indexEntryLookup idx h <&> isNothing
|
|
|
|
(t1,r) <- timeItT (lift $ readCommitChainHPSQ req Nothing h0 dontHandle)
|
|
|
|
let s = HPSQ.size r
|
|
debug $ pretty s <+> "new commits read at" <+> pretty (realToFrac @_ @(Fixed E3) t1)
|
|
|
|
cap <- liftIO getNumCapabilities
|
|
gitCatBatchQ <- contWorkerPool cap do
|
|
che <- ContT withGitCat
|
|
pure $ gitReadObjectMaybe che
|
|
|
|
uniq_ <- newTVarIO mempty
|
|
-- c1 <- newCacheFixedHPSQ 1000
|
|
(t3, _) <- timeItT $ lift $ forConcurrently_ (HPSQ.toList r) $ \(commit,_,_) -> do
|
|
|
|
(_,self) <- gitCatBatchQ commit
|
|
>>= orThrow (GitReadError (show $ pretty commit))
|
|
|
|
tree <- gitReadCommitTree self
|
|
|
|
-- читаем только те объекты, которые не в индексе
|
|
gitReadTreeObjectsOnly commit
|
|
<&> ([commit,tree]<>)
|
|
>>= \hs -> atomically (for_ hs (modifyTVar uniq_ . HS.insert))
|
|
|
|
debug $ "read new objects" <+> pretty (realToFrac @_ @(Fixed E2) t3)
|
|
|
|
(t4,new) <- lift $ timeItT $ readTVarIO uniq_ >>= indexFilterNewObjects idx
|
|
|
|
liftIO $ for_ new $ \n -> do
|
|
print $ pretty n
|
|
-- notice $ pretty (length new) <+> "new objects" <+> "at" <+> pretty (realToFrac @_ @(Fixed E2) t4)
|
|
|
|
|
|
entry $ bindMatch "reflog:tx:list:imported" $ nil_ $ \syn -> lift $ connectedDo do
|
|
resolveRepoKeyThrow syn >>= setGitRepoKey
|
|
waitRepo Nothing =<< getGitRepoKeyThrow
|
|
txImported >>= liftIO . print . vcat . (fmap pretty) . HS.toList
|
|
|
|
let (opts, argz) = splitOpts [ ("--checkpoints",0)
|
|
, ("--segments",0)
|
|
] syn
|
|
|
|
let cpOnly = or [ True | ListVal [StringLike "--checkpoints"] <- opts ]
|
|
let sOnly = or [ True | ListVal [StringLike "--segments"] <- opts ]
|
|
|
|
resolveRepoKeyThrow argz >>= setGitRepoKey
|
|
waitRepo Nothing =<< getGitRepoKeyThrow
|
|
|
|
hxs <- txListAll Nothing
|
|
|
|
liftIO $ forM_ hxs $ \(h,tx) -> do
|
|
let decoded = case tx of
|
|
TxSegment x | not cpOnly ->
|
|
Just ("S" <+> fill 44 (pretty h) <+> fill 44 (pretty x))
|
|
|
|
TxCheckpoint n x | not sOnly ->
|
|
Just ("C" <+> fill 44 (pretty h) <+> pretty x <+> fill 8 (pretty n))
|
|
|
|
_ -> Nothing
|
|
|
|
forM_ decoded print
|
|
|
|
|
|
entry $ bindMatch "reflog:tx:list" $ nil_ $ \syn -> lift $ connectedDo do
|
|
|
|
let (opts, argz) = splitOpts [ ("--checkpoints",0)
|
|
, ("--segments",0)
|
|
] syn
|
|
|
|
let cpOnly = or [ True | ListVal [StringLike "--checkpoints"] <- opts ]
|
|
let sOnly = or [ True | ListVal [StringLike "--segments"] <- opts ]
|
|
|
|
resolveRepoKeyThrow argz >>= setGitRepoKey
|
|
waitRepo Nothing =<< getGitRepoKeyThrow
|
|
|
|
hxs <- txListAll Nothing
|
|
|
|
liftIO $ forM_ hxs $ \(h,tx) -> do
|
|
let decoded = case tx of
|
|
TxSegment x | not cpOnly ->
|
|
Just ("S" <+> fill 44 (pretty h) <+> fill 44 (pretty x))
|
|
|
|
TxCheckpoint n x | not sOnly ->
|
|
Just ("C" <+> fill 44 (pretty h) <+> pretty x <+> fill 8 (pretty n))
|
|
|
|
_ -> Nothing
|
|
|
|
forM_ decoded print
|
|
|
|
entry $ bindMatch "reflog:refs" $ nil_ $ \syn -> lift $ connectedDo do
|
|
|
|
resolveRepoKeyThrow syn >>= setGitRepoKey
|
|
waitRepo Nothing =<< getGitRepoKeyThrow
|
|
|
|
rrefs <- importedRefs
|
|
for_ rrefs $ \(r,h) -> do
|
|
liftIO $ print $ fill 20 (pretty h) <+> pretty r
|
|
|
|
entry $ bindMatch "reflog:refs:raw" $ nil_ $ \syn -> lift $ connectedDo do
|
|
resolveRepoKeyThrow syn >>= setGitRepoKey
|
|
waitRepo Nothing =<< getGitRepoKeyThrow
|
|
|
|
refsFiles >>= readRefsRaw >>= liftIO . mapM_ (print . pretty)
|
|
|
|
entry $ bindMatch "repo:wait" $ nil_ $ \syn -> lift $ connectedDo do
|
|
resolveRepoKeyThrow syn >>= setGitRepoKey
|
|
waitRepo Nothing =<< getGitRepoKeyThrow
|
|
|
|
getRepoManifest >>= liftIO . print . pretty . mkForm "manifest" . coerce
|
|
|
|
entry $ bindMatch "repo:remotes" $ nil_ $ \syn -> lift do
|
|
|
|
remotes <- listRemotes
|
|
|
|
liftIO $ for_ remotes $ \(r,k) -> do
|
|
print $ fill 44 (pretty (AsBase58 k)) <+> pretty r
|
|
|
|
entry $ bindMatch "reflog:imported" $ nil_ $ \syn -> lift $ connectedDo do
|
|
resolveRepoKeyThrow syn >>= setGitRepoKey
|
|
waitRepo Nothing =<< getGitRepoKeyThrow
|
|
p <- importedCheckpoint
|
|
liftIO $ print $ pretty p
|
|
|
|
entry $ bindMatch "reflog:import" $ nil_ $ \syn -> lift $ connectedDo do
|
|
resolveRepoKeyThrow syn >>= setGitRepoKey
|
|
waitRepo Nothing =<< getGitRepoKeyThrow
|
|
importGitRefLog
|
|
|
|
brief "shows repo manifest" $
|
|
entry $ bindMatch "repo:manifest" $ nil_ $ \syn -> lift $ connectedDo do
|
|
resolveRepoKeyThrow syn >>= setGitRepoKey
|
|
manifest <- Repo.getRepoManifest
|
|
liftIO $ print $ pretty $ mkForm "manifest" (coerce manifest)
|
|
|
|
brief "shows repo reflog" $
|
|
entry $ bindMatch "repo:reflog" $ nil_ $ const $ lift $ connectedDo do
|
|
repo <- Repo.getRepoManifest
|
|
|
|
reflog <- getRefLog repo & orThrow GitRepoManifestMalformed
|
|
|
|
liftIO $ print $ pretty (AsBase58 reflog)
|
|
|
|
entry $ bindMatch "repo:credentials" $ nil_ $ \syn -> lift $ connectedDo $ do
|
|
resolveRepoKeyThrow syn >>= setGitRepoKey
|
|
waitRepo (Just 10) =<< getGitRepoKeyThrow
|
|
|
|
(p,_) <- getRepoRefLogCredentials
|
|
liftIO $ print $ pretty $ mkForm @C "matched" [mkSym (show $ pretty ( AsBase58 p) )]
|
|
|
|
entry $ bindMatch "repo:gk" $ nil_ $ \syn -> lift $ connectedDo $ do
|
|
resolveRepoKeyThrow syn >>= setGitRepoKey
|
|
gk' <- getGK
|
|
for_ gk' $ \(gkh, _) -> do
|
|
liftIO $ print $ pretty $ mkForm @C "gk" [ mkSym (show $ pretty gkh) ]
|
|
|
|
brief "updates group key for repo" $
|
|
args [arg "string" "repo", arg "hash" "group-key-hash" ] $
|
|
entry $ bindMatch "repo:gk:update" $ nil_ $ \case
|
|
[ x@(StringLike{}), HashLike h ] -> lift $ connectedDo do
|
|
repo <- resolveRepoKeyThrow [x]
|
|
updateGroupKey repo h
|
|
|
|
_ -> throwIO $ BadFormException @C nil
|
|
|
|
entry $ bindMatch "repo:gk:add:extra:keys" $ nil_ $ \case
|
|
( x@(StringLike{}) : keyHashes ) -> lift $ connectedDo do
|
|
repo <- resolveRepoKeyThrow [x]
|
|
setGitRepoKey repo
|
|
waitRepo (Just 10) =<< getGitRepoKeyThrow
|
|
|
|
sto <- getStorage
|
|
RepoManifest mf <- getRepoManifest
|
|
|
|
hh <- for [ x | HashLike x <- keyHashes ] $ \k -> do
|
|
_ <- loadGroupKeyMaybe @HBS2Basic sto k >>= orThrow (GitRepoNoGroupKey k)
|
|
pure k
|
|
|
|
updateRepoHead repo mf hh
|
|
|
|
_ -> throwIO $ BadFormException @C nil
|
|
|
|
|
|
-- FIXME: maybe-add-default-remote
|
|
entry $ bindMatch "repo:head" $ nil_ $ \syn -> lift $ connectedDo $ do
|
|
resolveRepoKeyThrow syn >>= setGitRepoKey
|
|
waitRepo Nothing =<< getGitRepoKeyThrow
|
|
lww <- getRepoRefMaybe
|
|
liftIO $ print $ pretty lww
|
|
|
|
entry $ bindMatch "repo:gk:journal:import" $ nil_ $ \syn -> lift $ connectedDo $ do
|
|
resolveRepoKeyThrow syn >>= setGitRepoKey
|
|
waitRepo Nothing =<< getGitRepoKeyThrow
|
|
importGroupKeys
|
|
|
|
entry $ bindMatch "repo:gk:journal:imported" $ nil_ $ \syn -> lift $ connectedDo $ do
|
|
resolveRepoKeyThrow syn >>= setGitRepoKey
|
|
waitRepo Nothing =<< getGitRepoKeyThrow
|
|
readGroupKeyFile <&> maybe nil (mkSym @C . show . pretty)
|
|
>>= liftIO . print . pretty
|
|
|
|
entry $ bindMatch "repo:gk:journal" $ nil_ $ \syn -> lift $ connectedDo $ do
|
|
resolveRepoKeyThrow syn >>= setGitRepoKey
|
|
waitRepo Nothing =<< getGitRepoKeyThrow
|
|
|
|
ref <- getGitRepoKeyThrow
|
|
|
|
lwwAPI <- getClientAPI @LWWRefAPI @UNIX
|
|
|
|
sto <- getStorage
|
|
|
|
runMaybeT do
|
|
|
|
LWWRef{..} <- liftIO (callRpcWaitMay @RpcLWWRefGet (TimeoutSec 1) lwwAPI (coerce ref))
|
|
>>= orThrow RpcTimeout
|
|
>>= toMPlus
|
|
|
|
hrefs <- lift $ readLogThrow (getBlock sto) lwwValue
|
|
|
|
journal <- headMay (tail hrefs) & toMPlus
|
|
|
|
keys <- lift $ readLogThrow (getBlock sto) journal
|
|
|
|
liftIO $ for_ keys $ \k -> do
|
|
liftIO $ print $ pretty k
|
|
|
|
|
|
let initExamples = [qc|
|
|
; just init a new repository
|
|
|
|
hbs2-git init --new
|
|
|
|
; init encrypted repository
|
|
|
|
; create new group key:
|
|
; your real keys will be different
|
|
; all hashes/keys appear in exampels/logs a PUBLIC information,
|
|
; so no secrets disclosures.
|
|
|
|
hbs2-cli hbs2:groupkey:store [hbs2:groupkey:create 67CRxnoQWasQsY9iidjJDYXSTKEZkpSVgDQYweWuhfd3]
|
|
39baH7SqqsAGgCSr3k9RJgY4nTwiMRXrgZUmKPFndzn8
|
|
|
|
|
|
hbs2-git init --new --encrypted 39baH7SqqsAGgCSr3k9RJgY4nTwiMRXrgZUmKPFndzn8
|
|
|
|
added git remote laundry-worry hbs23://7F1D7QGVVwJFJ649dsSHgrDUuqHYti3nkFx<censored>
|
|
updateRepoKey 7F1D7QGVVwJFJ649dsSHgrDUuqHYti3nkFx<censored>
|
|
|
|
git remote
|
|
|
|
laundry-worry
|
|
^^^^^^^^^^^^^
|
|
|
|
This is the git remote for the new repo. Rename it if you want.
|
|
|
|
hbs2-git3 repo:remotes
|
|
7F1D7QGVVwJFJ649dsSHgrDUuqHYti3nkFx<censored> laundry-worry
|
|
|
|
|
|
|]
|
|
let initMan = brief "initializes a new repository"
|
|
. args [ arg "new repository flag" "--new"
|
|
, arg "group key hash for encrypted repository" "<--encrypted group-key>"
|
|
]
|
|
. examples initExamples
|
|
|
|
initMan $
|
|
entry $ bindMatch "repo:init" $ nil_ $ \syn -> lift $ connectedDo do
|
|
Repo.initRepo syn
|
|
|
|
initMan $ entry $
|
|
bindAlias "init" "repo:init"
|
|
|
|
entry $ bindMatch "repo:relay-only" $ nil_ $ \case
|
|
[ SignPubKeyLike repo ] -> lift $ connectedDo do
|
|
setGitRepoKey repo
|
|
waitRepo (Just 10) =<< getGitRepoKeyThrow
|
|
|
|
_ -> throwIO (BadFormException @C nil)
|
|
|
|
exportEntries "reflog:"
|
|
|
|
|