hbs2/hbs2-tests/repo-export/RepoExportMain.hs

module Main where

import HBS2.Prelude.Plated
import HBS2.Data.Types.Refs
import HBS2.Merkle
import HBS2.Clock
import HBS2.OrDie
import HBS2Git.Config
import HBS2.Git.Local.CLI
import HBS2Git.App (detectRPC)
import HBS2.Peer.RPC.Client.Unix
import HBS2.Peer.RPC.API.Peer
import HBS2.Peer.RPC.API.Storage
import HBS2.Peer.RPC.API.RefLog
import HBS2.Peer.RPC.Client.StorageClient
import HBS2.System.Logger.Simple
import HBS2.Storage.Operations.ByteString
import HBS2.Storage
import HBS2.Git.Types

import UnliftIO
import Control.Monad.Reader
import Control.Monad.Catch
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Maybe
import Data.ByteString.Lazy qualified as LBS
import Data.ByteString.Lazy.Char8 qualified as LBS8
import Data.ByteString.Lazy (ByteString)
import Codec.Serialise
import Data.Maybe
import Data.HashSet qualified as HS
import Data.Vector qualified as V
import Data.Vector ((!))
import Data.HashSet (HashSet)
import Data.HashSet qualified as HashSet

import Text.InterpolatedString.Perl6 (qc)

import Options.Generic

data RPCEndpoints =
  RPCEndpoints
  { rpcPeer    :: ServiceCaller PeerAPI UNIX
  , rpcStorage :: ServiceCaller StorageAPI UNIX
  , rpcRefLog  :: ServiceCaller RefLogAPI UNIX
  }

runWithRPC :: forall m . (MonadUnliftIO m, MonadThrow m) => (RPCEndpoints -> m ()) -> m ()
runWithRPC action = do

  let soname' = Just "/tmp/hbs2-rpc.socket"

  soname <- race ( pause @'Seconds 1) (maybe (detectRPC True) pure soname') `orDie` "hbs2-peer rpc timeout!"

  client <- race ( pause @'Seconds 1) (newMessagingUnix False 1.0 soname) `orDie` "hbs2-peer rpc timeout!"

  rpc <- RPCEndpoints <$> makeServiceCaller (fromString soname)
                      <*> makeServiceCaller (fromString soname)
                      <*> makeServiceCaller (fromString soname)

  messaging <- async $ runMessagingUnix client
  link messaging

  let endpoints = [ Endpoint @UNIX  (rpcPeer rpc)
                  , Endpoint @UNIX  (rpcStorage rpc)
                  , Endpoint @UNIX  (rpcRefLog rpc)
                  ]

  c1 <- async $ liftIO $ runReaderT (runServiceClientMulti endpoints) client
  link c1

  test <- race ( pause @'Seconds 1) (callService @RpcPoke (rpcPeer rpc) ()) `orDie` "hbs2-peer rpc timeout!"

  void $ pure test `orDie` "hbs2-peer rpc error!"

  debug $ "hbs2-peer RPC ok" <+> pretty soname

  action rpc

  cancel messaging

  void $ waitAnyCatchCancel [messaging, c1]


data CLI = CLI { nThreads :: Maybe Int }
  deriving (Generic)

instance ParseRecord CLI


main :: IO ()
main = do
  bs <- gitRunCommand [qc|git cat-file --batch-check='%(objectname)'  --batch-all-object --unordered --buffer|]
          >>= orThrowUser "oopsie"
  let ls = LBS8.lines bs -- & HashSet.fromList
  print $ length ls

main1 :: IO ()
main1 = do
  dir <- findGitDir "." >>= orThrowUser "not a git dir"


  let hrs = [ "A9Y5k28STYMg2XGUA5xwpAU3CcQg3Fh5j56E4v1QYV7A"
            , "BZuMNqPy1vpxev4H5yKJ4TjTHrZ5HAqPzxDM1ZN74XY2"
            , "Bs2jEFJTSQnY7z5nActjBBanCEWSYnbzUzC41xhhHwtX"
            , "2rZxtNqi8haDEhQkVd2v1ddSfDub9bMH4BB9tgwqvxCF"
            , "Fe1cLjj9BPqHcLowTNwZvHkwT7tAL7dywBocdN3VYeMn"
            ] :: [HashRef]

  let pt = toPTree (MaxSize 256) (MaxNum 256) hrs

  root <- makeMerkle 0 pt $ \(hx,_,bss) -> do
            liftIO $ print $ "block:" <+> pretty hx

  print $ pretty root
  error "stop"

  (CLI mn) <- getRecord  "export git repo"

  let n = fromMaybe 1 mn

  flip runContT pure do

    o <- gitListAllObjects

    ep <- ContT runWithRPC

    let sto = StorageClient (rpcStorage ep)

    ou <- newTQueueIO

    qqs <- V.fromList <$> replicateM n newTQueueIO

    w <- liftIO $ async do
           for_ (zip [0..] o) $ \(i,x) -> do
            let j = i `mod` V.length qqs
            atomically $ writeTQueue (qqs ! j) (Just x)
           for_ qqs $ \q -> do
             atomically $ writeTQueue q Nothing

    ws <- liftIO $ for (V.toList qqs) $ \q -> async do
            cat <- startGitCatFile
            fix \next -> do
              e <- atomically $ readTQueue q
              case e of
                Nothing -> pure ()
                Just (_,h)  -> do
                  void $ runMaybeT do
                    GitObject t lbs <- toMPlus =<< gitReadFromCatFileBatch cat h
                    atomically $ writeTQueue ou (t, h, LBS.length lbs)
                  next

    wou <- liftIO $ async do
             fix \next -> do
               r <- atomically $ readTQueue ou
               print $ pretty r
               next

    mapM_ wait (w:ws)

    cancel wou

    -- for_ [q1, q2] -> do

    -- cat2 <- startGitCatFile

    -- h <- gitGetHash "HEAD" >>= orThrowUser "wtf1"
    -- rvl <- gitRevList Nothing h

    -- liftIO do
    --   for_  o $ \r@(o,h) -> runMaybeT do
    --     pure ()
        -- GitObject t lbs <- toMPlus =<< gitReadFromCatFileBatch cat h
        -- liftIO $ print $ pretty (t, h, LBS.length lbs)
        -- ght <- writeAsMerkle sto lbs

        -- tt <- getBlock sto ght
        --            >>= toMPlus
        --            >>= orThrowUser "FUCK" . (deserialiseOrFail @(MTree [HashRef]))

        -- let txt = fromString (show $ pretty t)
        -- let ann = MTreeAnn (ShortMetadata txt) NullEncryption tt
        -- putBlock sto (serialise ann) >>= toMPlus

      -- let pt = HS.fromList (HashRef <$> catMaybes allShit')
        --         & HS.toList
        --         & toPTree (MaxSize 256) (MaxNum 256)

      -- ht <- makeMerkle 0 pt $ \(_,_,bss) -> do
        --       void $ putBlock sto bss

      -- print $ pretty (HashRef ht)