From 5ffb44ac4926fe1a92632f37a0374ba84d5a5e53 Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Wed, 23 Aug 2023 16:38:46 +0400 Subject: [PATCH] Revert "test PR ADibgyhKo6 hbs2-git-config-location" This reverts commit 5b5639fc2b6f2444ae978cf5a2d0dfe9132298f9. --- .fixme/log | 2 +- .gitignore | 1 - docs/devlog.md | 8 -- hbs2-git/git-hbs2/GitRemoteMain.hs | 2 +- hbs2-git/git-hbs2/GitRemotePush.hs | 18 ++--- hbs2-git/git-hbs2/RunShow.hs | 25 +++--- hbs2-git/lib/HBS2/Git/Local/CLI.hs | 7 +- hbs2-git/lib/HBS2/Git/Types.hs | 5 ++ hbs2-git/lib/HBS2Git/App.hs | 11 +-- hbs2-git/lib/HBS2Git/Config.hs | 123 ++++++++++------------------- hbs2-git/lib/HBS2Git/Export.hs | 10 ++- hbs2-git/lib/HBS2Git/State.hs | 8 +- hbs2-git/lib/HBS2Git/Types.hs | 5 -- 13 files changed, 87 insertions(+), 138 deletions(-) diff --git a/.fixme/log b/.fixme/log index b40da91a..d93a4ec8 100644 --- a/.fixme/log +++ b/.fixme/log @@ -1,2 +1,2 @@ -(fixme-set "workflow" "test" "ADibgyhKo6") \ No newline at end of file +(fixme-set "workflow" "test" "CG2C18TK8v") \ No newline at end of file diff --git a/.gitignore b/.gitignore index b6f8bf00..b2a40f47 100644 --- a/.gitignore +++ b/.gitignore @@ -3,6 +3,5 @@ dist-newstyle hbs2.prof .fixme/state.db result -.hbs2-git # VS Code settings.json \ No newline at end of file diff --git a/docs/devlog.md b/docs/devlog.md index c90d3f94..87e98a23 100644 --- a/docs/devlog.md +++ b/docs/devlog.md @@ -1,11 +1,3 @@ -## 2023-14-08 - -PR: hbs2-git-config-location - branch: hbs2-git-fastpok - commit: 82d5a30f4510b3f70bfbf2bc208b14df4ce2b17d - Изменено расположение файла конфигурации hbs2-git, - незначительный рефакторинг. - ## 2023-07-30 какие-то косяки diff --git a/hbs2-git/git-hbs2/GitRemoteMain.hs b/hbs2-git/git-hbs2/GitRemoteMain.hs index 0a1ec744..0b024175 100644 --- a/hbs2-git/git-hbs2/GitRemoteMain.hs +++ b/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 diff --git a/hbs2-git/git-hbs2/GitRemotePush.hs b/hbs2-git/git-hbs2/GitRemotePush.hs index 088a04d7..917a1b75 100644 --- a/hbs2-git/git-hbs2/GitRemotePush.hs +++ b/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 - (_, config) <- Config.configInit + (_, syn) <- Config.configInit - -- dbPath <- makeDbPath remote - -- db <- dbEnv dbPath + dbPath <- makeDbPath remote + db <- dbEnv dbPath - runWithConfig config do + runWithConfig syn 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 - (_, config) <- Config.configInit + (_, syn) <- Config.configInit - runWithConfig config do + runWithConfig syn do _ <- cfgValue @ConfBranch @(Set GitRef) <&> transformBi normalizeRef loadCredentials mempty trace $ "deleting remote reference" <+> pretty br diff --git a/hbs2-git/git-hbs2/RunShow.hs b/hbs2-git/git-hbs2/RunShow.hs index 7998b02e..f8de184a 100644 --- a/hbs2-git/git-hbs2/RunShow.hs +++ b/hbs2-git/git-hbs2/RunShow.hs @@ -1,24 +1,22 @@ 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 Control.Monad.Reader -import Lens.Micro.Platform - --- import Data.Foldable +import Data.Foldable import Prettyprinter.Render.Terminal data ShowObject = ShowRef RepoRef | ShowConfig showRef :: (MonadIO m, MonadMask m) => RepoRef -> App m () -showRef _h = do - -- db <- makeDbPath h >>= dbEnv +showRef h = do + db <- makeDbPath h >>= dbEnv -- FIXME: re-implement-showRef pure () -- withDB db do @@ -36,12 +34,11 @@ showRefs = do runListRefs showConfig :: (MonadIO m, MonadMask m) => App m () -showConfig = do - configPath <- asks $ view appConfPath - liftIO $ do - config <- readFile configPath - putDoc $ green "Config file location:" <> section <> pretty configPath <> section - putDoc $ green "Config contents:" <> line <> pretty config <> line +showConfig = liftIO do + ConfigPathInfo{..} <- getConfigPathInfo + cfg <- readFile configFilePath + putDoc $ green "Config file location:" <> section <> pretty configFilePath <> section + putDoc $ green "Config contents:" <> line <> pretty cfg showSummary :: (MonadIO m, MonadMask m) => App m () showSummary = do diff --git a/hbs2-git/lib/HBS2/Git/Local/CLI.hs b/hbs2-git/lib/HBS2/Git/Local/CLI.hs index 0e4abb00..b8bd5910 100644 --- a/hbs2-git/lib/HBS2/Git/Local/CLI.hs +++ b/hbs2-git/lib/HBS2/Git/Local/CLI.hs @@ -32,6 +32,7 @@ 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 +141,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 +175,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 +250,7 @@ gitConfigSet k v = do gitGetRemotes :: MonadIO m => m [(Text,Text)] gitGetRemotes = do let cmd = [qc|git config --get-regexp '^remote\..*\.url$'|] - (_, out, _) <- liftIO $ readProcess (shell cmd) + (code, out, _) <- liftIO $ readProcess (shell cmd) let txt = Text.decodeUtf8 (LBS.toStrict out) diff --git a/hbs2-git/lib/HBS2/Git/Types.hs b/hbs2-git/lib/HBS2/Git/Types.hs index c2f0533c..4deeef81 100644 --- a/hbs2-git/lib/HBS2/Git/Types.hs +++ b/hbs2-git/lib/HBS2/Git/Types.hs @@ -14,9 +14,14 @@ 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 diff --git a/hbs2-git/lib/HBS2Git/App.hs b/hbs2-git/lib/HBS2Git/App.hs index 223ff20b..7c230ebe 100644 --- a/hbs2-git/lib/HBS2Git/App.hs +++ b/hbs2-git/lib/HBS2Git/App.hs @@ -22,6 +22,7 @@ import HBS2.Defaults (defBlockSize) import HBS2Git.Types import HBS2Git.Config as Config +import HBS2Git.State import Data.Maybe import Control.Monad.Trans.Maybe @@ -183,8 +184,7 @@ runApp l m = do setLoggingOff @DEBUG setLoggingOff @TRACE - pwd <- Config.getRepoDir - (configPath, config) <- Config.configInit + (pwd, syn) <- Config.configInit xdgstate <- getAppStateDir -- let statePath = xdgstate makeRelative home pwd @@ -203,11 +203,11 @@ runApp l m = do mtCred <- liftIO $ newTVarIO mempty - let env = AppEnv pwd (pwd ".git") config configPath xdgstate reQ szQ puQ rlQ mtCred + let env = AppEnv pwd (pwd ".git") syn xdgstate reQ szQ puQ rlQ mtCred runReaderT (fromApp m) env - debug $ vcat (fmap pretty config) + debug $ vcat (fmap pretty syn) setLoggingOff @DEBUG setLoggingOff @ERROR @@ -455,12 +455,9 @@ 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 diff --git a/hbs2-git/lib/HBS2Git/Config.hs b/hbs2-git/lib/HBS2Git/Config.hs index e7a8f0b7..c2b0e5f6 100644 --- a/hbs2-git/lib/HBS2Git/Config.hs +++ b/hbs2-git/lib/HBS2Git/Config.hs @@ -3,26 +3,23 @@ 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 Prettyprinter.Render.Terminal -import System.Directory +import HBS2.OrDie + +import Data.Config.Suckless + +import HBS2Git.Types + +import Data.Functor import System.FilePath -import System.IO -import Text.InterpolatedString.Perl6 (qc) +import System.Directory -- 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 @@ -42,85 +39,45 @@ findWorkingGitDir = do this <- liftIO getCurrentDirectory findGitDir this `orDie` ".git directory not found" -getRepoDir :: MonadIO m => m FilePath -getRepoDir = takeDirectory <$> findWorkingGitDir - -getOldConfigDir :: MonadIO m => FilePath -> m FilePath -getOldConfigDir repoDir = liftIO do +configPath :: MonadIO m => FilePath -> m FilePath +configPath pwd = liftIO do xdg <- liftIO $ getXdgDirectory XdgConfig appName home <- liftIO getHomeDirectory - pure $ xdg makeRelative home repoDir + pure $ xdg makeRelative home pwd -getOldConfigPath :: MonadIO m => FilePath -> m FilePath -getOldConfigPath repoDir = do - oldConfigDir <- getOldConfigDir repoDir - pure $ oldConfigDir configFileName +data ConfigPathInfo = ConfigPathInfo { + configRepoParentDir :: FilePath, + configDir :: FilePath, + configFilePath :: FilePath +} deriving (Eq, Show) -getNewConfigDir :: FilePath -> FilePath -getNewConfigDir repoDir = repoDir ("." <> appName) +-- returns git repository parent dir, config directory and config file path +getConfigPathInfo :: MonadIO m => m ConfigPathInfo +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 + } -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 +-- returns current directory, where found .git directory configInit :: MonadIO m => m (FilePath, [Syntax C]) configInit = liftIO do trace "configInit" - configPath <- getConfigPath - let configDir = takeDirectory configPath - configDirExists <- doesDirectoryExist configDir - unless configDirExists do + ConfigPathInfo{..} <- getConfigPathInfo + here <- doesDirectoryExist configDir + unless here do debug $ "create directory" <+> pretty configDir createDirectoryIfMissing True configDir - configExists <- doesFileExist configPath - unless configExists do - appendFile configPath "" - config <- readFile configPath <&> parseTop <&> either mempty id - pure (configPath, config) + confHere <- doesFileExist configFilePath + unless confHere do + appendFile configFilePath "" + cfg <- readFile configFilePath <&> parseTop <&> either mempty id + pure (configRepoParentDir, cfg) diff --git a/hbs2-git/lib/HBS2Git/Export.hs b/hbs2-git/lib/HBS2Git/Export.hs index b4094cd4..f168d513 100644 --- a/hbs2-git/lib/HBS2Git/Export.hs +++ b/hbs2-git/lib/HBS2Git/Export.hs @@ -13,6 +13,7 @@ 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 @@ -157,7 +158,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 @@ -274,7 +275,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 @@ -401,14 +402,15 @@ runExport fp repo = do shutUp - configPath <- asks $ view appConfPath + cwd <- liftIO getCurrentDirectory + cfgPath <- configPath cwd let krf = fromMaybe "keyring-file" fp & takeFileName liftIO $ putStrLn "" liftIO $ putDoc $ "exported" <+> pretty hhh <> section - <> green "Repository config:" <+> pretty configPath + <> green "Repository config:" <+> pretty (cfgPath "config") <> section <> "Put the keyring file" <+> yellow (pretty krf) <+> "into a safe place," <> line <> "like encrypted directory or volume." diff --git a/hbs2-git/lib/HBS2Git/State.hs b/hbs2-git/lib/HBS2Git/State.hs index 69a51a42..a79d669b 100644 --- a/hbs2-git/lib/HBS2Git/State.hs +++ b/hbs2-git/lib/HBS2Git/State.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} module HBS2Git.State where import HBS2.Prelude @@ -17,14 +16,19 @@ 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 @@ -102,7 +106,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 () diff --git a/hbs2-git/lib/HBS2Git/Types.hs b/hbs2-git/lib/HBS2Git/Types.hs index ba7c1768..87b71162 100644 --- a/hbs2-git/lib/HBS2Git/Types.hs +++ b/hbs2-git/lib/HBS2Git/Types.hs @@ -26,17 +26,13 @@ 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 @@ -72,7 +68,6 @@ data AppEnv = { _appCurDir :: FilePath , _appGitDir :: FilePath , _appConf :: [Syntax C] - , _appConfPath :: FilePath , _appStateDir :: FilePath , _appPeerHttpCat :: API , _appPeerHttpSize :: API