test PR ADibgyhKo6 hbs2-git-config-location

Squashed commit of the following:

commit a2652dfcb84e6318edbfd470284999ac55058a59
Author: Vladimir Krutkin <krutkinvs@gmail.com>
Date:   Tue Aug 15 09:40:08 2023 +0300

    Fix: create ".hbs2-git" dir if missing

commit 5c76f287b457e1bf7199631b0035c541c44a0d3b
Author: Vladimir Krutkin <krutkinvs@gmail.com>
Date:   Mon Aug 14 17:08:15 2023 +0300

    fixme

commit 721bed688408a02fb3e7bf9e9ea70fad73f2f665
Author: Vladimir Krutkin <krutkinvs@gmail.com>
Date:   Mon Aug 14 17:07:21 2023 +0300

    PR

commit 82d5a30f4510b3f70bfbf2bc208b14df4ce2b17d
Author: Vladimir Krutkin <krutkinvs@gmail.com>
Date:   Mon Aug 14 17:01:09 2023 +0300

    Changed hbs2-git config file location, refactoring

commit 84b0e7024afaaa892842b36b0d6691c9cb348ce1
Author: Vladimir Krutkin <krutkinvs@gmail.com>
Date:   Mon Aug 14 16:46:31 2023 +0300

    Fix warnings

commit 916436fed8ee6c8f2eb25dd24acc5f616e5e31a0
Author: Vladimir Krutkin <krutkinvs@gmail.com>
Date:   Wed Aug 9 17:04:34 2023 +0300

    Fix warnings

.fixme/log

@@ -1,2 +1,2 @@
 
-(fixme-set "workflow" "test" "CG2C18TK8v")
+(fixme-set "workflow" "test" "ADibgyhKo6")

.gitignore

@@ -3,5 +3,6 @@ dist-newstyle
 hbs2.prof
 .fixme/state.db
 result
+.hbs2-git
 # VS Code
 settings.json

docs/devlog.md

@@ -1,3 +1,11 @@
+## 2023-14-08
+
+PR: hbs2-git-config-location
+  branch: hbs2-git-fastpok
+  commit: 82d5a30f4510b3f70bfbf2bc208b14df4ce2b17d
+  Изменено расположение файла конфигурации hbs2-git,
+  незначительный рефакторинг.
+
 ## 2023-07-30
 
 какие-то косяки

hbs2-git/git-hbs2/GitRemoteMain.hs

@@ -8,7 +8,7 @@ import HBS2.Git.Types
 
 import HBS2.System.Logger.Simple
 
-import HBS2Git.Types(traceTime)
+-- import HBS2Git.Types(traceTime)
 import HBS2Git.App
 import HBS2Git.State
 import HBS2Git.Import

hbs2-git/git-hbs2/GitRemotePush.hs

@@ -2,17 +2,17 @@
 module GitRemotePush where
 
 import HBS2.Prelude.Plated
-import HBS2.Data.Types.Refs
+-- import HBS2.Data.Types.Refs
 import HBS2.OrDie
 import HBS2.System.Logger.Simple
-import HBS2.Net.Auth.Credentials hiding (getCredentials)
+-- import HBS2.Net.Auth.Credentials hiding (getCredentials)
 
 import HBS2.Git.Local
 import HBS2.Git.Local.CLI
 
 import HBS2Git.Config as Config
 import HBS2Git.Types
-import HBS2Git.State
+-- import HBS2Git.State
 import HBS2Git.App
 import HBS2Git.Export (exportRefOnly,exportRefDeleted)
 import HBS2Git.Import (importRefLogNew)
