{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# Language MultiWayIf #-}
{-# Language FunctionalDependencies #-}
{-# Language ViewPatterns #-}
{-# Language PatternSynonyms #-}
{-# Language RecordWildCards #-}
{-# Language UndecidableInstances #-}
{-# Language AllowAmbiguousTypes #-}
module Main where

import HBS2.Prelude.Plated
import HBS2.OrDie
import HBS2.Base58
import HBS2.Merkle
import HBS2.Data.Detect hiding (Blob)
import HBS2.Data.Detect qualified as Detect

import HBS2.Storage
import HBS2.Storage.Operations.Class
import HBS2.Storage.Operations.ByteString
import HBS2.Peer.CLI.Detect
import HBS2.Peer.RPC.Client
import HBS2.Peer.RPC.Client.Unix
import HBS2.Peer.RPC.API.Peer
import HBS2.Peer.RPC.API.RefLog
import HBS2.Peer.RPC.API.RefChan
import HBS2.Peer.RPC.API.LWWRef
import HBS2.Peer.RPC.API.Storage
import HBS2.Peer.RPC.Client.StorageClient

import HBS2.CLI.Run.Internal.Merkle (getTreeContents)

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

import HBS2.Git3.Types
import HBS2.Git3.State.Direct
import HBS2.Git3.Config.Local

import Data.Config.Suckless.Script
import DBPipe.SQLite

import Codec.Compression.Zstd qualified as Zstd
import Codec.Compression.Zstd.Streaming qualified as ZstdS
import Codec.Compression.Zstd.Streaming (Result(..))
import Codec.Compression.Zstd (maxCLevel)

import qualified Data.Attoparsec.ByteString as A
import Data.HashPSQ qualified as HPSQ
import Data.HashPSQ (HashPSQ)
import Data.Maybe
import Data.List qualified as L
import Data.ByteString.Lazy.Char8 qualified as LBS8
import Data.ByteString.Lazy qualified as LBS
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as BS8
import Data.ByteString.Lazy (ByteString)
import Data.ByteString.Builder as Builder
import Text.InterpolatedString.Perl6 (qc)
import Data.Set qualified as Set
import Data.HashSet qualified as HS
import Data.HashSet (HashSet(..))
import Data.HashMap.Strict qualified as HM
import Data.HashMap.Strict (HashMap(..))
import Data.Word

import Streaming.Prelude qualified as S
import System.Exit qualified as Q
import System.Environment qualified as E
import System.Process.Typed
import Control.Applicative
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Maybe
import Control.Monad.Reader
import Control.Monad.Except
import Control.Concurrent.STM qualified as STM
import System.IO (hPrint,hGetLine,IOMode(..))
import System.IO qualified as IO

import Data.Either
import Data.Coerce
import Data.Kind
import Data.List (sortOn)
import Data.Ord (Down(..))

import UnliftIO

{- HLINT ignore "Functor law" -}
{- HLINT ignore "Eta reduce" -}

type HBS2GitPerks m = (MonadUnliftIO  m)

quit :: MonadUnliftIO m => m ()
quit = liftIO Q.exitSuccess

class Cached cache k v | cache -> k, cache -> v where
  isCached :: forall m . MonadIO m => cache -> k -> m Bool
  cached   :: forall m . MonadIO m => cache -> k -> m v -> m v
  uncache  :: forall m . MonadIO m => cache -> k -> m ()

data GitException =
    CompressionError String
  | DecompressionError String
  | InvalidObjectFormat GitObjectType (Maybe GitHash)
  | InvalidGitPack ByteString
  | OtherGitError String
  | UnknownRev String
  | GitReadError String
  deriving stock (Eq,Show,Typeable,Generic)

instance Exception GitException

data GitTreeEntry =
  GitTreeEntry
  { gitEntryAttribs :: Word16
  , gitEntryType    :: GitObjectType
  , gitEntryHash    :: GitHash
  , gitEntrySize    :: Maybe Word32
  , gitEntryName    :: FilePath
  }

pattern GitTreeEntryView :: GitTreeEntry -> [ByteString]
pattern GitTreeEntryView e <- (isGitLsTreeEntry -> Just e)

gitNormaliseRef :: GitRef -> GitRef
gitNormaliseRef r@(GitRef what) =
  if BS8.isPrefixOf "refs/" what || what == "HEAD" then
    r
  else
    fromString (joinPath $ splitPath $ "refs" </> "heads" </> BS8.unpack what)

isGitLsTreeEntry :: [ByteString] -> Maybe GitTreeEntry
isGitLsTreeEntry = \case
  [sa,st,sh,ss,sn] -> do
    GitTreeEntry <$> readMay @Word16 (LBS8.unpack sa)
                 <*> fromStringMay (LBS8.unpack st)
                 <*> fromStringMay (LBS8.unpack sh)
                 <*> pure (readMay (LBS8.unpack ss))
                 <*> pure (LBS8.unpack sn)

  _ -> Nothing

gitReadTree :: (Pretty what, MonadIO m) => what -> m [GitTreeEntry]
gitReadTree what =
  gitRunCommand [qc|git ls-tree -t -l -r {pretty what}|]
     >>= orThrow (GitReadError (show $ pretty what))
     <&> fmap LBS8.words . LBS8.lines
     <&> mapMaybe \case
          GitTreeEntryView v -> do
            Just v
          _ -> Nothing
     <&> \s -> HM.elems (HM.fromList [ (gitEntryHash e, e) | e <- s])


class GitObjectReader a where
  gitReadObjectMaybe :: forall m . MonadIO m => a -> GitHash -> m (Maybe (GitObjectType, ByteString))

gitReadObjectThrow :: (Pretty h, MonadIO m) => GitObjectType -> h -> m ByteString
gitReadObjectThrow t h = do
  gitRunCommand [qc|git cat-file {pretty t} {pretty h}|]
    >>= orThrowPassIO

gitRevParse :: (Pretty ref, MonadIO m) => ref -> m (Maybe GitHash)
gitRevParse ref = do
  gitRunCommand [qc|git rev-parse {pretty ref}|]
    >>= orThrowPassIO
    <&> LBS8.words
    <&> maybe Nothing (fromStringMay . LBS8.unpack) . headMay

gitRevParseThrow :: (Pretty ref, MonadIO m) => ref -> m GitHash
gitRevParseThrow r = gitRevParse r >>= orThrow (UnknownRev (show $ pretty r))

gitReadHEAD :: MonadIO m => m (Maybe GitRef)
gitReadHEAD = runMaybeT do
  gitRunCommand [qc|git symbolic-ref HEAD|]
   >>= toMPlus
   <&> headMay . LBS8.lines
   >>= toMPlus
   <&> GitRef . LBS8.toStrict

withGitCat ::  (MonadIO m) => (Process Handle Handle () -> m a) -> m a
withGitCat action = do
  let cmd = "git"
  let args = ["cat-file", "--batch"]
  let config = setStdin createPipe $ setStdout createPipe $ setStderr closed $ proc cmd args
  p <- startProcess config
  action p

instance GitObjectReader (Process Handle Handle ()) where
  gitReadObjectMaybe ph co = liftIO do

    let ssin = getStdin ph
    let ssout = getStdout ph

    hPrint ssin $ pretty co
    hFlush ssin

    s <- hGetLine ssout

    runMaybeT do

      case words s of
        [_,t,ss] -> do
          n <- readMay @Int ss & toMPlus
          o <- fromStringMay @GitObjectType t & toMPlus
          bs <- lift $ LBS.hGet ssout n
          void $ lift $ hGetLine ssout
          pure (o,bs)

        _ -> mzero

newtype Short x = Short x

instance Pretty (Short GitObjectType) where
  pretty = \case
    (Short Tree)   -> "T"
    (Short Blob)   -> "B"
    (Short Commit) -> "C"


sortGitTreeEntries :: [GitTreeEntry] -> [GitTreeEntry]
sortGitTreeEntries = sortOn (\e -> (gitEntryType e, gitEntrySize e))

class GitWritePacksOpts a where
  excludeParents :: a -> Bool

instance GitWritePacksOpts () where
  excludeParents = const True

data GitWritePacksOptVal =
  WriteFullPack
  deriving stock (Eq,Ord,Show,Generic)

instance Hashable GitWritePacksOptVal

instance GitWritePacksOpts (HashSet GitWritePacksOptVal) where
  excludeParents o = not $ HS.member WriteFullPack o

data Git3Exception =
  Git3PeerNotConnected
  deriving (Show,Typeable,Generic)

instance Exception Git3Exception

data Git3Env =
    Git3Disconnected
    { gitRefLog   :: TVar (Maybe GitRemoteKey)
    }
  | Git3Connected
    { stateDb     :: DBPipeEnv
    , peerSocket  :: FilePath
    , peerStorage :: AnyStorage
    , peerAPI     :: ServiceCaller PeerAPI UNIX
    , gitRefLog   :: TVar (Maybe GitRemoteKey)
    }

class HasGitRemoteKey m where
  getGitRemoteKey :: m (Maybe GitRemoteKey)
  setGitRemoteKey :: GitRemoteKey -> m ()

instance (MonadIO m, MonadReader Git3Env m) => HasGitRemoteKey m where
  getGitRemoteKey = do
    e <- ask
    liftIO $ readTVarIO (gitRefLog e)

  setGitRemoteKey k = do
    e <- ask
    liftIO $ atomically $ writeTVar (gitRefLog e) (Just k)

instance (MonadIO m) => HasStateDB (Git3 m) where
  getStateDB = asks stateDb

instance (MonadIO m, MonadReader Git3Env m) => HasStorage m where
  getStorage = do
    e <- ask
    case e of
      Git3Disconnected{} -> throwIO Git3PeerNotConnected
      Git3Connected{..} -> pure peerStorage

newtype Git3 (m :: Type -> Type) a = Git3M { fromGit3 :: ReaderT Git3Env m a }
                   deriving newtype ( Applicative
                                    , Functor
                                    , Monad
                                    , MonadIO
                                    , MonadUnliftIO
                                    , MonadReader Git3Env
                                    )

type Git3Perks m = ( MonadIO m
                   , MonadUnliftIO m
                   )


instance MonadUnliftIO m => HasClientAPI PeerAPI UNIX (Git3 m) where
  getClientAPI = do
    ask  >>= \case
       Git3Disconnected{} -> throwIO Git3PeerNotConnected
       Git3Connected{..} -> pure peerAPI

nullGit3Env :: MonadIO m => m Git3Env
nullGit3Env = Git3Disconnected <$> newTVarIO Nothing

connectedDo :: (MonadIO m, MonadReader Git3Env m) => m a -> m a
connectedDo what = do
  env <- ask
  debug $ red "connectedDo"
  case env of
    Git3Disconnected{} -> do
      throwIO Git3PeerNotConnected

    _ -> what

withGit3Env :: Git3Perks m => Git3Env -> Git3 m a -> m a
withGit3Env env a = runReaderT (fromGit3 a) env

runGit3 :: Git3Perks m => Git3Env -> Git3 m b -> m b
runGit3 env action = withGit3Env env action

recover :: Git3 IO a -> Git3 IO a
recover m = fix \again -> do
  catch m $ \case
    Git3PeerNotConnected -> do

      soname <- detectRPC
                  `orDie` "can't locate hbs2-peer rpc"

      flip runContT pure do

        client <- lift $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname)
                    >>= orThrowUser ("can't connect to" <+> pretty soname)

        void $ ContT $ withAsync $ runMessagingUnix client

        peerAPI    <- makeServiceCaller @PeerAPI (fromString soname)
        refLogAPI  <- makeServiceCaller @RefLogAPI (fromString soname)
        storageAPI <- makeServiceCaller @StorageAPI (fromString soname)
        lwwAPI     <- makeServiceCaller @LWWRefAPI (fromString soname)

        -- let sto = AnyStorage (StorageClient storageAPI)

        let endpoints = [ Endpoint @UNIX  peerAPI
                        , Endpoint @UNIX  refLogAPI
                        , Endpoint @UNIX  lwwAPI
                        , Endpoint @UNIX  storageAPI
                        ]

        void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client

        ref <- getGitRemoteKey >>= orThrowUser "remote ref not set"

        dbPath <- getStatePathDB (AsBase58 ref)

        touch dbPath
        db <- newDBPipeEnv dbPipeOptsDef dbPath

        let sto = AnyStorage (StorageClient storageAPI)

        connected <- Git3Connected db soname sto peerAPI <$> newTVarIO (Just ref)

        liftIO $ withGit3Env connected (evolveState >> again)

gitReadCommitParents :: MonadIO m => ByteString -> m [GitHash]
gitReadCommitParents bs = do
   what <- LBS8.lines bs
             & takeWhile ( not . LBS8.null )
             & LBS8.unpack . LBS8.unlines
             & parseTop
             & orThrow (OtherGitError "invalid commit format")

   pure $ [ fromStringMay @GitHash hash
          | ListVal [ StringLike "parent", StringLike hash ] <- what
          ] & catMaybes

gitObjectExists :: (MonadIO m, Pretty what) => what -> m Bool
gitObjectExists what = do
  gitRunCommand [qc|git cat-file -e {pretty what}|] <&> isRight

data UState =
  UHead Word32 ByteString

data IOpType
  = IGitObject GitObjectType GitHash (Maybe ByteString)
  | ISetRef GitRef Int (Maybe GitHash)
  deriving (Show, Eq)

data IOp =
  IOp { iopOffset :: Word32
      , iopSize   :: Word32
      , iopType   :: IOpType
      }
  deriving (Show, Eq)

data ES =
  ES [BS.ByteString] Result


class EnumGitPackObjectsOpts a where
  enumObjectPayload :: a -> Bool

instance EnumGitPackObjectsOpts () where
  enumObjectPayload = const False

data DoEnumPayload = DoEnumPayload

instance EnumGitPackObjectsOpts DoEnumPayload where
  enumObjectPayload = const True

enumGitPackObjectsFromLBS :: (MonadIO m, EnumGitPackObjectsOpts opts)
                          => opts
                          -> ByteString
                          -> ( IOp -> m Bool )
                          -> m ()
enumGitPackObjectsFromLBS opts lbs action = do

  let chunks = LBS.toChunks lbs

  stream <- liftIO ZstdS.decompress

  chunks <- S.toList_ do

    flip fix (ES chunks stream) $ \go -> \case
        ES _ (Error s1 s2) -> throwIO (DecompressionError (s1 <> s2))

        ES [] (Consume work) ->
          go . ES [] =<< liftIO (work mempty)

        ES (r:rs) (Consume work) -> do
          go . ES rs =<< liftIO (work r)

        ES rs (Produce s continue) -> do
          S.yield s
          go . ES rs =<< liftIO continue

        ES _ (Done s) -> do
          S.yield s

  void $ flip fix (UHead 0 (LBS.fromChunks chunks)) $ \next -> \case
    UHead off chunk -> do
      let (skipped1,s0) = LBS8.span (=='\n') chunk
      -- read += len skipped

      unless (LBS.null s0) do
        let (hdr,rest) = LBS8.break (=='\n') s0
        -- read += len hdr

        let o = LBS.drop 1 rest -- skip '\n'. read+1
        -- read += 1

        let skipped2 = fromIntegral $ LBS8.length skipped1
                                    + LBS8.length hdr
                                    + 1

        let entryOffset = off + fromIntegral skipped2

        iop@(IOp{..}) <- unpackIOp 0 (LBS8.words hdr) & orThrow (InvalidGitPack hdr)

        let (rn, rest2) = LBS.splitAt (fromIntegral iopSize) o
        -- read += len rn        --

        let consumed = fromIntegral $ skipped2 + LBS.length rn

        let pl = case ( enumObjectPayload opts, iopType ) of
                   (True, IGitObject t h _) -> IGitObject t h (Just rn)
                   (_, t) -> t

        let actualIop  = iop { iopOffset = entryOffset
                             , iopType = pl
                             }

        continue <- action actualIop

        when continue do
          next (UHead (off + consumed) rest2)

data ExportState =
    ExportGetCommit
  | ExportProcessCommit GitHash ByteString
  | ExportCheck
  | ExportStart
  | ExportExit


data EOp =
    EGitObject GitObjectType GitHash (Maybe GitTreeEntry) ByteString
  | EGitRef    GitRef Int (Maybe GitHash)


unpackIOp :: Word32 -> [ByteString] -> Maybe IOp
unpackIOp off = \case
  ("C" : s : h : _) -> do
    size <- fromLBS s
    hash <- fromLBS' h
    pure $ IOp off size (IGitObject Commit hash Nothing)

  ("B" : s : h : _) -> do
    size <- fromLBS s
    hash <- fromLBS' h
    pure $ IOp off size (IGitObject Blob hash Nothing)

  ("T" : s : h : _) -> do
    size <- fromLBS s
    hash <- fromLBS' h
    pure $ IOp off size (IGitObject Tree hash Nothing)

  ("R" : s : n : r : rest) -> do
    size <- fromLBS s
    weight <- fromLBS n
    refName <- pure (GitRef $ LBS8.toStrict r)
    hash <- case rest of
      (h : _) -> Just <$> fromStringMay (LBS8.unpack h)
      _       -> pure Nothing
    pure $ IOp off size (ISetRef refName weight hash)

  _ -> Nothing

  where
    fromLBS :: forall a . Read a => ByteString -> Maybe a
    fromLBS = readMay . LBS8.unpack

    fromLBS' :: forall a. FromStringMaybe a => ByteString -> Maybe a
    fromLBS' = fromStringMay . LBS8.unpack

data EWState =
    EWAcc Int [GitTreeEntry] Int [EOp]

newtype CacheTVH k v = CacheTVH (TVar (HashMap k v))

instance Hashable k => Cached (CacheTVH k v) k v where
  isCached (CacheTVH t) k = readTVarIO  t <&> HM.member k
  uncache (CacheTVH t) k = atomically (modifyTVar t (HM.delete k))
  cached (CacheTVH t) k a = do
    what <- readTVarIO t <&> HM.lookup k
    case what of
      Just x -> pure x
      Nothing -> do
        r <- a
        atomically $ modifyTVar t (HM.insert k r)
        pure r

data CacheFixedHPSQ  k v =
  CacheFixedHPSQ
  { _cacheSize :: Int
  , _theCache  :: TVar (HashPSQ k TimeSpec v)
  }

newCacheFixedHPSQ :: MonadIO m => Int -> m (CacheFixedHPSQ k v)
newCacheFixedHPSQ l = CacheFixedHPSQ l <$> newTVarIO HPSQ.empty

instance (Ord k, Hashable k) => Cached (CacheFixedHPSQ k v) k v where

  isCached CacheFixedHPSQ{..} k = readTVarIO _theCache <&> HPSQ.member k

  uncache CacheFixedHPSQ{..} k = atomically $ modifyTVar _theCache (HPSQ.delete k)

  cached CacheFixedHPSQ{..} k a = do
    w <- readTVarIO _theCache <&> HPSQ.lookup k
    case w of
      Just (_,e) -> pure e
      Nothing -> do
        v <- a

        t <- getTimeCoarse

        atomically do
          s <- readTVar _theCache <&> HPSQ.size

          when (s >= _cacheSize) do
            modifyTVar _theCache HPSQ.deleteMin

          modifyTVar _theCache (HPSQ.insert k t v)

          pure v

export :: ( HBS2GitPerks m
          , MonadUnliftIO m
          , MonadReader Git3Env m
          , HasStorage m
          , HasStateDB m
          )
       => Maybe GitRef -> GitHash -> m ()
export mref' r = connectedDo $ flip runContT pure do
  debug $ green "export"  <+> pretty r

  let mref = gitNormaliseRef <$> mref'

  q <- newTVarIO ( HPSQ.empty @GitHash @Double @() )
  done <- newTVarIO ( mempty :: HashSet GitHash )

  atomically $ modifyTVar q (HPSQ.insert r 1.0 ())

  sto <- lift getStorage

  reader  <- ContT $ withGitCat
  reader2 <- ContT $ withGitCat

  let commitCacheSize = 2000

  missed <- CacheTVH <$> newTVarIO mempty
  commits <- newCacheFixedHPSQ commitCacheSize

  deferred <- newTQueueIO

  ContT $ bracket none $ const do
    hClose $ getStdin reader

  ContT $ bracket none $ const do
    hClose $ getStdin reader2

  ContT $ withAsync $ replicateM_ 2 $ forever do
    join $ atomically (readTQueue deferred)

  lift $ flip fix ExportStart $ \next -> \case

    ExportStart -> do
      here <- withState $ selectCBlock r <&> isJust
      if here then next ExportCheck else next ExportGetCommit

    ExportGetCommit -> do

      co' <- atomically $ stateTVar q $ HPSQ.alterMin \case
              Nothing      -> (Nothing, Nothing)
              Just (k,p,v) -> (Just (k,p), Nothing)

      case co' of
        Nothing -> do
          debug $ red "go ExportCheck"
          next ExportCheck

        Just (co,prio) -> do
          debug $ "Process commit" <+> pretty co <+> pretty prio
          debug $ "check-pack-for" <+> pretty prio <+> pretty co

          isDone <- readTVarIO done <&> HS.member co

          let already = isDone

          if already
            then do
              next ExportGetCommit
            else do
              (_,bs) <- liftIO (cached commits co (gitReadObjectMaybe reader co))
                            >>= orThrow (GitReadError (show $ pretty co))

              parents <- gitReadCommitParents bs

              n <- for (zip [1..] parents) $ \(i,gh) -> do
                     exists <- liftIO $ cached missed gh (isJust <$> cached commits gh (gitReadObjectMaybe reader gh))
                     here <- withState $ selectCBlock gh <&> isJust

                     unless exists do
                      debug $ red "missed!" <+> pretty gh
                      -- atomically $ modifyTVar done (HS.insert gh)

                     atomically do
                       pdone <- readTVar done <&> HS.member gh
                       if pdone || here || not exists then do -- for shallow commits?
                         pure 0
                       else do
                         modifyTVar q (HPSQ.insert gh (prio-i) ())
                         pure 1

              if sum n == 0 then do
                uncache commits co
                next $ ExportProcessCommit co bs
              else do
                -- error "FUCK!"
                debug $ yellow "put commit back" <+> pretty co
                atomically $ modifyTVar q (HPSQ.insert co prio ())
                next ExportGetCommit

    ExportProcessCommit co bs -> do
      debug $ "write pack for" <+> pretty co

      l <- readTVarIO q<&> HPSQ.keys

      let lastBlock = co == r && L.null l

      hhead <- gitRevParse co
                     >>= orThrow (OtherGitError $ show $ "can't parse" <+> pretty co)

      parents <- gitReadObjectThrow Commit hhead
                    >>= gitReadCommitParents

      skip <- if not (excludeParents ()) then do
                   pure mempty
                 else do
                    skip' <- S.toList_ $ for parents $ \p -> do
                        lift (try @_ @GitException (gitReadTree p))
                          <&> fromRight mempty
                          <&> fmap gitEntryHash >>= S.each

                    pure $ HS.fromList skip'

      r <- gitReadTree hhead
             <&> L.filter (\GitTreeEntry{..} -> not (HS.member gitEntryHash skip))
             -- <&> L.filter (\GitTreeEntry{..} -> gitEntryType /= Tree)
             <&> sortGitTreeEntries

      let blkMax = 1048576

      out <- newTQueueIO

      now <- liftIO getPOSIXTime <&> round

      let ref = maybeToList $ EGitRef <$> mref <*> pure now <*> pure (Just co)

      let seed = (if lastBlock then ref else mempty) <> [EGitObject Commit co Nothing bs]

      flip fix (EWAcc 1 r 0 seed) $ \go -> \case

        EWAcc _ [] _ [] -> none

        EWAcc i [] l acc -> do
          writePack sto l acc >>= atomically . writeTQueue out

        EWAcc i (r@GitTreeEntry{..}:rs) l acc | gitEntrySize >= Just (fromIntegral blkMax) -> do
          atomically $ writeTQueue deferred $ writeLargeBlob sto reader2 r >>= atomically . writeTQueue out
          go (EWAcc (succ i) rs l acc)

        EWAcc i rs l acc | l >= blkMax -> do
          atomically $ writeTQueue deferred $  writePack sto l acc >>=  atomically . writeTQueue out
          go (EWAcc (succ i) rs 0 mempty)

        EWAcc i (e@GitTreeEntry{..}:rs) l acc -> do

          lbs <- gitReadObjectMaybe reader gitEntryHash
                   >>= orThrow (GitReadError (show $ pretty gitEntryHash))
                   <&> snd

          let new = EGitObject gitEntryType gitEntryHash (Just e) lbs
          go (EWAcc i rs (l + fromIntegral (LBS.length lbs)) (new : acc))

      packs <- atomically do
                 allDone <- isEmptyTQueue deferred
                 unless allDone STM.retry
                 STM.flushTQueue out

      phashes <- catMaybes <$> withState (for parents selectCBlock)

      let v = "hbs2-git 3.0 zstd"
      let pps = vcat $ mconcat $ for phashes $ \p -> ["p" <+> pretty p]
      let meta = LBS8.pack $ show $ pretty v <> line <> pps

      hmeta <- putBlock sto meta >>= orThrow StorageError <&> HashRef

      let cblock = hmeta : uniqAndOrdered phashes <> uniqAndOrdered packs
      let pt = toPTree (MaxSize 1024) (MaxNum 1024) cblock

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

      withState $ transactional do
        insertCBlock co (HashRef root)

      notice $ "cblock" <+> pretty root

      atomically do
        modifyTVar done (HS.insert co)
        modifyTVar q (HPSQ.delete co)

      next ExportGetCommit

    ExportCheck -> do
      debug $ "ExportCheck dummy" <+> pretty r
      c <- withState $ selectCBlock r >>= orThrowUser "export failed"
      liftIO $ hPrint stdout (pretty c)
      next ExportExit

    ExportExit -> finish

  where
    finish = none

    uniqAndOrdered = Set.toList . Set.fromList

    writeLargeBlob sto reader GitTreeEntry{..} = liftIO do
      size <- gitEntrySize & orThrow (GitReadError (show $ "expected blob" <+> pretty gitEntryHash))
      debug $ yellow "write large object" <+> pretty gitEntryHash
      let p =    Builder.byteString [qc|{pretty $ Short gitEntryType} {pretty size} {pretty gitEntryHash} {gitEntryName}|]
              <> Builder.byteString "\n"
              &  LBS.toStrict . Builder.toLazyByteString

      -- TODO: check-if-work-on-large-files
      pieces <- S.toList_ do

        stream <- lift $ ZstdS.compress maxCLevel

        (t,lbs) <- gitReadObjectMaybe reader gitEntryHash
                      >>= orThrow (GitReadError (show $ pretty gitEntryHash))

        let chunks = p : LBS.toChunks lbs

        flip fix (chunks, stream) $ \go r ->
          case r of
          (c, Produce chunk continue)  -> do
            S.yield chunk
            w <- lift continue
            go (c,w)

          ([], Consume consume) -> do
            x <- lift $ consume mempty
            go ([],x)

          (s:ss, Consume consume) -> do
            x <- lift $ consume s
            go (ss,x)

          (_,Done bs) -> do
            S.yield bs

          (_,Error s1 s2) -> do
            throwIO (CompressionError (s1  <> " " <> s2))

      -- TODO: check-if-work-on-large-files
      createTreeWithMetadata sto mzero mempty (LBS.fromChunks pieces)
        >>= orThrowPassIO

    writePack sto l racc = do
      -- write
      -- pack
      -- merkle
      --
      let acc = reverse racc
      debug $ green "write pack of objects" <+> pretty l <+> pretty (length acc)

      let refs =  [ Builder.byteString [qc|R 0 {w} {show $ pretty ref} {show $ pretty h}|]
                  | EGitRef ref w h <- acc
                  ] & mconcat & (<> Builder.byteString "\n")

      parts <- for [ (h,t,e,lbs) | EGitObject t h e lbs <- acc ] $ \(h,t,e,lbs) -> liftIO do
        let ename = [qc|{fromMaybe mempty $ gitEntryName <$> e}|] :: ByteString

        -- notice $ "pack" <+> pretty h <+> pretty t
        let p =    Builder.byteString [qc|{pretty $ Short t} {pretty (LBS.length lbs)} {pretty h} {ename}|]
                <> Builder.byteString "\n"
                <> Builder.lazyByteString lbs
                <> Builder.byteString "\n"
        pure p

      let packed = Zstd.compress maxCLevel (LBS.toStrict $ Builder.toLazyByteString $ refs <> mconcat parts)

      createTreeWithMetadata sto mzero mempty (LBS.fromStrict packed)
        >>= orThrowPassIO

data CBlockReadError =
    EmptyCBlock
  | BadMetaData
  | MissedCBlock
  deriving stock (Show,Eq,Typeable)

data CBlockReadException =
 CBlockReadException HashRef CBlockReadError
 deriving stock (Show,Typeable)

instance Exception CBlockReadException

data CBlockSection =
    CBlockParents [HashRef]
  | CBlockData [HashRef]

readCBlock :: forall m . ( MonadIO m
                         )
           => AnyStorage
           -> HashRef
           -> ( CBlockSection  -> m () )
           -> m ()

readCBlock sto hash action = do

    hzz <- S.toList_ $ walkMerkle (coerce hash) (getBlock sto)  $ \case
      Left h -> throwIO MissedBlockError
      Right ( hs :: [HashRef] ) -> S.each hs

    hmeta <- headMay hzz & orThrow (CBlockReadException hash EmptyCBlock)

    what <- getBlock sto (coerce hmeta)
               >>= orThrow StorageError
               <&> LBS8.unpack
               <&> parseTop
               <&> fromRight mempty

    _ <- headMay [ ()
                 | ListVal [ StringLike "hbs2-git", _, StringLike "zstd" ] <- what
                 ] & orThrow (CBlockReadException hash BadMetaData)

    let pps = [ ph
              | ListVal [ StringLike "p", HashLike ph ] <- what
              ] & HS.fromList

    let rs = filter (\x -> not (HS.member x pps)) (tail hzz)

    action $ CBlockParents (HS.toList pps)
    action $ CBlockData rs

data WState =
    WStart
  | WNextSBlock
  | WReadSBlock Int HashRef
  | WProcessCBlock Int HashRef

traverseToCBlock :: forall m . MonadIO m
           => AnyStorage
           -> HashRef
           -> ( Int -> HashRef -> [HashRef] -> m () )
           -> m ()
traverseToCBlock sto cblock action = do

  q <- newTVarIO ( HPSQ.empty @HashRef @Int @() )
  done <- newTVarIO ( mempty :: HashSet HashRef )
  cache <- newCacheFixedHPSQ 1000

  flip fix WStart $ \next -> \case
    WStart -> do
      atomically $ modifyTVar q (HPSQ.insert cblock 1 ())
      next WNextSBlock

    WNextSBlock -> do

      blk' <- atomically $ stateTVar q $ HPSQ.alterMin \case
                Nothing      -> (Nothing, Nothing)
                Just (k,p,_) -> (Just (k,p), Nothing)

      debug $ "WNextSBlock" <+> pretty blk'

      maybe1 blk' none $ \(k,p) -> do
        next (WReadSBlock p k)

    WReadSBlock prio h -> do
      debug $ "WReadSBlock" <+> pretty h

      sections <- cached cache h $ S.toList_ (readCBlock sto h S.yield)

      for_ sections $ \case
        CBlockData _ -> none
        CBlockParents p -> do
          debug $ "parents" <+> pretty p
          next =<< atomically do
            d <- readTVar done
            for_ (zip [1..] p) $ \(i,x) -> do
              unless (HS.member x d) do
                modifyTVar q (HPSQ.insert x (prio-i) ())

            let hDone = HS.member h d

            unless hDone do
              modifyTVar q (HPSQ.insert h prio ())

            qq <- readTVar q
            if not (any (`HPSQ.member` qq) p) && not hDone then do
              pure $ WProcessCBlock prio h
            else do
              pure WNextSBlock

    WProcessCBlock i h -> do
      what <- cached cache h $ S.toList_ (readCBlock sto h S.yield)
      atomically $ modifyTVar done ( HS.insert h )
      uncache cache h

      debug $ "process cblock" <+> pretty h

      for_ what \case
        CBlockParents{} -> do
          none

        CBlockData hrefs -> do
          action i h hrefs

      next $ WNextSBlock


theDict :: forall m . ( HBS2GitPerks m
                      , HasClientAPI PeerAPI UNIX m
                      , HasStorage m
                      , HasGitRemoteKey m
                      , HasStateDB m
                      , MonadReader Git3Env m
                      ) => Dict C m
theDict = do
  makeDict @C do
    -- TODO: write-man-entries
    myHelpEntry
  where

    myHelpEntry = do
        entry $ bindMatch "--help" $ nil_ $ \case
          HelpEntryBound what -> do
            helpEntry what
            quit

          _ -> helpList False Nothing >> quit

        entry $ bindMatch "git:tree:ls" $ nil_ $ const do
          r <- gitReadTree "HEAD"
          for_ r $ \GitTreeEntry{..} -> do
            liftIO $ print $  pretty gitEntryHash
                          <+> pretty gitEntryType
                          <+> pretty gitEntrySize
                          <+> pretty gitEntryName

        entry $ bindMatch "reflog" $ nil_ $ \case
          [ SignPubKeyLike what ] -> do
            debug $ "set reflog" <+> pretty (AsBase58 what)
            lift $ setGitRemoteKey what

          _ -> throwIO (BadFormException @C nil)

        entry $ bindMatch "debug" $ nil_ $ const do
         setLogging @DEBUG  $ toStderr . logPrefix "[debug] "

        entry $ bindMatch "test:state:init" $ nil_ $ \case
          [ ] -> do
            lift $ connectedDo do
              r <- getGitRemoteKey >>= orThrowUser "git remote not set"
              p <- getStatePathDB (AsBase58 r)
              debug $ "test:state:init" <+> pretty p

          _ -> throwIO (BadFormException @C nil)

        entry $ bindMatch "test:git:normalize-ref" $ nil_  \case
          [ StringLike s ] -> display $ mkStr @C (show $ pretty $ gitNormaliseRef (fromString s))
          _ -> throwIO (BadFormException @C nil)

        entry $ bindMatch "test:hbs2:peer:poke" $ nil_ $ \syn -> do
          peer <- getClientAPI @PeerAPI @UNIX
          r    <- callRpcWaitRetry @RpcPoke (TimeoutSec 0.5) 2 peer () >>= orThrowUser "hbs2-peer not found"
          notice $ pretty r


        entry $ bindMatch "test:git:cblock:list" $ nil_ $ \syn -> lift do
          hash <- headMay [ x | HashLike x <- syn ] & orThrowUser "cblock hash not given"

          sto <- getStorage

          liftIO do

            readCBlock sto hash $ \case
              CBlockParents{} -> none
              CBlockData rs -> do
                for_ rs $ \r -> do
                  what <- runExceptT (getTreeContents sto r) >>= orThrowPassIO
                  debug $ yellow "reading" <+> pretty r
                  enumGitPackObjectsFromLBS () what $ \case
                    IOp o s (IGitObject t h _) -> do
                     putStrLn $ show $ pretty t <+> pretty h <+> pretty o <+> pretty s
                     pure True

                    IOp _ _ (ISetRef ref w h ) -> do
                      putStrLn $ show $ "ref" <+> pretty ref <+> pretty w <+> pretty h
                      pure True


        entry $ bindMatch "test:git:cblock:object:cat" $ nil_ $ \case
          [ HashLike cblock, StringLike g ] -> lift do

            sto <- getStorage
            h0 <- fromStringMay @GitHash g & orThrowUser "invalid git hash"

            readCBlock sto cblock $ \case
              CBlockParents{} -> none
              CBlockData rs -> do
                for_ rs $ \r -> do
                  what <- runExceptT (getTreeContents sto r) >>= orThrowPassIO
                  debug $ yellow "reading" <+> pretty r
                  enumGitPackObjectsFromLBS DoEnumPayload what $ \case

                    IOp _ _ (IGitObject _ h (Just body)) | h == h0 -> do
                      liftIO $ LBS.putStr body
                      pure False

                    _ -> pure True

          _ -> throwIO (BadFormException @C nil)

        entry $ bindMatch "test:git:cblock:scan" $ nil_ $ \case
          [ HashLike cblock ] -> lift do

            sto <- getStorage

            traverseToCBlock sto cblock $ \i h _ -> do
              debug $ green "process cblock data" <+> pretty i <+> pretty h

          _ -> throwIO (BadFormException @C nil)

        entry $ bindMatch "test:git:tree:export" $ nil_ $ \syn -> lift do
            (w, r) <- case syn of
                    [] -> (Nothing,) <$> gitRevParseThrow "HEAD"
                    [ StringLike co ] -> (Just (fromString co),) <$> gitRevParseThrow co
                    _ -> throwIO (BadFormException @C nil)

            let re = headMay [ GitRef (BS8.pack x) | ListVal [StringLike "--ref", StringLike x ] <- syn ]
            hd <- gitReadHEAD

            export (w <|> re <|> hd) r

-- 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 $ toStdout . logPrefix ""
  pure ()

flushLoggers :: MonadIO m => m ()
flushLoggers = do
  silence

silence :: MonadIO m => m ()
silence = do
  setLoggingOff @DEBUG
  setLoggingOff @ERROR
  setLoggingOff @WARN
  setLoggingOff @NOTICE

main :: IO ()
main = flip runContT pure do

  setupLogger

  ContT $ bracket none $ const do
    silence

  argz <- liftIO $ E.getArgs
  cli <- parseTop (unlines $ unwords <$> splitForms argz)
           & either  (error.show) pure

  env <- nullGit3Env

  void $ lift $ withGit3Env env do
    conf <- readLocalConf
    let dict = theDict
    recover $ run dict (conf <> cli)
      `finally` silence