wip

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)
+