mirror of https://github.com/voidlizard/hbs2
wip, Repo.fork
This commit is contained in:
voidlizard
parent
f12f4d1e12
commit
7807156cfa
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,170 +1,12 @@
|
|||
{-# Language UndecidableInstances #-}
|
||||
{-# Language AllowAmbiguousTypes #-}
|
||||
{-# Language PatternSynonyms #-}
|
||||
{-# Language ViewPatterns #-}
|
||||
module HBS2.Git3.Repo ( initRepo, waitRepo
|
||||
module HBS2.Git3.Repo ( waitRepo
|
||||
, getRepoRefMaybe
|
||||
, getRepoManifest
|
||||
, HasGitRemoteKey(..)
|
||||
, pattern RepoURL
|
||||
, module Exported
|
||||
) 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.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"
|
||||
import HBS2.Git3.Repo.Types as Exported
|
||||
import HBS2.Git3.Repo.Init as Exported
|
||||
|
||||
|
|
|
|||
|
|
@ -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"] []
|
||||
none
|
||||
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
|
||||
|
||||
_ -> throwIO $ BadFormException @C nil
|
||||
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
||||
|
|
@ -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" ]
|
||||
|
||||
|
||||
Loading…
Reference in New Issue