wip, Repo.fork

hbs2-git3/hbs2-git3.cabal

@@ -125,8 +125,10 @@ library
       HBS2.Git3.Prelude
       HBS2.Git3.Export
       HBS2.Git3.Import
-      HBS2.Git3.Repo
       HBS2.Git3.Repo.Fork
+      HBS2.Git3.Repo.Init
+      HBS2.Git3.Repo.Types
+      HBS2.Git3.Repo
       HBS2.Git3.Run
       HBS2.Git3.Logger
       HBS2.Git3.State

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

@@ -1,170 +1,12 @@
-{-# Language UndecidableInstances #-}
+module HBS2.Git3.Repo ( waitRepo
-{-# Language AllowAmbiguousTypes #-}
-{-# Language PatternSynonyms #-}
-{-# Language ViewPatterns #-}
-module HBS2.Git3.Repo ( initRepo, waitRepo
                       , getRepoRefMaybe
                       , getRepoManifest
                       , HasGitRemoteKey(..)
-                      , pattern RepoURL
+                      , module Exported
                       ) where
 
-import HBS2.Git3.Prelude
 import HBS2.Git3.State
 
-import HBS2.CLI.Run.MetaData
+import HBS2.Git3.Repo.Types as Exported
-import HBS2.Net.Auth.Credentials
+import HBS2.Git3.Repo.Init  as Exported
-
-import HBS2.KeyMan.Keys.Direct
-
-import Data.Config.Suckless.Script
-import Data.Config.Suckless.Almost.RPC
-
-import Data.HashSet qualified as HS
-import Data.Text qualified as Text
-import Data.ByteString.Lazy.Char8 qualified as LBS8
-import Data.Word
-import Lens.Micro.Platform
-
-import System.Random hiding (next)
-
-{- HLINT ignore "Functor law"-}
-
-data CInit =
-    CheckRepoKeyExist
-  | CreateRepoKey
-  | CheckRepoKeyStart GitRepoKey
-  | CheckRepoKeyWait TimeSpec (Timeout 'Seconds) GitRepoKey
-  | CheckRepoDefBlock GitRepoKey (LWWRef 'HBS2Basic)
-  | CreateRepoDefBlock GitRepoKey
-
-
-pattern RepoURL :: GitRemoteKey -> Syntax C
-pattern RepoURL x <- (isRepoURL -> Just x)
-
-isRepoURL :: Syntax C -> Maybe GitRemoteKey
-isRepoURL = \case
-  TextLike xs -> case mkList @C (fmap mkStr (Text.splitOn "://" xs)) of
-    ListVal [TextLike pref, SignPubKeyLike puk] | pref `HS.member` prefixes -> Just puk
-    _ -> Nothing
-
-  _ -> Nothing
-
-  where
-    prefixes = HS.fromList [ "hbs2", "hbs23" ]
-
-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 ]
-
-  root <- getConfigRootFile
-
-  sto  <- getStorage
-  lwwAPI    <- getClientAPI @LWWRefAPI @UNIX
-  refLogAPI <- getClientAPI @RefLogAPI @UNIX
-  peerAPI   <- getClientAPI @PeerAPI @UNIX
-
-  flip fix CheckRepoKeyExist $ \next -> \case
-    CheckRepoKeyExist -> do
-      debug "initRepo:CheckRepoKey"
-      mbk <- getGitRepoKey
-      next $ maybe CreateRepoKey CheckRepoKeyStart mbk
-
-    CreateRepoKey -> do
-      debug "initRepo:CreateRepoKey"
-
-      answ <- callProc "hbs2-cli" [] [mkSym "hbs2:lwwref:create"]
-
-      pk <- [ x | ListVal [SymbolVal "pk", SignPubKeyLike x] <- answ ]
-              & lastMay
-              & orThrowUser "can't create new lwwref"
-
-      liftIO $ appendFile root (show $ pretty $ mkForm "repo:ref" [mkSym @C (show $ pretty (AsBase58 pk))])
-
-    CheckRepoKeyStart pk -> do
-      debug $ "initRepo:CheckRepoKeyStart" <+> pretty (AsBase58 pk)
-
-      callRpcWaitMay @RpcLWWRefFetch (TimeoutSec 1) lwwAPI (LWWRefKey pk)
-        >>= orThrowUser "rpc timeout"
-
-      now <- getTimeCoarse
-
-      let waity = if new then ceiling 0.5e9 else ceiling 30e9
-
-      let till = TimeoutTS (now + fromNanoSecs waity )
-
-      next $ CheckRepoKeyWait (coerce till) 1.0 pk
-
-    CheckRepoKeyWait till w pk -> do
-
-      debug $ "initRepo:CheckRepoKeyWait" <+> pretty (AsBase58 pk)
-
-      rv <- getRepoRefMaybe
-
-      now <- getTimeCoarse
-
-      if now > till then do
-        next $ CreateRepoDefBlock pk
-      else do
-        maybe1 rv (pause w >> next (CheckRepoKeyWait till (1.10 * w) pk))
-                  (next . CheckRepoDefBlock pk)
-
-    CheckRepoDefBlock pk LWWRef{..} -> do
-      debug $ "init:CheckRepoDefBlock" <+> pretty (AsBase58 pk) <+> pretty lwwValue
-
-      repo <- getRepoManifest
-
-      reflog <- getRefLog repo & orThrow GitRepoManifestMalformed
-
-      callRpcWaitMay @RpcPollAdd (TimeoutSec 1) peerAPI (reflog, "reflog", 17)
-         >>= orThrowUser "rpc timeout"
-
-      -- FIXME: remove-this
-      liftIO $ print $ pretty $ mkForm "manifest" (coerce repo)
-
-    CreateRepoDefBlock pk  -> do
-
-      debug $ "init:CreateRepoDefBlock" <+> pretty (AsBase58 pk)
-
-      seed <- randomIO @Word64
-
-      creds <- runKeymanClientRO (loadCredentials pk)
-                 >>= orThrowUser ("not found credentials for"  <+> pretty (AsBase58 pk))
-
-      let (wsk,wpk) = (view peerSignSk creds, view peerSignPk creds)
-
-      let sk = view peerSignSk creds
-      (rpk,rsk) <- derivedKey @'HBS2Basic @'Sign seed sk
-
-      let manifest = [
-             mkForm @C "hbs2-git" [mkInt 3]
-           , mkForm "seed" [mkInt seed]
-           , mkForm "public" []
-           , mkForm "reflog" [mkSym (show $ pretty (AsBase58 rpk))]
-           ]
-
-      let mfs =  vcat $ fmap pretty manifest
-
-      tree <- createTreeWithMetadata sto Nothing mempty (LBS8.pack (show $ mfs))
-                >>= orThrowPassIO
-
-      liftIO $ print  $ pretty $ mkForm "manifest" manifest
-
-      let pt = toPTree (MaxSize defHashListChunk) (MaxNum defTreeChildNum) [tree]
-
-      blk <- makeMerkle 0 pt $ \(_,_,bs) -> do
-                void $ putBlock sto bs
-
-      notice $ "current root" <+> pretty blk <+> pretty tree
-
-      let box =  makeSignedBox wpk wsk (LWWRef 3 (coerce blk) Nothing)
-
-      callRpcWaitMay @RpcLWWRefUpdate (TimeoutSec 1) lwwAPI box
-         >>= orThrowUser "rpc timeout"
-
-      callRpcWaitMay @RpcPollAdd (TimeoutSec 1) peerAPI (rpk, "reflog", 17)
-         >>= orThrowUser "rpc timeout"
 

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

@@ -2,6 +2,7 @@ module HBS2.Git3.Repo.Fork (forkEntries) where
 
 import HBS2.Git3.Prelude
 import HBS2.Git3.State
+import HBS2.Git3.Repo.Init
 import HBS2.Git3.Git
 import HBS2.Data.Detect
 
@@ -41,15 +42,30 @@ 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
-  entry $ bindMatch (prefix <> "fork") $ nil_ $ \case
-    [ SignPubKeyLike what ] -> lift $ connectedDo do
-      error $ show $ "not yet" <+> pretty (AsBase58 what)
 
-      r <- callProc "git" ["--init"] []
+  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 what ] -> lift do
+
+          r <- callProc "git" ["--init", "."] []
+
           none
 
+          -- initRepo [newRepoOpt]
+
         _ -> throwIO $ BadFormException @C nil
 
+

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

@@ -0,0 +1,152 @@
+{-# Language UndecidableInstances #-}
+{-# Language AllowAmbiguousTypes #-}
+module HBS2.Git3.Repo.Init (initRepo,newRepoOpt) where
+
+import HBS2.Git3.Prelude
+import HBS2.Git3.State
+
+import HBS2.CLI.Run.MetaData
+import HBS2.Net.Auth.Credentials
+
+import HBS2.KeyMan.Keys.Direct
+
+import Data.Config.Suckless.Script
+import Data.Config.Suckless.Almost.RPC
+
+import Data.ByteString.Lazy.Char8 qualified as LBS8
+import Data.Word
+import Lens.Micro.Platform
+
+import System.Random hiding (next)
+
+
+{- HLINT ignore "Functor law"-}
+
+data CInit =
+    CheckRepoKeyExist
+  | CreateRepoKey
+  | CheckRepoKeyStart GitRepoKey
+  | CheckRepoKeyWait TimeSpec (Timeout 'Seconds) GitRepoKey
+  | CheckRepoDefBlock GitRepoKey (LWWRef 'HBS2Basic)
+  | CreateRepoDefBlock GitRepoKey
+
+newRepoOpt :: Syntax C
+newRepoOpt = mkList [mkSym "--new"]
+
+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 ]
+
+  root <- getConfigRootFile
+
+  sto  <- getStorage
+  lwwAPI    <- getClientAPI @LWWRefAPI @UNIX
+  refLogAPI <- getClientAPI @RefLogAPI @UNIX
+  peerAPI   <- getClientAPI @PeerAPI @UNIX
+
+  flip fix CheckRepoKeyExist $ \next -> \case
+    CheckRepoKeyExist -> do
+      debug "initRepo:CheckRepoKey"
+      mbk <- getGitRepoKey
+      next $ maybe CreateRepoKey CheckRepoKeyStart mbk
+
+    CreateRepoKey -> do
+      debug "initRepo:CreateRepoKey"
+
+      answ <- callProc "hbs2-cli" [] [mkSym "hbs2:lwwref:create"]
+
+      pk <- [ x | ListVal [SymbolVal "pk", SignPubKeyLike x] <- answ ]
+              & lastMay
+              & orThrowUser "can't create new lwwref"
+
+      liftIO $ appendFile root (show $ pretty $ mkForm "repo:ref" [mkSym @C (show $ pretty (AsBase58 pk))])
+
+    CheckRepoKeyStart pk -> do
+      debug $ "initRepo:CheckRepoKeyStart" <+> pretty (AsBase58 pk)
+
+      callRpcWaitMay @RpcLWWRefFetch (TimeoutSec 1) lwwAPI (LWWRefKey pk)
+        >>= orThrowUser "rpc timeout"
+
+      now <- getTimeCoarse
+
+      let waity = if new then ceiling 0.5e9 else ceiling 30e9
+
+      let till = TimeoutTS (now + fromNanoSecs waity )
+
+      next $ CheckRepoKeyWait (coerce till) 1.0 pk
+
+    CheckRepoKeyWait till w pk -> do
+
+      debug $ "initRepo:CheckRepoKeyWait" <+> pretty (AsBase58 pk)
+
+      rv <- getRepoRefMaybe
+
+      now <- getTimeCoarse
+
+      if now > till then do
+        next $ CreateRepoDefBlock pk
+      else do
+        maybe1 rv (pause w >> next (CheckRepoKeyWait till (1.10 * w) pk))
+                  (next . CheckRepoDefBlock pk)
+
+    CheckRepoDefBlock pk LWWRef{..} -> do
+      debug $ "init:CheckRepoDefBlock" <+> pretty (AsBase58 pk) <+> pretty lwwValue
+
+      repo <- getRepoManifest
+
+      reflog <- getRefLog repo & orThrow GitRepoManifestMalformed
+
+      callRpcWaitMay @RpcPollAdd (TimeoutSec 1) peerAPI (reflog, "reflog", 17)
+         >>= orThrowUser "rpc timeout"
+
+      -- FIXME: remove-this
+      liftIO $ print $ pretty $ mkForm "manifest" (coerce repo)
+
+    CreateRepoDefBlock pk  -> do
+
+      debug $ "init:CreateRepoDefBlock" <+> pretty (AsBase58 pk)
+
+      seed <- randomIO @Word64
+
+      creds <- runKeymanClientRO (loadCredentials pk)
+                 >>= orThrowUser ("not found credentials for"  <+> pretty (AsBase58 pk))
+
+      let (wsk,wpk) = (view peerSignSk creds, view peerSignPk creds)
+
+      let sk = view peerSignSk creds
+      (rpk,rsk) <- derivedKey @'HBS2Basic @'Sign seed sk
+
+      let manifest = [
+             mkForm @C "hbs2-git" [mkInt 3]
+           , mkForm "seed" [mkInt seed]
+           , mkForm "public" []
+           , mkForm "reflog" [mkSym (show $ pretty (AsBase58 rpk))]
+           ]
+
+      let mfs =  vcat $ fmap pretty manifest
+
+      tree <- createTreeWithMetadata sto Nothing mempty (LBS8.pack (show $ mfs))
+                >>= orThrowPassIO
+
+      liftIO $ print  $ pretty $ mkForm "manifest" manifest
+
+      let pt = toPTree (MaxSize defHashListChunk) (MaxNum defTreeChildNum) [tree]
+
+      blk <- makeMerkle 0 pt $ \(_,_,bs) -> do
+                void $ putBlock sto bs
+
+      notice $ "current root" <+> pretty blk <+> pretty tree
+
+      now <- liftIO getPOSIXTime  <&> round
+
+      let box =  makeSignedBox wpk wsk (LWWRef now (coerce blk) Nothing)
+
+      callRpcWaitMay @RpcLWWRefUpdate (TimeoutSec 1) lwwAPI box
+         >>= orThrowUser "rpc timeout"
+
+      callRpcWaitMay @RpcPollAdd (TimeoutSec 1) peerAPI (rpk, "reflog", 17)
+         >>= orThrowUser "rpc timeout"
+

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

@@ -0,0 +1,24 @@
+module HBS2.Git3.Repo.Types where
+
+import HBS2.Git3.Prelude
+
+import Data.Config.Suckless.Script
+
+import Data.HashSet qualified as HS
+import Data.Text qualified as Text
+
+pattern RepoURL :: GitRemoteKey -> Syntax C
+pattern RepoURL x <- (isRepoURL -> Just x)
+
+isRepoURL :: Syntax C -> Maybe GitRemoteKey
+isRepoURL = \case
+  TextLike xs -> case mkList @C (fmap mkStr (Text.splitOn "://" xs)) of
+    ListVal [TextLike pref, SignPubKeyLike puk] | pref `HS.member` prefixes -> Just puk
+    _ -> Nothing
+
+  _ -> Nothing
+
+  where
+    prefixes = HS.fromList [ "hbs2", "hbs23" ]
+
+