mirror of https://github.com/voidlizard/hbs2
wip, fixme:refchan:init
This commit is contained in:
Dmitry Zuikov
parent
fc223ab9a3
commit
c28f779ad3
|
|
@ -68,4 +68,3 @@ fixme-comments ";" "--"
|
||||||
source ./config.local
|
source ./config.local
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -491,26 +491,33 @@ runTop forms = do
|
||||||
) $
|
) $
|
||||||
args [] $
|
args [] $
|
||||||
returns "string" "refchan-key" $ do
|
returns "string" "refchan-key" $ do
|
||||||
entry $ bindMatch "refchan:init" $ nil_ $ const $ do
|
entry $ bindMatch "fixme:refchan:init" $ nil_ $ const $ do
|
||||||
|
|
||||||
let rch0 = refChanHeadDefault @L4Proto
|
let rch0 = refChanHeadDefault @L4Proto
|
||||||
sto <- lift getStorage
|
sto <- lift getStorage
|
||||||
peer <- lift $ getClientAPI @PeerAPI @UNIX
|
peer <- lift $ getClientAPI @PeerAPI @UNIX
|
||||||
rchanApi <- lift $ getClientAPI @RefChanAPI @UNIX
|
rchanApi <- lift $ getClientAPI @RefChanAPI @UNIX
|
||||||
|
|
||||||
|
dir <- localConfigDir
|
||||||
confFile <- localConfig
|
confFile <- localConfig
|
||||||
conf <- liftIO (readFile confFile)
|
|
||||||
<&> parseTop
|
|
||||||
<&> either (error.show) (fmap (fixContext @_ @C))
|
|
||||||
|
|
||||||
let already = headMay [ x
|
-- conf <- liftIO (readFile confFile)
|
||||||
| ListVal [StringLike "refchan", SignPubKeyLike x] <- conf
|
-- <&> parseTop
|
||||||
]
|
-- <&> either (error.show) (fmap (fixContext @_ @C))
|
||||||
|
|
||||||
|
-- let already = headMay [ x
|
||||||
|
-- | ListVal [StringLike "refchan", SignPubKeyLike x] <- conf
|
||||||
|
-- ]
|
||||||
|
|
||||||
|
rchan <- lift $ asks fixmeEnvRefChan
|
||||||
|
>>= readTVarIO
|
||||||
|
|
||||||
flip runContT pure $ callCC \done -> do
|
flip runContT pure $ callCC \done -> do
|
||||||
|
|
||||||
when (isJust already) do
|
when (isJust rchan) do
|
||||||
warn $ red "refchan is already set" <+> pretty (fmap AsBase58 already)
|
warn $ red "refchan is already set" <+> pretty (fmap AsBase58 rchan)
|
||||||
|
warn $ "done" <+> pretty (fmap AsBase58 rchan)
|
||||||
|
done ()
|
||||||
|
|
||||||
poked <- lift $ callRpcWaitMay @RpcPoke (TimeoutSec 1) peer ()
|
poked <- lift $ callRpcWaitMay @RpcPoke (TimeoutSec 1) peer ()
|
||||||
>>= orThrowUser "hbs2-peer not connected"
|
>>= orThrowUser "hbs2-peer not connected"
|
||||||
|
|
@ -549,6 +556,10 @@ runTop forms = do
|
||||||
|
|
||||||
notice $ green "readers" <+> pretty (length readers)
|
notice $ green "readers" <+> pretty (length readers)
|
||||||
|
|
||||||
|
rk <- lift $ runKeymanClientRO $ loadKeyRingEntries readers
|
||||||
|
<&> fmap snd . headMay
|
||||||
|
|
||||||
|
|
||||||
let rch1 = rch0 & set refChanHeadReaders (HS.fromList readers)
|
let rch1 = rch0 & set refChanHeadReaders (HS.fromList readers)
|
||||||
& set refChanHeadAuthors (HS.singleton signK)
|
& set refChanHeadAuthors (HS.singleton signK)
|
||||||
& set refChanHeadPeers (HM.singleton pkey 1)
|
& set refChanHeadPeers (HM.singleton pkey 1)
|
||||||
|
|
@ -567,6 +578,7 @@ runTop forms = do
|
||||||
<> line
|
<> line
|
||||||
else do
|
else do
|
||||||
notice "refchan definition seems okay, adding new refchan"
|
notice "refchan definition seems okay, adding new refchan"
|
||||||
|
|
||||||
refchan <- lift $ keymanNewCredentials (Just "refchan") 0
|
refchan <- lift $ keymanNewCredentials (Just "refchan") 0
|
||||||
|
|
||||||
creds <- lift $ runKeymanClientRO $ loadCredentials refchan
|
creds <- lift $ runKeymanClientRO $ loadCredentials refchan
|
||||||
|
|
@ -582,11 +594,44 @@ runTop forms = do
|
||||||
callService @RpcRefChanHeadPost rchanApi (HashRef href)
|
callService @RpcRefChanHeadPost rchanApi (HashRef href)
|
||||||
>>= orThrowUser "can't post refchan head"
|
>>= orThrowUser "can't post refchan head"
|
||||||
|
|
||||||
liftIO $ appendFile confFile $
|
|
||||||
show $ pretty ( mkList @C [ mkSym "refchan"
|
|
||||||
, mkSym (show $ pretty (AsBase58 refchan)) ]
|
|
||||||
)
|
|
||||||
|
|
||||||
|
let nonce = take 6 $ show $ pretty (AsBase58 refchan)
|
||||||
|
let rchanFile = "refchan-" <> nonce <> ".local"
|
||||||
|
let rchanFilePath = dir </> rchanFile
|
||||||
|
|
||||||
|
let note = ";; author and reader are inferred automatically" <> line
|
||||||
|
<> ";; from hbs2-keyman data" <> line
|
||||||
|
<> ";; edit them if needed" <> line
|
||||||
|
<> ";; reader is *your* reading public key." <> line
|
||||||
|
<> ";; author is *your* signing public key." <> line
|
||||||
|
|
||||||
|
let refChanClause = mkList @C [ mkSym "refchan"
|
||||||
|
, mkSym (show $ pretty (AsBase58 refchan))
|
||||||
|
]
|
||||||
|
|
||||||
|
let theirReaderKeyClause = maybe1 rk nil $ \(KeyringEntry pk _ _) -> do
|
||||||
|
mkList @C [ mkSym "reader", mkSym (show $ pretty (AsBase58 pk) ) ]
|
||||||
|
|
||||||
|
let theirAuthorClause = mkList @C [ mkSym "author", mkSym (show $ pretty (AsBase58 signK) ) ]
|
||||||
|
|
||||||
|
let content = (vcat $ [ pretty refChanClause ])
|
||||||
|
<> line
|
||||||
|
<> line
|
||||||
|
<> note
|
||||||
|
<> line
|
||||||
|
<> vcat [ pretty theirReaderKeyClause
|
||||||
|
, pretty theirAuthorClause
|
||||||
|
]
|
||||||
|
|
||||||
|
liftIO do
|
||||||
|
writeFile rchanFilePath $
|
||||||
|
show content
|
||||||
|
|
||||||
|
appendFile confFile $ show $ pretty $
|
||||||
|
mkList @C [ mkSym "source", mkSym ( "." </> rchanFile ) ]
|
||||||
|
|
||||||
|
|
||||||
|
notice $ green "refchan added" <+> pretty (AsBase58 refchan)
|
||||||
|
|
||||||
entry $ bindMatch "set-template" $ nil_ \case
|
entry $ bindMatch "set-template" $ nil_ \case
|
||||||
[SymbolVal who, SymbolVal w] -> do
|
[SymbolVal who, SymbolVal w] -> do
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue