@@ -33,6 +33,7 @@ module Obelisk.Command.Thunk
3333
3434import Control.Applicative
3535import Control.Exception (displayException, throwIO, try)
36+import Control.Lens.Indexed hiding ((<.>))
3637import Control.Monad
3738import Control.Monad.Catch (handle)
3839import Control.Monad.Except
@@ -49,6 +50,7 @@ import qualified Data.Git.Ref as Ref
4950import qualified Data.List as L
5051import Data.List.NonEmpty (NonEmpty (..))
5152import qualified Data.List.NonEmpty as NonEmpty
53+import Data.Map (Map)
5254import qualified Data.Map as Map
5355import Data.Maybe
5456import Data.Set (Set)
@@ -555,7 +557,7 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
555557 p' <- copyThunkToTmp tmpDir p
556558 unpackThunk' True p'
557559 result <- f p'
558− updateThunkFromTmp p' "origin" -- TODO: stop hardcoding remote
560+ updateThunkFromTmp p'
559561 return result
560562 where
561563 copyThunkToTmp tmpDir thunkDir = readThunk thunkDir >>= \case
@@ -566,8 +568,8 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
566568 proc "cp" ["-r", "-T", thunkDir, tmpThunk]
567569 return tmpThunk
568570 Right _ -> failWith $ "Thunk is not packed"
569− updateThunkFromTmp p' remote = do
570− packThunk' True p' remote
571+ updateThunkFromTmp p' = do
572+ packThunk' True p'
571573 callProcessAndLogOutput (Notice, Error) $
572574 proc "cp" ["-r", "-T", p', p]
573575
@@ -595,7 +597,7 @@ unpackThunk' noTrail thunkDir = readThunk thunkDir >>= \case
595597 Just c -> return $ T.unpack $ getUrl c
596598
597599 withSpinner' ("Fetching thunk " <> T.pack thunkDir)
598− ( finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkDir) $ do
600+ (finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkDir) $ do
599601 callProcessAndLogOutput (Debug, Debug) $
600602 proc "hub" ["clone", "-n", githubURI, tmpRepo]
601603 --If this directory already exists then something is weird and we should fail
@@ -641,86 +643,123 @@ unpackThunk' noTrail thunkDir = readThunk thunkDir >>= \case
641643
642644--TODO: add force mode to pack even if changes are present
643645--TODO: add a rollback mode to pack to the original thunk
644−packThunk :: MonadObelisk m => FilePath -> Text -> m ()
646+packThunk :: MonadObelisk m => FilePath -> m ()
645647packThunk = packThunk' False
646648
647−packThunk' :: MonadObelisk m => Bool -> FilePath -> Text -> m ()
648−packThunk' noTrail thunkDir upstream = readThunk thunkDir >>= \case
649+packThunk' :: MonadObelisk m => Bool -> FilePath -> m ()
650+packThunk' noTrail thunkDir = readThunk thunkDir >>= \case
649651 Left err -> failWith $ T.pack $ "thunk pack: " <> show err
650652 Right (ThunkData_Packed _) -> failWith "pack: thunk is already packed"
651653 Right (ThunkData_Checkout _) -> do
652654 withSpinner' ("Packing thunk " <> T.pack thunkDir)
653655 (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $ do
654− thunkPtr <- getThunkPtr thunkDir upstream
656+ thunkPtr <- getThunkPtr thunkDir
655657 callProcessAndLogOutput (Debug, Error) $ proc "rm" ["-rf", thunkDir]
656658 liftIO $ createThunk thunkDir thunkPtr
657659
658−getThunkPtr :: MonadObelisk m => FilePath -> Text -> m ThunkPtr
660+getThunkPtr :: MonadObelisk m => FilePath -> m ThunkPtr
659661getThunkPtr = getThunkPtr' True
660662
661−getThunkPtr' :: MonadObelisk m => Bool -> FilePath -> Text -> m ThunkPtr
662−getThunkPtr' checkClean thunkDir upstream = do
663− when checkClean $ ensureCleanGitRepo thunkDir True $
664− "thunk pack: thunk checkout contains unsaved modifications"
665−
666− -- Check whether there are any stashes
667− stashOutput <- readGitProcess thunkDir ["stash", "list"]
668− when checkClean $ case T.null stashOutput of
669− False -> do
670− failWith $ T.unlines $
671− [ "thunk pack: thunk checkout has stashes"
672− , "git stash list:"
673− ] ++ T.lines stashOutput
674− True -> return ()
675−
676− --Check whether all local heads are pushed
677− repoHeads <- T.lines <$> readGitProcess thunkDir ["for-each-ref", "--format=%(refname:short)", "refs/heads/"]
678− remotes <- T.lines <$> readGitProcess thunkDir ["remote"]
679− --Check that the upstream specified actually exists
680− case L.find (== upstream) remotes of
681− Nothing -> failWith $ "thunk pack: upstream " <> upstream <> " does not exist. Available upstreams are " <> T.intercalate ", " remotes
682− Just _ -> return ()
683− -- iterate over cartesian product
684− when checkClean $ forM_ repoHeads $ \hd -> do
685− [localRev] <- T.lines <$> readGitProcess thunkDir ["rev-parse", T.unpack hd]
686− forM_ remotes $ \rm -> do
687− --TODO: The error you get if a branch isn't pushed anywhere could be made more user friendly
688− [remoteMergeRev] <- fmap T.lines $ readGitProcess thunkDir
689− ["merge-base", T.unpack localRev, "remotes/" <> T.unpack rm <> "/" <> T.unpack hd]
690− case remoteMergeRev == localRev of
691− False -> failWith $ mconcat [ "thunk unpack: branch ", hd, " has not been pushed to ", rm ]
692− True -> return ()
693−
694− --We assume it's safe to pack the thunk at this point
695− [remoteUri'] <- fmap T.lines $ readGitProcess thunkDir ["config", "--get", "remote." <> T.unpack upstream <> ".url"]
696−
697− let uriParseFailure = "Could not identify git remote: " <> remoteUri'
698− mRemoteUri = parseGitUri remoteUri'
699− case mRemoteUri of
700− Nothing -> failWith uriParseFailure
701− Just remoteUri -> do
702− refs <- fmap (map (refsToTuples . T.words) . T.lines) $ readGitProcess thunkDir ["show-ref", "--head"]
703− -- safe because exactly one hash is associated with HEAD
704− let Just currentHead = fst <$> L.find ((== "HEAD") . snd) refs
705− remoteHeads = Map.fromList $ catMaybes $ fmap
706− (\(x,y) -> (,) x <$> T.stripPrefix ("refs/remotes/" <> upstream <> "/") y)
707− refs
708− localHeads = Map.fromList $ catMaybes $ fmap
709− (\(x,y) -> (,) x <$> T.stripPrefix "refs/heads/" y)
710− refs
711− mCurrentUpstreamBranch = Map.lookup currentHead remoteHeads
712− <|> Map.lookup currentHead localHeads
713− let src = uriToThunkSource remoteUri mCurrentUpstreamBranch
714− rev <- case src of
715− ThunkSource_GitHub s -> githubThunkRev s currentHead
716− ThunkSource_Git s -> gitThunkRev s currentHead
717− pure $ ThunkPtr
718− { _thunkPtr_rev = rev
719− , _thunkPtr_source = src
720− }
721− where
722− refsToTuples [x, y] = (x, y)
723− refsToTuples x = error $ "thunk pack: cannot parse ref " <> show x
663+getThunkPtr' :: forall m. MonadObelisk m => Bool -> FilePath -> m ThunkPtr
664+getThunkPtr' checkClean thunkDir = do
665+ when checkClean $ ensureCleanGitRepo thunkDir True $
666+ "thunk pack: thunk checkout contains unsaved modifications"
667+
668+ -- Check whether there are any stashes
669+ stashOutput <- readGitProcess thunkDir ["stash", "list"]
670+ when checkClean $ case T.null stashOutput of
671+ False -> do
672+ failWith $ T.unlines $
673+ [ "thunk pack: thunk checkout has stashes"
674+ , "git stash list:"
675+ ] ++ T.lines stashOutput
676+ True -> return ()
677+
678+ -- Get information on all branches and their (optional) designated upstream
679+ -- correspondents
680+ (headDump :: [Text]) <- T.lines <$> readGitProcess thunkDir
681+ [ "for-each-ref"
682+ , "--format=%(refname:short) %(upstream:short)"
683+ , "refs/heads/"
684+ ]
685+ (headInfo :: Map Text (Maybe Text)) <- fmap Map.fromList $ forM headDump $ \line -> do
686+ (branch : restOfLine) <- pure $ T.words line
687+ mUpstream <- case restOfLine of
688+ [] -> pure Nothing
689+ [u] -> pure $ Just u
690+ (_:_) -> failWith "git for-each-ref invalid output"
691+ pure (branch, mUpstream)
692+
693+ let errorMap :: Map Text ()
694+ headUpstream :: Map Text Text
695+ (errorMap, headUpstream) = flip Map.mapEither headInfo $ \case
696+ Nothing -> Left ()
697+ Just b -> Right b
698+
699+ -- Check that every branch has a remote equivalent
700+ when checkClean $ do
701+ let untrackedBranches = Map.keys errorMap
702+ when (not $ L.null untrackedBranches) $ failWith $ T.unlines $
703+ [ "thunk pack: Certain branches in the thunk have no upstream branch \
704+ \ set. This means don't know to check whether all your work is \
705+ \ saved. The offending branches are:"
706+ , ""
707+ , T.unwords untrackedBranches
708+ , ""
709+ , "To fix this, you probably want to do:"
710+ , ""
711+ ] ++
712+ ((\branch -> "git push -u origin " <> branch) <$> untrackedBranches) ++
713+ [ ""
714+ , "These will push the branches to the default remote under the same \
715+ \ name, and (thanks to the `-u`) remember that choice so you don't \
716+ \ get this error again."
717+ ]
718+
719+ -- loosely by https://stackoverflow.com/questions/7773939/show-git-ahead-and-behind-info-for-all-branches-including-remotes
720+ stats <- iforM headUpstream $ \branch upstream -> do
721+ (stat :: [Text]) <- T.lines <$> readGitProcess thunkDir
722+ [ "rev-list", "--left-right"
723+ , T.unpack branch <> "..." <> T.unpack upstream
724+ ]
725+ let ahead = length $ [ () | Just ('<', _) <- T.uncons <$> stat ]
726+ behind = length $ [ () | Just ('>', _) <- T.uncons <$> stat ]
727+ pure (upstream, (ahead, behind))
728+
729+ -- Those branches which have commits ahead of, i.e. not on, the upstream
730+ -- branch. Purely being behind is fine.
731+ let nonGood = Map.filter ((/= 0) . fst . snd) stats
732+
733+ when (not $ Map.null nonGood) $ failWith $ T.unlines $
734+ [ "thunk pack: Certain branches in the thunk have commits not yet pushed upstream:"
735+ , ""
736+ ] ++
737+ (flip map (Map.toList nonGood) $ \(branch, (upstream, (ahead, behind))) -> mconcat
738+ [" ", branch, " ahead: ", T.pack (show ahead), " behind: ", T.pack (show behind), " remote branch ", upstream]) ++
739+ [ ""
740+ , "Please push these upstream and try again."
741+ ]
742+
743+ -- We assume it's safe to pack the thunk at this point
744+
745+ -- Get current branch `git rev-parse --abbrev-ref HEAD`
746+ mCurrentBranch <- listToMaybe
747+ <$> T.lines
748+ <$> readGitProcess thunkDir ["rev-parse", "--abbrev-ref", "HEAD"]
749+
750+ let remote = maybe "origin" id $
751+ flip Map.lookup headUpstream =<< mCurrentBranch
752+
753+ [remoteUri'] <- fmap T.lines $ readGitProcess thunkDir
754+ [ "config"
755+ , "--get"
756+ , "remote." <> T.unpack remote <> ".url"
757+ ]
758+
759+ remoteUri <- case parseGitUri remoteUri' of
760+ Nothing -> failWith $ "Could not identify git remote: " <> remoteUri'
761+ Just uri -> pure uri
762+ uriThunkPtr remoteUri mCurrentBranch
724763
725764-- | Get the latest revision available from the given source
726765getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev