mirror of https://github.com/voidlizard/hbs2
git clone --mirror location bug fixed
This commit is contained in:
parent
a706af615e
commit
06970f527b
|
@ -19,9 +19,12 @@ import System.FilePath
|
||||||
import System.Directory
|
import System.Directory
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.Either
|
import Data.Either
|
||||||
|
import Data.List (isSuffixOf)
|
||||||
|
|
||||||
import System.Environment
|
import System.Environment
|
||||||
|
|
||||||
|
import System.IO (stderr)
|
||||||
|
|
||||||
appName :: FilePath
|
appName :: FilePath
|
||||||
appName = "hbs2-git"
|
appName = "hbs2-git"
|
||||||
|
|
||||||
|
@ -46,8 +49,6 @@ configPathOld pwd = liftIO do
|
||||||
|
|
||||||
configPath :: MonadIO m => FilePath -> m FilePath
|
configPath :: MonadIO m => FilePath -> m FilePath
|
||||||
configPath _ = liftIO do
|
configPath _ = liftIO do
|
||||||
env <- liftIO getEnvironment
|
|
||||||
-- hPrint stderr $ pretty env
|
|
||||||
pwd <- liftIO getCurrentDirectory
|
pwd <- liftIO getCurrentDirectory
|
||||||
git <- findGitDir pwd
|
git <- findGitDir pwd
|
||||||
byEnv <- lookupEnv "GIT_DIR"
|
byEnv <- lookupEnv "GIT_DIR"
|
||||||
|
@ -65,14 +66,18 @@ configPath _ = liftIO do
|
||||||
let repo = or [True | SymbolVal @C "repositoryformatversion" <- universeBi gitConf ]
|
let repo = or [True | SymbolVal @C "repositoryformatversion" <- universeBi gitConf ]
|
||||||
|
|
||||||
if core && bare && repo then do
|
if core && bare && repo then do
|
||||||
pure $ Just (pwd </> ".hbs2")
|
pure $ Just pwd
|
||||||
else
|
else
|
||||||
pure Nothing
|
pure Nothing
|
||||||
|
|
||||||
-- hPrint stderr appName
|
path <- pure (dropSuffix <$> (git <|> byEnv <|> bare)) `orDie` "*** hbs2-git: .git directory not found"
|
||||||
-- hPrint stderr =<< getEnvironment
|
|
||||||
path <- pure (git <|> byEnv <|> bare) `orDie` "*** hbs2-git: .git directory not found"
|
pure (path </> ".hbs2")
|
||||||
pure (takeDirectory path </> ".hbs2")
|
|
||||||
|
where
|
||||||
|
dropSuffix s | isSuffixOf ".git/" s = takeDirectory s
|
||||||
|
| isSuffixOf ".git" s = takeDirectory s
|
||||||
|
| otherwise = s
|
||||||
|
|
||||||
data ConfigPathInfo = ConfigPathInfo {
|
data ConfigPathInfo = ConfigPathInfo {
|
||||||
configRepoParentDir :: FilePath,
|
configRepoParentDir :: FilePath,
|
||||||
|
|
|
@ -52,6 +52,8 @@ import Streaming.Zip qualified as SZip
|
||||||
|
|
||||||
import HBS2Git.PrettyStuff
|
import HBS2Git.PrettyStuff
|
||||||
|
|
||||||
|
import System.Environment
|
||||||
|
|
||||||
data RunImportOpts =
|
data RunImportOpts =
|
||||||
RunImportOpts
|
RunImportOpts
|
||||||
{ _runImportDry :: Maybe Bool
|
{ _runImportDry :: Maybe Bool
|
||||||
|
@ -167,7 +169,14 @@ importRefLogNew opts ref = runResourceT do
|
||||||
sto <- getStorage
|
sto <- getStorage
|
||||||
|
|
||||||
let myTempDir = "hbs-git"
|
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
|
(_,dir) <- allocate (createTempDirectory temp myTempDir) removeDirectoryRecursive
|
||||||
|
|
||||||
lift $ makePolled ref
|
lift $ makePolled ref
|
||||||
|
@ -408,7 +417,10 @@ importRefLogNew opts ref = runResourceT do
|
||||||
|
|
||||||
withDB db $ do
|
withDB db $ do
|
||||||
stateUpdateCommitDepths
|
stateUpdateCommitDepths
|
||||||
|
|
||||||
|
when (length entries == length entries') do
|
||||||
statePutRefImported logRoot
|
statePutRefImported logRoot
|
||||||
|
|
||||||
savepointRelease sp0
|
savepointRelease sp0
|
||||||
|
|
||||||
where
|
where
|
||||||
|
|
Loading…
Reference in New Issue