fixed As13ga9cvf git-push-always-up-to-date

.fixme/log

@@ -315,4 +315,5 @@ fixme-del "6JM2L56F8k"
 fixme-del "FS3sZqqMX3"
 (fixme-set "workflow" "wip" "As13ga9cvf")
 (fixme-set "assigned" "voidlizard" "As13ga9cvf")
-(fixme-set "workflow" "test" "5JB9TJn4qM")
+(fixme-set "workflow" "test" "5JB9TJn4qM")
+(fixme-set "workflow" "test" "As13ga9cvf")

docs/devlog.md

@@ -2,7 +2,7 @@
 
 ## 2023-03-24
 
-проверка: wip95
+проверка: wip97
 
 TODO: storage-reliable-write
   Надёжную процедуру записи блока.

hbs2-git/git-hbs2/GitRemoteMain.hs

@@ -119,9 +119,8 @@ loop args = do
 
   hdRefOld <- readHeadDef db
 
-  updateLocalState ref
-
-  hd <- readHeadDef db
+  -- updateLocalState ref
+  -- hd <- readHeadDef db
 
   hashes <- withDB db stateGetAllObjects
 
@@ -170,11 +169,8 @@ loop args = do
         liftIO $ atomically $ writeTVar batch False
         -- -- FIXME: wtf
         -- when isBatch next
-        if isBatch then do
-            sendEol
-            next
-          else do
-            updateLocalState ref
+        sendEol
+        when isBatch next
 
       ["capabilities"] -> do
           trace $ "send capabilities" <+> pretty (BS.unpack capabilities)
@@ -183,6 +179,8 @@ loop args = do
 
       ["list"] -> do
 
+        updateLocalState ref
+        hd <- readHeadDef db
 
         hl <- liftIO $ readTVarIO jobNumT
         pb <- newProgressMonitor "storing git objects" hl
@@ -217,13 +215,18 @@ loop args = do
       ["fetch", sha1, x] -> do
         trace $ "fetch" <+> pretty (BS.unpack sha1) <+> pretty (BS.unpack x)
         liftIO $ atomically $ writeTVar batch True
+        sendEol
         next
 
       ["push", rr] -> do
         let bra = BS.split ':' rr
         let pu = fmap (fromString' . BS.unpack) bra
         liftIO $ atomically $ writeTVar batch True
-        push ref pu
+        pushed <- push ref pu
+        hPrint stderr (pretty pushed)
+        case pushed of
+          Nothing  -> sendEol
+          Just re -> sendLn [qc|ok {pretty re}|]
         next
 
       other -> die $ show other

hbs2-git/git-hbs2/GitRemotePush.hs

@@ -61,7 +61,7 @@ push :: forall  m . ( MonadIO m
                     , HasProgress (RunWithConfig (GitRemoteApp m))
                     )
 
-     => RepoRef -> [Maybe GitRef] -> GitRemoteApp m ()
+     => RepoRef -> [Maybe GitRef] -> GitRemoteApp m (Maybe GitRef)
 
 push remote [bFrom , Just br] = do
 
@@ -96,6 +96,9 @@ push remote [bFrom , Just br] = do
 
     info  $ "head:" <+> pretty hh
     info  $ "merkle:" <+> pretty root
+    pure (Just br)
 
-push r w = warn $ "ignoring weird push" <+> pretty w <+> pretty r
+push r w = do
+  warn $ "ignoring weird push" <+> pretty w <+> pretty r
+  pure Nothing