new config location for hbs2-git

now it's under .hbs2 on the same level,
where .git/ directory is located.

migration should work automatically. probably.

hbs2-git/git-hbs2/GitRemoteMain.hs

@@ -12,6 +12,7 @@ import HBS2Git.Types(traceTime)
 import HBS2Git.App
 import HBS2Git.State
 import HBS2Git.Import
+import HBS2Git.Evolve
 import HBS2.Git.Local.CLI
 
 import HBS2Git.Export (runExport)
@@ -82,7 +83,7 @@ loop :: forall m . ( MonadIO m
 loop args = do
 
 
-  -- setLogging @TRACE tracePrefix
+  setLogging @TRACE tracePrefix
 
   trace $ "args:" <+> pretty args
 
@@ -107,7 +108,7 @@ loop args = do
   unless checkRef do
     warn $ "reference" <+> pretty ref <+> "missing"
     warn "trying to init reference --- may be it's ours"
-    liftIO $ runApp NoLog (runExport Nothing ref)
+    liftIO $ runApp WithLog (runExport Nothing ref)
 
   refs <- withDB db stateGetActualRefs
 
@@ -217,6 +218,8 @@ main = do
 
   void $ installHandler sigPIPE Ignore Nothing
 
+  evolve
+
   env <- RemoteEnv <$> detectHBS2PeerCatAPI
                    <*> detectHBS2PeerSizeAPI
                    <*> detectHBS2PeerPutAPI

hbs2-git/git-hbs2/Main.hs

@@ -15,8 +15,8 @@ main :: IO ()
 main = join . customExecParser (prefs showHelpOnError) $
   info (helper <*> parser)
   (  fullDesc
-  <> header "hbsync block fetch"
+  <> header "git-hbs2"
-  <> progDesc "fetches blocks from hbsync peers"
+  <> progDesc "helper tool for hbs2-git"
   )
   where
     parser ::  Parser (IO ())

hbs2-git/git-hbs2/RunShow.hs

@@ -7,6 +7,7 @@ import HBS2Git.App
 import HBS2Git.State
 import HBS2Git.Config
 import HBS2Git.ListRefs
+import HBS2Git.PrettyStuff
 
 import Control.Monad.Catch (MonadMask)
 import Data.Foldable

hbs2-git/hbs2-git.cabal

@@ -104,14 +104,16 @@ library
       HBS2.Git.Types
       HBS2.Git.Local
       HBS2.Git.Local.CLI
-      HBS2Git.Types
+      HBS2Git.App
+      HBS2Git.Config
+      HBS2Git.Evolve
       HBS2Git.Export
+      HBS2Git.GitRepoLog
       HBS2Git.Import
       HBS2Git.ListRefs
-      HBS2Git.Config
+      HBS2Git.PrettyStuff
-      HBS2Git.App
       HBS2Git.State
-      HBS2Git.GitRepoLog
+      HBS2Git.Types
 
     -- other-modules:
     -- other-extensions:

hbs2-git/lib/HBS2Git/App.hs

@@ -14,7 +14,6 @@ import HBS2.OrDie
 import HBS2.Hash
 import HBS2.System.Logger.Simple
 import HBS2.Merkle
-import HBS2.Net.Proto.Types
 import HBS2.Git.Types
 import HBS2.Net.Proto.Definition()
 import HBS2.Net.Auth.Credentials hiding (getCredentials)
@@ -23,7 +22,7 @@ import HBS2.Defaults (defBlockSize)
 
 import HBS2Git.Types
 import HBS2Git.Config as Config
-import HBS2Git.State
+import HBS2Git.Evolve
 
 import Data.Maybe
 import Control.Monad.Trans.Maybe
@@ -54,7 +53,7 @@ import System.IO.Unsafe (unsafePerformIO)
 import Data.Cache qualified as Cache
 import Control.Concurrent.Async
 import System.Environment
-import Prettyprinter.Render.Terminal
+import System.IO
 
 import Streaming.Prelude qualified as S
 
@@ -188,6 +187,8 @@ runApp l m = do
     setLoggingOff @DEBUG
     setLoggingOff @TRACE
 
+  evolve
+
   (pwd, syn) <- Config.configInit
 
   xdgstate <- getAppStateDir
@@ -457,6 +458,9 @@ loadCredentials :: ( MonadIO m
                    , HasRefCredentials m
                    ) => [FilePath] -> m ()
 loadCredentials fp = do
+
+  trace $ "loadCredentials" <+> pretty fp
+
   krOpt' <- cfgValue @KeyRingFiles @(Set FilePath) <&> Set.toList
 
   let krOpt = List.nub $ fp <> krOpt'
@@ -488,9 +492,4 @@ loadKeyring fn = do
     let puk = view peerSignPk cred
     pure (puk, cred)
 
-green = annotate (color Green)
-
-yellow = annotate (color Yellow)
-
-section = line <> line
 

hbs2-git/lib/HBS2Git/Config.hs

@@ -39,12 +39,17 @@ findWorkingGitDir = do
   this <- liftIO getCurrentDirectory
   findGitDir this `orDie` ".git directory not found"
 
-configPath :: MonadIO m => FilePath -> m FilePath
+configPathOld :: MonadIO m => FilePath -> m FilePath
-configPath pwd = liftIO do
+configPathOld pwd = liftIO do
   xdg <- liftIO $ getXdgDirectory XdgConfig appName
   home <- liftIO getHomeDirectory
   pure $ xdg </> makeRelative home pwd
 
+configPath :: MonadIO m => FilePath -> m FilePath
+configPath _ = liftIO do
+  here   <- liftIO getCurrentDirectory
+  (findGitDir here <&> fmap ((</> ".hbs2") . takeDirectory)) `orDie` "*** hbs2-git: .git directory not found"
+
 data ConfigPathInfo = ConfigPathInfo {
   configRepoParentDir :: FilePath,
   configDir :: FilePath,
@@ -81,3 +86,4 @@ configInit = liftIO do
     appendFile configFilePath ""
   cfg <- readFile configFilePath <&> parseTop <&> either mempty id
   pure (configRepoParentDir, cfg)
+

hbs2-git/lib/HBS2Git/Evolve.hs

@@ -0,0 +1,78 @@
+module HBS2Git.Evolve (evolve) where
+
+import HBS2.Prelude.Plated
+import HBS2.System.Logger.Simple
+import HBS2.OrDie
+
+import HBS2.Git.Types
+import HBS2Git.Config
+import HBS2Git.PrettyStuff
+
+import Control.Monad.Trans.Maybe
+import Data.Functor
+import Data.List qualified as List
+import Prettyprinter.Render.Terminal
+import System.Directory
+import System.FilePath
+import UnliftIO
+
+-- NOTE: hbs2-git-evolve
+--   выполняет идемпотентные миграции между старыми и
+--   новыми версиями.
+--   например, переносит конфиг
+
+evolve :: MonadIO m => m ()
+evolve = do
+  trace "DO EVOLVE"
+
+  migrateConfig
+
+  shutUp
+
+  pure ()
+
+
+migrateConfig :: MonadIO m => m ()
+migrateConfig = void $ runMaybeT do
+  here   <- liftIO getCurrentDirectory
+  rootDir <- (findGitDir here <&> fmap takeDirectory) `orDie` "*** hbs2-git: working directory not found"
+
+  oldPath <- configPathOld here
+  let oldConf = oldPath </> "config"
+
+  guard =<< liftIO (doesDirectoryExist oldPath)
+  guard =<< liftIO (doesFileExist oldConf)
+
+  let newConfDir = rootDir </> ".hbs2"
+  let newConfFile = newConfDir </> "config"
+
+  guard =<< liftIO (not <$> doesFileExist newConfFile)
+
+  trace $ "EVOLVE: root directory" <+> pretty newConfDir
+
+  confFileHere <- liftIO $ doesFileExist newConfFile
+
+  guard (not confFileHere)
+
+  liftIO do
+    hPutDoc stderr $ red "evolve: creating new config" <+> pretty newConfFile <> line
+    createDirectoryIfMissing True newConfDir
+    hPutDoc stderr $ red "evolve: moving config to" <+> pretty newConfFile <> line
+    liftIO $ renameFile oldConf newConfFile
+
+    anything <- liftIO $ listDirectory oldPath
+
+    if List.null anything then do
+      hPutDoc stderr $ red "evolve: removing"
+                        <+> pretty oldPath <> line
+
+      removeDirectory oldPath
+    else do
+      hPutDoc stderr $ red "evolve: not empty" <+> pretty oldPath <> line
+
+      hPutDoc stderr $ yellow "evolve: remove"
+                          <+> pretty oldPath
+                          <+> yellow "on your own"
+                          <> line
+
+

hbs2-git/lib/HBS2Git/Export.hs

@@ -25,6 +25,7 @@ import HBS2Git.App
 import HBS2Git.State
 import HBS2Git.Config
 import HBS2Git.GitRepoLog
+import HBS2Git.PrettyStuff
 
 import Control.Applicative
 import Control.Monad.Catch

hbs2-git/lib/HBS2Git/ListRefs.hs

@@ -10,6 +10,7 @@ import HBS2.Git.Local.CLI
 import HBS2.Git.Types
 import HBS2Git.Import (importRefLogNew)
 import HBS2Git.State
+import HBS2Git.PrettyStuff
 
 import Data.HashMap.Strict qualified as HashMap
 import Data.Functor

hbs2-git/lib/HBS2Git/PrettyStuff.hs

@@ -0,0 +1,17 @@
+module HBS2Git.PrettyStuff where
+
+import Prettyprinter
+import Prettyprinter.Render.Terminal
+
+green :: Doc AnsiStyle -> Doc AnsiStyle
+green = annotate (color Green)
+
+yellow :: Doc AnsiStyle -> Doc AnsiStyle
+yellow = annotate (color Yellow)
+
+
+red :: Doc AnsiStyle -> Doc AnsiStyle
+red = annotate (color Red)
+
+section :: Doc ann
+section = line <> line

hbs2-git/lib/HBS2Git/Types.hs

@@ -212,6 +212,7 @@ exitFailure = do
 
 die :: MonadIO m => String -> m a
 die s = do
+  shutUp
   liftIO $ Exit.die s
 
 traceTime :: MonadIO m => String -> m a -> m a