wip

hbs2-core/hbs2-core.cabal

@@ -94,6 +94,7 @@ library
                     , HBS2.Polling
                     , HBS2.Hash
                     , HBS2.Merkle
+                    , HBS2.Merkle.MetaData
                     , HBS2.Net.Auth.Schema
                     , HBS2.Net.Auth.GroupKeyAsymm
                     , HBS2.Net.Auth.GroupKeySymm

hbs2-core/lib/HBS2/Merkle/MetaData.hs

@@ -0,0 +1,55 @@
+module HBS2.Merkle.MetaData where
+
+import HBS2.Prelude
+import HBS2.OrDie
+import HBS2.Data.Types.Refs
+import HBS2.Merkle
+import HBS2.Storage
+import HBS2.Data.Types.SmallEncryptedBlock
+import HBS2.Net.Auth.GroupKeySymm as G
+import HBS2.Storage.Operations.Class
+
+import Data.Coerce
+import Data.ByteString.Lazy qualified as LBS
+import Codec.Serialise
+import Data.Text.Encoding qualified as TE
+import Control.Monad.Except
+
+{- HLINT ignore "Functor law" -}
+
+extractMetaData :: forall s m . (MonadIO m, ForGroupKeySymm s, MonadError OperationError m)
+
+                => (GroupKey 'Symm s -> m (Maybe GroupSecret))
+                -> AnyStorage
+                -> HashRef
+                -> m Text
+extractMetaData fk sto hash = do
+
+    headBlock <- getBlock sto (coerce hash)
+                   >>= orThrowError MissedBlockError
+                   <&> deserialiseOrFail @(MTreeAnn [HashRef])
+                   >>= orThrowError UnsupportedFormat
+
+    case headBlock of
+      MTreeAnn { _mtaMeta = ShortMetadata s } -> do
+        pure  s
+
+      MTreeAnn { _mtaMeta = AnnHashRef h, _mtaCrypt = NullEncryption } -> do
+        getBlock sto h
+           >>= orThrowError MissedBlockError
+           <&> LBS.toStrict
+           <&> TE.decodeUtf8
+
+      MTreeAnn { _mtaMeta = AnnHashRef h } -> do
+        getBlock sto h
+           >>= orThrowError MissedBlockError
+           <&> deserialiseOrFail @(SmallEncryptedBlock AnnMetaData)
+           >>= orThrowError UnsupportedFormat
+           >>= G.decryptBlock @_ @s sto fk
+           >>= \case
+            ShortMetadata s -> pure s
+            _ -> throwError UnsupportedFormat
+
+      _ -> throwError UnsupportedFormat
+
+

hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs

@@ -396,8 +396,6 @@ decryptBlock :: forall t s sto h m . ( MonadIO m
                                      , MonadError OperationError m
                                      , Storage sto h ByteString m
                                      , ForGroupKeySymm s
-                                     , PubKey 'Encrypt s ~ AK.PublicKey
-                                     , PrivKey 'Encrypt s ~ AK.SecretKey
                                      , h ~ HbSync
                                      , Serialise t
                                      )

hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanUpdate.hs

@@ -71,6 +71,7 @@ pattern AcceptTran t a b <- (unpackAcceptTran -> (t, a, b))
   where
     AcceptTran Nothing a b = AcceptTran1 a b
     AcceptTran (Just t) a b = AcceptTran2 (Just t) a b
+{-# COMPLETE AcceptTran #-}
 
 instance ForRefChans e => Serialise (ProposeTran e)
 instance ForRefChans e => Serialise (AcceptTran e)

hbs2-peer/lib/HBS2/Peer/RPC/Client/RefChan.hs

@@ -3,6 +3,7 @@ module HBS2.Peer.RPC.Client.RefChan where
 
 import HBS2.OrDie
 import HBS2.Storage
+import HBS2.Merkle
 import HBS2.Storage.Operations.ByteString
 import HBS2.Data.Types.SignedBox
 
@@ -13,9 +14,13 @@ import HBS2.Peer.RPC.API.Storage
 import HBS2.Peer.RPC.Client.Internal
 import HBS2.Peer.RPC.Client.StorageClient
 
+import Data.ByteString (ByteString)
 import Data.Coerce
 import Control.Monad.Except
 import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Cont
+import Control.Monad.Reader
+import Codec.Serialise
 import UnliftIO
 
 
@@ -55,3 +60,123 @@ getRefChanHead puk = do
 
     pure hdblk
 
+postRefChanTx :: forall proto s  m . ( MonadUnliftIO m
+                                     , HasClientAPI RefChanAPI proto m
+                                     , HasClientAPI StorageAPI proto m
+                                     , HasProtocol proto (ServiceProto RefChanAPI proto)
+                                     , HasProtocol proto (ServiceProto StorageAPI proto)
+                                     , ForSignedBox s
+                                     , s ~ HBS2Basic
+                                     )
+                   => PubKey 'Sign s
+                   -> SignedBox ByteString s
+                   -> m ()
+postRefChanTx puk box = do
+  api <- getClientAPI @RefChanAPI @proto
+  callRpcWaitMay  @RpcRefChanPropose (TimeoutSec 1) api (puk, box) >>= \case
+    Nothing -> throwIO RpcTimeoutError
+    Just e  -> pure e
+
+fetchRefChanHead :: forall proto m . ( MonadUnliftIO m
+                                    , HasClientAPI RefChanAPI proto m
+                                    , HasProtocol proto (ServiceProto RefChanAPI proto)
+                                    )
+                   => PubKey 'Sign 'HBS2Basic
+                   -> m ()
+fetchRefChanHead puk = do
+  api <- getClientAPI @RefChanAPI @proto
+  callRpcWaitMay  @RpcRefChanHeadFetch (TimeoutSec 1) api puk >>= \case
+    Nothing -> throwIO RpcTimeoutError
+    _ -> pure ()
+
+fetchRefChan :: forall proto m . ( MonadUnliftIO m
+                                    , HasClientAPI RefChanAPI proto m
+                                    , HasProtocol proto (ServiceProto RefChanAPI proto)
+                                    )
+                   => PubKey 'Sign 'HBS2Basic
+                   -> m ()
+fetchRefChan puk = do
+  api <- getClientAPI @RefChanAPI @proto
+  callRpcWaitMay  @RpcRefChanFetch (TimeoutSec 1) api puk >>= \case
+    Nothing -> throwIO RpcTimeoutError
+    _ -> pure ()
+
+
+getRefChanValue :: forall proto m . ( MonadUnliftIO m
+                                    , HasClientAPI RefChanAPI proto m
+                                    , HasProtocol proto (ServiceProto RefChanAPI proto)
+                                    )
+                   => PubKey 'Sign 'HBS2Basic
+                   -> m (Maybe HashRef)
+getRefChanValue puk = do
+  api <- getClientAPI @RefChanAPI @proto
+  callRpcWaitMay  @RpcRefChanGet (TimeoutSec 1) api puk >>= \case
+    Nothing -> throwIO RpcTimeoutError
+    Just e -> pure e
+
+
+
+
+-- this is not MonadUnliftIO to be compatible with
+-- streaming
+--
+
+data RScanEnv proto =
+  RScanEnv {
+    rchanAPI :: ServiceCaller RefChanAPI proto
+  }
+
+
+instance Monad m => HasClientAPI RefChanAPI proto (ReaderT (RScanEnv proto) m) where
+  getClientAPI = asks rchanAPI
+
+data RefChanUpdateUnpacked e =
+  A (AcceptTran e) | P HashRef (ProposeTran e)
+  deriving stock (Generic)
+
+{-# COMPLETE A,P #-}
+
+walkRefChanTx :: forall proto m . ( MonadIO m
+                                  , HasClientAPI RefChanAPI proto m
+                                  , HasProtocol proto (ServiceProto RefChanAPI proto)
+                                  , HasStorage m
+                                  )
+            => PubKey 'Sign 'HBS2Basic
+            -> (RefChanUpdateUnpacked L4Proto -> m ())
+            -> m ()
+walkRefChanTx puk action = do
+  sto <- getStorage
+  api <- getClientAPI @RefChanAPI @proto
+
+  let env = RScanEnv api
+
+  flip runContT pure $ callCC $ \exit -> do
+
+    rcv' <- liftIO (runReaderT (getRefChanValue @proto puk) env)
+
+    rcv <- ContT $ maybe1 rcv' none
+
+    walkMerkle (coerce rcv) (getBlock sto) $ \case
+      -- FIXME: error-handling
+      Left _ -> exit ()
+
+      Right (hs :: [HashRef]) -> do
+        for_ hs $ \h -> do
+          lbs' <- getBlock sto (coerce h)
+          lbs  <- ContT $ maybe1 lbs' none
+
+          let txraw = deserialiseOrFail @(RefChanUpdate L4Proto) lbs
+                        & either (const Nothing) Just
+
+          tx <- ContT $ maybe1 txraw none
+
+          case tx of
+
+            Accept _ box  -> do
+              (_, txx) <- ContT $ maybe1 (unboxSignedBox0 box) none
+              lift $ action (A txx)
+
+            Propose _ box -> do
+              (_, txx) <- ContT $ maybe1 (unboxSignedBox0 box) none
+              lift $ action (P h txx)
+

hbs2-sync/src/HBS2/Sync/Prelude.hs

@@ -6,9 +6,14 @@ module HBS2.Sync.Prelude
 
 import HBS2.Prelude.Plated as Exported
 import HBS2.Base58
+import HBS2.Merkle
+import HBS2.Merkle.MetaData
 import HBS2.OrDie as Exported
 import HBS2.Data.Types.Refs as Exported
+import HBS2.Data.Types.SignedBox
+import HBS2.Net.Auth.Credentials
 import HBS2.Net.Auth.GroupKeySymm qualified as Symm
+import HBS2.Net.Auth.Schema
 import HBS2.Clock as Exported
 import HBS2.Net.Proto.Service
 import HBS2.Storage
@@ -29,6 +34,8 @@ import HBS2.Misc.PrettyStuff as Exported
 import HBS2.CLI.Run hiding (PeerException(..))
 import HBS2.CLI.Run.MetaData
 
+import HBS2.KeyMan.Keys.Direct
+
 import Data.Config.Suckless as Exported
 import Data.Config.Suckless.Script as Exported
 import Data.Config.Suckless.Script.File
@@ -37,7 +44,11 @@ import Codec.Serialise as Exported
 import Control.Concurrent.STM (flushTQueue)
 import Control.Monad.Reader as Exported
 import Control.Monad.Trans.Cont as Exported
+import Control.Monad.Trans.Maybe
+import Control.Monad.Except
+import Data.ByteString (ByteString)
 import Data.ByteString.Lazy qualified as LBS
+import Data.Coerce
 import Data.Either
 import Data.HashMap.Strict qualified as HM
 import Data.HashSet qualified as HS
@@ -93,6 +104,11 @@ instance MonadIO m => HasClientAPI PeerAPI UNIX (SyncApp m) where
   getClientAPI = ask >>= orThrow PeerNotConnectedException
                      <&> peerAPI
 
+instance MonadIO m => HasStorage (SyncApp m) where
+  getStorage = do
+    api <- getClientAPI @StorageAPI @UNIX
+    pure $ AnyStorage (StorageClient api)
+
 withSyncApp :: SyncAppPerks m => Maybe SyncEnv -> SyncApp m a -> m a
 withSyncApp env action = runReaderT (fromSyncApp action) env
 
@@ -143,6 +159,7 @@ data RunDirectoryException =
     RefChanNotSetException
   | RefChanHeadNotFoundException
   | EncryptionKeysNotDefined
+  | SignKeyNotSet
   deriving stock (Show,Typeable)
 
 instance Exception RunDirectoryException
@@ -159,7 +176,7 @@ getFileTimestamp filePath = do
   pure (round $ utcTimeToPOSIXSeconds t0)
 
 
-data EntryType = File | Dir
+data EntryType = File | Dir | Tomb
                  deriving stock (Eq,Ord,Show,Data,Generic)
 
 data EntryDesc =
@@ -182,32 +199,32 @@ isFile = \case
 
 entriesFromLocalFile :: MonadUnliftIO m => FilePath -> FilePath -> m (Map FilePath DirEntry)
 entriesFromLocalFile prefix fn' = do
-
   let fn0 = removePrefix prefix fn
   ts <- getFileTimestamp fn
-
+  pure $ entriesFromFile ts fn0
-  let dirs = splitDirectories (dropFileName fn0)
-               & dropWhile (== ".")
-
-  debug $ red "SOURCE" <+> pretty fn0 <+> pretty fn <+> pretty dirs
-
-  let es = flip L.unfoldr ("",dirs) $ \case
-              (_,[])   -> Nothing
-              (p,d:ds) -> Just (dirEntry ts (p </> d), (p </> d, ds) )
-
-  pure $ Map.fromList [ (p, e)
-                      | e@(DirEntry _ p) <- fileEntry ts fn0 : es
-                      ]
-
   where
     fn = normalise fn'
-    dirEntry ts p   = DirEntry (EntryDesc Dir ts) p
+
-    fileEntry ts p  = DirEntry (EntryDesc File ts) p
+entriesFromFile :: Word64 -> FilePath -> Map FilePath DirEntry
+entriesFromFile ts fn0 = do
+  let dirs = splitDirectories (dropFileName fn0)
+               & dropWhile (== ".")
+  let es = flip L.unfoldr ("",dirs) $ \case
+              (_,[])   -> Nothing
+              (p,d:ds) -> Just (dirEntry (p </> d), (p </> d, ds) )
+
+  Map.fromList [ (p, e)
+               | e@(DirEntry _ p) <- fileEntry fn0 : es
+               ]
+  where
+    dirEntry p   = DirEntry (EntryDesc Dir ts) p
+    fileEntry p  = DirEntry (EntryDesc File ts) p
 
 runDirectory :: ( IsContext c
                 , SyncAppPerks m
                 , HasClientAPI RefChanAPI UNIX m
                 , HasClientAPI StorageAPI UNIX m
+                , HasStorage m
                 , Exception (BadFormException c)
                 ) => FilePath -> RunM c m ()
 runDirectory path = do
@@ -223,6 +240,8 @@ runDirectory path = do
         err $ "no refchan head found for" <+> pretty path
       EncryptionKeysNotDefined -> do
         err $ "no readers defined in the refchan for " <+> pretty path
+      SignKeyNotSet -> do
+        err $ "sign key not set or not found " <+> pretty path
 
     `catch` \case
       (e :: OperationError) -> do
@@ -242,6 +261,7 @@ runDirectory path = do
       notice $ yellow "run directory" <+> pretty path
 
       trc    <- newTVarIO Nothing
+      tsign  <- newTVarIO Nothing
       texcl  <- newTQueueIO
       tincl  <- newTQueueIO
 
@@ -273,6 +293,19 @@ runDirectory path = do
 
         _ -> pure ()
 
+
+      bindBuiltins $ bindMatch "sign" $ nil_ $ \case
+        [SignPubKeyLike s] -> do
+          debug $ red "SIGN" <+> pretty (AsBase58 s)
+
+          runMaybeT do
+            creds <- MaybeT $ runKeymanClient $ loadCredentials s
+            atomically $ writeTVar tsign (Just creds)
+
+          pure ()
+
+        _ -> pure ()
+
       evalTop ins
 
       incl <- atomically (flushTQueue tincl) <&> HS.fromList <&> HS.toList
@@ -281,9 +314,14 @@ runDirectory path = do
       refchan <- readTVarIO trc
                    >>= orThrow RefChanNotSetException
 
+      fetchRefChan @UNIX refchan
+
       rch <- Client.getRefChanHead @UNIX refchan
                    >>= orThrow RefChanHeadNotFoundException
 
+      creds <- readTVarIO tsign
+                  >>= orThrow SignKeyNotSet
+
       sto <- getClientAPI @StorageAPI @UNIX
               <&> AnyStorage . StorageClient
 
@@ -310,14 +348,18 @@ runDirectory path = do
       debug "FUCKING GOT REFCHAN HEAD"
 
       let local = Map.fromList [ (p,e) | e@(DirEntry _ p) <- es' ]
-      let remote = Map.empty
+
+      remote <- getStateFromRefChan refchan
 
       let merged = Map.unionWith merge local remote
 
       for_ (Map.toList merged) $ \(p,e) -> do
         debug $ yellow "entry" <+> pretty p <+> viaShow e
 
-        when (not (Map.member p remote) && isFile e) do
+        warn $ red "POSTING IS SWITCHED OFF"
+
+
+        when (not (Map.member p remote) && isFile e && False) do
 
           -- FIXME: dangerous!
           lbs <- liftIO (LBS.readFile (path </> p))
@@ -342,6 +384,14 @@ runDirectory path = do
           href <- createTreeWithMetadata sto (Just gk) meta lbs
                     >>= orThrowPassIO
 
+          let tx = AnnotatedHashRef Nothing href
+          let spk = view peerSignPk creds
+          let ssk = view peerSignSk creds
+
+          let box = makeSignedBox @HBS2Basic spk ssk (LBS.toStrict $ serialise tx)
+
+          postRefChanTx @UNIX refchan box
+
           notice $ red "POST NEW REMOTE ENTRY" <+> pretty p <+> pretty href
 
           pure ()
@@ -351,6 +401,53 @@ runDirectory path = do
 
       debug $ pretty ins
 
+    getStateFromRefChan rchan = do
+
+      debug $ red "getStateFromRefChan" <+> pretty (AsBase58 rchan)
+
+      sto <- getStorage
+
+      outq <- newTQueueIO
+      tss <- newTVarIO mempty
+
+      walkRefChanTx @UNIX rchan $ \case
+        A (AcceptTran ts _ what) -> do
+          debug $ red "ACCEPT" <+> pretty ts <+> pretty what
+          for_ ts $ \w -> do
+            atomically $ modifyTVar tss (HM.insertWith max what (coerce @_ @Word64 w))
+
+        P orig (ProposeTran _ box) -> void $ runMaybeT do
+          (_, bs) <- unboxSignedBox0 box & toMPlus
+          AnnotatedHashRef w href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict bs)
+                                      & toMPlus . either (const Nothing) Just
+
+          let findKey gk = liftIO (runKeymanClient (extractGroupKeySecret gk))
+
+          runExceptT (extractMetaData @'HBS2Basic findKey sto href)
+           >>= either (const none) ( \meta -> atomically $ writeTQueue outq (orig, (href, meta)) )
+
+      trees <- atomically (flushTQueue outq)
+
+      tsmap <- readTVarIO tss
+
+      ess0 <- S.toList_ do
+        for_ trees $ \(txh, (tree, meta)) -> do
+          let what = parseTop meta & fromRight mempty
+          let loc  = headDef "" [ l | ListVal [StringLike "location:", StringLike l] <- what ]
+
+          void $ runMaybeT do
+            fn  <- toMPlus $ headMay [ l | ListVal [StringLike "file-name:", StringLike l] <- what ]
+            ts  <- toMPlus $ HM.lookup txh tsmap
+            let r = entriesFromFile ts (loc </> fn)
+            lift $ S.yield r
+
+      let ess = Map.unionsWith merge ess0
+
+      for_ (Map.toList ess) $ \(p,e) -> do
+        debug $ "REMOTE ENTRY" <+> pretty p <+> viaShow e
+
+      pure mempty
+
 
 syncEntries :: forall c m . (MonadUnliftIO m, IsContext c) => MakeDictM c m ()
 syncEntries = do
@@ -362,6 +459,7 @@ syncEntries = do
     _ -> do
       setLogging @DEBUG  debugPrefix
 
+-- debugPrefix :: LoggerEntry -> LoggerEntry
 debugPrefix = toStderr . logPrefix "[debug] "
 
 setupLogger :: MonadIO m => m ()