removing excess constraints

hbs2-git3/app/GitRemoteHelper.hs

@@ -175,6 +175,9 @@ main =  flip runContT pure do
 
   void $ lift $ withGit3Env env do
 
+    -- d_ <- asks gitRuntimeDict
+    -- atomically $ writeTVar d_ (Just (RuntimeDict fuck))
+
     conf <- readLocalConf
 
     cli <- parseCLI

hbs2-git3/app/Main.hs

@@ -21,11 +21,12 @@ main = flip runContT pure do
   cli <- parseTop (unlines $ unwords <$> splitForms argz)
            & either  (error.show) pure
 
-  env <- nullGit3Env
+  tvd <- newTVarIO theDict
+  env' <- nullGit3Env
+  let env = env' { gitRuntimeDict = Just (RuntimeDict tvd) }
 
   void $ lift $ withGit3Env env do
     conf <- readLocalConf
-    let dict = theDict
+    recover $ setupLogger >> runEval tvd (conf <> cli)
-    recover $ setupLogger >> run dict (conf <> cli)
       `finally` silence
 

hbs2-git3/lib/HBS2/Git3/Config/Local.hs

@@ -10,11 +10,4 @@ import Control.Monad.Trans.Maybe
 
 {- HLINT ignore "Functor law"-}
 
-getConfigPath :: MonadIO m => m (Maybe FilePath)
-getConfigPath = do
-  let name = ".hbs2-git3"
-  runMaybeT do
-    gitDir
-      >>= toMPlus <&> (</> name) . takeDirectory
-
 

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

@@ -100,7 +100,9 @@ exportEntries prefix = do
     let refs = HM.toList $ HM.fromList refs'
     export (Just h) refs
 
-export :: forall m . HBS2GitPerks m => Maybe GitHash -> [(GitRef, GitHash)] -> Git3 m ()
+export :: forall m . ( Git3Perks m
+                     )
+       => Maybe GitHash -> [(GitRef, GitHash)] -> Git3 m ()
 export mbh refs = withStateDo do
       tn <- getNumCapabilities
 
@@ -169,18 +171,19 @@ export mbh refs = withStateDo do
 
                 when (exported > 0) do
                   href <- createTreeWithMetadata sto gk meta lbs >>= orThrowPassIO
-                  writeLogEntry ("tree" <+> pretty ts <+> pretty href )
-                  debug $ "SENDING" <+> pretty href <+> pretty fn
-
                   let payload = LBS.toStrict $ serialise (AnnotatedHashRef Nothing href)
-                  tx <- withGit3Env env $ genRefLogUpdate payload
 
-                  let txh = hashObject @HbSync (serialise tx) & HashRef
+                  withGit3Env env do
+                    debug $ "SENDING" <+> pretty href <+> pretty fn
+                    writeLogEntry ("tree" <+> pretty ts <+> pretty href )
+                    tx <- genRefLogUpdate payload
 
-                  atomically (modifyTVar txCheckQ (HS.insert txh))
+                    let txh = hashObject @HbSync (serialise tx) & HashRef
 
-                  callRpcWaitMay @RpcRefLogPost (TimeoutSec 2) reflogAPI tx
+                    atomically (modifyTVar txCheckQ (HS.insert txh))
-                    >>= orThrowUser "rpc timeout"
+
+                    callRpcWaitMay @RpcRefLogPost (TimeoutSec 2) reflogAPI tx
+                      >>= orThrowUser "rpc timeout"
 
                 rm fn
                 next

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

@@ -123,11 +123,6 @@ data ImportStage =
 {- HLINT ignore "Functor law" -}
 
 importGitRefLog :: forall m . ( HBS2GitPerks m
-                              -- , HasStorage m
-                              -- , HasClientAPI PeerAPI UNIX m
-                              -- , HasClientAPI RefLogAPI UNIX m
-                              -- , HasGitRemoteKey m
-                              -- , MonadReader Git3Env m
                               )
              => Git3 m (Maybe HashRef)
 
@@ -257,10 +252,10 @@ importGitRefLog = withStateDo $ ask >>= \case
           Left  e                     -> err (viaShow e) >> throwIO e
 
 
-groupKeysFile :: MonadIO m => Git3 m FilePath
+groupKeysFile :: (MonadIO m) => Git3 m FilePath
 groupKeysFile = getStatePathM <&> (</> "groupkeys")
 
