wip, test sync

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

@@ -1,9 +1,11 @@
-module HBS2.CLI.Run.GroupKey where
+module HBS2.CLI.Run.GroupKey
+  ( module HBS2.CLI.Run.GroupKey
+  , loadGroupKey
+  ) where
 
 import HBS2.CLI.Prelude hiding (mapMaybe)
 
 import HBS2.Data.Types.Refs
-import HBS2.System.Logger.Simple.ANSI as All
 import HBS2.Storage.Operations.Class
 import HBS2.Storage.Operations.ByteString
 import HBS2.Base58
@@ -12,25 +14,18 @@ import HBS2.CLI.Run.Internal.GroupKey as G
 import HBS2.Net.Auth.GroupKeySymm as Symm
 import HBS2.Storage
 
-import HBS2.Net.Auth.Credentials
-import HBS2.KeyMan.Keys.Direct
 
 import HBS2.Peer.RPC.API.Storage
 import HBS2.Peer.RPC.Client
 import HBS2.Peer.RPC.Client.Unix
 
-import Data.List qualified as L
-import Data.Maybe
 import Data.Text qualified as Text
 import Data.ByteString.Lazy.Char8 as LBS8
 import Data.ByteString.Lazy as LBS
 import Data.ByteString.Char8 as BS8
 import Data.HashMap.Strict qualified as HM
-import Data.HashSet qualified as HS
-import Control.Monad.Trans.Cont
 import Control.Monad.Except
 import Codec.Serialise
-import Lens.Micro.Platform
 
 {- HLINT ignore "Functor law" -}
 

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

@@ -19,6 +19,7 @@ import HBS2.Merkle
 import HBS2.Data.Detect
 import HBS2.Net.Auth.Credentials
 import HBS2.Net.Proto.Types
+import HBS2.Storage hiding (Key)
 import HBS2.Storage.Operations.Class
 import HBS2.Storage.Operations.ByteString
 import HBS2.Storage(Storage(..))
@@ -433,3 +434,17 @@ deriveGroupSecret n bs = key0
     prk = HKDF.extractSkip @_ @HbSyncHash bs
     key0 = HKDF.expand prk nonceS typicalKeyLength & Saltine.decode & fromJust
 
