wip

hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs

@@ -105,23 +105,26 @@ groupKeyEntries = do
 
     _ -> throwIO $ BadFormException @C nil
 
-  entry $ bindMatch "hbs2:groupkey:create" $ \syn -> do
-    case syn of
-      [ListVal (StringLikeList keys)] -> do
-        s <- groupKeyFromKeyList  keys
-                <&> AsGroupKeyFile
-                <&> show . pretty
+  brief "create group key" $
+    args [ arg "keys" "list" ] $
+    desc "list of encryption public keys of members" $
+    entry $ bindMatch "hbs2:groupkey:create" $ \syn -> do
+      case syn of
+        [ListVal (StringLikeList keys)] -> do
+          s <- groupKeyFromKeyList  keys
+                  <&> AsGroupKeyFile
+                  <&> show . pretty
 
-        pure $ mkStr s
+          pure $ mkStr s
 
-      StringLikeList keys -> do
-        s <- groupKeyFromKeyList  keys
-                <&> AsGroupKeyFile
-                <&> show . pretty
+        StringLikeList keys -> do
+          s <- groupKeyFromKeyList  keys
+                  <&> AsGroupKeyFile
+                  <&> show . pretty
 
-        pure $ mkStr s
+          pure $ mkStr s
 
-      _ -> throwIO $ BadFormException @C nil
+        _ -> throwIO $ BadFormException @C nil
 
 
   entry $ bindMatch "hbs2:groupkey:dump" $ nil_ $ \syn -> do

hbs2-git3/hbs2-git3.cabal

@@ -126,6 +126,7 @@ library
       HBS2.Git3.Export
       HBS2.Git3.Import
       HBS2.Git3.Repo.Init
+      HBS2.Git3.Repo.Tools
       HBS2.Git3.Repo.Types
       HBS2.Git3.Repo
       HBS2.Git3.Run
@@ -142,6 +143,8 @@ library
 
       HBS2.Data.Log.Structured
 
+      Crypto.Bip39
+
     build-depends:    base
                     , base16-bytestring
                     , binary

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

@@ -1,44 +1,14 @@
 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 HBS2.Git3.Repo.Tools 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/Init.hs

@@ -5,11 +5,13 @@ module HBS2.Git3.Repo.Init (initRepo,newRepoOpt,encryptedNewOpt) where
 import HBS2.Git3.Prelude
 import HBS2.Git3.State
 import HBS2.Git3.Repo.Types
+import HBS2.Git3.Repo.Tools
 
 import HBS2.System.Dir
 
 import HBS2.CLI.Run.MetaData
 import HBS2.Net.Auth.Credentials
+import HBS2.Net.Auth.GroupKeySymm
 
 import HBS2.KeyMan.Keys.Direct
 
@@ -18,7 +20,9 @@ import Data.Config.Suckless.Almost.RPC
 
 import Data.ByteString.Lazy.Char8 qualified as LBS8
 import Data.Word
+import Data.Maybe
 import Data.Text qualified as Text
+import Data.HashMap.Strict qualified as HM
 import Lens.Micro.Platform
 
 import System.Random hiding (next)
@@ -40,13 +44,15 @@ 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 (opts, _) = splitOpts [("--new",0),("--encrypted",1)] syn
 
   let new = or [ True | ListVal [SymbolVal "--new"] <- opts ]
-  let encrypted = or [ True | ListVal [SymbolVal "--encrypted"] <- opts ]
+  let gkh = lastMay [ gk | ListVal [SymbolVal "--encrypted", HashLike gk] <- opts ]
 
   callProc "git" ["init"] []
 
@@ -142,12 +148,23 @@ initRepo syn = do
       callRpcWaitMay @RpcPollAdd (TimeoutSec 1) peerAPI (rpk, "reflog", 17)
          >>= orThrowUser "rpc timeout"
 
+      (gkf, gkblk) <- case gkh of
+               Nothing -> pure mempty
+               Just h  -> do
+                _ <- loadGroupKeyMaybe @'HBS2Basic sto h >>= orThrow (GroupKeyNotFound 1)
+
+                let gkPart = maybeToList gkh
+                let gkTree = toPTree (MaxSize defHashListChunk) (MaxNum defTreeChildNum) gkPart
+                gkblk <- makeMerkle 0 gkTree $ \(_,_,bs) -> do
+                          void $ putBlock sto bs
+                pure ([ mkForm "gk" [mkSym (show $ pretty (AsBase58 h)) ] ], [HashRef gkblk] )
+
       let manifest = [
              mkForm @C "hbs2-git" [mkInt 3]
            , mkForm "seed" [mkInt seed]
            , mkForm "public" []
            , mkForm "reflog" [mkSym (show $ pretty (AsBase58 rpk))]
-           ]
+           ] <> gkf
 
       let mfs =  vcat $ fmap pretty manifest
 
@@ -156,7 +173,7 @@ initRepo syn = do
 
       liftIO $ print  $ pretty $ mkForm "manifest" manifest
 
-      let pt = toPTree (MaxSize defHashListChunk) (MaxNum defTreeChildNum) [tree]
+      let pt = toPTree (MaxSize defHashListChunk) (MaxNum defTreeChildNum) ( tree : gkblk )
 
       blk <- makeMerkle 0 pt $ \(_,_,bs) -> do
                 void $ putBlock sto bs
@@ -170,7 +187,7 @@ initRepo syn = do
       callRpcWaitMay @RpcLWWRefUpdate (TimeoutSec 1) lwwAPI box
          >>= orThrowUser "rpc timeout"
 
