wip

fixme-new/lib/Fixme/Run.hs

@@ -139,6 +139,7 @@ runFixmeCLI m = do
             <*>  newTVarIO mzero
             <*>  newTVarIO mzero
             <*>  newTVarIO mzero
+            <*>  newTVarIO mempty
 
   -- FIXME: defer-evolve
   --   не все действия требуют БД,
@@ -442,6 +443,8 @@ runTop forms = do
        entry $ bindMatch "fixme:refchan:import" $ nil_ $ \case
           _ ->  void $ lift $ refchanImport
 
+       entry $ bindMatch "fixme:gk:export" $ nil_ $ \case
+          _ ->  void $ lift $ refchanExportGroupKeys
 
        entry $ bindMatch "source" $ nil_ $ \case
         [StringLike path] -> do
@@ -476,6 +479,11 @@ runTop forms = do
        entry $ bindMatch "fixme:refchan:update" $ nil_ $ const $ lift do
         refchanUpdate
 
+
+       entry $ bindMatch "cache:ignore" $ nil_ $ const $ lift do
+        tf <- asks fixmeEnvFlags
+        atomically $ modifyTVar tf (HS.insert FixmeIgnoreCached)
+
        entry $ bindMatch "git:blobs" $  \_ -> do
         blobs <- lift (listBlobs Nothing)
 

fixme-new/lib/Fixme/Run/Internal.hs

@@ -12,7 +12,7 @@ import Fixme.Scan as Scan
 import Fixme.GK
 
 import HBS2.Git.Local.CLI
-import HBS2.CLI.Run.MetaData (createTreeWithMetadata,getTreeContents)
+import HBS2.CLI.Run.MetaData (createTreeWithMetadata,getTreeContents,getGroupKeyHash)
 
 import HBS2.Polling
 import HBS2.OrDie
@@ -31,6 +31,7 @@ import HBS2.KeyMan.Keys.Direct
 
 import Data.Config.Suckless.Script.File
 
+import Data.List qualified as L
 import Data.List.Split (chunksOf)
 import Data.Aeson.Encode.Pretty as Aeson
 import Data.ByteString.Lazy qualified as LBS
@@ -530,6 +531,8 @@ refchanUpdate = do
 
   let w = view refChanHeadWaitAccept rch
 
+  refchanExportGroupKeys
+
   txn <- refchanExport ()
 
   unless (txn == 0) do
@@ -609,7 +612,6 @@ refchanImport = do
 
         else do
 
-          -- FIXME: decrypt-tree
           what <- liftIO (runExceptT $ getTreeContents sto href)
                     <&> either (const Nothing) Just
                     >>= toMPlus
@@ -773,3 +775,110 @@ fixmeRefChanInit = do
 
         notice $ green "refchan added" <+> pretty (AsBase58 refchan)
 
+
+
+refchanExportGroupKeys :: FixmePerks m => FixmeM m ()
+refchanExportGroupKeys = do
+
+  let gkHash x = hashObject @HbSync ("GKSCAN" <> serialise x) & HashRef
+
+  sto <- getStorage
+
+  chan <- asks fixmeEnvRefChan
+           >>= readTVarIO
+           >>= orThrowUser "refchan not set"
+
+  ignCached <- asks fixmeEnvFlags >>= readTVarIO <&> HS.member FixmeIgnoreCached
+
+  let goodToGo x | ignCached = pure True
+                 | otherwise = do
+        here <- selectIsAlreadyScanned (gkHash x)
+        pure $ not here
+
+  debug "refchanExportGroupKeys"
+
+  skip <- newTVarIO HS.empty
+  gkz <- newTVarIO HS.empty
+
+  walkRefChanTx @UNIX goodToGo chan $ \txh u -> do
+
+    case u of
+      P orig (ProposeTran _ box) -> void $ runMaybeT do
+        (_, bs) <- unboxSignedBox0 box & toMPlus
+
+        AnnotatedHashRef _ href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict bs)
+                                    & toMPlus . either (const Nothing) Just
+
+        result <- lift $ try @_ @OperationError  (getGroupKeyHash href)
+
+        case result of
+          Right (Just gk,_) -> do
+            atomically do
+              modifyTVar gkz  (HS.insert gk)
+              modifyTVar skip (HS.insert txh)
+
+          Right (Nothing,_) -> do
+            atomically $ modifyTVar skip (HS.insert txh)
+
+          Left UnsupportedFormat -> do
+            debug $ "unsupported" <+> pretty href
+            atomically $ modifyTVar skip (HS.insert txh)
+
+          Left e -> do
+             debug $ "other error" <+> viaShow e
+
+      _ -> none
+
+  l <- readTVarIO skip <&> HS.toList
+  r <- readTVarIO gkz <&> HS.toList
+
+  withState $ transactional do
+    for_ l (insertScanned . gkHash)
+
+  rchan <- asks fixmeEnvRefChan
+             >>= readTVarIO
+             >>= orThrowUser "refchan not set"
+
+  api   <- getClientAPI @RefChanAPI @UNIX
+
+  rch <-  RefChan.getRefChanHead @L4Proto sto (RefChanHeadKey rchan)
+              >>= orThrowUser "can't request refchan head"
+
+  hashes <- L.sort <$> S.toList_ do
+    for_ r $ \gkh -> void $ runMaybeT do
+      gk <- loadGroupKeyMaybe @'HBS2Basic sto gkh >>= toMPlus
+      gks <- liftIO (runKeymanClientRO $ findMatchedGroupKeySecret sto gk)
+
+      when (isNothing gks) do
+      --   lift $ withState (insertScanned (gkHash txh))
+        warn $ "unaccessible group key" <+> pretty gkh
+        mzero
+
+      debug $  red "prepare new gk0" <+> pretty gkh <+> pretty (groupKeyId gk)
+
+      gk1 <- generateGroupKey @'HBS2Basic gks (HS.toList $ view refChanHeadReaders rch)
+      gkh1 <- writeAsMerkle sto (serialise gk1) <&> HashRef
+      lift $ S.yield gkh1
+
+  notice $ yellow $ "new gk:" <+> pretty (L.length hashes)
+
+        -- scanned <- lift $ selectIsAlreadyScanned href
+
+        -- -- notice $ yellow "SCANNED" <+> pretty scanned
+
+        -- if scanned then do
+        --   atx <- readTVarIO accepts <&> fromMaybe mempty . HM.lookup txh
+        --   lift $ withState $ transactional do
+        --     insertScanned txh
+        --     for_ atx insertScanned
+
+        -- else do
+
+        --   -- FIXME: decrypt-tree
+        --   what <- liftIO (runExceptT $ getTreeContents sto href)
+        --             <&> either (const Nothing) Just
+        --             >>= toMPlus
+
+        --   exported <- deserialiseOrFail @[FixmeExported] what
+        --                 & toMPlus
+

