diff --git a/.fixme-new/config b/.fixme-new/config index 88b9c642..887e98eb 100644 --- a/.fixme-new/config +++ b/.fixme-new/config @@ -62,3 +62,5 @@ fixme-comments ";" "--" (refchan 3WtddmcE8zzgBAPR7Bu7mKMaVMTN423NNXSPUJp3Hx42) +(author 3fKeGjaDGBKtNqeNBPsThh8vSj4TPiqaaK7uHbB8MQUV) + diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index 591f0fcb..59f96c29 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/fixme-new/lib/Fixme/Run.hs @@ -136,6 +136,7 @@ runFixmeCLI m = do <*> newTVarIO (1,3) <*> newTVarIO mzero <*> newTVarIO mzero + <*> newTVarIO mzero -- FIXME: defer-evolve -- не все действия требуют БД, @@ -408,13 +409,19 @@ runTop forms = do _ -> throwIO $ BadFormException @C nil + entry $ bindMatch "author" $ nil_ \case + [SignPubKeyLike au] -> do + t <- lift $ asks fixmeEnvAuthor + atomically $ writeTVar t (Just au) + + _ -> throwIO $ BadFormException @C nil + entry $ bindMatch "git:commits" $ const $ do co <- lift listCommits <&> fmap (mkStr @C . view _1) pure $ mkList co - -- TODO: implement-fixme:refchan:export - entry $ bindMatch "fixme:refchan:export" $ nil_ \case - _ -> none + entry $ bindMatch "fixme:refchan:export" $ nil_ $ const do + void $ lift $ refchanExport entry $ bindMatch "git:blobs" $ \_ -> do blobs <- lift (listBlobs Nothing) diff --git a/fixme-new/lib/Fixme/Run/Internal.hs b/fixme-new/lib/Fixme/Run/Internal.hs index 57a63b8f..1803cb0d 100644 --- a/fixme-new/lib/Fixme/Run/Internal.hs +++ b/fixme-new/lib/Fixme/Run/Internal.hs @@ -12,22 +12,31 @@ import Fixme.Scan as Scan import HBS2.Git.Local.CLI +import HBS2.OrDie +import HBS2.Data.Types.SignedBox import HBS2.Base58 import HBS2.Merkle import HBS2.Data.Types.Refs import HBS2.Storage import HBS2.Storage.Compact +import HBS2.Storage.Operations.ByteString import HBS2.System.Dir +import HBS2.Net.Auth.Credentials import DBPipe.SQLite hiding (field) + +import HBS2.KeyMan.Keys.Direct + import Data.Config.Suckless import Data.Config.Suckless.Script.File +import Data.List.Split (chunksOf) import Control.Applicative import Data.Aeson.Encode.Pretty as Aeson import Data.ByteString (ByteString) import Data.ByteString.Lazy qualified as LBS import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.ByteString qualified as BS import Data.Either import Data.Maybe import Data.HashSet qualified as HS @@ -42,6 +51,7 @@ import Data.Text.IO qualified as Text import Data.Text.Encoding (encodeUtf8) import Text.InterpolatedString.Perl6 (qc) import Data.Coerce +import Data.Word import Control.Monad.Identity import Lens.Micro.Platform import System.Process.Typed @@ -324,3 +334,68 @@ cat_ hash = do liftIO $ action dict fallback + +data FixmeExported = + FixmeExported + { exportedKey :: FixmeKey + , exportedWeight :: Word64 + , exportedName :: FixmeAttrName + , exportedValue :: FixmeAttrVal + } + deriving stock Generic + +instance FromRow FixmeExported +instance ToRow FixmeExported +instance Serialise FixmeExported + +refchanExport :: FixmePerks m => FixmeM m () +refchanExport = do + sto <- getStorage + rchanAPI <- getClientAPI @RefChanAPI @UNIX + + + chan <- asks fixmeEnvRefChan + >>= readTVarIO + >>= orThrowUser "refchan not set" + + au <- asks fixmeEnvAuthor + >>= readTVarIO + >>= orThrowUser "author's key not set" + + creds <- runKeymanClientRO $ loadCredentials au + >>= orThrowUser "can't read credentials" + + + let (pk,sk) = (view peerSignPk creds, view peerSignSk creds) + + -- withRPC2 @RefChanAPI soname $ \caller -> do + -- for_ items $ \it -> do + -- let str = show (pretty it) + -- putStr str + -- let lbs = str & Text.pack & Text.encodeUtf8 + -- let box = makeSignedBox @L4Proto @BS.ByteString pk sk lbs + -- void $ callService @RpcRefChanPropose caller (chan, box) + + withState do + what <- select_ @_ @FixmeExported [qc|select o,w,k,cast (v as text) from object order by o, k, v|] + + let chu = chunksOf 10000 what + + for_ chu $ \x -> do + h <- writeAsMerkle sto (serialise x) + + let tx = AnnotatedHashRef Nothing (HashRef h) + + let lbs = serialise tx + + liftIO $ print (LBS.length lbs) + + let box = makeSignedBox @'HBS2Basic @BS.ByteString pk sk (LBS.toStrict lbs) + + warn $ "POST" <+> red "unencrypted!" <+> pretty (hashObject @HbSync (serialise box)) + + r <- callRpcWaitMay @RpcRefChanPropose (TimeoutSec 1) rchanAPI (chan, box) + + when (isNothing r) do + err $ red "hbs2-peer rpc calling timeout" + diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs index 758ac66c..79736901 100644 --- a/fixme-new/lib/Fixme/Types.hs +++ b/fixme-new/lib/Fixme/Types.hs @@ -356,6 +356,7 @@ data FixmeEnv = , fixmeEnvCatContext :: TVar (Int,Int) , fixmeEnvMyEndpoints :: TVar (Maybe MyPeerClientEndpoints) , fixmeEnvRefChan :: TVar (Maybe (PubKey 'Sign 'HBS2Basic)) + , fixmeEnvAuthor :: TVar (Maybe (PubKey 'Sign 'HBS2Basic)) } @@ -424,6 +425,7 @@ fixmeEnvBare = <*> newTVarIO (1,3) <*> newTVarIO mzero <*> newTVarIO mzero + <*> newTVarIO mzero withFixmeEnv :: FixmePerks m => FixmeEnv -> FixmeM m a -> m a withFixmeEnv env what = runReaderT ( fromFixmeM what) env