@@ -70,12 +70,12 @@ push :: forall  m . ( MonadIO m
 
 
 push remote what@[Just bFrom , Just br] = do
-  (_, syn) <- Config.configInit
+  (_, config) <- Config.configInit
 
-  dbPath <- makeDbPath remote
+  -- dbPath <- makeDbPath remote
-  db <- dbEnv dbPath
+  -- db <- dbEnv dbPath
 
-  runWithConfig syn do
+  runWithConfig config do
     _ <- cfgValue @ConfBranch  @(Set GitRef) <&> transformBi normalizeRef
     loadCredentials mempty
     trace $ "PUSH PARAMS" <+> pretty what
@@ -85,9 +85,9 @@ push remote what@[Just bFrom , Just br] = do
     pure (Just br)
 
 push remote [Nothing, Just br]  = do
-  (_, syn) <- Config.configInit
+  (_, config) <- Config.configInit
 
-  runWithConfig syn do
+  runWithConfig config do
     _ <- cfgValue @ConfBranch  @(Set GitRef) <&> transformBi normalizeRef
     loadCredentials mempty
     trace $ "deleting remote reference" <+> pretty br

hbs2-git/git-hbs2/RunShow.hs

@@ -1,22 +1,24 @@
 module RunShow where
 
 import HBS2.Prelude
-import HBS2.Base58
+-- import HBS2.Base58
 
 import HBS2Git.App
-import HBS2Git.State
+-- import HBS2Git.State
-import HBS2Git.Config
 import HBS2Git.ListRefs
 
 import Control.Monad.Catch (MonadMask)
-import Data.Foldable
+import Control.Monad.Reader
+import Lens.Micro.Platform
+
+-- import Data.Foldable
 import Prettyprinter.Render.Terminal
 
 data ShowObject = ShowRef RepoRef | ShowConfig
 
 showRef :: (MonadIO m, MonadMask m) => RepoRef -> App m ()
-showRef h = do
+showRef _h = do
-  db <- makeDbPath h >>= dbEnv
+  -- db <- makeDbPath h >>= dbEnv
   -- FIXME: re-implement-showRef
   pure ()
   -- withDB db do
@@ -34,11 +36,12 @@ showRefs = do
   runListRefs
 
 showConfig :: (MonadIO m, MonadMask m) => App m ()
-showConfig = liftIO do
+showConfig = do
-  ConfigPathInfo{..} <- getConfigPathInfo
+  configPath <- asks $ view appConfPath
-  cfg <- readFile configFilePath
+  liftIO $ do
-  putDoc $ green "Config file location:" <> section <> pretty configFilePath <> section
+    config <- readFile configPath
-  putDoc $ green "Config contents:" <> line <> pretty cfg
+    putDoc $ green "Config file location:" <> section <> pretty configPath <> section
+    putDoc $ green "Config contents:" <> line <> pretty config <> line
 
 showSummary :: (MonadIO m, MonadMask m) => App m ()
 showSummary = do

hbs2-git/lib/HBS2/Git/Local/CLI.hs

@@ -31,7 +31,6 @@ import Data.Text.Encoding (decodeLatin1)
 import Data.Text qualified as Text
 import System.Process.Typed
 import Text.InterpolatedString.Perl6 (qc)
-import Lens.Micro.Platform
 import Control.Monad.Trans.Maybe
 import System.IO
 
@@ -140,7 +139,7 @@ gitGetAllDependencies :: MonadIO m
                        -> ( GitHash -> IO () ) -- ^ progress update function
                        -> m [(GitHash, GitHash)]
 
-gitGetAllDependencies n objects lookup progress = liftIO do
+gitGetAllDependencies n objects lookup' progress = liftIO do
   input <- newTQueueIO
   output <- newTQueueIO
 
@@ -174,7 +173,7 @@ gitGetAllDependencies n objects lookup progress = liftIO do
             pure here
 
           unless done do
-            cached <- lookup h
+            cached <- lookup' h
 
             deps <- if null cached then do
                       gitGetDependencies h
@@ -249,7 +248,7 @@ gitConfigSet k v = do
 gitGetRemotes :: MonadIO m => m [(Text,Text)]
 gitGetRemotes = do
   let cmd = [qc|git config --get-regexp '^remote\..*\.url$'|]
-  (code, out, _) <- liftIO $ readProcess (shell cmd)
+  (_, out, _) <- liftIO $ readProcess (shell cmd)
 
   let txt = Text.decodeUtf8 (LBS.toStrict out)
 

hbs2-git/lib/HBS2/Git/Types.hs

@@ -14,14 +14,9 @@ import Data.ByteString.Char8 qualified as BS
 import Data.ByteString.Lazy.Char8 qualified as LBS
 import Data.Data
 import Data.Generics.Uniplate.Data()
-import Data.String (IsString(..))
 import Data.Text.Encoding (decodeLatin1)
 import Data.Text qualified as Text
-import Data.Text (Text)
-import GHC.Generics
-import Prettyprinter
 import Text.InterpolatedString.Perl6 (qc)
-import Data.Hashable
 import Codec.Serialise
 import Data.Maybe
 

hbs2-git/lib/HBS2Git/App.hs

@@ -22,7 +22,6 @@ import HBS2.Defaults (defBlockSize)
 
 import HBS2Git.Types
 import HBS2Git.Config as Config
-import HBS2Git.State
 
 import Data.Maybe
 import Control.Monad.Trans.Maybe
@@ -183,7 +182,8 @@ runApp l m = do
     setLoggingOff @DEBUG
     setLoggingOff @TRACE
 
-  (pwd, syn) <- Config.configInit
+  pwd <- Config.getRepoDir
+  (configPath, config) <- Config.configInit
 
   xdgstate <- getAppStateDir
   -- let statePath = xdgstate </> makeRelative home pwd
@@ -202,11 +202,11 @@ runApp l m = do
 
   mtCred <- liftIO $ newTVarIO mempty
 
-  let env = AppEnv pwd (pwd </> ".git") syn xdgstate reQ szQ puQ rlQ mtCred
+  let env = AppEnv pwd (pwd </> ".git") config configPath xdgstate reQ szQ puQ rlQ mtCred
 
   runReaderT (fromApp m) env
 
-  debug $ vcat (fmap pretty syn)
+  debug $ vcat (fmap pretty config)
 
   setLoggingOff @DEBUG
   setLoggingOff @ERROR
@@ -454,9 +454,12 @@ loadCredentials fp = do
     pure ()
 
 
+green :: Doc AnsiStyle -> Doc AnsiStyle
 green = annotate (color Green)
 
+yellow :: Doc AnsiStyle -> Doc AnsiStyle
 yellow = annotate (color Yellow)
 
+section :: Doc ann
 section = line <> line
 

hbs2-git/lib/HBS2Git/Config.hs

@@ -3,23 +3,26 @@ module HBS2Git.Config
   , module Data.Config.Suckless
   ) where
 