-readGroupKeyFile :: MonadIO m => Git3 m (Maybe HashRef)
+readGroupKeyFile :: (MonadIO m) => Git3 m (Maybe HashRef)
 readGroupKeyFile = do
   file <- groupKeysFile
   debug $ "readGroupKeyFile" <+> pretty file

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

@@ -23,7 +23,7 @@ import HBS2.KeyMan.Keys.Direct
 import HBS2.Data.Detect
 import HBS2.CLI.Run.MetaData (getTreeContents)
 
-import Data.Config.Suckless
+import Data.Config.Suckless.Script
 
 import HBS2.Peer.RPC.API.Storage
 import HBS2.Peer.RPC.Client.StorageClient
@@ -130,12 +130,14 @@ getRepoManifest = do
      >>= orThrow GitRepoManifestMalformed
      <&> RepoManifest
 
-nullGit3Env :: MonadIO m => m Git3Env
+nullGit3Env :: forall m . MonadIO m => m Git3Env
 nullGit3Env = Git3Disconnected
                 <$> newTVarIO defSegmentSize
                 <*> newTVarIO defCompressionLevel
                 <*> newTVarIO defIndexBlockSize
                 <*> newTVarIO Nothing
+                <*> pure Nothing
+
 
 connectedDo :: (MonadIO m) => Git3 m a -> Git3 m a
 connectedDo what = do
@@ -153,7 +155,7 @@ withGit3Env env a = runReaderT (fromGit3 a) env
 runGit3 :: Git3Perks m => Git3Env -> Git3 m b -> m b
 runGit3 env action = withGit3Env env action
 
-withStateDo :: MonadUnliftIO m => Git3 m a -> Git3 m a
+withStateDo :: (MonadUnliftIO m) => Git3 m a -> Git3 m a
 withStateDo action = do
 
   waitRepo Nothing =<< getGitRepoKeyThrow
@@ -169,6 +171,7 @@ recover m = fix \again -> 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)
@@ -197,6 +200,8 @@ recover m = fix \again -> do
 
         -- debug $ yellow $ "REPOKEY" <+> pretty (AsBase58 rk)
 
+        dict <- asks gitRuntimeDict
+
         connected <- Git3Connected soname sto peer refLogAPI lwwAPI
                         <$> newTVarIO rk
                         <*> newTVarIO Nothing
@@ -204,6 +209,7 @@ recover m = fix \again -> do
                         <*> newTVarIO defSegmentSize
                         <*> newTVarIO defCompressionLevel
                         <*> newTVarIO defIndexBlockSize
+                        <*> pure dict
 
 
         liftIO $ withGit3Env connected do

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

@@ -71,9 +71,7 @@ readLogFileLBS _ action = flip fix 0 \go n -> do
       go (succ n)
 
 indexPath :: forall m . ( Git3Perks m
-                        , MonadReader Git3Env m
+                        ) => Git3 m FilePath
-                        , HasGitRemoteKey m
-                        ) => m FilePath
 
 indexPath = getStatePathM
 
@@ -127,7 +125,7 @@ mergeSortedFilesN getKey inputFiles outFile = do
     mkState [] = Nothing
     mkState (x:xs) = Just (Entry (getKey x) (x:xs))
 
-compactIndex :: forall m . (Git3Perks m, HasGitRemoteKey m, MonadReader Git3Env m) => Natural -> m ()
+compactIndex :: forall m . (Git3Perks m) => Natural -> Git3 m ()
 compactIndex maxSize = do
   idxPath <- getStatePathM
   mkdir idxPath
@@ -144,8 +142,8 @@ compactIndex maxSize = do
     out <- liftIO $ emptyTempFile idxPath "objects-.idx"
     mergeSortedFilesN (BS.take 20) (map fst block) out
 
-openIndex :: forall a m . (Git3Perks m, HasGitRemoteKey m, MonadReader Git3Env m)
+openIndex :: forall a m . (Git3Perks m)
-          => m (Index a)
+          => Git3 m (Index a)
 
 openIndex = do
   files <- listObjectIndexFiles
