wip

hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs

@@ -3,8 +3,12 @@
 module HBS2.Peer.Proto.LWWRef where
 
 import HBS2.Prelude.Plated
+import HBS2.OrDie
 import HBS2.Base58
+import HBS2.Storage
 import HBS2.Hash
+import HBS2.Net.Auth.Credentials
+import HBS2.Net.Proto.Types
 import HBS2.Data.Types.SignedBox
 import HBS2.Data.Types.Refs
 import HBS2.Net.Proto.Types
@@ -14,6 +18,9 @@ import Data.ByteString (ByteString)
 import Data.Hashable hiding (Hashed)
 import Data.Maybe
 import Data.Word
+import Control.Monad.Trans.Maybe
+import Control.Monad.Except
+import Codec.Serialise
 
 data LWWRefProtoReq e =
     LWWProtoGet (LWWRefKey (Encryption e))
@@ -83,3 +90,50 @@ instance Pretty (LWWRef e) where
             | otherwise = parens ( "proof" <+> pretty lwwProof)
 
 
+data ReadLWWRefError =
+    ReadLWWStorageError
+  | ReadLWWFormatError
+  | ReadLWWSignatureError
+  deriving stock (Show,Typeable)
+
+readLWWRef :: forall e s m . ( MonadIO m
+                             , MonadError ReadLWWRefError m
+                             , Encryption e ~ s
+                             , ForLWWRefProto e
+                             , Signatures s
+                             , IsRefPubKey s
+                             )
+           => AnyStorage
+           -> LWWRefKey s
+           -> m (Maybe (LWWRef e))
+
+readLWWRef sto key = runMaybeT do
+  getRef sto key
+    >>= toMPlus
+    >>= getBlock sto
+    >>= toMPlus
+    <&> deserialiseOrFail @(SignedBox (LWWRef e) e)
+    >>= orThrowError ReadLWWFormatError
+    <&> unboxSignedBox0
+    >>= orThrowError ReadLWWSignatureError
+    <&> snd
+
+updateLWWRef :: forall s e m . ( Encryption e ~ s
+                               , ForLWWRefProto e
+                               , MonadIO m
+                               , Signatures s
+                               , IsRefPubKey s
+                               )
+             => AnyStorage
+             -> LWWRefKey s
+             -> PrivKey 'Sign s
+             -> LWWRef e
+             -> m (Maybe HashRef)
+
+updateLWWRef sto k sk v = do
+  let box = makeSignedBox @e (fromLwwRefKey k) sk v
+  runMaybeT do
+    hx <- putBlock sto (serialise box) >>= toMPlus
+    updateRef sto k hx
+    pure (HashRef hx)
+

hbs21-git/git-hbs21/Main.hs

@@ -11,6 +11,7 @@ import HBS2.Git.Data.RefLog
 import HBS2.Git.Local.CLI qualified as Git
 import HBS2.Git.Data.Tx qualified as TX
 import HBS2.Git.Data.Tx (RepoHead(..))
+import HBS2.Git.Data.LWWBlock
 import HBS2.Git.Data.GK
 
 import HBS2.Storage.Operations.ByteString
@@ -46,6 +47,9 @@ pRefLogId :: ReadM RefLogId
 pRefLogId = maybeReader (fromStringMay @RefLogId)
 
 
+pLwwKey :: ReadM (LWWRefKey HBS2Basic)
+pLwwKey = maybeReader fromStringMay
+
 pHashRef :: ReadM HashRef
 pHashRef = maybeReader (fromStringMay @HashRef)
 
@@ -57,7 +61,7 @@ pInit = do
 pExport :: GitPerks m => Parser (GitCLI m ())
 pExport = do
 