+import Data.Char (toLower)
+import Data.Config.Suckless
+import Data.Functor
+import HBS2.OrDie
 import HBS2.Prelude
 import HBS2.System.Logger.Simple
-import HBS2.OrDie
+import Prettyprinter.Render.Terminal
-
-import Data.Config.Suckless
-
-import HBS2Git.Types
-
-import Data.Functor
-import System.FilePath
 import System.Directory
+import System.FilePath
+import System.IO
+import Text.InterpolatedString.Perl6 (qc)
 
 -- type C = MegaParsec
 
 appName :: FilePath
 appName = "hbs2-git"
 
+configFileName :: FilePath
+configFileName = "config"
+
 -- Finds .git dir inside given directory moving upwards
 findGitDir :: MonadIO m => FilePath -> m (Maybe FilePath)
 findGitDir dir = liftIO do
@@ -39,45 +42,85 @@ findWorkingGitDir = do
   this <- liftIO getCurrentDirectory
   findGitDir this `orDie` ".git directory not found"
 
-configPath :: MonadIO m => FilePath -> m FilePath
+getRepoDir :: MonadIO m => m FilePath
-configPath pwd = liftIO do
+getRepoDir = takeDirectory <$> findWorkingGitDir
+
+getOldConfigDir :: MonadIO m => FilePath -> m FilePath
+getOldConfigDir repoDir = liftIO do
   xdg <- liftIO $ getXdgDirectory XdgConfig appName
   home <- liftIO getHomeDirectory
-  pure $ xdg </> makeRelative home pwd
+  pure $ xdg </> makeRelative home repoDir
 
