git.iko.soy/obelisk
on master help sign in
Fix a number of bugs, Text <-> String round trips, and log more
88a153bJohn Ericson
lib/command/src/Obelisk/Command/Thunk.hs+35−25
compare with master
unifiedsplit
@@ -158,16 +158,16 @@ getNixSha256ForUriUnpacked
158 => URI
158 => URI
159 -> m NixSha256
159 -> m NixSha256
160getNixSha256ForUriUnpacked uri =
160getNixSha256ForUriUnpacked uri =
161− withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> T.pack (show uri)) $ do
161+ withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> render uri) $ do
162− withNixRemoteCheck $ readProcessAndLogStderr Debug $
162+ withNixRemoteCheck $ readProcessAndLogOutput (Debug, Debug) $
163− proc "nix-prefetch-url" ["--unpack" , "--type" , "sha256" , show uri]
163+ proc "nix-prefetch-url" ["--unpack" , "--type" , "sha256" , T.unpack $ render uri]
164
164
165nixPrefetchGit :: MonadObelisk m => URI -> Text -> Bool -> m NixSha256
165nixPrefetchGit :: MonadObelisk m => URI -> Text -> Bool -> m NixSha256
166nixPrefetchGit uri rev fetchSubmodules =
166nixPrefetchGit uri rev fetchSubmodules =
167− withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> T.pack (show uri) <> " at " <> rev) $ do
167+ withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> render uri <> " at " <> rev) $ do
168 out <- withNixRemoteCheck $ readProcessAndLogStderr Debug $
168 out <- withNixRemoteCheck $ readProcessAndLogStderr Debug $
169 proc "nix-prefetch-git" $ filter (/="")
169 proc "nix-prefetch-git" $ filter (/="")
170− [ "--url", show uri
170+ [ "--url", T.unpack $ render uri
171 , "--rev", T.unpack rev
171 , "--rev", T.unpack rev
172 , if fetchSubmodules then "--fetch-submodules" else ""
172 , if fetchSubmodules then "--fetch-submodules" else ""
173 , "--quiet"
173 , "--quiet"
@@ -578,7 +578,9 @@ unpackThunk' noTrail thunkDir = readThunk thunkDir >>= \case
578 withSpinner' ("Fetching thunk " <> T.pack thunkName)
578 withSpinner' ("Fetching thunk " <> T.pack thunkName)
579 (finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkName) $ do
579 (finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkName) $ do
580 let git = callProcessAndLogOutput (Notice, Notice) . gitProc tmpRepo
580 let git = callProcessAndLogOutput (Notice, Notice) . gitProc tmpRepo
581− git ["clone", if _gitSource_fetchSubmodules s then "--recursive" else "", show (_gitSource_url s)]
581+ git $ [ "clone" ]
582+ ++ ("--recursive" <$ guard (_gitSource_fetchSubmodules s))
583+ ++ [ T.unpack $ render $ _gitSource_url s ]
582 git ["reset", "--hard", Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr]
584 git ["reset", "--hard", Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr]
583 when (_gitSource_fetchSubmodules s) $
585 when (_gitSource_fetchSubmodules s) $
584 git ["submodule", "update", "--recursive", "--init"]
586 git ["submodule", "update", "--recursive", "--init"]
@@ -632,23 +634,29 @@ getThunkPtr' checkClean thunkDir = do
632 -- correspondents
634 -- correspondents
633 (headDump :: [Text]) <- T.lines <$> readGitProcess thunkDir
635 (headDump :: [Text]) <- T.lines <$> readGitProcess thunkDir
634 [ "for-each-ref"
636 [ "for-each-ref"
635− , "--format=%(refname:short) %(upstream:short)"
637+ , "--format=%(refname:short) %(upstream:short) %(upstream:remotename)"
636 , "refs/heads/"
638 , "refs/heads/"
637 ]
639 ]
640+
641+ (headInfo :: Map Text (Maybe (Text, Text)))
638− (headInfo :: Map Text (Maybe Text)) <- fmap Map.fromList $ forM headDump $ \line -> do
642+ <- fmap Map.fromList $ forM headDump $ \line -> do
639− (branch : restOfLine) <- pure $ T.words line
643+ (branch : restOfLine) <- pure $ T.words line
640− mUpstream <- case restOfLine of
644+ mUpstream <- case restOfLine of
641− [] -> pure Nothing
645+ [] -> pure Nothing
642− [u] -> pure $ Just u
646+ [u, r] -> pure $ Just (u, r)
643− (_:_) -> failWith "git for-each-ref invalid output"
647+ (_:_) -> failWith "git for-each-ref invalid output"
644− pure (branch, mUpstream)
648+ pure (branch, mUpstream)
649+
650+ putLog Debug $ "branches: " <> T.pack (show headInfo)
645
651
646 let errorMap :: Map Text ()
652 let errorMap :: Map Text ()
647− headUpstream :: Map Text Text
653+ headUpstream :: Map Text (Text, Text)
648 (errorMap, headUpstream) = flip Map.mapEither headInfo $ \case
654 (errorMap, headUpstream) = flip Map.mapEither headInfo $ \case
649 Nothing -> Left ()
655 Nothing -> Left ()
650 Just b -> Right b
656 Just b -> Right b
651
657
658+ putLog Debug $ "branches with upstream branch set: " <> T.pack (show headUpstream)
659+
652 -- Check that every branch has a remote equivalent
660 -- Check that every branch has a remote equivalent
653 when checkClean $ do
661 when checkClean $ do
654 let untrackedBranches = Map.keys errorMap
662 let untrackedBranches = Map.keys errorMap
@@ -670,7 +678,7 @@ getThunkPtr' checkClean thunkDir = do
670 ]
678 ]
671
679
672 -- loosely by https://stackoverflow.com/questions/7773939/show-git-ahead-and-behind-info-for-all-branches-including-remotes
680 -- loosely by https://stackoverflow.com/questions/7773939/show-git-ahead-and-behind-info-for-all-branches-including-remotes
673− stats <- iforM headUpstream $ \branch upstream -> do
681+ stats <- iforM headUpstream $ \branch (upstream, _remote) -> do
674 (stat :: [Text]) <- T.lines <$> readGitProcess thunkDir
682 (stat :: [Text]) <- T.lines <$> readGitProcess thunkDir
675 [ "rev-list", "--left-right"
683 [ "rev-list", "--left-right"
676 , T.unpack branch <> "..." <> T.unpack upstream
684 , T.unpack branch <> "..." <> T.unpack upstream
@@ -695,13 +703,12 @@ getThunkPtr' checkClean thunkDir = do
695
703
696 -- We assume it's safe to pack the thunk at this point
704 -- We assume it's safe to pack the thunk at this point
697
705
698− -- Get current branch `git rev-parse --abbrev-ref HEAD`
706+ -- Get current branch ``
699 mCurrentBranch <- listToMaybe
707 mCurrentBranch <- listToMaybe
700 <$> T.lines
708 <$> T.lines
701 <$> readGitProcess thunkDir ["rev-parse", "--abbrev-ref", "HEAD"]
709 <$> readGitProcess thunkDir ["rev-parse", "--abbrev-ref", "HEAD"]
702
710
703− let remote = maybe "origin" id $
704− flip Map.lookup headUpstream =<< mCurrentBranch
711+ let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch
705
712
706 [remoteUri'] <- fmap T.lines $ readGitProcess thunkDir
713 [remoteUri'] <- fmap T.lines $ readGitProcess thunkDir
707 [ "config"
714 [ "config"
@@ -740,9 +747,10 @@ uriThunkPtr uri mbranch = do
740 case rev of
747 case rev of
741 Right r -> pure (ThunkSource_GitHub s, r)
748 Right r -> pure (ThunkSource_GitHub s, r)
742 Left e -> do
749 Left e -> do
743− putLog Alert $ " \
750+ putLog Warning $ " \
744−\ Failed to fetch archive from GitHub. This is probably a private repo. \
751+\Failed to fetch archive from GitHub. This is probably a private repo. \
745−\ Falling back on normal fetchgit. Original failure:\n\n" <> T.pack (show e)
752+\Falling back on normal fetchgit. Original failure:\n\n"
753+ errorToWarning e
746 let s' = forgetGithub s
754 let s' = forgetGithub s
747 (,) (ThunkSource_Git s') <$> gitThunkRev s' commit
755 (,) (ThunkSource_Git s') <$> gitThunkRev s' commit
748 ThunkSource_Git s -> (,) (ThunkSource_Git s) <$> gitThunkRev s commit
756 ThunkSource_Git s -> (,) (ThunkSource_Git s) <$> gitThunkRev s commit
@@ -846,7 +854,9 @@ gitThunkRev s commit = do
846gitGetCommitBranch
854gitGetCommitBranch
847 :: MonadObelisk m => URI -> Maybe Text -> m (Text, CommitId)
855 :: MonadObelisk m => URI -> Maybe Text -> m (Text, CommitId)
848gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote " <> uriMsg) $ do
856gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote " <> uriMsg) $ do
857+ bothMaps <- gitLsRemote
858+ (T.unpack $ render uri)
849− bothMaps <- rethrowE =<< liftIO (gitLsRemote (show uri) (GitRef_Branch <$> mbranch))
859+ (GitRef_Branch <$> mbranch)
850 branch <- case mbranch of
860 branch <- case mbranch of
851 Nothing -> withExitFailMessage "Failed to find default branch" $ do
861 Nothing -> withExitFailMessage "Failed to find default branch" $ do
852 b <- rethrowE $ gitLookupDefaultBranch bothMaps
862 b <- rethrowE $ gitLookupDefaultBranch bothMaps
@@ -860,10 +870,10 @@ gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote "
860 pure (branch, commit)
870 pure (branch, commit)
861 where
871 where
862 rethrowE = either failWith pure
872 rethrowE = either failWith pure
863− uriMsg = T.pack $ show uri
873+ uriMsg = render uri
864
874
865parseGitUri :: Text -> Maybe URI
875parseGitUri :: Text -> Maybe URI
866−parseGitUri x = mkURI x <|> parseSshShorthand x
876+parseGitUri x = parseSshShorthand x <|> mkURI x
867
877
868parseSshShorthand :: Text -> Maybe URI
878parseSshShorthand :: Text -> Maybe URI
869parseSshShorthand uri = do
879parseSshShorthand uri = do
lib/command/src/Obelisk/Command/Utils.hs+21−19
@@ -60,9 +60,11 @@ initGit repo = do
60 git ["add", "."]
60 git ["add", "."]
61 git ["commit", "-m", "Initial commit."]
61 git ["commit", "-m", "Initial commit."]
62
62
63+gitProcNoRepo :: [String] -> P.CreateProcess
64+gitProcNoRepo = P.proc "git"
65+
63gitProc :: FilePath -> [String] -> P.CreateProcess
66gitProc :: FilePath -> [String] -> P.CreateProcess
64−gitProc repo argsRaw =
67+gitProc repo = gitProcNoRepo . runGitInDir
65− P.proc "git" $ runGitInDir argsRaw
66 where
68 where
67 runGitInDir args' = case filter (not . null) args' of
69 runGitInDir args' = case filter (not . null) args' of
68 args@("clone":_) -> args <> [repo]
70 args@("clone":_) -> args <> [repo]
@@ -74,7 +76,7 @@ copyDir src dest =
74 (P.proc "cp" ["-a", ".", dest]) { P.cwd = Just src }
76 (P.proc "cp" ["-a", ".", dest]) { P.cwd = Just src }
75
77
76readGitProcess :: MonadObelisk m => FilePath -> [String] -> m Text
78readGitProcess :: MonadObelisk m => FilePath -> [String] -> m Text
77−readGitProcess repo = readProcessAndLogStderr Notice . gitProc repo
79+readGitProcess repo = readProcessAndLogOutput (Debug, Notice) . gitProc repo
78
80
79processToShellString :: FilePath -> [String] -> String
81processToShellString :: FilePath -> [String] -> String
80processToShellString cmd args = unwords $ map quoteAndEscape (cmd : args)
82processToShellString cmd args = unwords $ map quoteAndEscape (cmd : args)
@@ -90,7 +92,7 @@ runProcSilently = callProcessAndLogOutput (Debug, Debug)
90
92
91-- | A simpler wrapper for CliApp's readProcessAndLogStderr with sensible defaults.
93-- | A simpler wrapper for CliApp's readProcessAndLogStderr with sensible defaults.
92readProc :: MonadObelisk m => P.CreateProcess -> m Text
94readProc :: MonadObelisk m => P.CreateProcess -> m Text
93−readProc = readProcessAndLogStderr Error
95+readProc = readProcessAndLogOutput (Debug, Error)
94
96
95tshow :: Show a => a -> Text
97tshow :: Show a => a -> Text
96tshow = T.pack . show
98tshow = T.pack . show
@@ -111,21 +113,22 @@ gitLookupDefaultBranch (refs, _) = do
111gitLookupCommitForRef :: GitLsRemoteMaps -> GitRef -> Either Text CommitId
113gitLookupCommitForRef :: GitLsRemoteMaps -> GitRef -> Either Text CommitId
112gitLookupCommitForRef (_, commits) ref = case M.lookup ref commits of
114gitLookupCommitForRef (_, commits) ref = case M.lookup ref commits of
113 Just a -> pure a
115 Just a -> pure a
114− Nothing -> throwError $ "Did not find commit for" <> showGitRef ref
116+ Nothing -> throwError $ "Did not find commit for " <> showGitRef ref
115
117
116gitLsRemote
118gitLsRemote
119+ :: MonadObelisk m
117− :: String
120+ => String
118 -> Maybe GitRef
121 -> Maybe GitRef
119− -> IO (Either Text GitLsRemoteMaps)
122+ -> m GitLsRemoteMaps
120gitLsRemote repository mRef = do
123gitLsRemote repository mRef = do
121− res <- P.readProcess "git"
124+ t <- readProc $ gitProcNoRepo $
122− (["ls-remote", "--symref", repository]
125+ ["ls-remote", "--symref", repository]
123− ++ (maybeToList $ T.unpack . showGitRef <$> mRef))
126+ ++ (maybeToList $ T.unpack . showGitRef <$> mRef)
124− mempty
127+ maps <- case MP.runParser parseLsRemote "" t of
125− let t = T.pack res
126− return $ first (T.pack . MP.parseErrorPretty' t)
128+ Left err -> failWith $ T.pack $ MP.parseErrorPretty' t err
127− $ bimap M.fromList M.fromList . partitionEithers
129+ Right table -> pure $ bimap M.fromList M.fromList $ partitionEithers $ table
128− <$> MP.runParser (many parseLsRemote) "" t
130+ putLog Debug $ "git ls-remote maps: " <> T.pack (show maps)
131+ pure maps
129
132
130lexeme :: Parsec Void Text a -> Parsec Void Text a
133lexeme :: Parsec Void Text a -> Parsec Void Text a
131lexeme = ML.lexeme space
134lexeme = ML.lexeme space
@@ -133,8 +136,9 @@ lexeme = ML.lexeme space
133-- $ git ls-remote --symref git@github.com:obsidiansystems/obelisk.git HEAD
136-- $ git ls-remote --symref git@github.com:obsidiansystems/obelisk.git HEAD
134-- ref: refs/heads/master HEAD
137-- ref: refs/heads/master HEAD
135-- d0a8d25dc93f0acd096bc4ff2f550da9e2d0c8f5 refs/heads/master
138-- d0a8d25dc93f0acd096bc4ff2f550da9e2d0c8f5 refs/heads/master
136−parseLsRemote :: Parsec Void Text (Either (GitRef, GitRef) (GitRef, CommitId))
139+parseLsRemote :: Parsec Void Text [Either (GitRef, GitRef) (GitRef, CommitId)]
140+parseLsRemote =
137−parseLsRemote = try $ fmap Left parseRef <|> fmap Right parseCommit
141+ many ((fmap Left (try parseRef) <|> fmap Right parseCommit) <* try MP.eol) <* MP.eof
138 where
142 where
139 parseRef :: Parsec Void Text (GitRef, GitRef)
143 parseRef :: Parsec Void Text (GitRef, GitRef)
140 parseRef = do
144 parseRef = do
@@ -143,7 +147,6 @@ parseLsRemote = try $ fmap Left parseRef <|> fmap Right parseCommit
143 $ not . isSpace
147 $ not . isSpace
144 symbolicRef <- lexeme $ MP.takeWhileP (Just "symbolic ref")
148 symbolicRef <- lexeme $ MP.takeWhileP (Just "symbolic ref")
145 $ not . isSpace
149 $ not . isSpace
146− _ <- MP.eol
147 return (toGitRef symbolicRef, toGitRef ref)
150 return (toGitRef symbolicRef, toGitRef ref)
148 parseCommit :: Parsec Void Text (GitRef, CommitId)
151 parseCommit :: Parsec Void Text (GitRef, CommitId)
149 parseCommit = do
152 parseCommit = do
@@ -151,7 +154,6 @@ parseLsRemote = try $ fmap Left parseRef <|> fmap Right parseCommit
151 $ not . isSpace
154 $ not . isSpace
152 ref <- lexeme $ MP.takeWhileP (Just "ref")
155 ref <- lexeme $ MP.takeWhileP (Just "ref")
153 $ not . isSpace
156 $ not . isSpace
154− _ <- MP.eol
155 return (toGitRef ref, commitId)
157 return (toGitRef ref, commitId)
156
158
157data GitRef
159data GitRef