@@ -211,9 +209,7 @@ indexFilterNewObjectsMem idx@Index{..} hashes = do
 
 
 listObjectIndexFiles :: forall m . ( Git3Perks m
-                                   , MonadReader Git3Env m
+                                   ) => Git3 m [(FilePath, Natural)]
-                                   , HasGitRemoteKey m
-                                   ) => m [(FilePath, Natural)]
 
 listObjectIndexFiles = do
   path <- indexPath
@@ -275,13 +271,12 @@ bloomFilterSize n k p
 
 
 updateReflogIndex :: forall m . ( Git3Perks m
-                                , MonadReader Git3Env m
+                                -- , HasClientAPI PeerAPI UNIX m
-                                , HasClientAPI PeerAPI UNIX m
+                                -- , HasClientAPI RefLogAPI UNIX m
-                                , HasClientAPI RefLogAPI UNIX m
+                                -- , HasStorage m
-                                , HasStorage m
+                                -- , HasGitRemoteKey m
-                                , HasGitRemoteKey m
+                                -- , HasIndexOptions m
-                                , HasIndexOptions m
+                                ) => Git3 m ()
-                                ) => m ()
 updateReflogIndex = do
 
     reflog <- getGitRemoteKey >>= orThrow Git3ReflogNotSet
@@ -398,11 +393,7 @@ updateReflogIndex = do
 
 
 trimRefs :: forall m . ( Git3Perks m
-                       , MonadReader Git3Env m
+                       ) => Git3 m ()
-                       , HasGitRemoteKey m
-                       , HasStorage m
-                       , HasClientAPI RefLogAPI UNIX m
-                       ) => m ()
 trimRefs = do
     idxPath <- indexPath
     files <- refsFiles
@@ -439,11 +430,7 @@ trimRefs = do
     mapM_ rm files
 
 importedCheckpoint :: forall m . ( MonadIO m
-                                 , MonadReader Git3Env m
+                                 ) => Git3 m (Maybe HashRef)
-                                 , HasClientAPI RefLogAPI UNIX m
-                                 , HasStorage m
-                                 , HasGitRemoteKey m
-                                 ) => m (Maybe HashRef)
 
 importedCheckpoint = do
   state <- getStatePathM
@@ -459,30 +446,22 @@ nullHash :: GitHash
 nullHash = GitHash (BS.replicate 20 0)
 
 txImported :: forall m . ( Git3Perks m
-                         , MonadReader Git3Env m
+                         ) => Git3 m (HashSet HashRef)
-                         , HasClientAPI RefLogAPI UNIX m
-                         , HasStorage m
-                         , HasGitRemoteKey m
-                         ) => m (HashSet HashRef)
 
 txImported = maybe mempty HS.fromList <$> runMaybeT do
      cp <- lift importedCheckpoint >>= toMPlus
      fmap fst <$> lift (txListAll (Just cp))
 
 
-refsFiles :: forall m . (Git3Perks m, HasGitRemoteKey m) => m [FilePath]
+refsFiles :: forall m . (Git3Perks m) => Git3 m [FilePath]
 refsFiles = do
   state <- getStatePathM
   dirFiles state
     <&> filter ( (== ".ref") . takeExtension )
 
 readRefsRaw :: forall m . ( Git3Perks m
-                          , MonadReader Git3Env m
-                          , HasClientAPI RefLogAPI UNIX m
-                          , HasStorage m
-                          , HasGitRemoteKey m
                           )
-            => [FilePath] -> m [Syntax C]
+            => [FilePath] -> Git3 m [Syntax C]
 
 readRefsRaw files = do
   mapM (liftIO . E.try @IOError . readFile) files
@@ -492,11 +471,7 @@ readRefsRaw files = do
 
 {- HLINT ignore "Functor law"-}
 importedRefs :: forall m . ( Git3Perks m
-                           , MonadReader Git3Env m
+                           ) => Git3 m [(GitRef, GitHash)]
-                           , HasClientAPI RefLogAPI UNIX m
-                           , HasStorage m
-                           , HasGitRemoteKey m
-                           ) => m [(GitRef, GitHash)]
 
 importedRefs = do
 
@@ -521,11 +496,7 @@ importedRefs = do
   pure rrefs
 
 updateImportedCheckpoint :: forall m . ( Git3Perks m
-                                 , MonadReader Git3Env m
+                                 ) => HashRef -> Git3 m ()
-                                 , HasClientAPI RefLogAPI UNIX m
-                                 , HasStorage m
-                                 , HasGitRemoteKey m
-                                 ) => HashRef -> m ()
 
 updateImportedCheckpoint cp = do
   state <- getStatePathM

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

