mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
voidlizard
parent
34f61a7bc8
commit
e33d123c52
|
|
@ -125,7 +125,6 @@ library
|
|||
HBS2.Git3.Prelude
|
||||
HBS2.Git3.Export
|
||||
HBS2.Git3.Import
|
||||
HBS2.Git3.Repo.Fork
|
||||
HBS2.Git3.Repo.Init
|
||||
HBS2.Git3.Repo.Types
|
||||
HBS2.Git3.Repo
|
||||
|
|
|
|||
|
|
@ -1,12 +1,44 @@
|
|||
module HBS2.Git3.Repo ( waitRepo
|
||||
, getRepoRefMaybe
|
||||
, getRepoManifest
|
||||
, listRemotes
|
||||
, HasGitRemoteKey(..)
|
||||
, module Exported
|
||||
) where
|
||||
|
||||
import HBS2.Git3.Prelude
|
||||
import HBS2.System.Dir
|
||||
|
||||
import HBS2.Git.Local.CLI
|
||||
import HBS2.Git3.State
|
||||
|
||||
import HBS2.Git3.Repo.Types as Exported
|
||||
import HBS2.Git3.Repo.Init as Exported
|
||||
|
||||
import Data.Config.Suckless
|
||||
|
||||
import Data.Either
|
||||
|
||||
{- HLINT ignore "Functor law" -}
|
||||
|
||||
listRemotes :: MonadIO m => m [(GitRef, GitRepoKey)]
|
||||
listRemotes = do
|
||||
|
||||
git <- findGitDir >>= orThrow NoGitDir
|
||||
|
||||
conf <- liftIO (readFile (git </> "config"))
|
||||
<&> parseTop
|
||||
<&> fromRight mempty
|
||||
|
||||
let urls = flip fix (mempty,Nothing,conf) $ \next -> \case
|
||||
(acc,_, ListVal [SymbolVal "remote", StringLike x] : rest) ->
|
||||
next (acc,Just x, rest)
|
||||
|
||||
(acc, Just x, ListVal [SymbolVal "url", _, RepoURL3 u] : rest) ->
|
||||
next ( (fromString x, u) : acc, Nothing, rest)
|
||||
|
||||
(acc, x, _ : rest) -> next ( acc, x, rest)
|
||||
|
||||
(acc,_,[]) -> acc
|
||||
|
||||
pure urls
|
||||
|
|
|
|||
|
|
@ -1,94 +0,0 @@
|
|||
module HBS2.Git3.Repo.Fork (forkEntries) where
|
||||
|
||||
import HBS2.Git3.Prelude
|
||||
import HBS2.Git3.State
|
||||
import HBS2.Git3.Import
|
||||
import HBS2.Git3.Repo.Init
|
||||
import HBS2.Git3.Git
|
||||
import HBS2.Data.Detect
|
||||
|
||||
import HBS2.Data.Log.Structured
|
||||
|
||||
import HBS2.CLI.Run.Internal.Merkle (createTreeWithMetadata)
|
||||
-- import HBS2.CLI.Run.RefLog (mkRefLogUpdateFrom)
|
||||
|
||||
import HBS2.System.Dir
|
||||
|
||||
import HBS2.Git3.Config.Local
|
||||
import HBS2.Git3.Logger
|
||||
|
||||
import Data.Config.Suckless.Script
|
||||
import Data.Config.Suckless.Almost.RPC
|
||||
|
||||
import Data.Maybe
|
||||
|
||||
import Codec.Compression.Zstd.Streaming qualified as ZstdS
|
||||
import Codec.Compression.Zstd.Streaming (Result(..))
|
||||
import Data.ByteString.Builder as Builder
|
||||
import Data.ByteString.Lazy.Char8 qualified as LBS8
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Fixed
|
||||
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)
|
||||
import Data.Ord (comparing)
|
||||
import Lens.Micro.Platform
|
||||
import Streaming.Prelude qualified as S
|
||||
import System.IO (hPrint)
|
||||
import System.IO qualified as IO
|
||||
import System.IO.Temp as Temp
|
||||
import UnliftIO.Concurrent
|
||||
|
||||
import Text.InterpolatedString.Perl6 (qc)
|
||||
|
||||
forkEntries :: forall m . (HBS2GitPerks m) => Id -> MakeDictM C (Git3 m) ()
|
||||
forkEntries prefix = do
|
||||
|
||||
brief "forks hbs2-git repository"
|
||||
$ desc ("All new repo creation boilerplate:" <> line
|
||||
<> "creates a new sign key,"
|
||||
<+> "creates a new lww reference,"
|
||||
<+> "adds this key to hbs2-keyman," <> line
|
||||
<> "creates default repo manifest")
|
||||
$ args [ arg "key" "repo-ref"
|
||||
]
|
||||
$ examples [qc|
|
||||
hbs2-git repo:fork EvP3kskPVuKuKVMUc3LnfdW7GcFYjz6f5fFU1EGzrdgk
|
||||
|] $
|
||||
entry $ bindMatch (prefix <> "fork") $ nil_ $ \case
|
||||
[ SignPubKeyLike forked ] -> lift do
|
||||
|
||||
connectedDo do
|
||||
waitRepo Nothing forked
|
||||
importGitRefLog
|
||||
|
||||
-- hereGit <- gitDir
|
||||
|
||||
-- when (isJust hereGit) do
|
||||
-- die "This is an existing git repo. Start from scratch, please. Fork operation aborted"
|
||||
|
||||
-- debug $ "call fucking initRepo" <+> pretty [newRepoOpt]
|
||||
|
||||
-- env <- ask
|
||||
-- withGit3Env env do
|
||||
-- initRepo [newRepoOpt]
|
||||
|
||||
-- envNew <- nullGit3Env
|
||||
-- none
|
||||
-- connectedDo do
|
||||
-- notice "SHIT!"
|
||||
-- none
|
||||
|
||||
-- newRepo <- getGitRepoKey >>= orThrowUser "can't create new repo"
|
||||
-- notice $ yellow "new repo key" <+> pretty (AsBase58 newRepo)
|
||||
|
||||
_ -> throwIO $ BadFormException @C nil
|
||||
|
||||
|
||||
|
|
@ -1,9 +1,10 @@
|
|||
{-# Language UndecidableInstances #-}
|
||||
{-# Language AllowAmbiguousTypes #-}
|
||||
module HBS2.Git3.Repo.Init (initRepo,newRepoOpt) where
|
||||
module HBS2.Git3.Repo.Init (initRepo,newRepoOpt,encryptedNewOpt) where
|
||||
|
||||
import HBS2.Git3.Prelude
|
||||
import HBS2.Git3.State
|
||||
import HBS2.Git3.Repo.Types
|
||||
|
||||
import HBS2.System.Dir
|
||||
|
||||
|
|
@ -17,6 +18,7 @@ import Data.Config.Suckless.Almost.RPC
|
|||
|
||||
import Data.ByteString.Lazy.Char8 qualified as LBS8
|
||||
import Data.Word
|
||||
import Data.Text qualified as Text
|
||||
import Lens.Micro.Platform
|
||||
|
||||
import System.Random hiding (next)
|
||||
|
|
@ -35,12 +37,16 @@ data CInit =
|
|||
newRepoOpt :: Syntax C
|
||||
newRepoOpt = mkSym "--new"
|
||||
|
||||
encryptedNewOpt :: Syntax C
|
||||
encryptedNewOpt = mkSym "--encrypted"
|
||||
|
||||
initRepo :: forall m . HBS2GitPerks m => [Syntax C] -> Git3 m ()
|
||||
initRepo syn = do
|
||||
|
||||
let (opts, _) = splitOpts [("--new",0)] syn
|
||||
|
||||
let new = or [ True | ListVal [SymbolVal "--new"] <- opts ]
|
||||
let encrypted = or [ True | ListVal [SymbolVal "--encrypted"] <- opts ]
|
||||
|
||||
callProc "git" ["init"] []
|
||||
|
||||
|
|
@ -71,7 +77,7 @@ initRepo syn = do
|
|||
& lastMay
|
||||
& orThrowUser "can't create new lwwref"
|
||||
|
||||
liftIO $ appendFile root (show $ pretty $ mkForm "repo:ref" [mkSym @C (show $ pretty (AsBase58 pk))])
|
||||
-- liftIO $ appendFile root (show $ pretty $ mkForm "repo:ref" [mkSym @C (show $ pretty (AsBase58 pk))])
|
||||
|
||||
setGitRepoKey pk
|
||||
|
||||
|
|
@ -164,3 +170,11 @@ initRepo syn = do
|
|||
callRpcWaitMay @RpcLWWRefUpdate (TimeoutSec 1) lwwAPI box
|
||||
>>= orThrowUser "rpc timeout"
|
||||
|
||||
let remoteName = "repo-" <> take 4 (show $ pretty (AsBase58 pk))
|
||||
let remoteVal = Text.unpack $ remoteRepoURL pk
|
||||
|
||||
r <- callProc "git" ["remote", "add", remoteName, remoteVal] mempty
|
||||
|
||||
liftIO $ print $ pretty "added git remote" <+> pretty remoteName <+> pretty remoteVal
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -8,10 +8,16 @@ import Data.HashSet qualified as HS
|
|||
import Data.Text qualified as Text
|
||||
|
||||
pattern RepoURL :: GitRemoteKey -> Syntax C
|
||||
pattern RepoURL x <- (isRepoURL -> Just x)
|
||||
pattern RepoURL x <- (isRepoURL [ "hbs2", "hbs23" ] -> Just x)
|
||||
|
||||
isRepoURL :: Syntax C -> Maybe GitRemoteKey
|
||||
isRepoURL = \case
|
||||
pattern RepoURL3 :: GitRemoteKey -> Syntax C
|
||||
pattern RepoURL3 x <- (isRepoURL [ "hbs23" ] -> Just x)
|
||||
|
||||
remoteRepoURL :: GitRemoteKey -> Text
|
||||
remoteRepoURL k = Text.pack $ show $ "hbs23://" <> pretty (AsBase58 k)
|
||||
|
||||
isRepoURL :: [Text] -> Syntax C -> Maybe GitRemoteKey
|
||||
isRepoURL pref = \case
|
||||
TextLike xs -> case mkList @C (fmap mkStr (Text.splitOn "://" xs)) of
|
||||
ListVal [TextLike pref, SignPubKeyLike puk] | pref `HS.member` prefixes -> Just puk
|
||||
_ -> Nothing
|
||||
|
|
@ -19,6 +25,6 @@ isRepoURL = \case
|
|||
_ -> Nothing
|
||||
|
||||
where
|
||||
prefixes = HS.fromList [ "hbs2", "hbs23" ]
|
||||
prefixes = HS.fromList pref
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ import HBS2.Git3.Export
|
|||
import HBS2.Git3.Import
|
||||
import HBS2.Git3.State
|
||||
import HBS2.Git3.Repo qualified as Repo
|
||||
import HBS2.Git3.Repo.Fork (forkEntries)
|
||||
import HBS2.Git3.Repo
|
||||
import HBS2.Git3.Logger
|
||||
|
||||
import Data.Config.Suckless.Script
|
||||
|
|
@ -35,6 +35,7 @@ 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
|
||||
|
|
@ -47,6 +48,8 @@ import System.IO (hPrint)
|
|||
|
||||
import UnliftIO.Concurrent
|
||||
|
||||
{- HLINT ignore "Functor law" -}
|
||||
|
||||
theDict :: forall m . ( HBS2GitPerks m
|
||||
) => Dict C (Git3 m)
|
||||
theDict = do
|
||||
|
|
@ -167,61 +170,6 @@ compression ; prints compression level
|
|||
runConsumeLBS (ZstdL.decompress lbs) $ readLogFileLBS () $ \h s _ -> do
|
||||
liftIO $ print $ "object" <+> pretty h <+> pretty s
|
||||
|
||||
entry $ bindMatch "test:reflog:index:search:binary:test:2" $ nil_ $ const $ lift do
|
||||
r <- newTQueueIO
|
||||
idx <- openIndex
|
||||
enumEntries idx $ \e -> do
|
||||
let ha = GitHash $ coerce $ BS.take 20 e
|
||||
atomically $ writeTQueue r ha
|
||||
|
||||
hashes <- atomically $ STM.flushTQueue r
|
||||
liftIO $ print (length hashes)
|
||||
|
||||
mmaped <- listObjectIndexFiles <&> fmap fst
|
||||
>>= \xs -> for xs $ \x -> liftIO $ mmapFileByteString x Nothing
|
||||
|
||||
already_ <- newTVarIO (mempty :: HashSet GitHash)
|
||||
|
||||
for_ hashes $ \h -> do
|
||||
for_ mmaped $ \bs -> do
|
||||
here <- readTVarIO already_ <&> HS.member h
|
||||
unless here do
|
||||
found <- binarySearchBS 56 ( BS.take 20 . BS.drop 4 ) (coerce h) bs
|
||||
when (isJust found) do
|
||||
atomically $ modifyTVar already_ (HS.insert h)
|
||||
notice $ pretty h <+> "True"
|
||||
|
||||
entry $ bindMatch "test:reflog:index:search:binary:test" $ nil_ $ const $ lift do
|
||||
|
||||
files <- listObjectIndexFiles
|
||||
|
||||
forConcurrently_ files $ \(fn,_) -> do
|
||||
|
||||
lbs <- liftIO $ LBS.readFile fn
|
||||
|
||||
hashes <- S.toList_ $ runConsumeLBS lbs $ flip fix 0 \go n -> do
|
||||
done <- consumed
|
||||
if done then pure ()
|
||||
else do
|
||||
ssize <- readBytesMaybe 4
|
||||
>>= orThrow SomeReadLogError
|
||||
<&> fromIntegral . N.word32 . LBS.toStrict
|
||||
|
||||
hash <- readBytesMaybe 20
|
||||
>>= orThrow SomeReadLogError
|
||||
<&> GitHash . LBS.toStrict
|
||||
|
||||
void $ readBytesMaybe 32
|
||||
|
||||
lift $ S.yield hash
|
||||
go (succ n)
|
||||
|
||||
file <- liftIO $ mmapFileByteString fn Nothing
|
||||
|
||||
for_ hashes $ \h -> do
|
||||
-- found <- binSearchBS 24 (BS.take 20 . BS.drop 4) ( show . pretty . GitHash ) (coerce h) file
|
||||
found <- liftIO $ binarySearchBS 56 (BS.take 20 . BS.drop 4) (coerce h) file
|
||||
liftIO $ notice $ pretty h <+> pretty (isJust found)
|
||||
|
||||
entry $ bindMatch "reflog:index:search" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
|
||||
|
|
@ -455,6 +403,12 @@ compression ; prints compression level
|
|||
|
||||
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
|
||||
p <- importedCheckpoint
|
||||
|
|
@ -518,7 +472,5 @@ repo:ref ; shows current repo key
|
|||
|
||||
exportEntries "reflog:"
|
||||
|
||||
forkEntries "repo:"
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue