diff --git a/hbs2-cli/lib/HBS2/CLI/Run/LWWRef.hs b/hbs2-cli/lib/HBS2/CLI/Run/LWWRef.hs index 5dd82d43..b7b4b208 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/LWWRef.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/LWWRef.hs @@ -13,9 +13,11 @@ import HBS2.Peer.RPC.API.RefLog import HBS2.Peer.RPC.API.LWWRef import HBS2.Peer.Proto hiding (request) +import HBS2.Peer.Proto.LWWRef import HBS2.Base58 import HBS2.Net.Auth.Credentials import HBS2.Net.Auth.Schema() +import HBS2.Data.Types.SignedBox import HBS2.KeyMan.Keys.Direct import HBS2.KeyMan.App.Types @@ -86,17 +88,17 @@ lwwRefEntries = do so <- detectRPC `orDie` "rpc not found" api <- ContT $ withRPC2 @LWWRefAPI @UNIX so what <- callService @RpcLWWRefGet api ref - >>= orThrowUser "can't get reflog" + >>= orThrowUser "can't get lwwref value" pure $ mkStr (show $ pretty what) _ -> throwIO (BadFormException @C nil) entry $ bindMatch "hbs2:lwwref:update" $ \case - [StringLike puks, HashLike what] -> do + [StringLike puks, HashLike new] -> do flip runContT pure do - puk <- orThrowUser "bad lwwref key" (fromStringMay @(PubKey 'Sign 'HBS2Basic) puks) + puk <- orThrowUser "bad lwwref key" (fromStringMay puks) so <- detectRPC `orDie` "rpc not found" api <- ContT $ withRPC2 @LWWRefAPI @UNIX so @@ -105,11 +107,21 @@ lwwRefEntries = do >>= orThrowUser "can't load credentials" pure ( view peerSignSk creds, view peerSignPk creds ) + what <- callService @RpcLWWRefGet api puk + >>= orThrowUser "can't get lwwref value" - error "YAY!" - -- what <- callService @RpcLWWRefGet api ref - -- >>= orThrowUser "can't get reflog" - -- pure $ mkStr (show $ pretty what) + sno' <- case what of + Nothing -> pure 0 + Just lwwv -> pure (lwwSeq lwwv) + + let sno = succ sno' + + let box = makeSignedBox pk sk (LWWRef sno new Nothing) + + callService @RpcLWWRefUpdate api box + >>= orThrowUser "lww ref update error" + + pure nil _ -> throwIO (BadFormException @C nil) diff --git a/hbs2-peer/app/HttpWorker.hs b/hbs2-peer/app/HttpWorker.hs index abf189b1..6677f4e9 100644 --- a/hbs2-peer/app/HttpWorker.hs +++ b/hbs2-peer/app/HttpWorker.hs @@ -34,11 +34,14 @@ import Data.Either import Codec.Serialise (deserialiseOrFail) import Data.Aeson (object, (.=)) import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.Text qualified as Text import Control.Monad.Reader import Lens.Micro.Platform (view) import System.FilePath import Control.Monad.Except +import Control.Monad.Trans.Maybe import Control.Monad.Trans.Cont +import Data.Coerce import UnliftIO (async) @@ -46,11 +49,29 @@ import UnliftIO (async) -- TODO: introduce-http-of-off-feature -extractMetadataHash :: Hash HbSync -> LBS.ByteString -> Maybe (Hash HbSync) -extractMetadataHash what blob = - case tryDetect what blob of - MerkleAnn (MTreeAnn {_mtaMeta = AnnHashRef h, _mtaCrypt = NullEncryption}) -> Just h - _ -> Nothing +extractMetadataHash :: MonadIO m + => AnyStorage + -> HashRef + -> m (Maybe [Syntax C]) + +extractMetadataHash sto what = runMaybeT do + + blob <- getBlock sto (coerce what) + >>= toMPlus + + case tryDetect (coerce what) blob of + MerkleAnn (MTreeAnn {_mtaMeta = AnnHashRef h, _mtaCrypt = NullEncryption}) -> do + + getBlock sto h + >>= toMPlus + <&> LBS8.unpack + <&> fromRight mempty . parseTop + + + MerkleAnn (MTreeAnn {_mtaMeta = ShortMetadata txt, _mtaCrypt = NullEncryption}) -> do + parseTop (Text.unpack txt) & toMPlus + + _ -> mzero orElse :: m r -> Maybe a -> ContT r m a orElse a mb = ContT $ maybe1 mb a @@ -174,15 +195,10 @@ httpWorker (PeerConfig syn) pmeta e = do getTreeHash :: AnyStorage -> HashRef -> ActionM () getTreeHash sto what' = void $ flip runContT pure do - blob <- liftIO (getBlock sto what) + + meta <- extractMetadataHash sto what' >>= orElse (status status404) - mh <- orElse (status status404) (extractMetadataHash what blob) - - meta <- lift (getBlock sto mh) >>= orElse (status status404) - <&> LBS8.unpack - <&> fromRight mempty . parseTop - let tp = headDef "application/octet-stream" [ show (pretty w) | ListVal [SymbolVal "mime-type:", LitStrVal w] <- meta