fixme-new/lib/Fixme/Types.hs

@@ -332,6 +332,14 @@ data PeerNotConnected = PeerNotConnected
 
 instance Exception PeerNotConnected
 
+data FixmeFlags =
+  FixmeIgnoreCached
+  deriving stock (Eq,Ord,Enum,Show,Generic)
+
+instance Hashable FixmeFlags
+  -- hashWithSalt s e = undefined
+
+
 data FixmeEnv =
   FixmeEnv
   { fixmeLock              :: MVar ()
@@ -358,6 +366,7 @@ data FixmeEnv =
   , fixmeEnvRefChan        :: TVar (Maybe (PubKey 'Sign 'HBS2Basic))
   , fixmeEnvAuthor         :: TVar (Maybe (PubKey 'Sign 'HBS2Basic))
   , fixmeEnvReader         :: TVar (Maybe (PubKey 'Encrypt 'HBS2Basic))
+  , fixmeEnvFlags          :: TVar (HashSet FixmeFlags)
   }
 
 
@@ -428,6 +437,7 @@ fixmeEnvBare =
     <*>  newTVarIO mzero
     <*>  newTVarIO mzero
     <*>  newTVarIO mzero
+    <*>  newTVarIO mempty
 
 withFixmeEnv :: FixmePerks m => FixmeEnv -> FixmeM m a -> m a
 withFixmeEnv env what = runReaderT ( fromFixmeM what) env

hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs

@@ -28,22 +28,22 @@ import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Cont
 import Control.Monad.Except
 
+
 --FIXME: move-somewhere-else
-getGroupKeyHash :: ( IsContext c
+getGroupKeyHash :: ( MonadUnliftIO m
-                   , MonadUnliftIO m
                    , HasStorage m
                    , HasClientAPI StorageAPI UNIX m
                    )
                 => HashRef
-                -> RunM c m (Maybe HashRef, MTreeAnn [HashRef])
+                -> m (Maybe HashRef, MTreeAnn [HashRef])
 getGroupKeyHash h = do
   flip runContT pure do
-    sto <- getStorage
+    sto <- lift getStorage
 
     headBlock <- getBlock sto (fromHashRef h)
-                   >>= orThrowUser  "no-block"
+                   >>= orThrow MissedBlockError
                    <&> deserialiseOrFail @(MTreeAnn [HashRef])
-                   >>= orThrowUser  "invalid block format"
+                   >>= orThrow UnsupportedFormat
 
     case _mtaCrypt headBlock of
       (EncryptGroupNaClSymm hash _) ->

hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs

@@ -4,6 +4,7 @@ module HBS2.CLI.Run.MetaData
   ( metaDataEntries
   , createTreeWithMetadata
   , getTreeContents
+  , getGroupKeyHash
   ) where
 
 import HBS2.CLI.Prelude

hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Keys/Direct.hs

@@ -157,6 +157,13 @@ extractGroupKeySecret gk = do
 
     pure $ headMay r
 
+trackGK :: forall s m . (MonadIO m, s ~ HBS2Basic)
+         => AnyStorage
+        -> HashRef
+        -> m ()
+trackGK sto href = do
+  -- gk <- loadGroupKeyMaybe @s sto href
+  pure ()
 
 type TrackGroupKeyView = ( SomeHash GroupKeyId
                          , SomeHash HashRef

hbs2-keyman/hbs2-keyman/Main.hs

@@ -136,6 +136,7 @@ updateKeys = do
       conf <- getConf
       let rchans = [ r | ListVal [SymbolVal "refchan", SignPubKeyLike r] <- conf ]
 
+      -- FIXME: assume-huge-list
       seen <- withState selectAllSeenGKTx
 
       flip runContT pure $ callCC \exit -> do
@@ -152,6 +153,8 @@ updateKeys = do
 
             for_ rchans $ \r -> do
 
+              notice $ "scan refchan" <+> pretty (AsBase58  r)
+
               walkRefChanTx @proto (pure . not . flip HS.member seen) r $ \tx0 -> \case
                 P _  (ProposeTran _ box) -> do