diff --git a/hbs2-git3/hbs2-git3.cabal b/hbs2-git3/hbs2-git3.cabal index 360f9b03..42e22afd 100644 --- a/hbs2-git3/hbs2-git3.cabal +++ b/hbs2-git3/hbs2-git3.cabal @@ -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 diff --git a/hbs2-git3/lib/HBS2/Git3/Repo.hs b/hbs2-git3/lib/HBS2/Git3/Repo.hs index d667da71..3ab1cc7a 100644 --- a/hbs2-git3/lib/HBS2/Git3/Repo.hs +++ b/hbs2-git3/lib/HBS2/Git3/Repo.hs @@ -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 diff --git a/hbs2-git3/lib/HBS2/Git3/Repo/Fork.hs b/hbs2-git3/lib/HBS2/Git3/Repo/Fork.hs deleted file mode 100644 index 38795fa0..00000000 --- a/hbs2-git3/lib/HBS2/Git3/Repo/Fork.hs +++ /dev/null @@ -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 - - diff --git a/hbs2-git3/lib/HBS2/Git3/Repo/Init.hs b/hbs2-git3/lib/HBS2/Git3/Repo/Init.hs index 0822aedb..162c229b 100644 --- a/hbs2-git3/lib/HBS2/Git3/Repo/Init.hs +++ b/hbs2-git3/lib/HBS2/Git3/Repo/Init.hs @@ -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 + + diff --git a/hbs2-git3/lib/HBS2/Git3/Repo/Types.hs b/hbs2-git3/lib/HBS2/Git3/Repo/Types.hs index 066cc7cb..422101ca 100644 --- a/hbs2-git3/lib/HBS2/Git3/Repo/Types.hs +++ b/hbs2-git3/lib/HBS2/Git3/Repo/Types.hs @@ -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 diff --git a/hbs2-git3/lib/HBS2/Git3/Run.hs b/hbs2-git3/lib/HBS2/Git3/Run.hs index 7266e00f..cfd5edb1 100644 --- a/hbs2-git3/lib/HBS2/Git3/Run.hs +++ b/hbs2-git3/lib/HBS2/Git3/Run.hs @@ -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:" -