git clone --mirror location bug fixed

This commit is contained in:
Dmitry Zuikov 2023-10-16 15:42:13 +03:00
parent a706af615e
commit 06970f527b
2 changed files with 26 additions and 9 deletions

View File

@ -19,9 +19,12 @@ import System.FilePath
import System.Directory
import Data.Maybe
import Data.Either
import Data.List (isSuffixOf)
import System.Environment
import System.IO (stderr)
appName :: FilePath
appName = "hbs2-git"
@ -46,8 +49,6 @@ configPathOld pwd = liftIO do
configPath :: MonadIO m => FilePath -> m FilePath
configPath _ = liftIO do
env <- liftIO getEnvironment
-- hPrint stderr $ pretty env
pwd <- liftIO getCurrentDirectory
git <- findGitDir pwd
byEnv <- lookupEnv "GIT_DIR"
@ -65,14 +66,18 @@ configPath _ = liftIO do
let repo = or [True | SymbolVal @C "repositoryformatversion" <- universeBi gitConf ]
if core && bare && repo then do
pure $ Just (pwd </> ".hbs2")
pure $ Just pwd
else
pure Nothing
-- hPrint stderr appName
-- hPrint stderr =<< getEnvironment
path <- pure (git <|> byEnv <|> bare) `orDie` "*** hbs2-git: .git directory not found"
pure (takeDirectory path </> ".hbs2")
path <- pure (dropSuffix <$> (git <|> byEnv <|> bare)) `orDie` "*** hbs2-git: .git directory not found"
pure (path </> ".hbs2")
where
dropSuffix s | isSuffixOf ".git/" s = takeDirectory s
| isSuffixOf ".git" s = takeDirectory s
| otherwise = s
data ConfigPathInfo = ConfigPathInfo {
configRepoParentDir :: FilePath,

View File

@ -52,6 +52,8 @@ import Streaming.Zip qualified as SZip
import HBS2Git.PrettyStuff
import System.Environment
data RunImportOpts =
RunImportOpts
{ _runImportDry :: Maybe Bool
@ -167,7 +169,14 @@ importRefLogNew opts ref = runResourceT do
sto <- getStorage
let myTempDir = "hbs-git"
temp <- liftIO getCanonicalTemporaryDirectory
temp <- liftIO getTemporaryDirectory
wtf <- liftIO getEnvironment
hPrint stderr $ "CREATE TEMP DIR" <+> pretty temp <> line <> pretty wtf
-- liftIO $ void $ createDirectoryIfMissing True temp
(_,dir) <- allocate (createTempDirectory temp myTempDir) removeDirectoryRecursive
lift $ makePolled ref
@ -408,7 +417,10 @@ importRefLogNew opts ref = runResourceT do
withDB db $ do
stateUpdateCommitDepths
statePutRefImported logRoot
when (length entries == length entries') do
statePutRefImported logRoot
savepointRelease sp0
where