missed file

hbs2-git3/app/GitRemoteHelper.hs

@@ -0,0 +1,324 @@
+module Main where
+
+import Prelude hiding (getLine)
+
+import HBS2.Git3.Prelude
+import HBS2.Git3.Run
+import HBS2.Git3.Config.Local
+import HBS2.Git3.State.Index
+import HBS2.Git3.Import
+
+import HBS2.System.Dir
+
+import Control.Concurrent.STM qualified as STM
+import System.Posix.Signals
+import System.Environment
+import System.IO (hPutStrLn)
+import System.IO qualified as IO
+import System.Exit qualified as Exit
+
+import Data.Config.Suckless.Script
+
+import Data.ByteString.Char8 qualified as BS8
+import Data.ByteString.Lazy.Char8 qualified as LBS8
+import Data.Attoparsec.ByteString.Char8 hiding (try)
+import Data.Attoparsec.ByteString.Char8 qualified as Atto
+import Data.Maybe
+import Data.HashMap.Strict qualified as HM
+import Data.List qualified as L
+import Text.InterpolatedString.Perl6 (qc)
+import System.Exit hiding (die)
+import System.IO qualified as IO
+
+{- HLINT ignore "Use isEOF" -}
+{- HLINT ignore "Use putStrLn" -}
+
+done :: MonadIO m => m Bool
+done = hIsEOF stdin
+
+getLine :: MonadIO m => m String
+getLine = liftIO IO.getLine
+
+sendLine :: MonadIO m => String -> m ()
+sendLine = liftIO . IO.putStrLn
+
+die :: (MonadIO m, Pretty a) => a -> m b
+die s = liftIO $ Exit.die (show $ pretty s)
+
+-- parseURL :: String -> Maybe (LWWRefKey 'HBS2Basic)
+-- parseURL s = eitherToMaybe $ Atto.parseOnly p (BS8.pack s)
+--   where
+--     p = do
+--       void $ string "hbs21://" <|> string "hbs2://"
+
+--       Atto.takeWhile1 (`elem` getAlphabet)
+--        <&> BS8.unpack
+--        <&> fromStringMay @(LWWRefKey 'HBS2Basic)
+--        >>= maybe (fail "invalid reflog key") pure
+
+-- parsePush :: String -> Maybe (Maybe GitRef, GitRef)
+-- parsePush s = eitherToMaybe $ Atto.parseOnly p (BS8.pack s)
+--   where
+--     gitref = fromString @GitRef . BS8.unpack
+--     p = do
+--       a <- optional (Atto.takeWhile1 (/= ':')) <&> fmap gitref
+--       char ':'
+--       b <- Atto.takeWhile1 (const True) <&> gitref
+--       pure (a,b)
+
+data S =
+    Plain
+  | Push
+  | End
+  deriving stock (Eq,Ord,Show,Enum)
+
+
+
+localDict  :: forall m . ( HBS2GitPerks m
+                      -- , HasClientAPI PeerAPI UNIX m
+                      -- , HasStorage m
+                      -- , HasGitRemoteKey m
+                      -- , HasStateDB m
+                      ) => Dict C (Git3 m)
+localDict = makeDict @C do
+  entry $ bindMatch "r:capabilities" $ nil_ $ \syn -> do
+    notice "FUCKIN CAPABILITIES"
+    sendLine "push"
+    sendLine "fetch"
+    sendLine ""
+
+  entry $ bindMatch "r:list" $ nil_ $ \syn -> lift do
+    notice $ "FUCKIN LIST" <+> pretty syn
+
+    importGitRefLog
+
+    rrefs <- importedRefs
+
+    for_ rrefs $ \(r,h) -> do
+      debug $ pretty h <+> pretty r
+      sendLine $ show $ pretty h <+> pretty r
+
+    sendLine ""
+
+  entry $ bindMatch "r:" $ nil_ $ \syn -> lift do
+    none
+
+runTop :: (ParseSExp what, MonadUnliftIO m) => Dict C m -> what -> m ()
+runTop dict s = parseTop s & either (const none) (void . run dict)
+
+{- HLINT ignore "Functor law" -}
+main :: IO ()
+main =  flip runContT pure do
+  hSetBuffering stdin  LineBuffering
+  hSetBuffering stdout LineBuffering
+
+  setupLogger
+
+  ContT $ bracket none $ const do
+    silence
+
+  lift $ void $ installHandler sigPIPE Ignore Nothing
+  env <- nullGit3Env
+
+  let dict = theDict <> localDict
+
+  void $ lift $ withGit3Env env do
+
+    conf <- readLocalConf
+
+    void $ run dict conf
+
+    recover $ connectedDo do
+
+      notice "run all shit"
+
+      flip fix Plain $ \next -> \case
+        Plain -> do
+
+          debug "PLAIN!"
+
+          eof <- done
+
+          when eof $ next End
+
+          inp <- getLine
+
+          when (null (words inp)) $ next End
+
+          notice $ pretty "INPUT" <+> pretty inp
+
+          runTop dict ("r:"<>inp)
+
+          next Plain
+
+        _ -> do
+          debug "JOPA"
+          liftIO exitSuccess
+
+        -- Plain -> do
+        --   inp <- getLine
+        --   notice $ pretty "INPUT" <+> pretty inp
+        --   runTop dict ("r:"<>inp)
+        --   next Plain
+
+        -- Push -> do
+        --   debug "WHAT2"
+        --   next Push
+
+  -- args <- getArgs
+
+  -- (remote, puk) <- case args of
+  --                    [s, u] ->
+  --                       (s,) <$> pure (parseURL u)
+  --                                 `orDie` show ("invalid reflog" <+> pretty u)
+
+  --                    _ -> die "bad args"
+
+-- debugPrefix :: LoggerEntry -> LoggerEntry
+debugPrefix = toStderr . logPrefix "[debug] "
+
+setupLogger :: MonadIO m => m ()
+setupLogger = do
+  -- setLogging @DEBUG  $ toStderr . logPrefix "[debug] "
+  setLogging @ERROR  $ toStderr . logPrefix "[error] "
+  setLogging @WARN   $ toStderr . logPrefix "[warn] "
+  setLogging @NOTICE $ toStderr . logPrefix ""
+  pure ()
+
+flushLoggers :: MonadIO m => m ()
+flushLoggers = do
+  silence
+
+silence :: MonadIO m => m ()
+silence = do
+  setLoggingOff @DEBUG
+  setLoggingOff @ERROR
+  setLoggingOff @WARN
+  setLoggingOff @NOTICE
+
+
+  -- runGitCLI mempty $ do
+  --   env <- ask
+
+    -- flip runContT pure do
+
+    --   lift $ withGitEnv (env & set gitApplyHeads False) do
+
+    --     debug $ red "run" <+> pretty args
+
+    --     sto <- asks _storage
+    --     ip <- asks _progress
+
+    --     importRepoWait puk
+    --       `catch` (\(_ :: ImportRefLogNotFound) -> do
+    --                   onProgress ip ImportAllDone
+    --                   let url = headMay (catMaybes [ parseURL a | a <- args]) <&> AsBase58
+    --                   pause @'Seconds 0.25
+    --                   liftIO $ hFlush stderr
+    --                   liftIO $ hPutDoc stderr $ ""
+    --                               <> 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
+    --                               <> "git" <+> pretty hbs2Name <+> "export --new" <+> pretty url <> line <> line
+    --                               <> "to init the reflog first." <> line
+    --                               <> "Pushing to an existing reflog as a new one may cause unwanted data duplication." <> line
+    --                               <> line
+    --                               <> "Note: what ever pushed -- can not be unpushed" <> line
+    --                               <> "If it's not a new reflog --- just wait until it became available"
+    --                   liftIO exitFailure
+    --               )
+    --       `catch` ( \(ImportTxApplyError h) -> do
+    --                   onProgress ip ImportAllDone
+    --                   pause @'Seconds 0.25
+    --                   liftIO $ hFlush stderr
+    --                   liftIO $ hPutDoc stderr $ red "Can not apply tx" <+>  pretty h <> line <> line
+    --                                   <> "It means you don't have a key do decrypt this tx or the data is not completely downloaded yet"
+    --                                   <> line
+
+    --                   liftIO exitFailure
+    --               )
+
+    --     void $ runExceptT do
+
+    --         tpush <- newTQueueIO -- @(GitRef, Maybe GitHash)
+
+    --         flip fix Plain $ \next s -> do
+
+    --           eof <- done
+
+    --           when eof $ pure ()
+
+    --           cmd <- ExceptT (try @_ @IOError (getLine <&> words))
+
+    --           debug $ "C:" <+> pretty cmd
+
+    --           case cmd of
+
+    --             [] | s == Plain -> do
+    --               onProgress ip (ImportSetQuiet True)
+    --               pure ()
+
+    --             [] | s == Push -> do
+    --                    refs <- atomically (STM.flushTQueue tpush)
+    --                              <&> HM.toList . HM.fromList
+
+    --                    importRepoWait puk
+    --                    export puk refs
+    --                    sendLine ""
+    --                    next Plain
+
+    --             ["capabilities"] -> do
+    --               debug $ "send capabilities"
+    --               sendLine "push"
+    --               sendLine "fetch"
+    --               sendLine ""
+    --               next Plain
+
+    --             ("list" : _) -> do
+
+
+    --                 -- FIXME: may-cause-reference-inconsistency
+    --                 --   надо брать max(head) для lwwref
+    --                 --   а не максимальную транзу, накаченную на репо
+    --                 r'  <- runMaybeT do
+    --                         -- tx <- selectMaxAppliedTx >>= lift  . toMPlus <&> fst
+
+    --                         -- (_,rh) <- TX.readRepoHeadFromTx sto tx >>= lift . toMPlus
+    --                         rh <- liftIO (withGitEnv env (readActualRepoHeadFor puk))
+    --                                 >>= toMPlus
+
+    --                         pure (view repoHeadRefs rh)
+
+    --                 let r = fromMaybe mempty r'
+
+    --                 forM_ (fmap (show . formatRef) r) sendLine
+
+    --                 sendLine ""
+
+    --                 next Plain
+
+    --             ("push" : pargs : _ ) -> do
+    --               (fromRef, toRef) <- orThrowUser "can't parse push" (parsePush pargs)
+
+    --               r <- readProcess (setStderr closed $ shell [qc|git rev-parse {pretty $ fromRef}|])
+    --                     <&> headDef "" . LBS8.words . view _2
+    --                     <&> fromStringMay @GitHash . LBS8.unpack
+
+    --               let val = const r =<< fromRef
+
+    --               atomically $ writeTQueue tpush (toRef, val)
+
+    --               sendLine [qc|ok {pretty toRef}|]
+    --               next Push
+
+    --             _ -> next Plain
+
+    --           pure ()
+
+  -- `finally` liftIO do
+    -- hPutStrLn stdout "" >> hFlush stdout
+    -- -- notice $ red "BYE"
+    -- hPutStrLn stderr ""
+
+