diff --git a/extra/Lamdera.hs b/extra/Lamdera.hs index 9d188ddb..63744a40 100644 --- a/extra/Lamdera.hs +++ b/extra/Lamdera.hs @@ -134,6 +134,8 @@ module Lamdera , icdiff , withStdinYesAll , getGitBranch + , GitRepoStatus(..) + , gitRepoStatus , launchAppZero , killAppZero , head_ @@ -174,7 +176,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import Data.FileEmbed (bsToExp) import Language.Haskell.TH (runIO) -import System.FilePath as FP ((), joinPath, splitDirectories, takeDirectory) +import System.FilePath as FP ((), joinPath, splitDirectories, takeDirectory, isAbsolute) import qualified System.Directory as Dir import Control.Monad (unless, filterM) import System.Info @@ -1117,6 +1119,64 @@ getGitBranch = do stdout & pack & strip & pure +{-| Describes how the `.git` entry at a project root presents itself. + +In a normal clone `.git` is a directory. In a git worktree it is instead a text +file containing a single `gitdir: ` line pointing at the real git +directory under the main checkout's `.git/worktrees/`. The `git` binary +resolves this transparently, but our own existence checks need to be aware of +it so we don't mistake a worktree for an uninitialised project. -} +data GitRepoStatus + = GitRepoMissing -- ^ no `.git` at all -> safe to `git init` + | GitRepoDir -- ^ `.git` is a normal directory + | GitRepoWorktree FilePath -- ^ `.git` is a file pointing at an existing gitdir + | GitRepoWorktreeBroken String -- ^ `.git` is a file but malformed / dangling (reason) + deriving (Eq, Show) + + +{-| Inspect the `.git` entry at a project root, following the worktree `gitdir:` +pointer the same way `git` does. When `.git` is a file we verify it has the +expected `gitdir: ` format and that the target directory exists, returning +a specific reason for each failure case. -} +gitRepoStatus :: FilePath -> IO GitRepoStatus +gitRepoStatus root = do + let dotGit = root ".git" + isDir <- Dir.doesDirectoryExist dotGit + isFile <- Dir.doesFileExist dotGit + if isDir + then pure GitRepoDir + else if not isFile + then pure GitRepoMissing + else do + contentsM <- readUtf8Text dotGit + case contentsM >>= parseGitdirPointer of + Nothing -> + pure $ GitRepoWorktreeBroken + ("Found a `.git` file at " <> dotGit <> + " but it does not contain the expected `gitdir: ` pointer.") + Just rel -> do + let target = if FP.isAbsolute rel then rel else root rel + targetExists <- Dir.doesDirectoryExist target + if targetExists + then pure (GitRepoWorktree target) + else pure $ GitRepoWorktreeBroken + ("The `.git` file at " <> dotGit <> + " points to a git directory that does not exist: " <> target) + + +{-| Parse the `gitdir: ` pointer from the first line of a worktree `.git` +file, returning the path. -} +parseGitdirPointer :: Text -> Maybe FilePath +parseGitdirPointer contents = + case T.lines contents of + [] -> Nothing + (firstLine:_) -> + let trimmed = T.strip firstLine + in if T.isPrefixOf "gitdir:" trimmed + then Just $ T.unpack $ T.strip $ T.drop (T.length "gitdir:") trimmed + else Nothing + + launchAppZero :: Text -> IO () launchAppZero appId = do callCommand $ "~/lamdera/scripts/launchAppZero.sh " <> unpack appId diff --git a/extra/Lamdera/CLI/Check.hs b/extra/Lamdera/CLI/Check.hs index 008dc7c5..6f4547c9 100644 --- a/extra/Lamdera/CLI/Check.hs +++ b/extra/Lamdera/CLI/Check.hs @@ -1023,27 +1023,38 @@ showExternalTypeWarnings warnings = do checkGitInitialised :: FilePath -> IO () checkGitInitialised root = do - gitInitialised <- Dir.doesDirectoryExist $ root ".git" - onlyWhen (not gitInitialised) $ do - appName <- getInput $ - D.vcat - [ "It looks like your project is missing a git repository!" - , "I can initialize it for you." - , "What is your Lamdera app name? [enter to skip]: " - ] - - if appName == "" - then do - Progress.throw - $ Help.report "SKIPPING GIT INITIALISATION" (Nothing) - ("Okay, I'll let you set it up then!") - [ D.reflow "See for more."] - else do - progressPointer_ "Initialising git..." - callCommand $ "cd " <> root <> " && git init" - let gitAddRemoteCmd = "git remote add lamdera git@apps.lamdera.com:" <> appName <> ".git" - atomicPutStrLn $ "Adding remote: " <> gitAddRemoteCmd - callCommand $ "cd " <> root <> " && " <> gitAddRemoteCmd + status <- gitRepoStatus root + case status of + GitRepoDir -> pure () + GitRepoWorktree _ -> pure () + GitRepoWorktreeBroken reason -> + -- Don't offer `git init` here – that would clobber a worktree's `.git` file. + Progress.throw + $ Help.report "BROKEN GIT WORKTREE" (Nothing) + (reason) + [ D.reflow "This looks like a git worktree whose `.git` file is malformed or points to a git directory that no longer exists." + , D.reflow "Try re-creating the worktree, or run `git worktree repair` from the main checkout." + ] + GitRepoMissing -> do + appName <- getInput $ + D.vcat + [ "It looks like your project is missing a git repository!" + , "I can initialize it for you." + , "What is your Lamdera app name? [enter to skip]: " + ] + + if appName == "" + then do + Progress.throw + $ Help.report "SKIPPING GIT INITIALISATION" (Nothing) + ("Okay, I'll let you set it up then!") + [ D.reflow "See for more."] + else do + progressPointer_ "Initialising git..." + callCommand $ "cd " <> root <> " && git init" + let gitAddRemoteCmd = "git remote add lamdera git@apps.lamdera.com:" <> appName <> ".git" + atomicPutStrLn $ "Adding remote: " <> gitAddRemoteCmd + callCommand $ "cd " <> root <> " && " <> gitAddRemoteCmd genericExit :: String -> IO a diff --git a/extra/Lamdera/Init.hs b/extra/Lamdera/Init.hs index d252d06b..6fed3b2b 100644 --- a/extra/Lamdera/Init.hs +++ b/extra/Lamdera/Init.hs @@ -4,7 +4,6 @@ module Lamdera.Init where import System.FilePath (()) -import qualified System.Directory as Dir import NeatInterpolation import Lamdera @@ -22,7 +21,8 @@ writeDefaultImplementations = do else writeUtf8 (root filename) implementation ) writeLineIfMissing "elm-stuff" (root ".gitignore") - onlyWhen_ (fmap not $ Dir.doesDirectoryExist (root ".git")) $ do + status <- gitRepoStatus root + onlyWhen_ (status == GitRepoMissing) $ do Ext.Common.cq_ "git" ["init"] "" pure () diff --git a/test/Test/Check.hs b/test/Test/Check.hs index 0586d3d8..8264bd85 100644 --- a/test/Test/Check.hs +++ b/test/Test/Check.hs @@ -6,6 +6,7 @@ module Test.Check where import System.FilePath (()) import qualified System.Directory as Dir +import System.IO.Temp (withSystemTempDirectory) import qualified Data.Text as T import qualified Data.Map as Map import qualified Data.Set as Set @@ -193,6 +194,54 @@ suite = tests $ ,"bar : something" ,"bar =\n and bar too, including it's type sig\n"] (Lamdera.CLI.Check.extractTopLevelExpressions input) + + , scope "gitRepoStatus detects directories, worktrees, and broken pointers" $ do + + -- No `.git` at all -> safe to offer `git init` + missing <- io $ withSystemTempDirectory "lamdera-git-missing" $ \tmp -> + gitRepoStatus tmp + scope "no .git -> GitRepoMissing" $ expectEqual GitRepoMissing missing + + -- Normal clone: `.git` is a directory + normal <- io $ withSystemTempDirectory "lamdera-git-dir" $ \tmp -> do + Ext.Common.bash $ "cd " <> tmp <> " && git init -q" + gitRepoStatus tmp + scope ".git directory -> GitRepoDir" $ expectEqual GitRepoDir normal + + -- Worktree: `.git` is a file pointing at an existing gitdir + worktree <- io $ withSystemTempDirectory "lamdera-git-wt" $ \tmp -> do + let mainDir = tmp "main" + wtDir = tmp "wt" + Dir.createDirectoryIfMissing True mainDir + Ext.Common.bash $ "cd " <> mainDir + <> " && git init -q" + <> " && git config user.email test@example.com" + <> " && git config user.name test" + <> " && git commit -q --allow-empty -m init" + <> " && git worktree add -q " <> wtDir + gitRepoStatus wtDir + scope "worktree .git file -> GitRepoWorktree" $ + case worktree of + GitRepoWorktree _ -> ok + other -> crash $ "expected GitRepoWorktree, got " <> show other + + -- `.git` is a file but doesn't contain a `gitdir:` pointer + malformed <- io $ withSystemTempDirectory "lamdera-git-malformed" $ \tmp -> do + writeUtf8 (tmp ".git") "not a gitdir line\n" + gitRepoStatus tmp + scope "malformed .git file -> GitRepoWorktreeBroken" $ + case malformed of + GitRepoWorktreeBroken _ -> ok + other -> crash $ "expected GitRepoWorktreeBroken (malformed), got " <> show other + + -- `.git` file points at a gitdir that doesn't exist + dangling <- io $ withSystemTempDirectory "lamdera-git-dangling" $ \tmp -> do + writeUtf8 (tmp ".git") "gitdir: /no/such/git/dir\n" + gitRepoStatus tmp + scope "dangling gitdir pointer -> GitRepoWorktreeBroken" $ + case dangling of + GitRepoWorktreeBroken _ -> ok + other -> crash $ "expected GitRepoWorktreeBroken (dangling), got " <> show other ]