-data ConfigPathInfo = ConfigPathInfo {
+getOldConfigPath :: MonadIO m => FilePath -> m FilePath
-  configRepoParentDir :: FilePath,
+getOldConfigPath repoDir = do
-  configDir :: FilePath,
+  oldConfigDir <- getOldConfigDir repoDir
-  configFilePath :: FilePath
+  pure $ oldConfigDir </> configFileName
-} deriving (Eq, Show)
 
--- returns git repository parent dir, config directory and config file path 
+getNewConfigDir :: FilePath -> FilePath
-getConfigPathInfo :: MonadIO m => m ConfigPathInfo
+getNewConfigDir repoDir = repoDir </> ("." <> appName)
-getConfigPathInfo = do
-  trace "getConfigPathInfo"
-  gitDir <- findWorkingGitDir
-  let pwd = takeDirectory gitDir
-  confP <- configPath pwd
-  let confFile = confP </> "config"
-  trace $ "git dir" <+> pretty gitDir
-  trace $ "confPath:" <+> pretty confP
-  pure ConfigPathInfo {
-      configRepoParentDir = pwd,
-      configDir = confP,
-      configFilePath = confFile
-    }
 
--- returns current directory, where found .git directory
+getNewConfigPath :: FilePath -> FilePath
+getNewConfigPath repoDir = getNewConfigDir repoDir </> configFileName
+
+askPermissionToMoveConfig :: MonadIO m => FilePath -> FilePath -> m Bool
+askPermissionToMoveConfig oldConfigPath newConfigPath = do
+  liftIO $
+    putDoc
+      [qc|We've detected an existing config file in the old location: 
+{pretty oldConfigPath}
+
+The new location is:
+{pretty newConfigPath}
+
+Would you like to automatically move the config file to the new location? [Y/n] |]
+  liftIO $ hFlush stdout
+  response <- liftIO getLine
+  if map toLower response `elem` ["y", "yes"]
+    then pure True
+    else pure False
+
+isDirectoryEmpty :: FilePath -> IO Bool
+isDirectoryEmpty path = do
+  entries <- listDirectory path
+  return $ null entries
+
+getConfigPath :: MonadIO m => m FilePath
+getConfigPath = do
+  repoDir <- getRepoDir
+  oldConfigPath <- getOldConfigPath repoDir
+  let newConfigPath = getNewConfigPath repoDir
+  oldConfigExists <- liftIO $ doesFileExist oldConfigPath
+  if oldConfigExists
+    then do
+      permitted <- askPermissionToMoveConfig oldConfigPath newConfigPath
+      if permitted
+        then do
+          liftIO $ createDirectoryIfMissing True $ takeDirectory newConfigPath 
+          liftIO $ renameFile oldConfigPath newConfigPath
+          liftIO $ putDoc "Config file moved successfully."
+
+          -- also remove parent dir if it's empty
+          let oldConfigDir = takeDirectory oldConfigPath
+          isEmpty <- liftIO $ isDirectoryEmpty oldConfigDir
+          when isEmpty $ 
+            liftIO $ removeDirectory oldConfigDir
+
+          pure newConfigPath
+        else pure oldConfigPath
+    else pure newConfigPath
+
+-- returns config file location and its content, if file it doesn't exist creates one
 configInit :: MonadIO m => m (FilePath, [Syntax C])
 configInit = liftIO do
   trace "configInit"
-  ConfigPathInfo{..} <- getConfigPathInfo
+  configPath <- getConfigPath
-  here <- doesDirectoryExist configDir
+  let configDir = takeDirectory configPath
-  unless here do
+  configDirExists <- doesDirectoryExist configDir
+  unless configDirExists do
     debug $ "create directory" <+> pretty configDir
     createDirectoryIfMissing True configDir
-  confHere <- doesFileExist configFilePath
+  configExists <- doesFileExist configPath
-  unless confHere do
+  unless configExists do
-    appendFile configFilePath ""
+    appendFile configPath ""
-  cfg <- readFile configFilePath <&> parseTop <&> either mempty id
+  config <- readFile configPath <&> parseTop <&> either mempty id
-  pure (configRepoParentDir, cfg)
+  pure (configPath, config)

