wip

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

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

hbs2-git3/lib/HBS2/Git3/Repo/Fork.hs

@@ -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
-
-

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
+
+

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
+pattern RepoURL3 :: GitRemoteKey -> Syntax C
-isRepoURL = \case
+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
 
 

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:"
-