wip, massive refactoring

hbs2-git3/app/Main.hs

@@ -9,23 +9,9 @@
 {-# Language OverloadedLabels #-}
 module Main where
 
-import HBS2.Prelude.Plated
+import HBS2.Git3.Prelude
-import HBS2.OrDie
-import HBS2.Base58
-import HBS2.Merkle
-import HBS2.Data.Detect hiding (Blob)
-import HBS2.Data.Detect qualified as Detect
 
-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

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
 

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
+
+

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

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)
+

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)
+