diff --git a/hbs2-git3/app/Main.hs b/hbs2-git3/app/Main.hs index 9472fa1b..b60601ac 100644 --- a/hbs2-git3/app/Main.hs +++ b/hbs2-git3/app/Main.hs @@ -24,6 +24,8 @@ import HBS2.Peer.RPC.Client.StorageClient import HBS2.Git.Local import HBS2.Git.Local.CLI +import HBS2.CLI.Run.Internal.Merkle (createTreeWithMetadata) + import HBS2.System.Logger.Simple.ANSI as Exported import HBS2.System.Dir import HBS2.Misc.PrettyStuff as Exported @@ -262,11 +264,11 @@ instance MonadUnliftIO m => HasClientAPI PeerAPI UNIX (Git3 m) where Git3Disconnected{} -> throwIO Git3PeerNotConnected Git3Connected{..} -> pure peerAPI -instance (MonadUnliftIO m, HasClientAPI api proto m) => HasClientAPI api proto (RunM c m) where - getClientAPI = lift (getClientAPI @api @proto) +-- instance (MonadUnliftIO m, HasClientAPI api proto m) => HasClientAPI api proto (RunM c m) where +-- getClientAPI = lift (getClientAPI @api @proto) -instance (MonadUnliftIO m, HasClientAPI api proto m) => HasClientAPI api proto (ContT a (RunM c m)) where - getClientAPI = lift $ getClientAPI @api @proto +-- instance (MonadUnliftIO m, HasClientAPI api proto m) => HasClientAPI api proto (ContT a (RunM c m)) where +-- getClientAPI = lift $ getClientAPI @api @proto nullGit3Env :: MonadIO m => m Git3Env nullGit3Env = Git3Disconnected <$> newTVarIO Nothing @@ -412,6 +414,7 @@ theDict :: forall m . ( HBS2GitPerks m , HasClientAPI PeerAPI UNIX m , HasStorage m , HasGitRemoteKey m + , HasStateDB m , MonadReader Git3Env m ) => Dict C m theDict = do @@ -499,6 +502,8 @@ theDict = do entry $ bindMatch "test:git:tree:export" $ nil_ $ \syn -> do + mkdir "export" + r <- case syn of [] -> gitRevParseThrow "HEAD" [ StringLike co ] -> gitRevParseThrow co @@ -535,9 +540,12 @@ theDict = do Just (co,prio) -> do debug $ "Process commit" <+> pretty co - debug $ "check-pack-for" <+> pretty co + debug $ "check-pack-for" <+> pretty prio <+> pretty co - already <- readTVarIO done <&> HS.member co + inDb <- lift $ withState (selectGitPack co) <&> isJust + isDone <- readTVarIO done <&> HS.member co + + let already = inDb || isDone if already then next ExportGetCommit @@ -547,10 +555,38 @@ theDict = do parents <- gitReadCommitParents bs - for_ (zip [1..] parents) $ \(i,gh) -> do - atomically $ modifyTVar q (HPSQ.insert gh (prio-i) ()) + n <- for (zip [1..] parents) $ \(i,gh) -> do + atomically do + pdone <- readTVar done <&> HS.member gh + if pdone then do + pure 0 + else do + modifyTVar q (HPSQ.insert gh (prio-i) ()) + pure 1 - atomically $ modifyTVar done (HS.insert co) + if sum n == 0 then lift do + debug $ "write pack for" <+> pretty co + + let fn = "export" show (pretty co) <> ".pack" + + liftIO $ withFile fn WriteMode $ \to -> do + gitWriteCommitPackIO () reader co $ \pss -> do + BS.hPut to pss + + -- FIXME: support-encryption! + lbs <- liftIO $ LBS.readFile fn + + href <- createTreeWithMetadata sto mzero mempty lbs + >>= orThrowUser "can't write merkle tree" + + debug $ "pack-merkle-tree-hash" <+> pretty href + + withState do + insertGitPack co href + + atomically $ modifyTVar done (HS.insert co) + else do + atomically $ modifyTVar q (HPSQ.insert co prio ()) next ExportGetCommit diff --git a/hbs2-git3/lib/HBS2/Git3/State/Direct.hs b/hbs2-git3/lib/HBS2/Git3/State/Direct.hs index 8633a329..fc583f35 100644 --- a/hbs2-git3/lib/HBS2/Git3/State/Direct.hs +++ b/hbs2-git3/lib/HBS2/Git3/State/Direct.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} module HBS2.Git3.State.Direct ( module HBS2.Git3.State.Direct , module HBS2.Git3.State.Types @@ -5,13 +6,17 @@ module HBS2.Git3.State.Direct import HBS2.Prelude.Plated import HBS2.OrDie +import HBS2.Data.Types.Refs import HBS2.System.Dir +import HBS2.Git.Local + import HBS2.Git3.State.Types import DBPipe.SQLite import System.Directory +import Data.Maybe import Text.InterpolatedString.Perl6 (qc) @@ -38,14 +43,41 @@ evolveState = do ddl [qc| create table if not exists -gitobject - ( githash text not null primary key - , type text not null - , cblock text not null +gitpack + ( kommit text not null primary key , pack text not null ) |] - pure () + +instance ToField GitHash where + toField h = toField (show $ pretty h) + +instance ToField GitRef where + toField h = toField (show $ pretty h) + +instance FromField GitRef where + fromField = fmap fromString . fromField @String + +instance FromField GitHash where + fromField = fmap fromString . fromField @String + +instance ToField HashRef where + toField x = toField $ show $ pretty x + +instance FromField HashRef where + fromField = fmap (fromString @HashRef) . fromField @String + +insertGitPack :: MonadIO m => GitHash -> HashRef -> DBPipeM m () +insertGitPack co pack = do + insert [qc| + insert into gitpack (kommit,pack) values(?,?) + on conflict (kommit) do update set pack = excluded.pack + |] (co, pack) + +selectGitPack :: MonadIO m => GitHash -> DBPipeM m (Maybe HashRef) +selectGitPack gh = do + select [qc|select pack from gitpack where kommit = ? limit 1|] (Only gh) + <&> listToMaybe . fmap fromOnly