wip

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
+-- instance (MonadUnliftIO m, HasClientAPI api proto m) => HasClientAPI api proto (RunM c m) where
-  getClientAPI = lift (getClientAPI @api @proto)
+--   getClientAPI = lift (getClientAPI @api @proto)
 
-instance (MonadUnliftIO m, HasClientAPI api proto m) => HasClientAPI api proto (ContT a (RunM c m)) where
+-- instance (MonadUnliftIO m, HasClientAPI api proto m) => HasClientAPI api proto (ContT a (RunM c m)) where
-  getClientAPI = lift $ getClientAPI @api @proto
+--   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
+                            n <- for (zip [1..] parents) $ \(i,gh) -> do
-                              atomically $ modifyTVar q (HPSQ.insert gh (prio-i) ())
+                                   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
+
+                            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
 

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
+gitpack
-  ( githash text not null primary key
+  ( kommit  text not null primary key
-  , type    text not null
-  , cblock  text not null
   , 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