@@ -7,6 +7,7 @@ module HBS2.Git3.State.Internal.Types
 
 import HBS2.Git3.Prelude
 import HBS2.Git3.Config.Local
+import HBS2.Git.Local.CLI
 import HBS2.System.Dir
 
 import Data.Config.Suckless.Script
@@ -21,23 +22,30 @@ import Control.Exception qualified as E
 unit :: FilePath
 unit = "hbs2-git"
 
-getStatePath :: (MonadIO m, Pretty ref) => ref -> m (Maybe FilePath)
+getConfigPath :: MonadIO m => Git3 m (Maybe FilePath)
+getConfigPath = do
+  let name = ".hbs2-git3"
+  runMaybeT do
+    gitDir
+      >>= toMPlus <&> (</> name) . takeDirectory
+
+getStatePath :: (MonadIO m, Pretty ref) => ref -> Git3 m (Maybe FilePath)
 getStatePath p = runMaybeT do
-  d <- getConfigPath >>= toMPlus
+  d <- lift getConfigPath >>= toMPlus
   pure $ d </> show (pretty p)
 
-getConfigRootFile :: MonadIO m => m FilePath
+getConfigRootFile :: MonadIO m => Git3 m FilePath
 getConfigRootFile = do
   getConfigPath
     >>= orThrow StateDirNotDefined
     <&> (</> "config")
 
-readLocalConf :: MonadIO m => m [Syntax C]
+readLocalConf :: forall m . HBS2GitPerks m => Git3 m [Syntax C]
 readLocalConf = do
 
   fromMaybe mempty <$> runMaybeT do
 
-    conf <- liftIO (E.try @SomeException getConfigRootFile)
+    conf <- lift (try @_ @SomeException getConfigRootFile)
               >>= toMPlus
 
     lift $ touch conf
@@ -93,12 +101,16 @@ instance Hashable GitWritePacksOptVal
 instance GitWritePacksOpts (HashSet GitWritePacksOptVal) where
   excludeParents o = not $ HS.member WriteFullPack o
 
+data RuntimeDict = forall c m . (IsContext c, HBS2GitPerks m)
+                 => RuntimeDict { fromRuntimeDict :: TVar (Dict c m) }
+
 data Git3Env =
     Git3Disconnected
     { gitPackedSegmentSize :: TVar Int
     , gitCompressionLevel  :: TVar Int
     , gitIndexBlockSize    :: TVar Natural
     , gitRepoKey           :: TVar (Maybe GitRepoKey)
+    , gitRuntimeDict       :: Maybe RuntimeDict
     }
   | Git3Connected
     { peerSocket   :: FilePath
@@ -112,6 +124,7 @@ data Git3Env =
     , gitPackedSegmentSize :: TVar Int
     , gitCompressionLevel  :: TVar Int
     , gitIndexBlockSize :: TVar Natural
+    , gitRuntimeDict       :: Maybe RuntimeDict
     }
 
 class HasExportOpts m where
@@ -169,6 +182,10 @@ instance (MonadIO m) => HasGitRemoteKey (Git3 m) where
     e <- ask
     liftIO $ atomically $ writeTVar (gitRepoKey e) (Just k)
 
+class IsContext c => HasRuntimeDict c m where
+  getRuntimeDict :: m (TVar (Dict c m))
+
+
 getGitRepoKeyThrow :: (MonadIO m, HasGitRemoteKey m) => m GitRepoKey
 getGitRepoKeyThrow = getGitRepoKey >>= orThrow GitRepoRefNotSet
 
@@ -216,7 +233,7 @@ instance HasClientAPI api UNIX (Git3 m) => HasClientAPI api UNIX (ContT whatever
 instance HasClientAPI api UNIX (Git3 m) => HasClientAPI api UNIX (MaybeT (Git3 m)) where
   getClientAPI = lift getClientAPI
 
-getStatePathM :: forall m . (MonadIO m, HasGitRemoteKey m) => m FilePath
+getStatePathM :: forall m . (MonadIO m) => Git3 m FilePath
 getStatePathM = do
   k <- getGitRemoteKey >>= orThrow RefLogNotSet
   getStatePath (AsBase58 k) >>= orThrow StateDirNotDefined