6ea4544 · obelisk · git.iko.soy

git.iko.soy/obelisk

on master help sign in

preserve initial project state by checking to see if branch exists before making changes

6ea4544hsloan8 years ago

lib/command/src/Obelisk/Command/Thunk.hs+21−8

compare with master

unifiedsplit

@@ -67,6 +67,7 @@ import GitHub

67import GitHub.Data.Name

68import Obelisk.Command.Nix

69import System.Directory

70+import System.Exit

70import System.FilePath

71import System.FilePath

71import System.IO.Error

72import System.IO.Error

72import System.IO.Temp

73import System.IO.Temp

@@ -629,14 +630,26 @@ setThunk = setThunk' False

629setThunk' :: MonadObelisk m => Bool -> String -> FilePath -> m ()

630setThunk' :: MonadObelisk m => Bool -> String -> FilePath -> m ()

630setThunk' noTrail branch thunkDir = checkThunkDirectory thunkDir >> readThunk thunkDir >>= \case

631setThunk' noTrail branch thunkDir = checkThunkDirectory thunkDir >> readThunk thunkDir >>= \case

631 Left err -> failWith $ T.pack $ "thunk set : " <> show err

632 Left err -> failWith $ T.pack $ "thunk set : " <> show err

632− Right (ThunkData_Packed _) -> do

633+ Right (ThunkData_Packed thunkptr) -> do

633− -- TODO: create a ThunkPtr from the branch name

634+ let thunkSrc = _thunkPtr_source thunkptr

635+ repository = case thunkSrc of

636+ ThunkSource_Git gitSource -> (T.unpack $ render $ _gitSource_url gitSource)

637+ ThunkSource_GitHub gitHubSource -> T.unpack $ "git@github.com:"

638+ <> (untagName $ _gitHubSource_owner gitHubSource)

639+ <> "/"

640+ <> (untagName $ _gitHubSource_repo gitHubSource)

641+ <> ".git"

642+ -- check to see if branch exists before modifying directory

643+ (exitCode, _) <- gitLsRemoteExitCode repository branch

644+ case exitCode of

645+ ExitSuccess -> do

634− _ <- unpackThunk' noTrail thunkDir

646+ _ <- unpackThunk' noTrail thunkDir

635− -- TODO: if git checkout branch errors out, the directory should be restored back to it's previous state

636− callProcessAndLogOutput (Debug, Error) $ gitProc thunkDir ["checkout", branch]

647+ callProcessAndLogOutput (Debug, Error) $ gitProc thunkDir ["checkout", branch]

637− _ <- packThunk' noTrail thunkDir

648+ _ <- packThunk' noTrail thunkDir

638− updateThunkToLatest thunkDir

649+ updateThunkToLatest thunkDir

639− -- TODO: use overwriteThunk thunkDir (someThunkPtr)

650+ ExitFailure errNum -> failWith $ T.pack $ if errNum == 2

651+ then "Error: branch not found"

652+ else ("Error Code: " <> show errNum <> "issue checking out the desired branch")

640 Right (ThunkData_Checkout _) -> do

653 Right (ThunkData_Checkout _) -> do

641 callProcessAndLogOutput (Debug, Error) $ gitProc thunkDir ["checkout", branch]

654 callProcessAndLogOutput (Debug, Error) $ gitProc thunkDir ["checkout", branch]

642 _ <- packThunk' noTrail thunkDir

655 _ <- packThunk' noTrail thunkDir

lib/command/src/Obelisk/Command/Utils.hs+16

@@ -22,6 +22,7 @@ import qualified Data.Text as T

22import Data.Void (Void)

23import System.Directory (canonicalizePath)

24import System.Environment (getExecutablePath)

25+import System.Exit (ExitCode)

25import qualified System.Process as P

26import qualified System.Process as P

26import Text.Megaparsec as MP

27import Text.Megaparsec as MP

27import Text.Megaparsec.Char as MP

28import Text.Megaparsec.Char as MP

@@ -130,6 +131,21 @@ gitLsRemote repository mRef = do

130 putLog Debug $ "git ls-remote maps: " <> T.pack (show maps)

131 putLog Debug $ "git ls-remote maps: " <> T.pack (show maps)

131 pure maps

132 pure maps

132

133

134+gitLsRemoteExitCode

135+ :: MonadObelisk m

136+ => String

137+ -> String

138+ -> m (ExitCode, GitLsRemoteMaps)

139+gitLsRemoteExitCode repository branchName = do

140+ (exitCode, out, _err) <- readCreateProcessWithExitCode $ gitProcNoRepo $

141+ ["ls-remote", "--exit-code", repository, branchName]

142+ let t = T.pack out

143+ maps <- case MP.runParser parseLsRemote "" t of

144+ Left err -> failWith $ T.pack $ MP.parseErrorPretty' t err

145+ Right table -> pure $ bimap M.fromList M.fromList $ partitionEithers $ table

146+ putLog Debug $ "git ls-remote maps: " <> T.pack (show maps)

147+ pure (exitCode, maps)

148+

133lexeme :: Parsec Void Text a -> Parsec Void Text a

149lexeme :: Parsec Void Text a -> Parsec Void Text a

134lexeme = ML.lexeme $ void $ MP.takeWhileP (Just "within-line white space") $

150lexeme = ML.lexeme $ void $ MP.takeWhileP (Just "within-line white space") $

135 flip elem [' ', '\t']

151 flip elem [' ', '\t']