+
+loadGroupKeyMaybe :: ( MonadIO m
+                     ) => AnyStorage -> HashRef -> m (Maybe (GroupKey 'Symm HBS2Basic))
+loadGroupKeyMaybe sto h = do
+
+  runMaybeT do
+
+    bs <- runExceptT (readFromMerkle sto (SimpleKey (fromHashRef h)))
+            <&> either (const Nothing) Just
+            >>= toMPlus
+
+    deserialiseOrFail bs
+      &  toMPlus
+

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

@@ -5,19 +5,22 @@ module HBS2.Sync.Prelude
 
 
 import HBS2.Prelude.Plated as Exported
+import HBS2.Clock
 import HBS2.Base58
+import HBS2.Data.Detect
 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.GroupKeySymm as Symm
 import HBS2.Net.Auth.Schema
 import HBS2.Clock as Exported
 import HBS2.Net.Proto.Service
 import HBS2.Storage
 import HBS2.Storage.Operations.Class
+import HBS2.Storage.Operations.ByteString
 import HBS2.Peer.Proto.RefChan
 import HBS2.Peer.CLI.Detect
 import HBS2.Peer.RPC.Client
@@ -33,6 +36,7 @@ import HBS2.Misc.PrettyStuff as Exported
 
 import HBS2.CLI.Run hiding (PeerException(..))
 import HBS2.CLI.Run.MetaData
+-- import HBS2.CLI.Run.GroupKey
 
 import HBS2.KeyMan.Keys.Direct
 
@@ -66,10 +70,12 @@ import Data.Time.LocalTime (utcToLocalTime, getCurrentTimeZone, utc)
 import Data.Word
 import Lens.Micro.Platform
 import Streaming.Prelude qualified as S
-import System.Directory (getModificationTime)
+import System.Directory (getModificationTime,setModificationTime)
 import System.FilePath.Posix
 import UnliftIO
 
+import UnliftIO.IO.File qualified as UIO
+
 {- HLINT ignore "Functor law" -}
 {- HLINT ignore "Eta reduce" -}
 
@@ -181,32 +187,37 @@ data EntryType = File | Dir | Tomb
 
 data EntryDesc =
   EntryDesc
-  { entryType      :: EntryType
+  { entryType        :: EntryType
-  , entryTimestamp :: Word64
+  , entryTimestamp   :: Word64
+  , entryRemoteHash  :: Maybe HashRef
   }
   deriving stock (Eq,Ord,Show,Data,Generic)
 
-data DirEntry = DirEntry EntryDesc FilePath
+data Entry =
-                deriving stock (Eq,Ord,Show,Data,Generic)
+  DirEntry EntryDesc FilePath
+  deriving stock (Eq,Ord,Show,Data,Generic)
 
-getEntryTimestamp :: DirEntry -> Word64
+getEntryTimestamp :: Entry -> Word64
 getEntryTimestamp (DirEntry d _) = entryTimestamp d
 
-isFile :: DirEntry -> Bool
+getEntryHash :: Entry -> Maybe HashRef
+getEntryHash (DirEntry d _) = entryRemoteHash d
+
+isFile :: Entry -> Bool
 isFile = \case
   DirEntry (EntryDesc { entryType = File}) _ -> True
   _ -> False
 
-entriesFromLocalFile :: MonadUnliftIO m => FilePath -> FilePath -> m (Map FilePath DirEntry)
+entriesFromLocalFile :: MonadUnliftIO m => FilePath -> FilePath -> m (Map FilePath Entry)
 entriesFromLocalFile prefix fn' = do
   let fn0 = removePrefix prefix fn
   ts <- getFileTimestamp fn
-  pure $ entriesFromFile ts fn0
+  pure $ entriesFromFile Nothing ts fn0
   where
     fn = normalise fn'
 
-entriesFromFile :: Word64 -> FilePath -> Map FilePath DirEntry
+entriesFromFile :: Maybe HashRef -> Word64 -> FilePath -> Map FilePath Entry
-entriesFromFile ts fn0 = do
+entriesFromFile h ts fn0 = do
   let dirs = splitDirectories (dropFileName fn0)
                & dropWhile (== ".")
   let es = flip L.unfoldr ("",dirs) $ \case
@@ -217,8 +228,8 @@ entriesFromFile ts fn0 = do
                | e@(DirEntry _ p) <- fileEntry fn0 : es
                ]
   where
-    dirEntry p   = DirEntry (EntryDesc Dir ts) p
+    dirEntry p   = DirEntry (EntryDesc Dir ts Nothing) p
-    fileEntry p  = DirEntry (EntryDesc File ts) p
+    fileEntry p  = DirEntry (EntryDesc File ts h) p
 
 runDirectory :: ( IsContext c
                 , SyncAppPerks m
@@ -253,9 +264,15 @@ runDirectory path = do
 
   where
 
-    merge :: DirEntry -> DirEntry -> DirEntry
+    merge :: Entry -> Entry -> Entry
     merge a b = if getEntryTimestamp a > getEntryTimestamp b then a else b
 
+    freshIn :: FilePath -> Entry -> Map FilePath Entry -> Bool
+    freshIn p e state = do
+      let remote = Map.lookup p state
+      maybe1 remote True $ \r -> do
+        getEntryTimestamp e > getEntryTimestamp r
+
     runDir = do
 
       notice $ yellow "run directory" <+> pretty path
@@ -306,6 +323,7 @@ runDirectory path = do
 
         _ -> pure ()
 
+      debug $ pretty ins
       evalTop ins
 
       incl <- atomically (flushTQueue tincl) <&> HS.fromList <&> HS.toList
@@ -353,50 +371,67 @@ runDirectory path = do
 
       let merged = Map.unionWith merge local remote
 
-      for_ (Map.toList merged) $ \(p,e) -> do
+      flip runContT pure do
-        debug $ yellow "entry" <+> pretty p <+> viaShow e
 
-        -- warn $ red "POSTING IS SWITCHED OFF"
+        for_ (Map.toList merged) $ \(p,e) -> do
+          debug $ yellow "entry" <+> pretty p <+> viaShow e
 
-        when (not (Map.member p remote) && isFile e) do
+          callCC $ \next -> do
 
-          -- FIXME: dangerous!
+            when (freshIn p e remote) do
-          lbs <- liftIO (LBS.readFile (path </> p))
 
-          let (dir,file) = splitFileName p
+              -- FIXME: dangerous!
+              lbs <- liftIO (LBS.readFile (path </> p))
 
-          let meta = HM.fromList [ ("file-name", fromString file)
+              let (dir,file) = splitFileName p
-                                 ]
-                      <> case dir of
-                           "./" -> mempty
-                           d    -> HM.singleton "location" (fromString d)
 
-          let members = view refChanHeadReaders rch & HS.toList
+              let meta = HM.fromList [ ("file-name", fromString file)
+                                     ]
+                          <> case dir of
+                               "./" -> mempty
+                               d    -> HM.singleton "location" (fromString d)
 
-          -- FIXME: support-unencrypted?
+              let members = view refChanHeadReaders rch & HS.toList
-          when (L.null members) do
-            throwIO EncryptionKeysNotDefined
 
-          gk <- Symm.generateGroupKey @'HBS2Basic Nothing members
+              -- FIXME: support-unencrypted?
+              when (L.null members) do
+                throwIO EncryptionKeysNotDefined
 
-          -- FIXME: survive-this-error?
+              gk <- Symm.generateGroupKey @'HBS2Basic Nothing members
-          href <- createTreeWithMetadata sto (Just gk) meta lbs
-                    >>= orThrowPassIO
 
-          let tx = AnnotatedHashRef Nothing href
+              -- FIXME: survive-this-error?
-          let spk = view peerSignPk creds
+              href <- lift $ createTreeWithMetadata sto (Just gk) meta lbs
-          let ssk = view peerSignSk creds
+                        >>= orThrowPassIO
 
-          let box = makeSignedBox @HBS2Basic spk ssk (LBS.toStrict $ serialise tx)
+              let tx = AnnotatedHashRef Nothing href
+              let spk = view peerSignPk creds
+              let ssk = view peerSignSk creds
 
-          postRefChanTx @UNIX refchan box
+              let box = makeSignedBox @HBS2Basic spk ssk (LBS.toStrict $ serialise tx)
 
-          notice $ red "POST NEW REMOTE ENTRY" <+> pretty p <+> pretty href
+              notice $ red "POST NEW REMOTE ENTRY" <+> pretty p <+> pretty href
 
-        unless (Map.member p local) do
+              lift $ postRefChanTx @UNIX refchan box
-          notice $ red "WRITE NEW LOCAL ENTRY" <+> pretty p
+
+            when (freshIn p e local) do
+              h <- ContT $ maybe1 (getEntryHash e) none
+              -- let h = getEntryHash e
+
+              notice $ red "WRITE NEW LOCAL ENTRY" <+> pretty path <+> pretty p <+> pretty (getEntryHash e)
+
+              lbs' <- lift (runExceptT (getTreeContents sto h))
+                      <&> either (const Nothing) Just
+
+              lbs <- ContT $ maybe1 lbs' none
+
+              liftIO $ UIO.withBinaryFileAtomic (path </> p) WriteMode $ \fh -> do
+                LBS.hPutStr fh lbs
+
+              let ts  = getEntryTimestamp e
+              let timestamp = posixSecondsToUTCTime (fromIntegral ts)
+
+              liftIO $ setModificationTime (path </> p) timestamp
 
-      debug $ pretty ins
 
     getStateFromRefChan rchan = do
 
@@ -435,12 +470,45 @@ runDirectory path = do
           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)
+            let r = entriesFromFile (Just tree) ts (loc </> fn)
             lift $ S.yield r
 
       pure $ Map.unionsWith merge ess0
 
 
+getTreeContents :: ( MonadUnliftIO m
+                   , MonadError OperationError m
+                   )
+                => AnyStorage
+                -> HashRef
+                -> m LBS.ByteString
+
+getTreeContents sto href = do
+
+  blk <- getBlock sto (coerce href)
+           >>= orThrowError MissedBlockError
+
+  let q = tryDetect (coerce href) blk
+
+  case q of
+
+    MerkleAnn (MTreeAnn {_mtaCrypt = NullEncryption }) -> do
+      readFromMerkle sto (SimpleKey (coerce href))
+
+    MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm gkh _}) -> do
+
+      rcpts  <- Symm.loadGroupKeyMaybe sto (HashRef gkh)
+                  >>= orThrowError (GroupKeyNotFound 11)
+                  <&> HM.keys . Symm.recipients
+
+      kre <- runKeymanClient do
+                loadKeyRingEntries rcpts <&> fmap snd
+
+      readFromMerkle sto (ToDecryptBS kre (coerce href))
+
+    _ -> throwError UnsupportedFormat
+
+
 syncEntries :: forall c m . (MonadUnliftIO m, IsContext c) => MakeDictM c m ()
 syncEntries = do