mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
Dmitry Zuikov
parent
3c0fef0596
commit
bbf0d8ef62
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
, MonadUnliftIO m
|
||||
getGroupKeyHash :: ( 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 _) ->
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@ module HBS2.CLI.Run.MetaData
|
|||
( metaDataEntries
|
||||
, createTreeWithMetadata
|
||||
, getTreeContents
|
||||
, getGroupKeyHash
|
||||
) where
|
||||
|
||||
import HBS2.CLI.Prelude
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue