diff --git a/fixme-new/lib/Fixme/Run/Internal.hs b/fixme-new/lib/Fixme/Run/Internal.hs index 684fa0d4..cbb8e6e3 100644 --- a/fixme-new/lib/Fixme/Run/Internal.hs +++ b/fixme-new/lib/Fixme/Run/Internal.hs @@ -867,3 +867,139 @@ refchanExportGroupKeys = do err $ red "hbs2-peer rpc calling timeout" + +fixmeRefChanInit :: FixmePerks m => FixmeM m () +fixmeRefChanInit = do + let rch0 = refChanHeadDefault @L4Proto + sto <- getStorage + peer <- getClientAPI @PeerAPI @UNIX + rchanApi <- getClientAPI @RefChanAPI @UNIX + + dir <- localConfigDir + confFile <- localConfig + + rchan <- asks fixmeEnvRefChan + >>= readTVarIO + + flip runContT pure $ callCC \done -> do + + when (isJust rchan) do + warn $ red "refchan is already set" <+> pretty (fmap AsBase58 rchan) + warn $ "done" <+> pretty (fmap AsBase58 rchan) + done () + + poked <- lift $ callRpcWaitMay @RpcPoke (TimeoutSec 1) peer () + >>= orThrowUser "hbs2-peer not connected" + <&> parseTop + <&> fromRight mempty + + pkey <- [ fromStringMay @(PubKey 'Sign 'HBS2Basic) x + | ListVal [SymbolVal "peer-key:", StringLike x ] <- poked + ] & headMay . catMaybes & orThrowUser "hbs2-peer key not set" + + + notice $ green "default peer" <+> pretty (AsBase58 pkey) + + + signK' <- lift $ runKeymanClientRO $ listCredentials + <&> headMay + + signK <- ContT $ maybe1 signK' (throwIO $ userError "no default author key found in hbs2-keyman") + + notice $ green "default author" <+> pretty (AsBase58 signK) + + -- TODO: use-hbs2-git-api? + (_, gkh', _) <- readProcess (shell [qc|git hbs2 key|]) + <&> over _2 ( (fromStringMay @HashRef) <=< (notEmpty . headDef "" . lines . LBS8.unpack) ) + <&> \x -> case view _1 x of + ExitFailure _ -> set _2 Nothing x + ExitSuccess -> x + + notice $ green "group key" <+> maybe "none" pretty gkh' + + readers <- fromMaybe mempty <$> runMaybeT do + gh <- toMPlus gkh' + gk <- loadGroupKeyMaybe @'HBS2Basic sto gh + >>= toMPlus + pure $ HM.keys (recipients gk) + + notice $ green "readers" <+> pretty (length readers) + + rk <- lift $ runKeymanClientRO $ loadKeyRingEntries readers + <&> fmap snd . headMay + + + let rch1 = rch0 & set refChanHeadReaders (HS.fromList readers) + & set refChanHeadAuthors (HS.singleton signK) + & set refChanHeadPeers (HM.singleton pkey 1) + + + let unlucky = HM.null (view refChanHeadPeers rch1) + || HS.null (view refChanHeadAuthors rch1) + + + liftIO $ print $ pretty rch1 + + if unlucky then do + warn $ red $ "refchan definition is not complete;" <+> + "you may add missed keys, edit the" <+> + "defition and add if manually or repeat init attempt" + <> line + else do + notice "refchan definition seems okay, adding new refchan" + + refchan <- lift $ keymanNewCredentials (Just "refchan") 0 + + creds <- lift $ runKeymanClientRO $ loadCredentials refchan + >>= orThrowUser "can't load credentials" + + let box = makeSignedBox @'HBS2Basic (view peerSignPk creds) (view peerSignSk creds) rch1 + + href <- writeAsMerkle sto (serialise box) + + callService @RpcPollAdd peer (refchan, "refchan", 17) + >>= orThrowUser "can't subscribe to refchan" + + callService @RpcRefChanHeadPost rchanApi (HashRef href) + >>= orThrowUser "can't post refchan head" + + + 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 = line + <> vcat [ pretty refChanClause ] + <> line + <> line + <> note + <> line + <> vcat [ pretty theirReaderKeyClause + , pretty theirAuthorClause + ] + + liftIO do + writeFile rchanFilePath $ + show content + + appendFile confFile $ show $ + line <> + pretty (mkList @C [ mkSym "source", mkSym ( "." rchanFile ) ]) + + notice $ green "refchan added" <+> pretty (AsBase58 refchan) +