diff --git a/hbs2-git3/app/Main.hs b/hbs2-git3/app/Main.hs index c4b4b65c..0cd2982a 100644 --- a/hbs2-git3/app/Main.hs +++ b/hbs2-git3/app/Main.hs @@ -9,23 +9,9 @@ {-# Language OverloadedLabels #-} module Main where -import HBS2.Prelude.Plated -import HBS2.OrDie -import HBS2.Base58 -import HBS2.Merkle -import HBS2.Data.Detect hiding (Blob) -import HBS2.Data.Detect qualified as Detect +import HBS2.Git3.Prelude -import HBS2.Storage -import HBS2.Storage.Operations.Class -import HBS2.Storage.Operations.ByteString -import HBS2.Peer.Proto.RefLog 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 @@ -39,9 +25,7 @@ import HBS2.Data.Log.Structured import HBS2.CLI.Run.Internal.Merkle (createTreeWithMetadata) import HBS2.CLI.Run.RefLog (getCredentialsForReflog,mkRefLogUpdateFrom) -import HBS2.System.Logger.Simple.ANSI as Exported import HBS2.System.Dir -import HBS2.Misc.PrettyStuff as Exported import HBS2.Git3.Types import HBS2.Git3.State.Direct @@ -51,17 +35,14 @@ import HBS2.Git3.Git import Data.Config.Suckless.Script import DBPipe.SQLite -import Codec.Compression.Zstd qualified as Zstd import Codec.Compression.Zstd.Streaming qualified as ZstdS import Codec.Compression.Zstd.Streaming (Result(..)) -import Codec.Compression.Zstd (maxCLevel) import Codec.Compression.Zstd.Lazy qualified as ZstdL import Codec.Compression.Zlib qualified as Zlib import Data.HashPSQ qualified as HPSQ import Data.HashPSQ (HashPSQ) -import qualified Data.OrdPSQ as PSQ import Data.Maybe import Data.List qualified as L @@ -70,7 +51,6 @@ import Data.List.Split (chunksOf) 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 Network.ByteOrder qualified as N @@ -91,20 +71,13 @@ import Data.Heap (Entry(..)) import Data.Heap qualified as Heap import Streaming.Prelude qualified as S -import Streaming hiding (run,chunksOf) 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.State qualified as State -import Control.Monad.Reader -import Control.Monad.Except import Control.Monad.Trans.Writer.CPS qualified as Writer import Control.Concurrent.STM qualified as STM -import Codec.Serialise import System.Directory (setCurrentDirectory) import System.Random hiding (next) import System.IO.MMap (mmapFileByteString) @@ -112,13 +85,9 @@ import System.IO qualified as IO import System.IO (hPrint) import System.IO.Temp as Temp -import Data.Either -import Data.Coerce -import Data.Kind import Data.Vector qualified as Vector import Data.Vector.Algorithms.Search qualified as MV -import UnliftIO import UnliftIO.Concurrent import UnliftIO.IO.File qualified as UIO @@ -126,144 +95,12 @@ import UnliftIO.IO.File qualified as UIO {- HLINT ignore "Eta reduce" -} -defSegmentSize :: Int -defSegmentSize = 50 * 1024 * 1024 - -defCompressionLevel :: Int -defCompressionLevel = maxCLevel - -type HBS2GitPerks m = (MonadUnliftIO m) - -quit :: MonadUnliftIO m => m () -quit = liftIO Q.exitSuccess - class Cached cache k v | cache -> k, cache -> v where isCached :: forall m . MonadIO m => cache -> k -> m Bool cached :: forall m . MonadIO m => cache -> k -> m v -> m v uncache :: forall m . MonadIO m => cache -> k -> 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 - deriving (Show,Typeable,Generic) - -instance Exception Git3Exception - -data Git3Env = - Git3Disconnected - { gitRefLog :: TVar (Maybe GitRemoteKey) - , gitPackedSegmentSize :: TVar Int - , gitCompressionLevel :: TVar Int - } - | Git3Connected - { stateDb :: DBPipeEnv - , peerSocket :: FilePath - , peerStorage :: AnyStorage - , peerAPI :: ServiceCaller PeerAPI UNIX - , reflogAPI :: ServiceCaller RefLogAPI UNIX - , gitRefLog :: TVar (Maybe GitRemoteKey) - , gitPackedSegmentSize :: TVar Int - , gitCompressionLevel :: TVar Int - } - -class HasGitRemoteKey m where - getGitRemoteKey :: m (Maybe GitRemoteKey) - setGitRemoteKey :: GitRemoteKey -> 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) - -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) => HasStateDB (Git3 m) where - getStateDB = asks stateDb - -instance (MonadIO m, MonadReader Git3Env m) => HasStorage m where - getStorage = do - e <- ask - case e of - Git3Disconnected{} -> throwIO Git3PeerNotConnected - Git3Connected{..} -> pure peerStorage - -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 - -nullGit3Env :: MonadIO m => m Git3Env -nullGit3Env = Git3Disconnected - <$> newTVarIO Nothing - <*> newTVarIO defSegmentSize - <*> newTVarIO defCompressionLevel - -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 @@ -296,19 +133,14 @@ recover m = fix \again -> do ref <- getGitRemoteKey >>= orThrowUser "remote ref not set" - dbPath <- getStatePathDB (AsBase58 ref) - - touch dbPath - db <- newDBPipeEnv dbPipeOptsDef dbPath - let sto = AnyStorage (StorageClient storageAPI) - connected <- Git3Connected db soname sto peerAPI refLogAPI + connected <- Git3Connected soname sto peerAPI refLogAPI <$> newTVarIO (Just ref) <*> newTVarIO defSegmentSize <*> newTVarIO defCompressionLevel - liftIO $ withGit3Env connected (evolveState >> again) + liftIO $ withGit3Env connected again --- @@ -431,7 +263,6 @@ readCommitChainHPSQ :: ( HBS2GitPerks m , MonadUnliftIO m , MonadReader Git3Env m , HasStorage m - , HasStateDB m ) => (GitHash -> m Bool) -> Maybe GitRef @@ -549,12 +380,6 @@ data ECC = | ECCWrite Int FilePath Handle Result | ECCFinalize Bool FilePath Handle Result -class HasExportOpts m where - setPackedSegmedSize :: Int -> m () - getPackedSegmetSize :: m Int - getCompressionLevel :: m Int - setCompressionLevel :: Int -> m () - mergeSortedFiles :: forall m . MonadUnliftIO m diff --git a/hbs2-git3/hbs2-git3.cabal b/hbs2-git3/hbs2-git3.cabal index 59101ba5..306799d6 100644 --- a/hbs2-git3/hbs2-git3.cabal +++ b/hbs2-git3/hbs2-git3.cabal @@ -120,8 +120,10 @@ library exposed-modules: HBS2.Git3.Types + HBS2.Git3.Prelude HBS2.Git3.State.Types HBS2.Git3.State.Direct + HBS2.Git3.State.Index HBS2.Git3.Config.Local HBS2.Git3.Git diff --git a/hbs2-git3/lib/HBS2/Git3/Prelude.hs b/hbs2-git3/lib/HBS2/Git3/Prelude.hs new file mode 100644 index 00000000..21a4c5b3 --- /dev/null +++ b/hbs2-git3/lib/HBS2/Git3/Prelude.hs @@ -0,0 +1,186 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# Language RecordWildCards #-} +{-# Language UndecidableInstances #-} +{-# Language AllowAmbiguousTypes #-} +module HBS2.Git3.Prelude + ( module HBS2.Git3.Prelude + , module Exported + , module HBS2.Peer.RPC.Client + , module HBS2.Peer.RPC.Client.Unix + , module Codec.Serialise + , runExceptT + ) where + +import HBS2.Prelude.Plated 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.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.Client hiding (encode,decode) +import HBS2.Peer.RPC.Client.Unix hiding (encode,decode) +import HBS2.Storage as Exported +import HBS2.Storage.Operations.Class as Exported +import HBS2.System.Logger.Simple.ANSI as Exported + +import HBS2.Git3.Types + +-- TODO: about-to-remove +import DBPipe.SQLite + +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.Coerce as Exported +import Data.HashSet (HashSet(..)) +import Data.HashSet qualified as HS +import Data.Kind +import System.Exit qualified as Q + +import UnliftIO as Exported + + +defSegmentSize :: Int +defSegmentSize = 50 * 1024 * 1024 + +defCompressionLevel :: Int +defCompressionLevel = maxCLevel + +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 + deriving (Show,Typeable,Generic) + +instance Exception Git3Exception + +data Git3Env = + Git3Disconnected + { gitRefLog :: TVar (Maybe GitRemoteKey) + , gitPackedSegmentSize :: TVar Int + , gitCompressionLevel :: TVar Int + } + | Git3Connected + { peerSocket :: FilePath + , peerStorage :: AnyStorage + , peerAPI :: ServiceCaller PeerAPI UNIX + , reflogAPI :: ServiceCaller RefLogAPI UNIX + , gitRefLog :: TVar (Maybe GitRemoteKey) + , gitPackedSegmentSize :: TVar Int + , gitCompressionLevel :: TVar Int + } + +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 () + +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) + +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 + +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 + +nullGit3Env :: MonadIO m => m Git3Env +nullGit3Env = Git3Disconnected + <$> newTVarIO Nothing + <*> newTVarIO defSegmentSize + <*> newTVarIO defCompressionLevel + +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 + + diff --git a/hbs2-git3/lib/HBS2/Git3/State/Direct.hs b/hbs2-git3/lib/HBS2/Git3/State/Direct.hs index 43c73f27..46b6e570 100644 --- a/hbs2-git3/lib/HBS2/Git3/State/Direct.hs +++ b/hbs2-git3/lib/HBS2/Git3/State/Direct.hs @@ -25,13 +25,6 @@ import Data.List qualified as List import Text.InterpolatedString.Perl6 (qc) -unit :: FilePath -unit = "hbs2-git" - -getStatePath :: (MonadIO m, DBRef db) => db -> m FilePath -getStatePath p = do - d <- getConfigPath - pure $ d show (pretty p) getStatePathDB :: (MonadIO m, DBRef db) => db -> m FilePath getStatePathDB p = do diff --git a/hbs2-git3/lib/HBS2/Git3/State/Index.hs b/hbs2-git3/lib/HBS2/Git3/State/Index.hs new file mode 100644 index 00000000..0fa4806a --- /dev/null +++ b/hbs2-git3/lib/HBS2/Git3/State/Index.hs @@ -0,0 +1,77 @@ +module HBS2.Git3.State.Index where + +import HBS2.Git3.Prelude +import HBS2.System.Dir +import HBS2.CLI.Run.Internal.Merkle (getTreeContents) +import HBS2.Git3.State.Types + +import HBS2.Data.Log.Structured + +import Data.List qualified as L +import Network.ByteOrder qualified as N +import System.IO.Temp as Temp +import Data.ByteString.Lazy qualified as LBS + +import Codec.Compression.Zstd.Lazy qualified as ZstdL +import Streaming.Prelude qualified as S +import Streaming hiding (run,chunksOf) + +import UnliftIO +import UnliftIO.IO.File qualified as UIO + + +-- writeReflogIndex = do + +-- reflog <- getGitRemoteKey >>= orThrowUser "reflog not set" + +-- api <- getClientAPI @RefLogAPI @UNIX + +-- sto <- getStorage + +-- flip runContT pure do + +-- what' <- lift $ callRpcWaitMay @RpcRefLogGet (TimeoutSec 2) api reflog +-- >>= orThrowUser "rpc timeout" + +-- what <- ContT $ maybe1 what' none + +-- idxPath <- getStatePath (AsBase58 reflog) <&> ( "index") +-- mkdir idxPath + +-- notice $ "STATE" <+> pretty idxPath + +-- sink <- S.toList_ do +-- walkMerkle (coerce what) (getBlock sto) $ \case +-- Left{} -> throwIO MissedBlockError +-- Right (hs :: [HashRef]) -> do +-- for_ hs $ \h -> void $ runMaybeT do + +-- tx <- getBlock sto (coerce h) +-- >>= toMPlus + +-- RefLogUpdate{..} <- deserialiseOrFail @(RefLogUpdate L4Proto) tx +-- & toMPlus + +-- AnnotatedHashRef _ href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict _refLogUpdData) +-- & toMPlus + +-- -- FIXME: error logging +-- lbs <- liftIO (runExceptT (getTreeContents sto href)) +-- >>= orThrow MissedBlockError + +-- pieces <- S.toList_ do +-- void $ runConsumeLBS (ZstdL.decompress lbs) $ readLogFileLBS () $ \o s _ -> do +-- lift $ S.yield o + +-- lift $ S.yield (h, pieces) + +-- liftIO $ forConcurrently_ sink $ \(tx, pieces) -> do +-- idxName <- emptyTempFile idxPath "objects-.idx" +-- let ss = L.sort pieces +-- UIO.withBinaryFileAtomic idxName WriteMode $ \wh -> do +-- for_ ss $ \sha1 -> do +-- let key = coerce @_ @N.ByteString sha1 +-- let value = coerce @_ @N.ByteString tx +-- -- notice $ pretty sha1 <+> pretty tx +-- writeSection ( LBS.fromChunks [key,value] ) (LBS.hPutStr wh) + diff --git a/hbs2-git3/lib/HBS2/Git3/State/Types.hs b/hbs2-git3/lib/HBS2/Git3/State/Types.hs index a7fd1883..e238cff3 100644 --- a/hbs2-git3/lib/HBS2/Git3/State/Types.hs +++ b/hbs2-git3/lib/HBS2/Git3/State/Types.hs @@ -5,12 +5,24 @@ module HBS2.Git3.State.Types 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) +