mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
voidlizard
parent
2e6fbaccc0
commit
7528d291c3
|
|
@ -164,6 +164,7 @@ outputs = { self, nixpkgs, flake-utils, ... }@inputs:
|
|||
pkgs.libsodium
|
||||
pkgs.file
|
||||
pkgs.zlib
|
||||
pkgs.bzip2
|
||||
inputs.hspup.packages.${pkgs.system}.default
|
||||
]
|
||||
);
|
||||
|
|
|
|||
|
|
@ -1,10 +1,21 @@
|
|||
{-# Language ViewPatterns #-}
|
||||
{-# Language PatternSynonyms #-}
|
||||
{-# Language RecordWildCards #-}
|
||||
module Main where
|
||||
|
||||
import HBS2.Prelude.Plated
|
||||
import HBS2.OrDie
|
||||
import HBS2.Storage.Compact
|
||||
|
||||
import HBS2.Storage
|
||||
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.Git.Local
|
||||
import HBS2.Git.Local.CLI
|
||||
|
|
@ -30,6 +41,7 @@ import Data.ByteString qualified as BS
|
|||
import Data.ByteString.Lazy (ByteString)
|
||||
import Text.InterpolatedString.Perl6 (qc)
|
||||
import Data.HashSet qualified as HS
|
||||
import Data.HashSet (HashSet(..))
|
||||
import Data.HashMap.Strict qualified as HM
|
||||
import Data.Word
|
||||
|
||||
|
|
@ -38,14 +50,18 @@ 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 Control.Monad.Reader
|
||||
import System.IO (hPrint,hGetLine,IOMode(..))
|
||||
import System.IO qualified as IO
|
||||
|
||||
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)
|
||||
|
||||
|
|
@ -56,6 +72,7 @@ data GitException =
|
|||
CompressionError String
|
||||
| InvalidObjectFormat GitObjectType (Maybe GitHash)
|
||||
| InvalidGitPack ByteString
|
||||
| OtherGitError String
|
||||
deriving stock (Eq,Show,Typeable,Generic)
|
||||
|
||||
instance Exception GitException
|
||||
|
|
@ -99,7 +116,7 @@ gitReadObjectThrow t h = do
|
|||
gitRunCommand [qc|git cat-file {pretty t} {pretty h}|]
|
||||
>>= orThrowPassIO
|
||||
|
||||
gitRevParse :: MonadIO m => GitRef -> m (Maybe GitHash)
|
||||
gitRevParse :: (Pretty ref, MonadIO m) => ref -> m (Maybe GitHash)
|
||||
gitRevParse ref = do
|
||||
gitRunCommand [qc|git rev-parse {pretty ref}|]
|
||||
>>= orThrowPassIO
|
||||
|
|
@ -124,7 +141,179 @@ instance Pretty (Short GitObjectType) where
|
|||
|
||||
|
||||
sortGitTreeEntries :: [GitTreeEntry] -> [GitTreeEntry]
|
||||
sortGitTreeEntries = sortOn (\entry -> (gitEntryType entry, gitEntrySize entry))
|
||||
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
|
||||
| Git3Connected
|
||||
{ peerSocket :: FilePath
|
||||
, peerAPI :: ServiceCaller PeerAPI UNIX
|
||||
}
|
||||
|
||||
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
|
||||
|
||||
instance (MonadUnliftIO m, HasClientAPI api proto m) => HasClientAPI api proto (RunM c m) where
|
||||
getClientAPI = lift (getClientAPI @api @proto)
|
||||
|
||||
instance (MonadUnliftIO m, HasClientAPI api proto m) => HasClientAPI api proto (ContT a (RunM c m)) where
|
||||
getClientAPI = lift $ getClientAPI @api @proto
|
||||
|
||||
nullGit3Env :: MonadIO m => m Git3Env
|
||||
nullGit3Env = pure Git3Disconnected
|
||||
|
||||
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
|
||||
|
||||
let connected = Git3Connected soname peerAPI
|
||||
|
||||
liftIO $ withGit3Env connected again
|
||||
|
||||
gitWriteCommitPackIO :: (GitWritePacksOpts opt, Pretty what) => opt -> what -> ( BS.ByteString -> IO () ) -> IO ()
|
||||
gitWriteCommitPackIO opts what action = do
|
||||
hhead <- gitRevParse what >>= orThrow (OtherGitError $ show $ "can't parse" <+> pretty what)
|
||||
|
||||
co <- gitReadObjectThrow Commit hhead
|
||||
<&> LBS8.lines
|
||||
<&> takeWhile ( not . LBS8.null )
|
||||
<&> LBS8.unpack . LBS8.unlines
|
||||
<&> parseTop
|
||||
>>= orThrow (OtherGitError "invalid commit format")
|
||||
|
||||
let parents = [ fromStringMay @GitHash hash
|
||||
| ListVal [ StringLike "parent", StringLike hash ] <- co
|
||||
] & catMaybes
|
||||
|
||||
-- debug $ "EXCLUDE PARENTS" <+> pretty (excludeParents opts)
|
||||
|
||||
skip <- if not (excludeParents opts) then do
|
||||
pure mempty
|
||||
else do
|
||||
skip' <- S.toList_ $ for parents $ \p -> do
|
||||
gitReadTree p <&> fmap gitEntryHash >>= S.each
|
||||
pure $ 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 params = defaultCompressParams
|
||||
let compressStream = BZ.compressIO params
|
||||
|
||||
lift $ flip fix compressStream $ \go -> \case
|
||||
BZ.CompressInputRequired next -> do
|
||||
|
||||
inO <- atomically $ tryReadTQueue inq
|
||||
|
||||
case inO of
|
||||
Nothing -> go =<< 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 & orThrow (OtherGitError "git cat-file --batch error")
|
||||
co <- liftIO $ LBS.hGet ssout n
|
||||
void $ liftIO $ hGetLine ssout
|
||||
let header = [qc|{pretty (Short t)} {s} {pretty ha}|]
|
||||
go =<< next (LBS.toStrict (LBS8.intercalate "\n" [header, co]))
|
||||
|
||||
e -> throwIO $ OtherGitError ("git cat-file --batch error: " <> show e)
|
||||
|
||||
BZ.CompressOutputAvailable outchunk next -> do
|
||||
action outchunk
|
||||
go =<< next
|
||||
|
||||
BZ.CompressStreamEnd -> pure ()
|
||||
|
||||
data UState =
|
||||
UHead ByteString
|
||||
|
|
@ -140,7 +329,7 @@ unpackPEntry = \case
|
|||
_ -> Nothing
|
||||
|
||||
theDict :: forall m . ( HBS2GitPerks m
|
||||
-- , HasTimeLimits UNIX (ServiceProto MyRPC UNIX) m
|
||||
, HasClientAPI PeerAPI UNIX m
|
||||
) => Dict C m
|
||||
theDict = do
|
||||
makeDict @C do
|
||||
|
|
@ -181,81 +370,32 @@ theDict = do
|
|||
|
||||
_ -> 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 ]
|
||||
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
|
||||
|
||||
hhead <- gitRevParse co >>= orThrowUser ("can't parse" <+> pretty co)
|
||||
entry $ bindMatch "test:git:tree:export" $ nil_ $ \syn -> flip runContT pure do
|
||||
pure ()
|
||||
|
||||
co <- gitReadObjectThrow Commit hhead
|
||||
<&> LBS8.lines
|
||||
<&> takeWhile ( not . LBS8.null )
|
||||
<&> LBS8.unpack . LBS8.unlines
|
||||
<&> parseTop
|
||||
>>= orThrowUser "invalid commit format"
|
||||
entry $ bindMatch "test:git:tree:pack:write" $ nil_ $ \syn -> flip runContT pure do
|
||||
|
||||
let parents = [ fromStringMay @GitHash hash
|
||||
| ListVal [ StringLike "parent", StringLike hash ] <- co
|
||||
] & catMaybes
|
||||
let o = [ WriteFullPack | StringLike "--full" <- syn ] & HS.fromList
|
||||
|
||||
skip' <- S.toList_ $ for parents $ \p -> do
|
||||
gitReadTree p <&> fmap gitEntryHash >>= S.each
|
||||
(what,to) <- case syn of
|
||||
|
||||
let skip = HS.fromList skip'
|
||||
( StringLike rev : StringLike fn : _) -> do
|
||||
-- let co = headDef "HEAD" $ [ GitRef (LBS8.toStrict $ LBS8.pack what) | StringLike what <- syn ]
|
||||
fh <- ContT $ bracket (liftIO (IO.openFile fn WriteMode)) hClose
|
||||
pure (rev, fh)
|
||||
|
||||
r <- gitReadTree hhead
|
||||
<&> L.filter (\GitTreeEntry{..} -> not (HS.member gitEntryHash skip))
|
||||
<&> sortGitTreeEntries
|
||||
( StringLike rev : _ ) -> pure ( rev, stdout )
|
||||
|
||||
flip runContT pure do
|
||||
ph <- ContT withGitCat
|
||||
let ssin = getStdin ph
|
||||
let ssout = getStdout ph
|
||||
_ -> pure ( "HEAD", stdout )
|
||||
|
||||
inq <- newTQueueIO
|
||||
|
||||
atomically do
|
||||
writeTQueue inq (Commit, hhead)
|
||||
for_ r $ \GitTreeEntry{..} -> do
|
||||
writeTQueue inq (gitEntryType, gitEntryHash)
|
||||
|
||||
let
|
||||
go :: Handle -> BZ.CompressStream IO -> IO ()
|
||||
go outh (BZ.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 (BZ.CompressOutputAvailable outchunk next) = do
|
||||
BS.hPut outh outchunk
|
||||
go outh =<< next
|
||||
go _ BZ.CompressStreamEnd = return ()
|
||||
|
||||
let params = defaultCompressParams
|
||||
let compressStream = BZ.compressIO params
|
||||
|
||||
liftIO $ go stdout compressStream
|
||||
|
||||
none
|
||||
liftIO $ gitWriteCommitPackIO o what $ \bs -> do
|
||||
BS.hPut to bs
|
||||
|
||||
-- debugPrefix :: LoggerEntry -> LoggerEntry
|
||||
debugPrefix = toStderr . logPrefix "[debug] "
|
||||
|
|
@ -279,8 +419,6 @@ silence = do
|
|||
setLoggingOff @WARN
|
||||
setLoggingOff @NOTICE
|
||||
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = flip runContT pure do
|
||||
|
||||
|
|
@ -293,8 +431,9 @@ main = flip runContT pure do
|
|||
cli <- parseTop (unlines $ unwords <$> splitForms argz)
|
||||
& either (error.show) pure
|
||||
|
||||
let dict = theDict
|
||||
|
||||
void $ lift $ run dict cli
|
||||
env <- nullGit3Env
|
||||
|
||||
void $ lift $ withGit3Env env do
|
||||
let dict = theDict
|
||||
recover $ run dict cli
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,136 @@
|
|||
cabal-version: 3.0
|
||||
name: hbs2-git3
|
||||
version: 0.24.1.2
|
||||
synopsis: reimplemented fixme
|
||||
-- description:
|
||||
license: BSD-3-Clause
|
||||
license-file: LICENSE
|
||||
author: Dmitry Zuikov
|
||||
-- copyright:
|
||||
category: System
|
||||
build-type: Simple
|
||||
-- extra-doc-files: CHANGELOG.md
|
||||
-- extra-source-files:
|
||||
|
||||
common shared-properties
|
||||
ghc-options:
|
||||
-Wall
|
||||
-fno-warn-type-defaults
|
||||
-threaded
|
||||
-rtsopts
|
||||
-O2
|
||||
"-with-rtsopts=-N4 -A64m -AL256m -I0"
|
||||
|
||||
default-language: GHC2021
|
||||
|
||||
default-extensions:
|
||||
ApplicativeDo
|
||||
, BangPatterns
|
||||
, BlockArguments
|
||||
, ConstraintKinds
|
||||
, DataKinds
|
||||
, DeriveDataTypeable
|
||||
, DeriveGeneric
|
||||
, DerivingStrategies
|
||||
, DerivingVia
|
||||
, ExtendedDefaultRules
|
||||
, FlexibleContexts
|
||||
, FlexibleInstances
|
||||
, GADTs
|
||||
, GeneralizedNewtypeDeriving
|
||||
, ImportQualifiedPost
|
||||
, LambdaCase
|
||||
, MultiParamTypeClasses
|
||||
, OverloadedStrings
|
||||
, QuasiQuotes
|
||||
, RecordWildCards
|
||||
, ScopedTypeVariables
|
||||
, StandaloneDeriving
|
||||
, TupleSections
|
||||
, TypeApplications
|
||||
, TypeFamilies
|
||||
|
||||
|
||||
build-depends:
|
||||
hbs2-core
|
||||
, hbs2-peer
|
||||
, hbs2-storage-simple
|
||||
, hbs2-keyman-direct-lib
|
||||
, hbs2-git
|
||||
, hbs2-cli
|
||||
, db-pipe
|
||||
, suckless-conf
|
||||
, fuzzy-parse
|
||||
|
||||
, aeson
|
||||
, aeson-pretty
|
||||
, attoparsec
|
||||
, atomic-write
|
||||
, bytestring
|
||||
, binary
|
||||
, containers
|
||||
, directory
|
||||
, exceptions
|
||||
, filepath
|
||||
, filepattern
|
||||
, generic-lens
|
||||
, generic-deriving
|
||||
, interpolatedstring-perl6
|
||||
, memory
|
||||
, microlens-platform
|
||||
, mtl
|
||||
, safe
|
||||
, serialise
|
||||
, scientific
|
||||
, streaming
|
||||
, stm
|
||||
, split
|
||||
, text
|
||||
, temporary
|
||||
, time
|
||||
, timeit
|
||||
, transformers
|
||||
, typed-process
|
||||
, unordered-containers
|
||||
, unliftio
|
||||
, unliftio-core
|
||||
, zlib
|
||||
, prettyprinter
|
||||
, prettyprinter-ansi-terminal
|
||||
, random
|
||||
, vector
|
||||
, unix
|
||||
, uuid
|
||||
|
||||
|
||||
library
|
||||
import: shared-properties
|
||||
|
||||
other-modules:
|
||||
|
||||
exposed-modules:
|
||||
|
||||
build-depends: base
|
||||
, base16-bytestring
|
||||
, binary
|
||||
, bzlib
|
||||
, unix
|
||||
|
||||
hs-source-dirs: lib
|
||||
|
||||
|
||||
executable hbs2-git3
|
||||
import: shared-properties
|
||||
main-is: Main.hs
|
||||
-- other-modules:
|
||||
-- other-extensions:
|
||||
build-depends:
|
||||
base, hbs2-git3, hbs2-core, hbs2-peer, hbs2-git
|
||||
, bzlib
|
||||
, binary
|
||||
, vector
|
||||
|
||||
hs-source-dirs: app
|
||||
default-language: GHC2021
|
||||
|
||||
|
||||
Loading…
Reference in New Issue