diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs index e9a2e69d..12813c55 100644 --- a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs +++ b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs @@ -162,7 +162,7 @@ export key refs = do subscribeLWWRef key - lww@LWWBlockData{..} <- waitOrInitLWWRef + (lww, LWWBlockData{..}) <- waitOrInitLWWRef let puk0 = fromLwwRefKey key diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs index f61360af..eadb6c1c 100644 --- a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs +++ b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs @@ -91,7 +91,11 @@ importRepoWait lwwKey = do fetchLWWRef lwwKey next (IWaitLWWBlock (pred w)) - Just (LWWBlockData{..}) -> do + Just (LWWRef{..}, LWWBlockData{..}) -> do + + withState do + insertLww lwwKey lwwSeq lwwRefLogPubKey + void $ try @_ @SomeException (getRefLogMerkle lwwRefLogPubKey) subscribeRefLog lwwRefLogPubKey pause @'Seconds 0.25 diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/RefLog.hs b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/RefLog.hs index 912543d6..13371f5d 100644 --- a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/RefLog.hs +++ b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/RefLog.hs @@ -1,9 +1,13 @@ -module HBS2.Git.Client.RefLog where +module HBS2.Git.Client.RefLog + ( module HBS2.Git.Client.RefLog + , module HBS2.Peer.Proto.RefLog + ) where import HBS2.Git.Client.Prelude import HBS2.Git.Client.App.Types import HBS2.Git.Data.RefLog import HBS2.Git.Data.LWWBlock +import HBS2.Peer.Proto.RefLog data RefLogRequestTimeout = RefLogRequestTimeout deriving (Show,Typeable) diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/State.hs b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/State.hs index 7dcfd915..5974090d 100644 --- a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/State.hs +++ b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/State.hs @@ -10,14 +10,16 @@ import HBS2.Git.Client.Prelude import HBS2.Git.Client.App.Types import HBS2.Git.Client.Config +import HBS2.Peer.Proto.RefLog + import HBS2.Git.Data.RefLog +import HBS2.Git.Data.LWWBlock import DBPipe.SQLite import Data.Maybe import Data.List qualified as List - import Text.InterpolatedString.Perl6 (qc) - +import Data.Word newtype Base58Field a = Base58Field { fromBase58Field :: a } deriving stock (Eq,Ord,Generic) @@ -28,6 +30,9 @@ instance Pretty (AsBase58 a) => ToField (Base58Field a) where instance IsString a => FromField (Base58Field a) where fromField = fmap (Base58Field . fromString) . fromField @String +instance FromField (RefLogKey HBS2Basic) where + fromField = fmap fromString . fromField @String + instance ToField HashRef where toField h = toField @String (show $ pretty h) @@ -46,6 +51,8 @@ instance FromField GitRef where instance FromField GitHash where fromField = fmap fromString . fromField @String +instance FromField (LWWRefKey HBS2Basic) where + fromField = fmap fromString . fromField @String createStateDir :: (GitPerks m, MonadReader GitEnv m) => m () createStateDir = do @@ -74,6 +81,7 @@ evolveDB = withState do createBundleKeyTable createBundleObjectTable createNewGK0Table + createLwwTable commitAll createTxTable :: MonadIO m => DBPipeM m () @@ -156,6 +164,19 @@ create table if not exists newgk0 ) |] + +createLwwTable :: MonadIO m => DBPipeM m () +createLwwTable = do + ddl [qc| +create table if not exists lww + ( hash text not null + , seq text not null + , reflog text not null + , primary key (hash,seq,reflog) + ) + |] + + existsTx :: MonadIO m => HashRef -> DBPipeM m Bool existsTx txHash = do select @(Only Bool) [qc| @@ -346,3 +367,16 @@ limit 1 |] (Only (Base58Field reflog)) <&> listToMaybe +insertLww :: MonadIO m => LWWRefKey HBS2Basic -> Word64 -> RefLogId -> DBPipeM m () +insertLww lww snum reflog = do + insert [qc| +INSERT INTO lww (hash, seq, reflog) VALUES (?, ?, ?) +ON CONFLICT (hash,seq,reflog) DO NOTHING + |] (Base58Field lww, snum, Base58Field reflog) + +selectAllLww :: MonadIO m => DBPipeM m [(LWWRefKey HBS2Basic, Word64, RefLogId)] +selectAllLww = do + select_ [qc| +SELECT hash, seq, reflog FROM lww + |] <&> fmap (over _3 (fromRefLogKey @HBS2Basic)) + diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Data/LWWBlock.hs b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Data/LWWBlock.hs index 4e4e290a..b4c45261 100644 --- a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Data/LWWBlock.hs +++ b/hbs21-git/hbs2-git-client-lib/HBS2/Git/Data/LWWBlock.hs @@ -65,6 +65,7 @@ data LWWBlockOpError = instance Exception LWWBlockOpError +{- HLINT ignore "Functor law" -} readLWWBlock :: forall e s m . ( MonadIO m , Signatures s @@ -75,11 +76,11 @@ readLWWBlock :: forall e s m . ( MonadIO m ) => AnyStorage -> LWWRefKey s - -> m (Maybe (LWWBlockData e)) + -> m (Maybe (LWWRef e, LWWBlockData e)) readLWWBlock sto k = runMaybeT do - LWWRef{..} <- runExceptT (readLWWRef @e sto k) + w@LWWRef{..} <- runExceptT (readLWWRef @e sto k) >>= toMPlus >>= toMPlus @@ -88,6 +89,7 @@ readLWWBlock sto k = runMaybeT do <&> deserialiseOrFail @(LWWBlock e) >>= toMPlus <&> lwwBlockData + <&> (w,) initLWWRef :: forall e s m . ( MonadIO m , MonadError LWWBlockOpError m