mirror of https://github.com/voidlizard/hbs2
266 lines
6.6 KiB
Haskell
266 lines
6.6 KiB
Haskell
module Main where
|
||
|
||
import HBS2.Prelude
|
||
import HBS2.Data.Types.Refs
|
||
import HBS2.Base58
|
||
import HBS2.OrDie
|
||
import HBS2.Git.Types
|
||
import HBS2.Git.Local.CLI
|
||
|
||
import HBS2.System.Logger.Simple
|
||
|
||
import HBS2Git.Types()
|
||
import HBS2Git.Types qualified as G
|
||
import HBS2Git.App
|
||
import HBS2Git.State
|
||
import HBS2Git.Update
|
||
import HBS2Git.Export
|
||
import HBS2Git.Config as Config
|
||
|
||
import GitRemoteTypes
|
||
import GitRemotePush
|
||
|
||
import Control.Concurrent.Async
|
||
import Control.Concurrent.STM
|
||
import Control.Monad.Reader
|
||
import Data.Attoparsec.Text
|
||
import Data.Attoparsec.Text qualified as Atto
|
||
import Data.ByteString.Char8 qualified as BS
|
||
import Data.ByteString.Lazy.Char8 qualified as LBS
|
||
import Data.Foldable
|
||
import Data.Functor
|
||
import Data.HashSet qualified as HashSet
|
||
import Data.Maybe
|
||
import Data.Text qualified as Text
|
||
import System.Environment
|
||
import System.Exit qualified as Exit
|
||
import System.Posix.Signals
|
||
import System.ProgressBar
|
||
import Text.InterpolatedString.Perl6 (qc)
|
||
import UnliftIO.IO as UIO
|
||
import Control.Monad.Trans.Maybe
|
||
|
||
|
||
send :: MonadIO m => BS.ByteString -> m ()
|
||
send = liftIO . BS.hPutStr stdout
|
||
|
||
sendLn :: MonadIO m => BS.ByteString -> m ()
|
||
sendLn s = do
|
||
trace $ "sendLn" <+> pretty (show s)
|
||
liftIO $ BS.hPutStrLn stdout s
|
||
|
||
sendEol :: MonadIO m => m ()
|
||
sendEol = liftIO $ BS.hPutStrLn stdout "" >> hFlush stdout
|
||
|
||
receive :: MonadIO m => m BS.ByteString
|
||
receive = liftIO $ BS.hGetLine stdin
|
||
|
||
done :: MonadIO m => m Bool
|
||
done = UIO.hIsEOF stdin
|
||
|
||
parseRepoURL :: String -> Maybe HashRef
|
||
parseRepoURL url' = either (const Nothing) Just (parseOnly p url)
|
||
where
|
||
url = Text.pack url'
|
||
p = do
|
||
_ <- string "hbs2://"
|
||
topic' <- Atto.manyTill' anyChar endOfInput
|
||
let topic = BS.unpack <$> fromBase58 (BS.pack topic')
|
||
maybe (fail "invalid url") (pure . fromString) topic
|
||
|
||
|
||
capabilities :: BS.ByteString
|
||
capabilities = BS.unlines ["push","fetch"]
|
||
|
||
|
||
readHeadDef :: HasCatAPI m => DBEnv -> m LBS.ByteString
|
||
readHeadDef db =
|
||
withDB db stateGetHead >>=
|
||
\r' -> maybe1 r' (pure "\n") \r -> do
|
||
readObject r <&> fromMaybe "\n"
|
||
|
||
loop :: forall m . ( MonadIO m
|
||
, HasProgress (RunWithConfig (GitRemoteApp m))
|
||
) => [String] -> GitRemoteApp m ()
|
||
loop args = do
|
||
|
||
|
||
-- setLogging @TRACE tracePrefix
|
||
|
||
trace $ "args:" <+> pretty args
|
||
|
||
let ref' = case args of
|
||
[_, s] -> Text.stripPrefix "hbs2://" (Text.pack s) <&> fromString @RepoRef . Text.unpack
|
||
_ -> Nothing
|
||
|
||
ref <- pure ref' `orDie` ("invalid reference: " <> show args)
|
||
|
||
trace $ "ref:" <+> pretty ref
|
||
|
||
dbPath <- makeDbPath ref
|
||
|
||
trace $ "dbPath:" <+> pretty dbPath
|
||
|
||
db <- dbEnv dbPath
|
||
|
||
--FIXME: git-fetch-second-time
|
||
-- Разобраться, почему git fetch срабатывает со второго раза
|
||
|
||
-- FIXME: git-push-always-up-to-date
|
||
-- Разобраться, почему git push всегда говорит
|
||
-- , что всё up-to-date
|
||
|
||
checkRef <- readRef ref <&> isJust
|
||
|
||
unless checkRef do
|
||
warn $ "reference" <+> pretty ref <+> "missing"
|
||
warn "trying to init reference --- may be it's ours"
|
||
liftIO $ runApp NoLog (runExport Nothing ref)
|
||
|
||
hdRefOld <- readHeadDef db
|
||
|
||
updateLocalState ref
|
||
|
||
hd <- readHeadDef db
|
||
|
||
hashes <- withDB db stateGetAllObjects
|
||
|
||
-- FIXME: asap-get-all-existing-objects-or-all-if-clone
|
||
-- если clone - доставать всё
|
||
-- если fetch - брать список объектов и импортировать
|
||
-- только те, которых нет в репо
|
||
|
||
existed <- gitListAllObjects <&> HashSet.fromList
|
||
|
||
jobz <- liftIO newTQueueIO
|
||
|
||
-- TODO: check-if-fetch-really-works
|
||
-- TODO: check-if-fetch-actually-works
|
||
|
||
jobNumT <- liftIO $ newTVarIO 0
|
||
liftIO $ atomically $ for_ hashes $ \o@(_,gh,_) -> do
|
||
unless (HashSet.member gh existed) do
|
||
modifyTVar' jobNumT succ
|
||
writeTQueue jobz o
|
||
|
||
env <- ask
|
||
|
||
batch <- liftIO $ newTVarIO False
|
||
|
||
fix \next -> do
|
||
|
||
eof <- done
|
||
|
||
when eof do
|
||
exitFailure
|
||
|
||
s <- receive
|
||
|
||
let str = BS.unwords (BS.words s)
|
||
let cmd = BS.words str
|
||
|
||
-- trace $ pretty (fmap BS.unpack cmd)
|
||
-- hPrint stderr $ show $ pretty (fmap BS.unpack cmd)
|
||
--
|
||
|
||
isBatch <- liftIO $ readTVarIO batch
|
||
|
||
case cmd of
|
||
[] -> do
|
||
liftIO $ atomically $ writeTVar batch False
|
||
-- -- FIXME: wtf
|
||
-- when isBatch next
|
||
if isBatch then do
|
||
sendEol
|
||
next
|
||
else do
|
||
updateLocalState ref
|
||
|
||
["capabilities"] -> do
|
||
trace $ "send capabilities" <+> pretty (BS.unpack capabilities)
|
||
send capabilities >> sendEol
|
||
next
|
||
|
||
["list"] -> do
|
||
|
||
|
||
hl <- liftIO $ readTVarIO jobNumT
|
||
pb <- newProgressMonitor "storing git objects" hl
|
||
|
||
-- FIXME: thread-num-hardcoded
|
||
liftIO $ replicateConcurrently_ 4 $ fix \nl -> do
|
||
atomically (tryReadTQueue jobz) >>= \case
|
||
Nothing -> pure ()
|
||
Just (h,_,t) -> do
|
||
runRemoteM env do
|
||
-- FIXME: proper-error-handling
|
||
o <- readObject h `orDie` [qc|unable to fetch object {pretty t} {pretty h}|]
|
||
r <- gitStoreObject (GitObject t o)
|
||
|
||
when (isNothing r) do
|
||
err $ "can't write object to git" <+> pretty h
|
||
|
||
G.updateProgress pb 1
|
||
nl
|
||
|
||
for_ (LBS.lines hd) (sendLn . LBS.toStrict)
|
||
sendEol
|
||
next
|
||
|
||
["list","for-push"] -> do
|
||
-- FIXME: send-head-before-update
|
||
for_ (LBS.lines hdRefOld) (sendLn . LBS.toStrict)
|
||
sendEol
|
||
next
|
||
|
||
-- TODO: check-if-git-push-works
|
||
["fetch", sha1, x] -> do
|
||
trace $ "fetch" <+> pretty (BS.unpack sha1) <+> pretty (BS.unpack x)
|
||
liftIO $ atomically $ writeTVar batch True
|
||
next
|
||
|
||
["push", rr] -> do
|
||
let bra = BS.split ':' rr
|
||
let pu = fmap (fromString' . BS.unpack) bra
|
||
liftIO $ atomically $ writeTVar batch True
|
||
push ref pu
|
||
next
|
||
|
||
other -> die $ show other
|
||
|
||
where
|
||
fromString' "" = Nothing
|
||
fromString' x = Just $ fromString x
|
||
|
||
main :: IO ()
|
||
main = do
|
||
|
||
hSetBuffering stdin NoBuffering
|
||
hSetBuffering stdout LineBuffering
|
||
|
||
doTrace <- lookupEnv "HBS2TRACE" <&> isJust
|
||
|
||
when doTrace do
|
||
setLogging @DEBUG debugPrefix
|
||
setLogging @TRACE tracePrefix
|
||
|
||
setLogging @NOTICE noticePrefix
|
||
setLogging @ERROR errorPrefix
|
||
setLogging @WARN warnPrefix
|
||
setLogging @INFO infoPrefix
|
||
|
||
args <- getArgs
|
||
|
||
void $ installHandler sigPIPE Ignore Nothing
|
||
|
||
env <- RemoteEnv <$> detectHBS2PeerCatAPI
|
||
<*> detectHBS2PeerSizeAPI
|
||
<*> liftIO (newTVarIO mempty)
|
||
|
||
runRemoteM env do
|
||
loop args
|
||
|
||
shutUp
|
||
|
||
|