hbs2-git/lib/HBS2Git/Export.hs

@@ -13,7 +13,6 @@ import HBS2.Data.Types.Refs
 import HBS2.OrDie
 import HBS2.System.Logger.Simple
 import HBS2.Net.Proto.Definition()
-import HBS2.Clock
 import HBS2.Base58
 
 import HBS2.Git.Local
@@ -158,7 +157,7 @@ writeLogSegments :: forall m . ( MonadIO m
                  -> [(GitLogEntry, LBS.ByteString)]
                  -> ExportT m [HashRef]
 
-writeLogSegments onProgress val objs chunkSize trailing = do
+writeLogSegments onProgress _val objs chunkSize trailing = do
 
   db          <- asks $ view exportDB
   written     <- asks $ view exportWritten
@@ -275,7 +274,7 @@ exportRefOnly _ remote rfrom ref val = do
 
   entries <- traceTime "gitRevList" $ gitRevList lastKnownRev val
 
-  let entryNum = length entries
+  let _entryNum = length entries
 
   -- NOTE: just-for-test-new-non-empty-push-to-another-branch-112
 
@@ -402,15 +401,14 @@ runExport fp repo = do
 
   shutUp
 
-  cwd <- liftIO getCurrentDirectory
+  configPath  <- asks $ view appConfPath
-  cfgPath <- configPath cwd
   let krf = fromMaybe "keyring-file" fp & takeFileName
 
   liftIO $ putStrLn ""
   liftIO $ putDoc $
     "exported" <+> pretty hhh
     <> section
-    <> green "Repository config:" <+> pretty (cfgPath </> "config")
+    <> green "Repository config:" <+> pretty configPath
     <> section
     <>  "Put the keyring file" <+> yellow (pretty krf) <+> "into a safe place," <> line
     <> "like encrypted directory or volume."

hbs2-git/lib/HBS2Git/State.hs

@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 module HBS2Git.State where
 
 import HBS2.Prelude
@@ -16,19 +17,14 @@ import Database.SQLite.Simple.FromField
 import Database.SQLite.Simple.ToField
 import Control.Monad.Reader
 import Text.InterpolatedString.Perl6 (qc)
-import Data.String
 import Data.ByteString.Lazy.Char8 qualified as LBS
 import System.Directory
 import System.FilePath
 import Data.Maybe
-import Data.Text (Text)
-import Prettyprinter
 import Data.UUID.V4 qualified as UUID
 import Control.Monad.Catch
 import Control.Concurrent.STM
-import System.IO.Unsafe
 import Data.Graph (graphFromEdges, topSort)
-import Data.Map qualified as Map
 import Lens.Micro.Platform
 
 -- FIXME: move-orphans-to-separate-module
@@ -106,7 +102,7 @@ dbEnvReadOnly = dbEnv0 none
 
 withDB :: (MonadIO m, MonadMask m) => DBEnv -> DB m a -> m a
 withDB env action = do
-  conn <- initConnection env
+  _conn <- initConnection env
   finally (runReaderT (fromDB action) env) $ do
     -- NOTE: we could not close connection here.
     pure ()

hbs2-git/lib/HBS2Git/Types.hs

@@ -26,13 +26,17 @@ import Control.Monad.IO.Class
 import Control.Monad.Reader
 import Database.SQLite.Simple (Connection)
 import Data.Char (isSpace)
+import Data.Set qualified as Set
+import Data.Set (Set)
 import Data.List qualified as List
+import Data.Maybe
 import Lens.Micro.Platform
 import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HashMap
 import Codec.Serialise
 import Control.Concurrent.STM
 import System.IO qualified as IO
+import UnliftIO.IO qualified as UIO
 import System.IO (Handle)
 import Data.Kind
 import Control.Monad.Catch
@@ -68,6 +72,7 @@ data AppEnv =
   { _appCurDir       :: FilePath
   , _appGitDir       :: FilePath
   , _appConf         :: [Syntax C]
+  , _appConfPath     :: FilePath
   , _appStateDir     :: FilePath
   , _appPeerHttpCat  :: API
   , _appPeerHttpSize :: API