diff --git a/hbs2-git/git-hbs2/GitRemoteMain.hs b/hbs2-git/git-hbs2/GitRemoteMain.hs index 0b024175..ef0bc331 100644 --- a/hbs2-git/git-hbs2/GitRemoteMain.hs +++ b/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 diff --git a/hbs2-git/git-hbs2/Main.hs b/hbs2-git/git-hbs2/Main.hs index e8199481..65659ef1 100644 --- a/hbs2-git/git-hbs2/Main.hs +++ b/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" - <> progDesc "fetches blocks from hbsync peers" + <> header "git-hbs2" + <> progDesc "helper tool for hbs2-git" ) where parser :: Parser (IO ()) diff --git a/hbs2-git/git-hbs2/RunShow.hs b/hbs2-git/git-hbs2/RunShow.hs index f8de184a..2c68bc05 100644 --- a/hbs2-git/git-hbs2/RunShow.hs +++ b/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 diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index 6daf2d4c..eb288375 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/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.App + HBS2Git.PrettyStuff HBS2Git.State - HBS2Git.GitRepoLog + HBS2Git.Types -- other-modules: -- other-extensions: diff --git a/hbs2-git/lib/HBS2Git/App.hs b/hbs2-git/lib/HBS2Git/App.hs index 26d6a31d..e6a8772a 100644 --- a/hbs2-git/lib/HBS2Git/App.hs +++ b/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 diff --git a/hbs2-git/lib/HBS2Git/Config.hs b/hbs2-git/lib/HBS2Git/Config.hs index c2b0e5f6..1fe891fa 100644 --- a/hbs2-git/lib/HBS2Git/Config.hs +++ b/hbs2-git/lib/HBS2Git/Config.hs @@ -39,19 +39,24 @@ findWorkingGitDir = do this <- liftIO getCurrentDirectory findGitDir this `orDie` ".git directory not found" -configPath :: MonadIO m => FilePath -> m FilePath -configPath pwd = liftIO do +configPathOld :: MonadIO m => FilePath -> m FilePath +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, configFilePath :: FilePath } deriving (Eq, Show) --- returns git repository parent dir, config directory and config file path +-- returns git repository parent dir, config directory and config file path getConfigPathInfo :: MonadIO m => m ConfigPathInfo getConfigPathInfo = do trace "getConfigPathInfo" @@ -81,3 +86,4 @@ configInit = liftIO do appendFile configFilePath "" cfg <- readFile configFilePath <&> parseTop <&> either mempty id pure (configRepoParentDir, cfg) + diff --git a/hbs2-git/lib/HBS2Git/Evolve.hs b/hbs2-git/lib/HBS2Git/Evolve.hs new file mode 100644 index 00000000..1e7ebdfc --- /dev/null +++ b/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 + + diff --git a/hbs2-git/lib/HBS2Git/Export.hs b/hbs2-git/lib/HBS2Git/Export.hs index 2f8ef3d2..9da6d7ce 100644 --- a/hbs2-git/lib/HBS2Git/Export.hs +++ b/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 diff --git a/hbs2-git/lib/HBS2Git/ListRefs.hs b/hbs2-git/lib/HBS2Git/ListRefs.hs index 97c2860f..09b44168 100644 --- a/hbs2-git/lib/HBS2Git/ListRefs.hs +++ b/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 diff --git a/hbs2-git/lib/HBS2Git/PrettyStuff.hs b/hbs2-git/lib/HBS2Git/PrettyStuff.hs new file mode 100644 index 00000000..bdfaedd4 --- /dev/null +++ b/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 diff --git a/hbs2-git/lib/HBS2Git/Types.hs b/hbs2-git/lib/HBS2Git/Types.hs index 87b71162..5c0dd079 100644 --- a/hbs2-git/lib/HBS2Git/Types.hs +++ b/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