-      let remoteName = "repo-" <> take 4 (show $ pretty (AsBase58 pk))
+      remoteName <- newRemoteName pk <&> show .pretty
       let remoteVal  = Text.unpack $ remoteRepoURL pk
 
       r <- callProc "git" ["remote", "add", remoteName, remoteVal] mempty

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

@@ -0,0 +1,84 @@
+{-# Language UndecidableInstances #-}
+{-# Language AllowAmbiguousTypes #-}
+module HBS2.Git3.Repo.Tools where
+
+import HBS2.Git3.Prelude
+import HBS2.Git3.State
+import HBS2.Git3.Repo.Types
+
+import HBS2.System.Dir
+
+import HBS2.Git.Local.CLI
+
+import Data.Config.Suckless.Script
+
+import Control.Applicative
+import Crypto.Bip39
+import Data.ByteString.Lazy.Char8 qualified as LBS8
+import Data.ByteString.Lazy qualified as LBS
+import Data.Either
+import Data.HashMap.Strict qualified as HM
+import Data.Maybe
+import Data.Text qualified as Text
+import Data.Word
+import Lens.Micro.Platform
+import System.Random hiding (next)
+
+
+{- 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
+
+resolveRepoKeyThrow :: MonadIO m => [Syntax C] -> m GitRepoKey
+resolveRepoKeyThrow = \case
+  [ SignPubKeyLike url ] -> pure url
+  [ RepoURL url ]  -> pure url
+  [ StringLike x ] -> do
+    refs <- listRemotes
+    lookup (fromString x) refs &  orThrow (GitRemoteKeyNotResolved x)
+  x -> throwIO (GitRemoteKeyNotResolved (show $ pretty (mkList x)))
+
+newRemoteName :: MonadIO m => GitRepoKey -> m GitRef
+newRemoteName key = do
+  refs <- listRemotes <&> HM.fromList
+
+  flip fix Nothing $ \again i -> do
+
+    when (i > Just 128) $ throwIO GitCantGenerateRemoteName
+
+    suff <- case i of
+              Nothing -> pure mempty
+              Just _ -> do
+                p <- randomIO @Word8 <&> Text.pack . show
+                pure $ "-" <> p
+
+    name <- toMnemonic (LBS.toStrict . LBS.drop 8 $ serialise key)
+                &   orThrow GitCantGenerateRemoteName
+                <&> Text.intercalate "-" . take 2 . Text.words
+                <&> (<> suff)
+                <&> fromString @GitRef . Text.unpack
+
+    if not (HM.member name refs) then pure name
+    else again (succ <$> ( i <|> Just 0) )
+
+

hbs2-git3/lib/HBS2/Git3/Run.hs

@@ -411,14 +411,17 @@ compression      ;  prints compression level
             print $ fill 44 (pretty (AsBase58 k)) <+> pretty r
 
         entry $ bindMatch "reflog:imported" $ nil_ $ \syn -> lift $ connectedDo do
+          resolveRepoKeyThrow syn >>= setGitRepoKey
           p <- importedCheckpoint
           liftIO $ print $ pretty p
 
         entry $ bindMatch "reflog:import" $ nil_ $ \syn -> lift $ connectedDo do
+          resolveRepoKeyThrow syn >>= setGitRepoKey
           importGitRefLog
 
         brief "shows repo manifest" $
-          entry $ bindMatch "repo:manifest" $ nil_ $ const $ lift $ connectedDo do
+          entry $ bindMatch "repo:manifest" $ nil_ $ \syn -> lift $ connectedDo do
+            resolveRepoKeyThrow syn >>= setGitRepoKey
             manifest <- Repo.getRepoManifest
             liftIO $ print $ pretty $ mkForm "manifest" (coerce manifest)
 
@@ -430,35 +433,13 @@ compression      ;  prints compression level
 
             liftIO $ print $ pretty (AsBase58 reflog)
 
-        entry $ bindMatch "repo:credentials" $ nil_ $ const $ lift $ connectedDo $ do
-
+        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) )]
 
-        brief "set default repository key"
-          $ desc "needed when you call hbs2-git command directly"
-          $ examples [qc|
-; in config:
-repo:ref EvP3kskPVuKuKVMUc3LnfdW7GcFYjz6f5fFU1EGzrdgk
-
-repo:ref ; shows current repo key
-          |] $
-            entry $ bindMatch "repo:ref" $ nil_ $ \case
-              [ SignPubKeyLike k ] -> lift do
-                setGitRepoKey k
-
-              [] -> lift do
-                r <- getGitRepoKey >>= orThrow GitRepoRefNotSet
-                liftIO $  print $ pretty (AsBase58 r)
-
-              _ -> throwIO (BadFormException @C nil)
-
-        entry $ bindMatch "repo:ref:value"$ nil_ $ const $ lift $ connectedDo do
-          val <- Repo.getRepoRefMaybe >>= orThrowUser "can't read ref value"
-          liftIO $ print $ pretty val
-
         entry $ bindMatch "repo:init" $ nil_ $ \syn -> lift $ connectedDo do
             Repo.initRepo syn
 

hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs

@@ -58,6 +58,8 @@ data HBS2GitExcepion =
   | Git3PeerNotConnected
   | Git3ReflogNotSet
   | NoGitDir
+  | GitRemoteKeyNotResolved String
+  | GitCantGenerateRemoteName
   deriving stock (Show,Typeable)
 
 instance Exception HBS2GitExcepion