mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
voidlizard
parent
2298295972
commit
b5410825c3
|
|
@ -6,7 +6,7 @@ import Prelude hiding (getLine)
|
|||
import HBS2.Git3.Prelude
|
||||
import HBS2.Git3.Run
|
||||
import HBS2.Git3.Config.Local
|
||||
import HBS2.Git3.State.Index
|
||||
import HBS2.Git3.State
|
||||
import HBS2.Git3.Import
|
||||
import HBS2.Git3.Export
|
||||
import HBS2.Git3.Git
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@ module Main where
|
|||
|
||||
import HBS2.Git3.Prelude
|
||||
import HBS2.Git3.Run
|
||||
import HBS2.Git3.State
|
||||
|
||||
import HBS2.Data.Log.Structured
|
||||
|
||||
|
|
@ -55,7 +56,7 @@ setupLogger = do
|
|||
-- setLogging @DEBUG $ toStderr . logPrefix "[debug] "
|
||||
setLogging @ERROR $ toStderr . logPrefix "[error] "
|
||||
setLogging @WARN $ toStderr . logPrefix "[warn] "
|
||||
setLogging @NOTICE $ toStdout . logPrefix ""
|
||||
setLogging @NOTICE $ toStderr . logPrefix ""
|
||||
pure ()
|
||||
|
||||
flushLoggers :: MonadIO m => m ()
|
||||
|
|
@ -81,6 +82,7 @@ main = flip runContT pure do
|
|||
cli <- parseTop (unlines $ unwords <$> splitForms argz)
|
||||
& either (error.show) pure
|
||||
|
||||
|
||||
env <- nullGit3Env
|
||||
|
||||
void $ lift $ withGit3Env env do
|
||||
|
|
|
|||
|
|
@ -127,12 +127,13 @@ library
|
|||
HBS2.Git3.Import
|
||||
HBS2.Git3.Repo
|
||||
HBS2.Git3.Run
|
||||
HBS2.Git3.State.Types
|
||||
HBS2.Git3.State.RefLog
|
||||
HBS2.Git3.State.Index
|
||||
HBS2.Git3.State.Segment
|
||||
HBS2.Git3.State
|
||||
HBS2.Git3.State.Internal.Types
|
||||
HBS2.Git3.State.Internal.RefLog
|
||||
HBS2.Git3.State.Internal.Index
|
||||
HBS2.Git3.State.Internal.Segment
|
||||
HBS2.Git3.State.Internal.LWWBlock
|
||||
HBS2.Git3.Config.Local
|
||||
HBS2.Git3.State.LWWBlock
|
||||
HBS2.Git3.Git
|
||||
HBS2.Git3.Git.Pack
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
module HBS2.Git3.Export (exportEntries,export) where
|
||||
|
||||
import HBS2.Git3.Prelude
|
||||
import HBS2.Git3.State.Index
|
||||
import HBS2.Git3.State
|
||||
import HBS2.Git3.Git
|
||||
import HBS2.Data.Detect
|
||||
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@ import HBS2.Git3.Prelude
|
|||
import HBS2.OrDie
|
||||
|
||||
import HBS2.Git3.Types
|
||||
import HBS2.Git3.State.Internal.Types
|
||||
import HBS2.Git.Local
|
||||
import HBS2.Git.Local.CLI
|
||||
|
||||
|
|
@ -39,13 +40,6 @@ import UnliftIO
|
|||
|
||||
{-HLINT Ignore "Functor law"-}
|
||||
|
||||
pattern GitHashLike:: forall {c} . GitHash -> Syntax c
|
||||
pattern GitHashLike x <- (
|
||||
\case
|
||||
StringLike s -> fromStringMay @GitHash s
|
||||
LitIntVal 0 -> Just $ GitHash (BS.replicate 20 0)
|
||||
_ -> Nothing
|
||||
-> Just x )
|
||||
|
||||
data GitException =
|
||||
CompressionError String
|
||||
|
|
|
|||
|
|
@ -3,11 +3,9 @@
|
|||
module HBS2.Git3.Import where
|
||||
|
||||
import HBS2.Git3.Prelude
|
||||
import HBS2.Git3.State.Index
|
||||
import HBS2.Git3.State
|
||||
import HBS2.Git3.Git
|
||||
import HBS2.Git3.Git.Pack
|
||||
import HBS2.Git3.State.RefLog
|
||||
import HBS2.Git3.State.Segment
|
||||
|
||||
import HBS2.Storage.Operations.Missed
|
||||
import HBS2.CLI.Run.Internal.Merkle (getTreeContents)
|
||||
|
|
@ -111,6 +109,7 @@ importGitRefLog :: forall m . ( HBS2GitPerks m
|
|||
, HasStorage m
|
||||
, HasClientAPI PeerAPI UNIX m
|
||||
, HasClientAPI RefLogAPI UNIX m
|
||||
, HasGitRemoteKey m
|
||||
, MonadReader Git3Env m
|
||||
)
|
||||
=> m ()
|
||||
|
|
|
|||
|
|
@ -12,6 +12,8 @@ module HBS2.Git3.Prelude
|
|||
, module Codec.Serialise
|
||||
, runExceptT
|
||||
, pattern SignPubKeyLike
|
||||
, pattern GitHashLike
|
||||
, maxCLevel
|
||||
) where
|
||||
|
||||
import HBS2.Prelude.Plated as Exported
|
||||
|
|
@ -31,26 +33,26 @@ import HBS2.Peer.RPC.API.Storage as Exported
|
|||
import HBS2.Peer.RPC.Client hiding (encode,decode)
|
||||
import HBS2.Peer.RPC.Client.Unix hiding (encode,decode)
|
||||
import HBS2.Peer.RPC.Client.StorageClient
|
||||
import HBS2.Peer.CLI.Detect
|
||||
import HBS2.Data.Types.SignedBox as Exported
|
||||
import HBS2.Storage as Exported
|
||||
import HBS2.Storage.Operations.Class as Exported
|
||||
import HBS2.System.Logger.Simple.ANSI as Exported
|
||||
|
||||
import HBS2.Git3.Types as Exported
|
||||
import HBS2.Git3.State.Types as Exported
|
||||
-- import HBS2.Git3.State.Types as Exported
|
||||
|
||||
import HBS2.System.Dir
|
||||
|
||||
import Data.Config.Suckless.Syntax
|
||||
|
||||
import Codec.Compression.Zstd (maxCLevel)
|
||||
import Codec.Serialise
|
||||
import Control.Monad.Except (runExceptT)
|
||||
import Control.Monad.Reader as Exported
|
||||
import Control.Monad.Trans.Cont as Exported
|
||||
import Control.Monad.Trans.Maybe as Exported
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.Coerce as Exported
|
||||
import Data.HashSet (HashSet)
|
||||
import Data.HashSet qualified as HS
|
||||
import Data.HashPSQ qualified as HPSQ
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.HashMap.Strict qualified as HM
|
||||
|
|
@ -63,241 +65,6 @@ import System.FilePattern as Exported
|
|||
import GHC.Natural as Exported
|
||||
import UnliftIO as Exported
|
||||
|
||||
data RefLogNotSetException =
|
||||
RefLogNotSetException
|
||||
deriving stock (Show,Typeable)
|
||||
|
||||
instance Exception RefLogNotSetException
|
||||
|
||||
defSegmentSize :: Int
|
||||
defSegmentSize = 50 * 1024 * 1024
|
||||
|
||||
defCompressionLevel :: Int
|
||||
defCompressionLevel = maxCLevel
|
||||
|
||||
defIndexBlockSize :: Natural
|
||||
defIndexBlockSize = 32 * 1024 * 1024
|
||||
|
||||
type HBS2GitPerks m = (MonadUnliftIO m)
|
||||
|
||||
|
||||
quit :: MonadUnliftIO m => m ()
|
||||
quit = liftIO Q.exitSuccess
|
||||
|
||||
|
||||
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
|
||||
| Git3ReflogNotSet
|
||||
| Git3RpcTimeout
|
||||
deriving (Show,Typeable,Generic)
|
||||
|
||||
instance Exception Git3Exception
|
||||
|
||||
data Git3Env =
|
||||
Git3Disconnected
|
||||
{ gitRefLog :: TVar (Maybe GitRemoteKey)
|
||||
, gitPackedSegmentSize :: TVar Int
|
||||
, gitCompressionLevel :: TVar Int
|
||||
, gitIndexBlockSize :: TVar Natural
|
||||
}
|
||||
| Git3Connected
|
||||
{ peerSocket :: FilePath
|
||||
, peerStorage :: AnyStorage
|
||||
, peerAPI :: ServiceCaller PeerAPI UNIX
|
||||
, reflogAPI :: ServiceCaller RefLogAPI UNIX
|
||||
, lwwAPI :: ServiceCaller LWWRefAPI UNIX
|
||||
, gitRefLog :: TVar (Maybe GitRemoteKey)
|
||||
, gitRepoKey :: TVar (Maybe GitRepoKey)
|
||||
, gitPackedSegmentSize :: TVar Int
|
||||
, gitCompressionLevel :: TVar Int
|
||||
, gitIndexBlockSize :: TVar Natural
|
||||
}
|
||||
|
||||
class HasExportOpts m where
|
||||
setPackedSegmedSize :: Int -> m ()
|
||||
getPackedSegmetSize :: m Int
|
||||
getCompressionLevel :: m Int
|
||||
setCompressionLevel :: Int -> m ()
|
||||
|
||||
class HasGitRemoteKey m where
|
||||
getGitRemoteKey :: m (Maybe GitRemoteKey)
|
||||
setGitRemoteKey :: GitRemoteKey -> m ()
|
||||
getGitRepoKey :: m (Maybe GitRepoKey)
|
||||
setGitRepoKey :: GitRepoKey -> 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)
|
||||
|
||||
getGitRepoKey = do
|
||||
e <- ask
|
||||
liftIO $ readTVarIO (gitRepoKey e)
|
||||
|
||||
setGitRepoKey k = do
|
||||
e <- ask
|
||||
liftIO $ atomically $ writeTVar (gitRepoKey e) (Just k)
|
||||
|
||||
instance (MonadIO m, MonadReader Git3Env m) => HasExportOpts m where
|
||||
getPackedSegmetSize = asks gitPackedSegmentSize >>= readTVarIO
|
||||
setPackedSegmedSize x = do
|
||||
e <- asks gitPackedSegmentSize
|
||||
atomically $ writeTVar e x
|
||||
|
||||
getCompressionLevel = asks gitCompressionLevel >>= readTVarIO
|
||||
setCompressionLevel x = do
|
||||
e <- asks gitCompressionLevel
|
||||
atomically $ writeTVar e (min maxCLevel x)
|
||||
|
||||
instance (MonadIO m, MonadReader Git3Env m) => HasStorage m where
|
||||
getStorage = do
|
||||
e <- ask
|
||||
case e of
|
||||
Git3Disconnected{} -> throwIO Git3PeerNotConnected
|
||||
Git3Connected{..} -> pure peerStorage
|
||||
|
||||
class MonadIO m => HasIndexOptions m where
|
||||
getIndexBlockSize :: m Natural
|
||||
setIndexBlockSize :: Natural -> m ()
|
||||
|
||||
instance (MonadIO m, MonadReader Git3Env m) => HasIndexOptions m where
|
||||
getIndexBlockSize = asks gitIndexBlockSize >>= readTVarIO
|
||||
|
||||
setIndexBlockSize n = do
|
||||
e <- asks gitIndexBlockSize
|
||||
atomically $ writeTVar e n
|
||||
|
||||
newtype Git3 (m :: Type -> Type) a = Git3M { fromGit3 :: ReaderT Git3Env m a }
|
||||
deriving newtype ( Applicative
|
||||
, Functor
|
||||
, Monad
|
||||
, MonadIO
|
||||
, MonadUnliftIO
|
||||
, MonadReader Git3Env
|
||||
, MonadTrans
|
||||
)
|
||||
|
||||
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 RefLogAPI UNIX (Git3 m) where
|
||||
getClientAPI = do
|
||||
ask >>= \case
|
||||
Git3Disconnected{} -> throwIO Git3PeerNotConnected
|
||||
Git3Connected{..} -> pure reflogAPI
|
||||
|
||||
|
||||
instance (MonadUnliftIO m) => HasClientAPI LWWRefAPI UNIX (Git3 m) where
|
||||
getClientAPI = do
|
||||
ask >>= \case
|
||||
Git3Disconnected{} -> throwIO Git3PeerNotConnected
|
||||
Git3Connected{..} -> pure lwwAPI
|
||||
|
||||
nullGit3Env :: MonadIO m => m Git3Env
|
||||
nullGit3Env = Git3Disconnected
|
||||
<$> newTVarIO Nothing
|
||||
<*> newTVarIO defSegmentSize
|
||||
<*> newTVarIO defCompressionLevel
|
||||
<*> newTVarIO defIndexBlockSize
|
||||
|
||||
connectedDo :: (MonadIO m) => Git3 m a -> Git3 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
|
||||
|
||||
|
||||
getStatePathM :: forall m . (HBS2GitPerks m, HasGitRemoteKey m) => m FilePath
|
||||
getStatePathM = do
|
||||
k <- getGitRemoteKey >>= orThrow RefLogNotSetException
|
||||
getStatePath (AsBase58 k)
|
||||
|
||||
|
||||
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"
|
||||
|
||||
state <- getStatePath (AsBase58 ref)
|
||||
|
||||
mkdir state
|
||||
|
||||
let sto = AnyStorage (StorageClient storageAPI)
|
||||
|
||||
connected <- Git3Connected soname sto peerAPI refLogAPI lwwAPI
|
||||
<$> newTVarIO (Just ref)
|
||||
<*> newTVarIO Nothing
|
||||
<*> newTVarIO defSegmentSize
|
||||
<*> newTVarIO defCompressionLevel
|
||||
<*> newTVarIO defIndexBlockSize
|
||||
|
||||
liftIO $ withGit3Env connected again
|
||||
|
||||
e -> throwIO e
|
||||
|
||||
|
||||
class Cached cache k v | cache -> k, cache -> v where
|
||||
|
|
@ -354,3 +121,15 @@ instance (Ord k, Hashable k) => Cached (CacheFixedHPSQ k v) k v where
|
|||
|
||||
pure v
|
||||
|
||||
quit :: MonadUnliftIO m => m ()
|
||||
quit = liftIO Q.exitSuccess
|
||||
|
||||
|
||||
pattern GitHashLike:: forall {c} . GitHash -> Syntax c
|
||||
pattern GitHashLike x <- (
|
||||
\case
|
||||
StringLike s -> fromStringMay @GitHash s
|
||||
LitIntVal 0 -> Just $ GitHash (BS.replicate 20 0)
|
||||
_ -> Nothing
|
||||
-> Just x )
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
module HBS2.Git3.Run where
|
||||
|
||||
import HBS2.Git3.Prelude
|
||||
import HBS2.Git3.State.Index
|
||||
import HBS2.Git3.Git.Pack
|
||||
|
||||
import HBS2.Peer.CLI.Detect
|
||||
|
|
@ -23,7 +22,7 @@ import HBS2.Git3.Config.Local
|
|||
import HBS2.Git3.Git
|
||||
import HBS2.Git3.Export
|
||||
import HBS2.Git3.Import
|
||||
import HBS2.Git3.State.RefLog
|
||||
import HBS2.Git3.State
|
||||
import HBS2.Git3.Repo qualified as Repo
|
||||
|
||||
import Data.Config.Suckless.Script
|
||||
|
|
@ -144,13 +143,6 @@ theDict = do
|
|||
<+> 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] "
|
||||
|
||||
|
|
@ -569,7 +561,6 @@ theDict = do
|
|||
rrefs <- importedRefs
|
||||
liftIO $ print $ pretty rrefs
|
||||
|
||||
|
||||
entry $ bindMatch "reflog:imported" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
p <- importedCheckpoint
|
||||
liftIO $ print $ pretty p
|
||||
|
|
@ -577,13 +568,32 @@ theDict = do
|
|||
entry $ bindMatch "reflog:import" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
importGitRefLog
|
||||
|
||||
entry $ bindMatch "repo:manifest:show" $ nil_ $ const $ lift $ connectedDo do
|
||||
manifest <- Repo.getRepoManifest
|
||||
liftIO $ print $ pretty $ mkForm "manifest" manifest
|
||||
|
||||
entry $ bindMatch "repo:reflog:show" $ nil_ $ const $ lift $ connectedDo do
|
||||
repo <- Repo.getRepoManifest
|
||||
|
||||
reflog <- [ x | x@(ListVal [SymbolVal "reflog", SignPubKeyLike _]) <- repo ]
|
||||
& headMay & orThrow GitRepoManifestMalformed
|
||||
|
||||
liftIO $ print $ pretty reflog
|
||||
|
||||
entry $ bindMatch "repo:key:show" $ nil_ $ const $ lift do
|
||||
r <- getGitRepoKey >>= orThrow GitRepoRefNotSet
|
||||
liftIO $ print $ pretty (AsBase58 r)
|
||||
|
||||
entry $ bindMatch "repo:key" $ nil_ $ \case
|
||||
[ SignPubKeyLike k ] -> lift $ connectedDo do
|
||||
[ SignPubKeyLike k ] -> lift do
|
||||
setGitRepoKey k
|
||||
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
|
||||
entry $ bindMatch "repo:ref:value"$ nil_ $ const $ lift $ connectedDo do
|
||||
val <- Repo.getRepoRefMaybe >>= orThrowUser "can't read ref value"
|
||||
liftIO $ print $ pretty val
|
||||
|
||||
entry $ bindMatch "repo:init" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
Repo.initRepo syn
|
||||
-- conf <- getConfigRootFile
|
||||
|
|
|
|||
|
|
@ -0,0 +1,27 @@
|
|||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# Language UndecidableInstances #-}
|
||||
{-# Language AllowAmbiguousTypes #-}
|
||||
module HBS2.Git3.State
|
||||
( module HBS2.Git3.State
|
||||
, module Exported
|
||||
) where
|
||||
|
||||
import HBS2.Git3.Prelude
|
||||
|
||||
import HBS2.Git3.State.Internal.Types as Exported
|
||||
import HBS2.Git3.State.Internal.LWWBlock as Exported
|
||||
import HBS2.Git3.State.Internal.RefLog as Exported
|
||||
import HBS2.Git3.State.Internal.Segment as Exported
|
||||
import HBS2.Git3.State.Internal.Index as Exported
|
||||
|
||||
import HBS2.Peer.RPC.API.Storage
|
||||
import HBS2.Peer.RPC.Client.StorageClient
|
||||
import HBS2.System.Dir
|
||||
import HBS2.Peer.CLI.Detect
|
||||
|
||||
import Data.HashSet (HashSet)
|
||||
import Data.HashSet qualified as HS
|
||||
import Data.Kind
|
||||
|
||||
import Codec.Compression.Zstd (maxCLevel)
|
||||
|
||||
|
|
@ -1,11 +1,12 @@
|
|||
module HBS2.Git3.State.Index where
|
||||
module HBS2.Git3.State.Internal.Index where
|
||||
|
||||
import HBS2.Git3.Prelude
|
||||
import HBS2.System.Dir
|
||||
import HBS2.CLI.Run.Internal.Merkle (getTreeContents)
|
||||
import HBS2.Git3.State.Types
|
||||
import HBS2.Git3.State.Segment
|
||||
import HBS2.Git3.State.RefLog
|
||||
|
||||
import HBS2.Git3.State.Internal.Types
|
||||
import HBS2.Git3.State.Internal.Segment
|
||||
import HBS2.Git3.State.Internal.RefLog
|
||||
import HBS2.Git3.Git
|
||||
|
||||
import HBS2.Data.Log.Structured
|
||||
|
|
@ -66,6 +67,7 @@ readLogFileLBS _ action = flip fix 0 \go n -> do
|
|||
|
||||
indexPath :: forall m . ( Git3Perks m
|
||||
, MonadReader Git3Env m
|
||||
, HasGitRemoteKey m
|
||||
) => m FilePath
|
||||
indexPath = do
|
||||
reflog <- getGitRemoteKey >>= orThrow Git3ReflogNotSet
|
||||
|
|
@ -121,7 +123,7 @@ mergeSortedFilesN getKey inputFiles outFile = do
|
|||
mkState [] = Nothing
|
||||
mkState (x:xs) = Just (Entry (getKey x) (x:xs))
|
||||
|
||||
compactIndex :: forall m . (Git3Perks m, MonadReader Git3Env m) => Natural -> m ()
|
||||
compactIndex :: forall m . (Git3Perks m, HasGitRemoteKey m, MonadReader Git3Env m) => Natural -> m ()
|
||||
compactIndex maxSize = do
|
||||
reflog <- getGitRemoteKey >>= orThrowUser "reflog not set"
|
||||
idxPath <- getStatePath (AsBase58 reflog)
|
||||
|
|
@ -139,7 +141,7 @@ compactIndex maxSize = do
|
|||
out <- liftIO $ emptyTempFile idxPath "objects-.idx"
|
||||
mergeSortedFilesN (BS.take 20) (map fst block) out
|
||||
|
||||
openIndex :: forall a m . (Git3Perks m, MonadReader Git3Env m)
|
||||
openIndex :: forall a m . (Git3Perks m, HasGitRemoteKey m, MonadReader Git3Env m)
|
||||
=> m (Index a)
|
||||
|
||||
openIndex = do
|
||||
|
|
@ -207,6 +209,7 @@ indexFilterNewObjectsMem idx@Index{..} hashes = do
|
|||
|
||||
listObjectIndexFiles :: forall m . ( Git3Perks m
|
||||
, MonadReader Git3Env m
|
||||
, HasGitRemoteKey m
|
||||
) => m [(FilePath, Natural)]
|
||||
|
||||
listObjectIndexFiles = do
|
||||
|
|
@ -273,6 +276,7 @@ updateReflogIndex :: forall m . ( Git3Perks m
|
|||
, HasClientAPI PeerAPI UNIX m
|
||||
, HasClientAPI RefLogAPI UNIX m
|
||||
, HasStorage m
|
||||
, HasGitRemoteKey m
|
||||
, HasIndexOptions m
|
||||
) => m ()
|
||||
updateReflogIndex = do
|
||||
|
|
@ -386,6 +390,7 @@ importedCheckpoint :: forall m . ( Git3Perks m
|
|||
, MonadReader Git3Env m
|
||||
, HasClientAPI RefLogAPI UNIX m
|
||||
, HasStorage m
|
||||
, HasGitRemoteKey m
|
||||
) => m (Maybe HashRef)
|
||||
|
||||
importedCheckpoint = do
|
||||
|
|
@ -406,6 +411,7 @@ importedRefs :: forall m . ( Git3Perks m
|
|||
, MonadReader Git3Env m
|
||||
, HasClientAPI RefLogAPI UNIX m
|
||||
, HasStorage m
|
||||
, HasGitRemoteKey m
|
||||
) => m [(GitRef, GitHash)]
|
||||
|
||||
importedRefs = do
|
||||
|
|
@ -441,6 +447,7 @@ updateImportedCheckpoint :: forall m . ( Git3Perks m
|
|||
, MonadReader Git3Env m
|
||||
, HasClientAPI RefLogAPI UNIX m
|
||||
, HasStorage m
|
||||
, HasGitRemoteKey m
|
||||
) => HashRef -> m ()
|
||||
|
||||
updateImportedCheckpoint cp = do
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
module HBS2.Git3.State.Internal.LWWBlock where
|
||||
|
||||
import HBS2.Git3.Prelude
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,7 +1,9 @@
|
|||
module HBS2.Git3.State.RefLog where
|
||||
module HBS2.Git3.State.Internal.RefLog where
|
||||
|
||||
import HBS2.Git3.Prelude
|
||||
|
||||
import HBS2.Git3.State.Internal.Types
|
||||
|
||||
import Control.Applicative
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.Maybe
|
||||
|
|
@ -55,10 +57,10 @@ refLogRef :: forall m . ( HBS2GitPerks m
|
|||
|
||||
refLogRef = do
|
||||
refLogAPI <- getClientAPI @RefLogAPI @UNIX
|
||||
reflog <- getGitRemoteKey >>= orThrow RefLogNotSetException
|
||||
reflog <- getGitRemoteKey >>= orThrow RefLogNotSet
|
||||
|
||||
callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) refLogAPI reflog
|
||||
>>= orThrow RefLogNotSetException
|
||||
>>= orThrow RefLogNotSet
|
||||
|
||||
txList :: forall m . ( HBS2GitPerks m
|
||||
, HasStorage m
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
module HBS2.Git3.State.Segment where
|
||||
module HBS2.Git3.State.Internal.Segment where
|
||||
|
||||
import HBS2.Git3.Prelude
|
||||
import Data.ByteString.Lazy ( ByteString )
|
||||
|
|
@ -0,0 +1,328 @@
|
|||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# Language UndecidableInstances #-}
|
||||
module HBS2.Git3.State.Internal.Types
|
||||
( module HBS2.Git3.State.Internal.Types
|
||||
, pattern SignPubKeyLike
|
||||
) where
|
||||
|
||||
|
||||
import HBS2.Git3.Prelude
|
||||
import HBS2.Git3.Config.Local
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.System.Dir
|
||||
import HBS2.Data.Detect (readLogThrow)
|
||||
import HBS2.CLI.Run.MetaData (getTreeContents)
|
||||
|
||||
import Data.Config.Suckless
|
||||
|
||||
import HBS2.Defaults as Exported
|
||||
import HBS2.OrDie as Exported
|
||||
import HBS2.Data.Types.Refs as Exported
|
||||
import HBS2.Base58 as Exported
|
||||
import HBS2.Merkle as Exported
|
||||
import HBS2.Misc.PrettyStuff as Exported
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.Peer.Proto.LWWRef as Exported
|
||||
import HBS2.Peer.Proto.RefLog as Exported
|
||||
import HBS2.Peer.RPC.API.RefLog as Exported
|
||||
import HBS2.Peer.RPC.API.Peer as Exported
|
||||
import HBS2.Peer.RPC.API.LWWRef as Exported
|
||||
import HBS2.Peer.RPC.API.Storage as Exported
|
||||
import HBS2.Peer.RPC.Client hiding (encode,decode)
|
||||
import HBS2.Peer.RPC.Client.Unix hiding (encode,decode)
|
||||
import HBS2.Peer.RPC.Client.StorageClient
|
||||
import HBS2.Peer.CLI.Detect (detectRPC)
|
||||
import HBS2.Data.Types.SignedBox as Exported
|
||||
import HBS2.Storage as Exported
|
||||
import HBS2.Storage.Operations.Class as Exported
|
||||
import HBS2.System.Logger.Simple.ANSI as Exported
|
||||
|
||||
import Data.Text.Encoding qualified as TE
|
||||
import Data.Text.Encoding.Error qualified as TE
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
|
||||
import Data.Kind
|
||||
import Data.HashSet (HashSet)
|
||||
import Data.HashSet qualified as HS
|
||||
|
||||
import System.FilePath
|
||||
|
||||
unit :: FilePath
|
||||
unit = "hbs2-git"
|
||||
|
||||
getStatePath :: (MonadIO m, Pretty ref) => ref -> m FilePath
|
||||
getStatePath p = do
|
||||
d <- getConfigPath
|
||||
pure $ d </> show (pretty p)
|
||||
|
||||
data HBS2GitExcepion =
|
||||
RefLogNotSet
|
||||
| GitRepoRefNotSet
|
||||
| GitRepoRefEmpty
|
||||
| GitRepoManifestMalformed
|
||||
| RpcTimeout
|
||||
deriving stock (Show,Typeable)
|
||||
|
||||
instance Exception HBS2GitExcepion
|
||||
|
||||
defSegmentSize :: Int
|
||||
defSegmentSize = 50 * 1024 * 1024
|
||||
|
||||
defCompressionLevel :: Int
|
||||
defCompressionLevel = maxCLevel
|
||||
|
||||
defIndexBlockSize :: Natural
|
||||
defIndexBlockSize = 32 * 1024 * 1024
|
||||
|
||||
type HBS2GitPerks m = (MonadUnliftIO m)
|
||||
|
||||
|
||||
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
|
||||
| Git3ReflogNotSet
|
||||
| Git3RpcTimeout
|
||||
deriving (Show,Typeable,Generic)
|
||||
|
||||
instance Exception Git3Exception
|
||||
|
||||
data Git3Env =
|
||||
Git3Disconnected
|
||||
{ gitPackedSegmentSize :: TVar Int
|
||||
, gitCompressionLevel :: TVar Int
|
||||
, gitIndexBlockSize :: TVar Natural
|
||||
, gitRepoKey :: TVar (Maybe GitRepoKey)
|
||||
}
|
||||
| Git3Connected
|
||||
{ peerSocket :: FilePath
|
||||
, peerStorage :: AnyStorage
|
||||
, peerAPI :: ServiceCaller PeerAPI UNIX
|
||||
, reflogAPI :: ServiceCaller RefLogAPI UNIX
|
||||
, lwwAPI :: ServiceCaller LWWRefAPI UNIX
|
||||
, gitRepoKey :: TVar (Maybe GitRepoKey)
|
||||
, gitRefLog :: TVar (Maybe GitRemoteKey)
|
||||
, gitPackedSegmentSize :: TVar Int
|
||||
, gitCompressionLevel :: TVar Int
|
||||
, gitIndexBlockSize :: TVar Natural
|
||||
}
|
||||
|
||||
class HasExportOpts m where
|
||||
setPackedSegmedSize :: Int -> m ()
|
||||
getPackedSegmetSize :: m Int
|
||||
getCompressionLevel :: m Int
|
||||
setCompressionLevel :: Int -> m ()
|
||||
|
||||
|
||||
instance (MonadIO m, MonadReader Git3Env m) => HasExportOpts m where
|
||||
getPackedSegmetSize = asks gitPackedSegmentSize >>= readTVarIO
|
||||
setPackedSegmedSize x = do
|
||||
e <- asks gitPackedSegmentSize
|
||||
atomically $ writeTVar e x
|
||||
|
||||
getCompressionLevel = asks gitCompressionLevel >>= readTVarIO
|
||||
setCompressionLevel x = do
|
||||
e <- asks gitCompressionLevel
|
||||
atomically $ writeTVar e (min maxCLevel x)
|
||||
|
||||
instance (MonadIO m, MonadReader Git3Env m) => HasStorage m where
|
||||
getStorage = do
|
||||
e <- ask
|
||||
case e of
|
||||
Git3Disconnected{} -> throwIO Git3PeerNotConnected
|
||||
Git3Connected{..} -> pure peerStorage
|
||||
|
||||
class MonadIO m => HasIndexOptions m where
|
||||
getIndexBlockSize :: m Natural
|
||||
setIndexBlockSize :: Natural -> m ()
|
||||
|
||||
instance (MonadIO m, MonadReader Git3Env m) => HasIndexOptions m where
|
||||
getIndexBlockSize = asks gitIndexBlockSize >>= readTVarIO
|
||||
|
||||
setIndexBlockSize n = do
|
||||
e <- asks gitIndexBlockSize
|
||||
atomically $ writeTVar e n
|
||||
|
||||
class HasGitRemoteKey m where
|
||||
getGitRemoteKey :: m (Maybe GitRemoteKey)
|
||||
getGitRepoKey :: m (Maybe GitRepoKey)
|
||||
setGitRepoKey :: GitRepoKey -> m ()
|
||||
|
||||
instance (MonadIO m) => HasGitRemoteKey (Git3 m) where
|
||||
getGitRemoteKey =
|
||||
ask >>= \case
|
||||
Git3Connected{..} -> readTVarIO gitRefLog
|
||||
_ -> pure Nothing
|
||||
|
||||
getGitRepoKey = do
|
||||
e <- ask
|
||||
liftIO $ readTVarIO (gitRepoKey e)
|
||||
|
||||
setGitRepoKey k = do
|
||||
e <- ask
|
||||
liftIO $ atomically $ writeTVar (gitRepoKey e) (Just k)
|
||||
|
||||
getStatePathM :: forall m . (HBS2GitPerks m, HasGitRemoteKey m) => m FilePath
|
||||
getStatePathM = do
|
||||
k <- getGitRemoteKey >>= orThrow RefLogNotSet
|
||||
getStatePath (AsBase58 k)
|
||||
|
||||
getRepoRefMaybe :: forall m . HBS2GitPerks m => Git3 m (Maybe (LWWRef 'HBS2Basic))
|
||||
getRepoRefMaybe = do
|
||||
lwwAPI <- getClientAPI @LWWRefAPI @UNIX
|
||||
|
||||
pk <- getGitRepoKey >>= orThrow GitRepoRefNotSet
|
||||
|
||||
callRpcWaitMay @RpcLWWRefGet (TimeoutSec 1) lwwAPI (LWWRefKey pk)
|
||||
>>= orThrow RpcTimeout
|
||||
|
||||
getRepoManifest :: forall m . HBS2GitPerks m => Git3 m [Syntax C]
|
||||
getRepoManifest = do
|
||||
|
||||
sto <- getStorage
|
||||
|
||||
LWWRef{..} <- getRepoRefMaybe >>= orThrow GitRepoRefEmpty
|
||||
|
||||
mfref <- readLogThrow (getBlock sto) lwwValue
|
||||
<&> headMay
|
||||
>>= orThrow GitRepoManifestMalformed
|
||||
|
||||
runExceptT (getTreeContents sto mfref)
|
||||
>>= orThrowPassIO
|
||||
<&> TE.decodeUtf8With TE.lenientDecode . LBS.toStrict
|
||||
<&> parseTop
|
||||
>>= orThrow GitRepoManifestMalformed
|
||||
|
||||
newtype Git3 (m :: Type -> Type) a = Git3M { fromGit3 :: ReaderT Git3Env m a }
|
||||
deriving newtype ( Applicative
|
||||
, Functor
|
||||
, Monad
|
||||
, MonadIO
|
||||
, MonadUnliftIO
|
||||
, MonadReader Git3Env
|
||||
, MonadTrans
|
||||
)
|
||||
|
||||
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 RefLogAPI UNIX (Git3 m) where
|
||||
getClientAPI = do
|
||||
ask >>= \case
|
||||
Git3Disconnected{} -> throwIO Git3PeerNotConnected
|
||||
Git3Connected{..} -> pure reflogAPI
|
||||
|
||||
|
||||
instance (MonadUnliftIO m) => HasClientAPI LWWRefAPI UNIX (Git3 m) where
|
||||
getClientAPI = do
|
||||
ask >>= \case
|
||||
Git3Disconnected{} -> throwIO Git3PeerNotConnected
|
||||
Git3Connected{..} -> pure lwwAPI
|
||||
|
||||
nullGit3Env :: MonadIO m => m Git3Env
|
||||
nullGit3Env = Git3Disconnected
|
||||
<$> newTVarIO defSegmentSize
|
||||
<*> newTVarIO defCompressionLevel
|
||||
<*> newTVarIO defIndexBlockSize
|
||||
<*> newTVarIO Nothing
|
||||
|
||||
connectedDo :: (MonadIO m) => Git3 m a -> Git3 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
|
||||
|
||||
peer <- 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 peer
|
||||
, Endpoint @UNIX refLogAPI
|
||||
, Endpoint @UNIX lwwAPI
|
||||
, Endpoint @UNIX storageAPI
|
||||
]
|
||||
|
||||
void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client
|
||||
|
||||
let sto = AnyStorage (StorageClient storageAPI)
|
||||
|
||||
rk <- lift getGitRepoKey
|
||||
|
||||
connected <- Git3Connected soname sto peer refLogAPI lwwAPI
|
||||
<$> newTVarIO rk
|
||||
<*> newTVarIO Nothing
|
||||
<*> newTVarIO defSegmentSize
|
||||
<*> newTVarIO defCompressionLevel
|
||||
<*> newTVarIO defIndexBlockSize
|
||||
|
||||
liftIO $ withGit3Env connected do
|
||||
|
||||
mf <- getRepoManifest
|
||||
|
||||
let reflog = lastMay [ x
|
||||
| ListVal [SymbolVal "reflog", SignPubKeyLike x] <- mf
|
||||
]
|
||||
|
||||
ask >>= \case
|
||||
Git3Connected{..} -> atomically $ writeTVar gitRefLog reflog
|
||||
_ -> none
|
||||
|
||||
ref <- getGitRemoteKey >>= orThrow GitRepoManifestMalformed
|
||||
|
||||
state <- getStatePath (AsBase58 ref)
|
||||
mkdir state
|
||||
|
||||
again
|
||||
|
||||
e -> throwIO e
|
||||
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
module HBS2.Git3.State.LWWBlock where
|
||||
|
||||
import HBS2.Git3.Prelude
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,29 +0,0 @@
|
|||
module HBS2.Git3.State.Types
|
||||
( module HBS2.Git3.State.Types
|
||||
, pattern SignPubKeyLike
|
||||
) where
|
||||
|
||||
|
||||
import HBS2.Prelude.Plated
|
||||
import HBS2.Git3.Config.Local
|
||||
import HBS2.Net.Auth.Credentials
|
||||
|
||||
import DBPipe.SQLite
|
||||
|
||||
import System.FilePath
|
||||
|
||||
type DBRef w = ( Pretty w )
|
||||
|
||||
class MonadIO m => HasStateDB m where
|
||||
getStateDB :: m DBPipeEnv
|
||||
|
||||
|
||||
unit :: FilePath
|
||||
unit = "hbs2-git"
|
||||
|
||||
getStatePath :: (MonadIO m, DBRef db) => db -> m FilePath
|
||||
getStatePath p = do
|
||||
d <- getConfigPath
|
||||
pure $ d </> show (pretty p)
|
||||
|
||||
|
||||
Loading…
Reference in New Issue