mirror of https://github.com/voidlizard/hbs2
wip13
This commit is contained in:
voidlizard
parent
a7aae31cac
commit
dbcff19aed
|
|
@ -164,7 +164,6 @@ outputs = { self, nixpkgs, flake-utils, ... }@inputs:
|
|||
pkgs.libsodium
|
||||
pkgs.file
|
||||
pkgs.zlib
|
||||
pkgs.bzip2
|
||||
inputs.hspup.packages.${pkgs.system}.default
|
||||
]
|
||||
);
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# Language MultiWayIf #-}
|
||||
{-# Language FunctionalDependencies #-}
|
||||
{-# Language ViewPatterns #-}
|
||||
{-# Language PatternSynonyms #-}
|
||||
|
|
@ -45,12 +46,6 @@ import HBS2.Git3.Config.Local
|
|||
import Data.Config.Suckless.Script
|
||||
import DBPipe.SQLite
|
||||
|
||||
-- import Codec.Compression.GZip as GZ1
|
||||
-- import Codec.Compression.Zlib.Internal qualified as GZ
|
||||
|
||||
import Codec.Compression.BZip as BZ1
|
||||
import Codec.Compression.BZip.Internal qualified as BZ
|
||||
-- import Codec.Compression.Zlib.Internal qualified as GZ
|
||||
import Codec.Compression.Zstd qualified as Zstd
|
||||
import Codec.Compression.Zstd.Streaming qualified as ZstdS
|
||||
import Codec.Compression.Zstd.Streaming (Result(..))
|
||||
|
|
@ -63,6 +58,7 @@ 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)
|
||||
|
|
@ -77,6 +73,7 @@ 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
|
||||
|
|
@ -130,6 +127,13 @@ data GitTreeEntry =
|
|||
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
|
||||
|
|
@ -171,6 +175,14 @@ gitRevParse ref = do
|
|||
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"
|
||||
|
|
@ -377,9 +389,6 @@ gitObjectExists what = do
|
|||
data UState =
|
||||
UHead ByteString
|
||||
|
||||
pattern PEntryView :: GitObjectType -> Word32 -> GitHash -> [ByteString]
|
||||
pattern PEntryView t s h <- ( unpackPEntry -> Just (t,s,h) )
|
||||
|
||||
unpackPEntry :: [ByteString] -> Maybe (GitObjectType, Word32, GitHash)
|
||||
unpackPEntry = \case
|
||||
("C" : s : h : _) -> (Commit,,) <$> readMay (LBS8.unpack s) <*> fromStringMay (LBS8.unpack h)
|
||||
|
|
@ -393,7 +402,7 @@ data ES =
|
|||
|
||||
enumGitPackObjectsFromLBS :: MonadIO m
|
||||
=> ByteString
|
||||
-> ( GitObjectType -> Word32 -> GitHash -> m Bool )
|
||||
-> ( IOp -> m Bool )
|
||||
-> m ()
|
||||
enumGitPackObjectsFromLBS lbs action = do
|
||||
|
||||
|
|
@ -424,13 +433,15 @@ enumGitPackObjectsFromLBS lbs action = do
|
|||
let s0 = LBS8.dropWhile (=='\n') chunk
|
||||
unless (LBS.null s0) do
|
||||
let (hdr,rest) = LBS8.break (=='\n') s0
|
||||
(t,s,h) <- unpackPEntry (LBS8.words hdr) & orThrow (InvalidGitPack hdr)
|
||||
void $ action t s h
|
||||
|
||||
iop@(IOp s _) <- unpackIOp (LBS8.words hdr) & orThrow (InvalidGitPack hdr)
|
||||
|
||||
void $ action iop
|
||||
|
||||
let o = LBS.drop 1 rest
|
||||
let (_, rest2) = LBS.splitAt (fromIntegral s) o
|
||||
next (UHead rest2)
|
||||
|
||||
|
||||
data ExportState =
|
||||
ExportGetCommit
|
||||
| ExportProcessCommit GitHash ByteString
|
||||
|
|
@ -452,8 +463,55 @@ data WInput =
|
|||
| WInputCBlock HashRef
|
||||
|
||||
|
||||
data EOp =
|
||||
EGitObject GitObjectType GitHash (Maybe GitTreeEntry) ByteString
|
||||
| EGitRef GitRef Int (Maybe GitHash)
|
||||
|
||||
data IOpType
|
||||
= IOGitObject GitObjectType GitHash
|
||||
| IOSetRef GitRef Int (Maybe GitHash)
|
||||
deriving (Show, Eq)
|
||||
|
||||
data IOp = IOp Word32 IOpType
|
||||
deriving (Show, Eq)
|
||||
|
||||
unpackIOp :: [ByteString] -> Maybe IOp
|
||||
unpackIOp = \case
|
||||
("C" : s : h : _) -> do
|
||||
size <- fromLBS s
|
||||
hash <- fromLBS' h
|
||||
pure $ IOp size (IOGitObject Commit hash)
|
||||
|
||||
("B" : s : h : _) -> do
|
||||
size <- fromLBS s
|
||||
hash <- fromLBS' h
|
||||
pure $ IOp size (IOGitObject Blob hash)
|
||||
|
||||
("T" : s : h : _) -> do
|
||||
size <- fromLBS s
|
||||
hash <- fromLBS' h
|
||||
pure $ IOp size (IOGitObject Tree hash)
|
||||
|
||||
("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 size (IOSetRef 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 [(GitHash, GitObjectType,Maybe GitTreeEntry, ByteString)]
|
||||
EWAcc Int [GitTreeEntry] Int [EOp]
|
||||
|
||||
newtype CacheTVH k v = CacheTVH (TVar (HashMap k v))
|
||||
|
||||
|
|
@ -509,10 +567,12 @@ export :: ( HBS2GitPerks m
|
|||
, HasStorage m
|
||||
, HasStateDB m
|
||||
)
|
||||
=> GitHash -> m ()
|
||||
export r = connectedDo $ flip runContT pure do
|
||||
=> 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 )
|
||||
|
||||
|
|
@ -539,19 +599,6 @@ export r = connectedDo $ flip runContT pure do
|
|||
ContT $ withAsync $ replicateM_ 2 $ forever do
|
||||
join $ atomically (readTQueue deferred)
|
||||
|
||||
-- let noCBlock x = do
|
||||
-- here <- withState $ selectCBlock x
|
||||
-- pure (isNothing here)
|
||||
|
||||
-- pre <- gitRunCommand [qc|git rev-list {pretty r}|]
|
||||
-- <&> fromRight mempty
|
||||
-- <&> LBS8.lines
|
||||
-- <&> mapMaybe ( fromStringMay @GitHash . LBS8.unpack )
|
||||
-- <&> take (10 * commitCacheSize)
|
||||
-- >>= filterM (lift . noCBlock)
|
||||
-- <&> take commitCacheSize
|
||||
-- >>= \xs -> lift (mapM_ (\x -> cached commits x (gitReadObjectMaybe reader x)) xs)
|
||||
|
||||
lift $ flip fix ExportGetCommit $ \next -> \case
|
||||
|
||||
ExportStart -> do
|
||||
|
|
@ -642,7 +689,7 @@ export r = connectedDo $ flip runContT pure do
|
|||
|
||||
out <- newTQueueIO
|
||||
|
||||
flip fix (EWAcc 1 r 0 [(co,Commit,Nothing,bs)]) $ \go -> \case
|
||||
flip fix (EWAcc 1 r 0 [EGitObject Commit co Nothing bs]) $ \go -> \case
|
||||
|
||||
EWAcc _ [] _ [] -> none
|
||||
|
||||
|
|
@ -663,7 +710,8 @@ export r = connectedDo $ flip runContT pure do
|
|||
>>= orThrow (GitReadError (show $ pretty gitEntryHash))
|
||||
<&> snd
|
||||
|
||||
go (EWAcc i rs (l + fromIntegral (LBS.length lbs)) ((gitEntryHash,gitEntryType, Just e, lbs) : acc))
|
||||
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
|
||||
|
|
@ -756,10 +804,15 @@ export r = connectedDo $ flip runContT pure do
|
|||
-- write
|
||||
-- pack
|
||||
-- merkle
|
||||
--
|
||||
let acc = reverse racc
|
||||
debug $ green "write pack of objects" <+> pretty l <+> pretty (length acc)
|
||||
|
||||
parts <- for acc $ \(h,t,e,lbs) -> liftIO do
|
||||
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
|
||||
|
|
@ -824,15 +877,8 @@ theDict = do
|
|||
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
|
||||
entry $ bindMatch "test:git:tree:pack:dump" $ nil_ $ \case
|
||||
[ StringLike fn ] -> do
|
||||
|
||||
lbs <- liftIO (LBS8.readFile fn)
|
||||
|
||||
enumGitPackObjectsFromLBS lbs $ \t s h -> do
|
||||
liftIO $ print $ pretty h <+> pretty t <+> pretty s
|
||||
pure True
|
||||
|
||||
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
|
||||
|
|
@ -872,17 +918,25 @@ theDict = do
|
|||
for_ rs $ \r -> do
|
||||
what <- runExceptT (getTreeContents sto r) >>= orThrowPassIO
|
||||
debug $ yellow "reading" <+> pretty r
|
||||
enumGitPackObjectsFromLBS what $ \t s h -> do
|
||||
enumGitPackObjectsFromLBS what $ \case
|
||||
IOp s (IOGitObject t h) -> do
|
||||
putStrLn $ show $ pretty t <+> pretty h <+> pretty s
|
||||
pure True
|
||||
|
||||
IOp _ (IOSetRef ref w h ) -> do
|
||||
putStrLn $ show $ pretty ref <+> pretty w <+> pretty h
|
||||
pure True
|
||||
|
||||
entry $ bindMatch "test:git:tree:export" $ nil_ $ \syn -> lift do
|
||||
r <- case syn of
|
||||
[] -> gitRevParseThrow "HEAD"
|
||||
[ StringLike co ] -> gitRevParseThrow co
|
||||
(w, r) <- case syn of
|
||||
[] -> (Nothing,) <$> gitRevParseThrow "HEAD"
|
||||
[ StringLike co ] -> (Just (fromString co),) <$> gitRevParseThrow co
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
|
||||
export r
|
||||
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] "
|
||||
|
|
|
|||
|
|
@ -120,7 +120,6 @@ library
|
|||
build-depends: base
|
||||
, base16-bytestring
|
||||
, binary
|
||||
, bzlib
|
||||
, psqueues
|
||||
, unix
|
||||
|
||||
|
|
@ -134,7 +133,6 @@ executable hbs2-git3
|
|||
-- other-extensions:
|
||||
build-depends:
|
||||
base, hbs2-git3, hbs2-core, hbs2-peer, hbs2-git
|
||||
, bzlib
|
||||
, binary
|
||||
, psqueues
|
||||
, vector
|
||||
|
|
@ -150,7 +148,6 @@ executable hbs2-git-daemon
|
|||
-- other-extensions:
|
||||
build-depends:
|
||||
base, hbs2-git3, hbs2-core, hbs2-peer, hbs2-git
|
||||
, bzlib
|
||||
, binary
|
||||
, vector
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue