module HBS2.Git.Data.Tx.Git ( module HBS2.Git.Data.Tx.Git , OperationError(..) , RepoHead(..) ) where import HBS2.Git.Client.Prelude import HBS2.Git.Data.RefLog import HBS2.Defaults import HBS2.Data.Detect import HBS2.KeyMan.Keys.Direct import HBS2.Peer.Proto import HBS2.Net.Auth.GroupKeySymm import HBS2.Net.Auth.Credentials import HBS2.Storage.Operations.ByteString import HBS2.Storage.Operations.Missed import HBS2.Git.Data.GK import HBS2.Git.Data.RepoHead import HBS2.Git.Local import HBS2.Merkle.Walk import Data.Maybe import Data.Either import Data.Word import Data.ByteString.Lazy qualified as LBS import Data.ByteString (ByteString) import Streaming.Prelude qualified as S import Data.Binary.Get import Data.ByteArray.Hash (SipHash(..), SipKey(..)) import Data.ByteArray.Hash qualified as BA import Data.HashMap.Strict qualified as HM type Rank = Integer type LBS = LBS.ByteString type RepoTx = RefLogUpdate L4Proto data TxKeyringNotFound = TxKeyringNotFound deriving stock (Show, Typeable, Generic) instance Exception TxKeyringNotFound class GroupKeyOperations m where openGroupKey :: GK0 -> m (Maybe GroupSecret) loadKeyrings :: HashRef -> m [KeyringEntry 'HBS2Basic] makeRepoHeadSimple :: MonadIO m => Text -> Text -> Maybe Text -> Maybe HashRef -> [(GitRef, GitHash)] -> m RepoHead makeRepoHeadSimple name brief manifest gk refs = do t <- getEpoch pure $ RepoHeadSimple RepoHeadType1 t gk name brief manifest refs mempty writeRepoHead :: MonadUnliftIO m => AnyStorage -> RepoHead -> m HashRef writeRepoHead sto rh = writeAsMerkle sto (serialise rh) <&> HashRef makeTx :: forall s m . (MonadUnliftIO m, GroupKeyOperations m, s ~ 'HBS2Basic) => AnyStorage -> Bool -- ^ rewrite bundle merkle tree with new gk0 -> Rank -- ^ tx rank -> RefLogId -> ( PubKey 'Sign s -> m (Maybe (PrivKey 'Sign s) ) ) -> RepoHead -> [HashRef] -> [LBS] -> m RepoTx makeTx sto rewrite r puk findSk rh prev lbss = do let rfk = RefLogKey @'HBS2Basic puk privk <- findSk puk >>= orThrow TxKeyringNotFound -- FIXME: delete-on-fail headRef <- writeRepoHead sto rh writeEnv <- newWriteBundleEnv sto rh cRefs <- for lbss (writeBundle writeEnv) let newBundles0 = prev <> cRefs newBundles <- do if not rewrite then do pure newBundles0 else do for newBundles0 \bh -> do blk <- getBlock sto (fromHashRef bh) >>= orThrow StorageError case tryDetect (fromHashRef bh) blk of Merkle{} -> do bs <- runExceptT (readFromMerkle sto (SimpleKey (fromHashRef bh))) >>= either throwIO pure trace $ "encrypt existed block" <+> pretty bh writeBundle writeEnv bs MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm2 o gkh nonce}) -> do gk <- runExceptT (readGK0 sto (HashRef gkh)) >>= orThrow (GroupKeyNotFound 4) gks <- openGroupKey gk >>= orThrow (GroupKeyNotFound 5) debug $ "update GK0 for existed block" <+> pretty bh let rcpt = HM.keys (recipients (wbeGk0 writeEnv)) gk1 <- generateGroupKey @'HBS2Basic (Just gks) rcpt gk1h <- writeAsMerkle sto (serialise gk1) let newCrypt = EncryptGroupNaClSymm2 o gk1h nonce let newTreeBlock = ann { _mtaCrypt = newCrypt } newTree <- enqueueBlock sto (serialise newTreeBlock) >>= orThrow StorageError pure (HashRef newTree) _ -> throwIO UnsupportedFormat let pt = toPTree (MaxSize defHashListChunk) (MaxNum 256) newBundles me <- makeMerkle 0 pt $ \(_,_,bss) -> do void $ putBlock sto bss let meRef = HashRef me -- FIXME: ASAP-race-condition-on-seq-ref -- При разборе транзакции, если по какой-то причине -- голова сразу не подъезжает, то не подъедет уже никогда, -- и бранчи не приедут (Import). -- -- Возможные решения: запатчить процедуру импорта (1) -- Добавить ссылкун а RepoHead в блок, где приезжают -- пулы -- TODO: post-real-rank-for-tx let tx = SequentialRef r (AnnotatedHashRef (Just headRef) meRef) & serialise & LBS.toStrict makeRefLogUpdate @L4Proto @'HBS2Basic puk privk tx unpackTx :: MonadIO m => RefLogUpdate L4Proto -> m (Integer, HashRef, HashRef) unpackTx tx = do sr <- deserialiseOrFail @SequentialRef (LBS.fromStrict (view refLogUpdData tx)) & orThrow UnsupportedFormat case sr of SequentialRef n (AnnotatedHashRef (Just rhh) blkh) -> pure (n,rhh,blkh) _ -> throwIO UnsupportedFormat readTx :: (MonadIO m, MonadError OperationError m) => AnyStorage -> HashRef -> m (Integer, HashRef, RepoHead, HashRef) readTx sto href = do tx <- getBlock sto (fromHashRef href) >>= orThrowError MissedBlockError <&> deserialiseOrFail @(RefLogUpdate L4Proto) >>= orThrowError UnsupportedFormat (n,rhh,blkh) <- unpackTx tx rh <- runExceptT (readFromMerkle sto (SimpleKey (fromHashRef rhh))) >>= orThrowError IncompleteData <&> deserialiseOrFail @RepoHead >>= orThrowError UnsupportedFormat missed <- S.head_ (findMissedBlocks2 sto blkh) <&> isJust when missed do throwError IncompleteData pure (n, rhh, rh, blkh) readRepoHeadFromTx :: MonadIO m => AnyStorage -> HashRef -> m (Maybe (HashRef, RepoHead)) readRepoHeadFromTx sto href = runMaybeT do tx <- getBlock sto (fromHashRef href) >>= toMPlus <&> deserialiseOrFail @(RefLogUpdate L4Proto) >>= toMPlus (n,rhh,_) <- unpackTx tx runExceptT (readFromMerkle sto (SimpleKey (fromHashRef rhh))) >>= toMPlus <&> deserialiseOrFail @RepoHead >>= toMPlus <&> (rhh,) data BundleMeta = BundleMeta { bundleHash :: HashRef , bundleEncrypted :: Bool } deriving stock (Show,Generic) data BundleWithMeta = BundleWithMeta { bundleMeta :: BundleMeta , bundlebBytes :: LBS } deriving stock (Generic) readBundle :: (MonadIO m, MonadError OperationError m, GroupKeyOperations m) => AnyStorage -> RepoHead -> HashRef -> m BundleWithMeta readBundle sto rh ref = do obj <- getBlock sto (fromHashRef ref) >>= orThrow MissedBlockError let q = tryDetect (fromHashRef ref) obj let findSec = runKeymanClientRO . findMatchedGroupKeySecret sto case q of Merkle t -> do let meta = BundleMeta ref False BundleWithMeta meta <$> readFromMerkle sto (SimpleKey key) MerkleAnn (MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm gkh _}) -> do let meta = BundleMeta ref True BundleWithMeta meta <$> readFromMerkle sto (ToDecryptBS key (liftIO . findSec)) _ -> throwError UnsupportedFormat where key = fromHashRef ref readBundleRefs :: (MonadIO m) => AnyStorage -> HashRef -> m (Either [HashRef] [HashRef]) readBundleRefs sto bunh = do (hs S.:> er) <- S.toList $ streamMerkle @HashRef (getBlock sto) (fromHashRef bunh) case er of Left wme -> case wme of MerkleHashNotFound h -> pure (Left [HashRef h]) MerkleDeserialiseFailure h _ -> pure (Left [HashRef h]) Right () -> pure (Right hs) type GitPack = LBS.ByteString type UnpackedBundle = (Word32, Word32, [GitHash], GitPack) unpackPackMay :: LBS.ByteString -> Maybe UnpackedBundle unpackPackMay co = result $ flip runGetOrFail co do w <- getWord32be v <- getWord32be idx <- lookAheadE (getLazyByteString (fromIntegral w) <&> deserialiseOrFail @[GitHash]) >>= either (fail.show) pure pack <- getRemainingLazyByteString pure (w,v,idx,pack) where result = \case Left{} -> Nothing Right (_,_,r) -> Just r data WriteBundleEnv = WriteBundleEnvPlain { wbeHead :: RepoHead , wbeStorage :: AnyStorage } | WriteBundleEnvEnc { wbeSk1 :: SipKey , wbeSk2 :: SipKey , wbeHead :: RepoHead , wbeGk0 :: GK0 , wbeGks :: GroupSecret , wbeStorage :: AnyStorage } newWriteBundleEnv :: (MonadIO m, GroupKeyOperations m) => AnyStorage -> RepoHead -> m WriteBundleEnv newWriteBundleEnv sto rh = case _repoHeadGK0 rh of Nothing -> do pure $ WriteBundleEnvPlain rh sto Just gk0h -> do gk0 <- runExceptT (readGK0 sto gk0h) >>= either throwIO pure gks <- openGroupKey gk0 >>= orThrow (GroupKeyNotFound 3) pure $ WriteBundleEnvEnc { wbeSk1 = SipKey 2716370006254639645 507093936407764973 , wbeSk2 = SipKey 9209704780415729085 272090086441077315 , wbeHead = rh , wbeGk0 = gk0 , wbeGks = gks , wbeStorage = sto } makeNonceForBundle :: Monad m => WriteBundleEnv -> LBS.ByteString -> m ByteString makeNonceForBundle env lbs = do let piece = ( LBS.take (fromIntegral defBlockSize * 2) lbs <> serialise (wbeHead env) ) & hashObject @HbSync & serialise & LBS.drop 1 & LBS.toStrict pure piece writeBundle :: MonadIO m => WriteBundleEnv -> LBS.ByteString -> m HashRef writeBundle env lbs = do case env of WriteBundleEnvPlain{..} -> do writeAsMerkle wbeStorage lbs <&> HashRef WriteBundleEnvEnc{..} -> do let bsStream = readChunkedBS lbs defBlockSize nonce <- makeNonceForBundle env lbs let (SipHash a) = BA.sipHash wbeSk1 nonce let (SipHash b) = BA.sipHash wbeSk2 nonce let source = ToEncryptSymmBS wbeGks (Right wbeGk0) nonce bsStream NoMetaData (Just (EncryptGroupNaClSymmBlockSIP (a,b))) th <- runExceptT (writeAsMerkle wbeStorage source) >>= orThrow StorageError pure $ HashRef th