-  puk <- argument pRefLogId (metavar "REFLOG-KEY")
+  puk <- argument pLwwKey (metavar "REFLOG-KEY")
 
   et <- flag ExportInc ExportNew
            (  long "new" <> help "new is usable to export to a new empty reflog"
@@ -86,7 +90,7 @@ pExport = do
 
 pImport :: GitPerks m => Parser (GitCLI m ())
 pImport = do
-  puk <- argument pRefLogId (metavar "REFLOG-KEY")
+  puk <- argument pLwwKey (metavar "LWWREF")
 
   pure do
     git <- Git.findGitDir >>= orThrowUser "not a git dir"

hbs21-git/git-remote-hbs21/Main.hs

@@ -12,6 +12,7 @@ import HBS2.Git.Client.Config
 import HBS2.Git.Data.RefLog
 import HBS2.Git.Data.Tx qualified as TX
 import HBS2.Git.Data.Tx (RepoHead(..))
+import HBS2.Git.Data.LWWBlock
 
 import HBS2.System.Dir
 
@@ -47,7 +48,7 @@ sendLine = liftIO . IO.putStrLn
 die :: (MonadIO m, Pretty a) => a -> m b
 die s = liftIO $ Exit.die (show $ pretty s)
 
-parseURL :: String -> Maybe RefLogId
+parseURL :: String -> Maybe (LWWRefKey HBS2Basic)
 parseURL s = eitherToMaybe $ Atto.parseOnly p (BS8.pack s)
   where
     p = do
@@ -55,7 +56,7 @@ parseURL s = eitherToMaybe $ Atto.parseOnly p (BS8.pack s)
 
       Atto.takeWhile1 (`elem` getAlphabet)
        <&> BS8.unpack
-       <&> fromStringMay @RefLogId
+       <&> fromStringMay @(LWWRefKey HBS2Basic)
        >>= maybe (fail "invalid reflog key") pure
 
 parsePush :: String -> Maybe (Maybe GitRef, GitRef)
@@ -111,7 +112,7 @@ main = do
                       pause @'Seconds 0.25
                       liftIO $ hFlush stderr
                       liftIO $ hPutDoc stderr $ ""
-                                  <> ul (yellow "Reflog" <+> pretty url <+>  yellow "is not available yet.") <> line
+                                  <> ul (yellow "Reference" <+> pretty url <+>  yellow "is not available yet.") <> line
                                   <> "If you sure it's a new one -- make sure you've added the key to hbs2-keyman and then run"
                                   <> line <> line
                                   <> "hbs2-keyman update" <> line <> line

hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/App.hs

@@ -62,6 +62,10 @@ drawProgress (ProgressQ q) = do
               put ""
               next qq
 
+            ImportWaitLWW n lww -> do
+              limit 0.25 $ put ("wait lwwref" <+> pretty lww <+> pretty n)
+              next quiet
+
             ImportRefLogStart puk -> do
               put ("wait reflog" <+> pretty (AsBase58 puk))
               next quiet

hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs

@@ -9,6 +9,7 @@ import HBS2.Git.Client.Progress
 
 import HBS2.Git.Data.RefLog
 import HBS2.Git.Data.Tx
+import HBS2.Git.Data.LWWBlock
 import HBS2.Git.Data.GK
 
 import HBS2.Git.Local.CLI
@@ -38,6 +39,7 @@ instance Exception ExportError
 instance HasErrorStatus ExportError where
   getStatus = \case
     ExportUnsupportedOperation -> Failed
+    ExportBundleCreateError -> Failed
 
 instance ToFilePath (GitRef, GitHash) where
   toFilePath (g, r) = show (pretty g)
@@ -143,10 +145,12 @@ storeNewGK0 = do
     writeAsMerkle sto (serialise gk) <&> HashRef <&> (,epoch)
 
 export :: (GitPerks m, MonadReader GitEnv m, GroupKeyOperations m)
-       => RefLogId
+       => LWWRefKey HBS2Basic
        -> [(GitRef,Maybe GitHash)]
        -> m ()
-export puk refs  = do
+export lww refs  = do
+
+  puk <- error "FIXME: puk"
 
   subscribeRefLog puk
 

hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs

@@ -11,6 +11,7 @@ import HBS2.Git.Client.Progress
 
 import HBS2.Git.Data.RefLog
 import HBS2.Git.Data.Tx
+import HBS2.Git.Data.LWWBlock
 
 import Data.ByteString.Lazy qualified as LBS
 
@@ -26,7 +27,6 @@ import System.Exit
 data ImportRefLogNotFound = ImportRefLogNotFound
                             deriving stock (Typeable,Show)
 
-
 instance Exception ImportRefLogNotFound
 
 
@@ -53,47 +53,64 @@ instance Show ImportTxError where
 instance Exception ImportTxError
 
 data IState =
-    IWaitRefLog Int
+    IWaitLWWBlock Int
-  | IScanRefLog HashRef
+  | IWaitRefLog Int RefLogId
+  | IScanRefLog RefLogId HashRef
   | IApplyTx HashRef
   | IExit
 
 importRepoWait :: (GitPerks m, MonadReader GitEnv m)
-               => RefLogId
+               => LWWRefKey HBS2Basic
                -> m ()
 
-importRepoWait  puk = do
+importRepoWait lwwKey = do
 
   env <- ask
 
-  subscribeRefLog puk
-
   ip  <- asks _progress
+  sto <- asks _storage
 
   meet <- newTVarIO (mempty :: HashMap HashRef Int)
 
-  flip fix (IWaitRefLog 20) $ \next -> \case
+  flip fix (IWaitLWWBlock 20) $ \next -> \case
-    IWaitRefLog w | w <= 0 -> do
+
+    IWaitLWWBlock w | w <= 0 -> do
       throwIO ImportRefLogNotFound
 
-    IWaitRefLog w  -> do
+    IWaitLWWBlock w -> do
+      onProgress ip (ImportWaitLWW w lwwKey)
+      lww <- readLWWBlock @L4Proto sto lwwKey
+
+      case lww of
+        Nothing -> do
+          pause @'Seconds 2
+          next (IWaitLWWBlock (pred w))
+
+        Just blk -> do
+          error "FOUND SHIT!"
+          pure ()
+
+    IWaitRefLog w puk | w <= 0 -> do
+      throwIO ImportRefLogNotFound
+
+    IWaitRefLog w puk -> do
       onProgress ip (ImportRefLogStart puk)
       try @_ @SomeException (getRefLogMerkle puk) >>= \case
         Left _ -> do
           onProgress ip (ImportRefLogDone puk Nothing)
           pause @'Seconds 2
-          next (IWaitRefLog (pred w))
+          next (IWaitRefLog (pred w) puk)
 
         Right Nothing -> do
           onProgress ip (ImportRefLogDone puk Nothing)
           pause @'Seconds 2
-          next (IWaitRefLog (pred w))
+          next (IWaitRefLog (pred w) puk)
 
         Right (Just h) -> do
           onProgress ip (ImportRefLogDone puk (Just h))
-          next (IScanRefLog h)
+          next (IScanRefLog puk h)
 
-    IScanRefLog h -> do
+    IScanRefLog puk h -> do
       scanRefLog puk h
       withState (selectMaxSeqTxNotDone puk) >>= \case
         Just tx -> next (IApplyTx tx)
@@ -108,7 +125,7 @@ importRepoWait  puk = do
                       onProgress ip (ImportWaitTx h)
                       pause @'Seconds 0.25
 
-            next (IScanRefLog h)
+            next (IScanRefLog puk h)
 
     IApplyTx h -> do
       onProgress ip (ImportApplyTx h)
@@ -152,8 +169,7 @@ importRepoWait  puk = do
         pure IExit
       else do
         pause @'Seconds 2
-        pure (IWaitRefLog 5)
+        pure (IWaitLWWBlock 5)
-
 
 scanRefLog :: (GitPerks m, MonadReader GitEnv m)
            => RefLogId

hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Progress.hs

@@ -4,6 +4,7 @@ module HBS2.Git.Client.Progress where
 
 import HBS2.Git.Client.Prelude
 import HBS2.Git.Data.RefLog
+import HBS2.Git.Data.LWWBlock
 
 import HBS2.Git.Data.Tx
 
@@ -21,6 +22,7 @@ class HasProgress a where
 
 data ProgressEvent =
     ImportIdle
+  | ImportWaitLWW Int (LWWRefKey HBS2Basic)
   | ImportRefLogStart RefLogId
   | ImportRefLogDone  RefLogId (Maybe HashRef)
   | ImportWaitTx HashRef

hbs21-git/hbs2-git-client-lib/HBS2/Git/Data/LWWBlock.hs

@@ -0,0 +1,138 @@
+{-# Language AllowAmbiguousTypes #-}
+{-# Language UndecidableInstances #-}
+module HBS2.Git.Data.LWWBlock
+  ( module HBS2.Git.Data.LWWBlock
+  , module HBS2.Peer.Proto.LWWRef
+  , HBS2Basic
+  ) where
+
+import HBS2.Prelude.Plated
+import HBS2.OrDie
+import HBS2.Net.Proto.Types
+import HBS2.Data.Types.Refs
+import HBS2.Data.Types.SignedBox
+import HBS2.Net.Auth.Schema()
+import HBS2.Net.Auth.Credentials
+import HBS2.Storage
+import HBS2.Peer.Proto.LWWRef
+
+import Data.Word
+import Codec.Serialise
+import System.Random
+
+import Control.Exception
+import Control.Monad.Except
+import Control.Monad.Trans.Maybe
+
+-- NOTE: on-lww-block-data
+--   HKDF ( SK(LWWRef) , lwwRefNonce ) ==> SK( RefLog )
+--   lwwRefLogPubKey ==  PK ( SK (RefLog ) )
+--
+--   LWWBlock is required to make repo reference "stable",
+--   i.e. it should remains the same even if the structure
+--   of repository has been changed or it was, say, "trimmed".
+--
+--   Therefore, there is the root key and the LWWRef, pointing
+--   to a block, which contains actual seed data for the "current"
+--   repo and it's possible to support permanent reference (LWWRef)
+--   to a repo, while it's actual structure may be changed
+--   (hbs2-git repo structure changes or garbage collecting (removing old
+--   transactions, etc).
+--
+--   (LWWRef PK) -> (LWWBlockData) -> (RefLog : [TX])
+--
+
+data LWWBlockData e =
+  LWWBlockData
+  { lwwRefSeed       :: Word64
+  , lwwRefLogPubKey  :: PubKey 'Sign (Encryption e)
+  }
+  deriving stock Generic
+
+data LWWBlock e =
+  LWWBlock1 { lwwBlockData :: LWWBlockData e }
+  deriving stock Generic
+
+instance Serialise (PubKey 'Sign (Encryption e)) => Serialise (LWWBlockData e)
+instance Serialise (PubKey 'Sign (Encryption e)) => Serialise (LWWBlock e)
+
+
+data LWWBlockOpError =
+    LWWBlockOpSkNotAvail
+  | LWWBlockOpStorageError
+  | LWWBlockOpSomeError
+  deriving stock (Show,Typeable,Generic)
+
+instance Exception LWWBlockOpError
+
+
+readLWWBlock :: forall e s m . ( MonadIO m
+                               , Signatures s
+                               , s ~ Encryption e
+                               , ForLWWRefProto e
+                               , IsRefPubKey s
+                               )
+             => AnyStorage
+             -> LWWRefKey s
+             -> m (Maybe (LWWBlockData e))
+
+readLWWBlock sto k = runMaybeT do
+
+  LWWRef{..} <- runExceptT (readLWWRef @e sto k)
+                  >>= toMPlus
+                  >>= toMPlus
+
+  getBlock sto (fromHashRef lwwValue)
+    >>= toMPlus
+    <&> deserialiseOrFail @(LWWBlock e)
+    >>= toMPlus
+    <&> lwwBlockData
+
+initLWWRef :: forall s e m . ( MonadIO m
+                             , MonadError LWWBlockOpError m
+                             , IsRefPubKey s
+                             , ForSignedBox e
+                             , HasDerivedKey s 'Sign Word64 m
+                             , s ~ Encryption e
+                             , Signatures s
+                             )
+           => AnyStorage
+           -> Maybe Word64
+           -> ( PubKey 'Sign s -> m (Maybe (PrivKey 'Sign s) ) )
+           -> LWWRefKey s
+           -> m HashRef
+initLWWRef sto seed' findSk lwwKey  = do
+  -- let k0 = fromLwwRefKey lww
+  seed   <- maybe1 seed' randomIO pure
+
+  let pk0 = fromLwwRefKey lwwKey
+  sk0 <- findSk pk0
+           >>= orThrowError LWWBlockOpSkNotAvail
+
+  lww0 <- runMaybeT do
+            getRef sto lwwKey >>= toMPlus
+              >>= getBlock sto >>= toMPlus
+              <&> deserialiseOrFail @(SignedBox (LWWRef e) e)
+              >>= toMPlus
+              <&> unboxSignedBox0
+              >>= toMPlus
+              <&> snd
+
+  (pk1, _) <- derivedKey @s @'Sign seed sk0
+
+  let newLwwData = LWWBlock1 (LWWBlockData @e seed pk1)
+
+  hx <- putBlock sto (serialise newLwwData)
+          >>= orThrowError LWWBlockOpStorageError
+          <&> HashRef
+
+  let lww :: LWWRef e
+      lww = LWWRef { lwwSeq = succ (maybe 0 lwwSeq lww0)
+                   , lwwValue = hx
+                   , lwwProof = Nothing
+                   }
+
+  updateLWWRef @s sto lwwKey sk0 lww
+    >>= orThrowError LWWBlockOpStorageError
+
+

hbs21-git/hbs21-git.cabal

@@ -103,6 +103,7 @@ library hbs2-git-client-lib
       HBS2.Git.Data.Tx
       HBS2.Git.Data.GK
       HBS2.Git.Data.RefLog
+      HBS2.Git.Data.LWWBlock
 
       HBS2.Git.Client.Prelude
       HBS2.Git.Client.App.Types