mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
voidlizard
parent
49b16606aa
commit
3acb1aaabe
2
Makefile
2
Makefile
|
|
@ -27,6 +27,8 @@ BINS := \
|
|||
hbs2-sync \
|
||||
fixme-new \
|
||||
hbs2-storage-simple-benchmarks \
|
||||
hbs2-git3
|
||||
|
||||
|
||||
RT_DIR := tests/RT
|
||||
|
||||
|
|
|
|||
|
|
@ -61,7 +61,6 @@ class ( Monad m
|
|||
|
||||
delRef :: (Hashed h k, RefMetaData k) => a -> k -> m ()
|
||||
|
||||
|
||||
data AnyStorage = forall zu . ( Storage zu HbSync ByteString IO
|
||||
) => AnyStorage zu
|
||||
|
||||
|
|
@ -89,9 +88,6 @@ instance (IsKey HbSync, MonadIO m) => Storage AnyStorage HbSync ByteString m wh
|
|||
delRef (AnyStorage s) = liftIO . delRef s
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
calcChunks :: forall a b . (Integral a, Integral b)
|
||||
=> Integer -- | block size
|
||||
-> Integer -- | chunk size
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@ instance Pretty GitRef where
|
|||
pretty (GitRef x) = pretty @String [qc|{x}|]
|
||||
|
||||
data GitObjectType = Commit | Tree | Blob
|
||||
deriving stock (Eq,Ord,Show,Generic)
|
||||
deriving stock (Eq,Ord,Show,Generic,Enum)
|
||||
|
||||
instance Serialise GitObjectType
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,296 @@
|
|||
{-# Language ViewPatterns #-}
|
||||
{-# Language PatternSynonyms #-}
|
||||
module Main where
|
||||
|
||||
import HBS2.Prelude.Plated
|
||||
import HBS2.OrDie
|
||||
import HBS2.Storage.Compact
|
||||
|
||||
import HBS2.Git.Local
|
||||
import HBS2.Git.Local.CLI
|
||||
|
||||
import HBS2.System.Logger.Simple.ANSI as Exported
|
||||
import HBS2.System.Dir
|
||||
import HBS2.Misc.PrettyStuff as Exported
|
||||
|
||||
import Data.Config.Suckless.Script
|
||||
|
||||
import Codec.Compression.Zstd qualified as Z
|
||||
|
||||
import Codec.Compression.GZip qualified as GZ1
|
||||
import Codec.Compression.Zlib.Internal qualified as GZ
|
||||
|
||||
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.Lazy (ByteString)
|
||||
import Text.InterpolatedString.Perl6 (qc)
|
||||
import Data.HashSet qualified as HS
|
||||
import Data.HashMap.Strict qualified as HM
|
||||
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.Monad.Trans.Cont
|
||||
import System.IO (hPrint,hGetLine)
|
||||
|
||||
import Data.List (sortOn)
|
||||
import Data.Ord (Down(..))
|
||||
|
||||
import UnliftIO
|
||||
|
||||
{- HLINT ignore "Functor law" -}
|
||||
|
||||
type HBS2GitPerks m = (MonadUnliftIO m)
|
||||
|
||||
quit :: MonadUnliftIO m => m ()
|
||||
quit = liftIO Q.exitSuccess
|
||||
|
||||
data GitException =
|
||||
CompressionError String
|
||||
| InvalidObjectFormat GitObjectType (Maybe GitHash)
|
||||
| InvalidGitPack ByteString
|
||||
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)
|
||||
|
||||
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}|]
|
||||
>>= orThrowPassIO
|
||||
<&> fmap LBS8.words . LBS8.lines
|
||||
<&> mapMaybe \case
|
||||
GitTreeEntryView v -> do
|
||||
Just v
|
||||
_ -> Nothing
|
||||
|
||||
gitReadObjectThrow :: (Pretty h, MonadIO m) => GitObjectType -> h -> m ByteString
|
||||
gitReadObjectThrow t h = do
|
||||
gitRunCommand [qc|git cat-file {pretty t} {pretty h}|]
|
||||
>>= orThrowPassIO
|
||||
|
||||
gitRevParse :: MonadIO m => GitRef -> m (Maybe GitHash)
|
||||
gitRevParse ref = do
|
||||
gitRunCommand [qc|git rev-parse {pretty ref}|]
|
||||
>>= orThrowPassIO
|
||||
<&> LBS8.words
|
||||
<&> maybe Nothing (fromStringMay . LBS8.unpack) . headMay
|
||||
|
||||
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
|
||||
|
||||
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 (\entry -> (gitEntryType entry, gitEntrySize entry))
|
||||
|
||||
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)
|
||||
["B", s, h] -> (Blob,,) <$> readMay (LBS8.unpack s) <*> fromStringMay (LBS8.unpack h)
|
||||
["T", s, h] -> (Tree,,) <$> readMay (LBS8.unpack s) <*> fromStringMay (LBS8.unpack h)
|
||||
_ -> Nothing
|
||||
|
||||
theDict :: forall m . ( HBS2GitPerks m
|
||||
-- , HasTimeLimits UNIX (ServiceProto MyRPC UNIX) 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 "test:git:tree:pack:dump" $ nil_ $ \case
|
||||
[ StringLike fn ] -> do
|
||||
|
||||
content <- liftIO $ fmap GZ1.decompress (LBS8.readFile fn)
|
||||
|
||||
flip fix (UHead content) $ \next -> \case
|
||||
UHead "" -> none
|
||||
UHead bs -> do
|
||||
|
||||
let (hd,rest) = LBS8.span (/='\n') bs
|
||||
|
||||
case LBS8.words hd of
|
||||
PEntryView t s h -> do
|
||||
liftIO $ print $ pretty h <+> pretty t <+> pretty s
|
||||
next $ UHead (LBS8.drop (1 + fromIntegral s) rest)
|
||||
|
||||
_ -> throwIO (InvalidGitPack hd)
|
||||
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
|
||||
entry $ bindMatch "test:git:tree:pack:write" $ nil_ $ \syn -> do
|
||||
|
||||
let co = headDef "HEAD" $ [ GitRef (LBS8.toStrict $ LBS8.pack what) | StringLike what <- syn ]
|
||||
|
||||
hhead <- gitRevParse co >>= orThrowUser ("can't parse" <+> pretty co)
|
||||
|
||||
co <- gitReadObjectThrow Commit hhead
|
||||
<&> LBS8.lines
|
||||
<&> takeWhile ( not . LBS8.null )
|
||||
<&> LBS8.unpack . LBS8.unlines
|
||||
<&> parseTop
|
||||
>>= orThrowUser "invalid commit format"
|
||||
|
||||
let parents = [ fromStringMay @GitHash hash
|
||||
| ListVal [ StringLike "parent", StringLike hash ] <- co
|
||||
] & catMaybes
|
||||
|
||||
skip' <- S.toList_ $ for parents $ \p -> do
|
||||
gitReadTree p <&> fmap gitEntryHash >>= S.each
|
||||
|
||||
let skip = HS.fromList skip'
|
||||
|
||||
r <- gitReadTree hhead
|
||||
<&> L.filter (\GitTreeEntry{..} -> not (HS.member gitEntryHash skip))
|
||||
<&> sortGitTreeEntries
|
||||
|
||||
flip runContT pure do
|
||||
ph <- ContT withGitCat
|
||||
let ssin = getStdin ph
|
||||
let ssout = getStdout ph
|
||||
|
||||
inq <- newTQueueIO
|
||||
|
||||
atomically do
|
||||
writeTQueue inq (Commit, hhead)
|
||||
for_ r $ \GitTreeEntry{..} -> do
|
||||
writeTQueue inq (gitEntryType, gitEntryHash)
|
||||
|
||||
let
|
||||
go :: Handle -> GZ.CompressStream IO -> IO ()
|
||||
go outh (GZ.CompressInputRequired next) = do
|
||||
|
||||
inO <- atomically $ tryReadTQueue inq
|
||||
|
||||
case inO of
|
||||
Nothing -> go outh =<< next mempty
|
||||
|
||||
Just (t,ha) -> do
|
||||
|
||||
liftIO $ hPrint ssin $ pretty ha
|
||||
liftIO $ hFlush ssin
|
||||
|
||||
s <- liftIO $ hGetLine ssout
|
||||
|
||||
case words s of
|
||||
[_,_,s] -> do
|
||||
n <- readMay @Int s & orThrowUser "fuck!"
|
||||
co <- liftIO $ LBS.hGet ssout n
|
||||
void $ liftIO $ hGetLine ssout
|
||||
let header = [qc|{pretty (Short t)} {s} {pretty ha}|]
|
||||
go outh =<< next (LBS.toStrict (LBS8.intercalate "\n" [header, co]))
|
||||
|
||||
e -> error (show e)
|
||||
|
||||
go outh (GZ.CompressOutputAvailable outchunk next) = do
|
||||
BS.hPut outh outchunk
|
||||
go outh =<< next
|
||||
go _ GZ.CompressStreamEnd = return ()
|
||||
|
||||
let compressStream = GZ.compressIO GZ.gzipFormat GZ.defaultCompressParams
|
||||
|
||||
liftIO $ go stdout compressStream
|
||||
|
||||
none
|
||||
|
||||
-- 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
|
||||
|
||||
let dict = theDict
|
||||
|
||||
void $ lift $ run dict cli
|
||||
|
||||
|
||||
Loading…
Reference in New Issue