wip

hbs2-git3/app/GitRemoteHelper.hs

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

hbs2-git3/app/Main.hs

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

hbs2-git3/hbs2-git3.cabal

@@ -127,12 +127,13 @@ library
       HBS2.Git3.Import
       HBS2.Git3.Repo
       HBS2.Git3.Run
-      HBS2.Git3.State.Types
+      HBS2.Git3.State
-      HBS2.Git3.State.RefLog
+      HBS2.Git3.State.Internal.Types
-      HBS2.Git3.State.Index
+      HBS2.Git3.State.Internal.RefLog
-      HBS2.Git3.State.Segment
+      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
 

hbs2-git3/lib/HBS2/Git3/Export.hs

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

hbs2-git3/lib/HBS2/Git3/Git.hs

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

hbs2-git3/lib/HBS2/Git3/Import.hs

@@ -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 ()

hbs2-git3/lib/HBS2/Git3/Prelude.hs

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

hbs2-git3/lib/HBS2/Git3/Run.hs

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

hbs2-git3/lib/HBS2/Git3/State.hs

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

hbs2-git3/lib/HBS2/Git3/State/Internal/Index.hs

@@ -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.Internal.Types
-import HBS2.Git3.State.RefLog
+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

hbs2-git3/lib/HBS2/Git3/State/Internal/LWWBlock.hs

@@ -0,0 +1,7 @@
+module HBS2.Git3.State.Internal.LWWBlock where
+
+import HBS2.Git3.Prelude
+
+
+
+

hbs2-git3/lib/HBS2/Git3/State/Internal/RefLog.hs

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

hbs2-git3/lib/HBS2/Git3/State/Internal/Segment.hs

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

hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs

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

hbs2-git3/lib/HBS2/Git3/State/LWWBlock.hs

@@ -1,7 +0,0 @@
-module HBS2.Git3.State.LWWBlock where
-
-import HBS2.Git3.Prelude
-
-
-
-

hbs2-git3/lib/HBS2/Git3/State/Types.hs

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