c89afe3 · obelisk · git.iko.soy

git.iko.soy/obelisk

on master help sign in

Improve thunk repacking

c89afe3John Ericson8 years ago

lib/command/src/Obelisk/Command.hs+4−21

compare with master

unifiedsplit

@@ -181,7 +181,6 @@ deployInitOpts = DeployInitOpts

181 <*> strOption (long "route" <> metavar "PUBLICROUTE" <> help "Publicly accessible URL of your app")

182 <*> strOption (long "admin-email" <> metavar "ADMINEMAIL" <> help "Email address where administrative alerts will be sent")

183 <*> flag True False (long "disable-https" <> help "Disable automatic https configuration for the backend")

184− <*> strOption (long "upstream" <> value "origin" <> metavar "REMOTE" <> help "git remote to use for the src thunk" <> showDefault)

185

184

186type TeamID = String

185type TeamID = String

187data PlatformDeployment = Android | IOS TeamID

186data PlatformDeployment = Android | IOS TeamID

@@ -204,7 +203,6 @@ data DeployInitOpts = DeployInitOpts

204 , _deployInitOpts_route :: String

203 , _deployInitOpts_route :: String

205 , _deployInitOpts_adminEmail :: String

204 , _deployInitOpts_adminEmail :: String

206 , _deployInitOpts_enableHttps :: Bool

205 , _deployInitOpts_enableHttps :: Bool

207− , _deployInitOpts_remote :: String

208 }

206 }

209 deriving Show

207 deriving Show

210

208

@@ -226,32 +224,17 @@ thunkDirectoryParser = fmap (dropTrailingPathSeparator . normalise) . strArgumen

226 , help "Path to directory containing thunk data"

224 , help "Path to directory containing thunk data"

227 ]

225 ]

228

226

229−data ThunkPackOpts = ThunkPackOpts

230− { _thunkPackOpts_directory :: FilePath

231− , _thunkPackOpts_upstream :: String

232− }

233− deriving Show

234−

235data ThunkCommand

227data ThunkCommand

236 = ThunkCommand_Update [FilePath]

228 = ThunkCommand_Update [FilePath]

237 | ThunkCommand_Unpack [FilePath]

229 | ThunkCommand_Unpack [FilePath]

238− | ThunkCommand_Pack [ThunkPackOpts]

230+ | ThunkCommand_Pack [FilePath]

239 deriving Show

231 deriving Show

240

232

241−thunkPackOpts :: Parser ThunkPackOpts

242−thunkPackOpts = (ThunkPackOpts <$> thunkDirectoryParser <*>) . strOption $ mconcat

243− [ long "upstream"

244− , value "origin"

245− , metavar "REMOTE"

246− , help "Git remote that packed thunk will point to"

247− , showDefault

248− ]

249−

250thunkCommand :: Parser ThunkCommand

233thunkCommand :: Parser ThunkCommand

251thunkCommand = hsubparser $ mconcat

234thunkCommand = hsubparser $ mconcat

252 [ command "update" $ info (ThunkCommand_Update <$> some thunkDirectoryParser) $ progDesc "Update thunk to latest revision available"

235 [ command "update" $ info (ThunkCommand_Update <$> some thunkDirectoryParser) $ progDesc "Update thunk to latest revision available"

253 , command "unpack" $ info (ThunkCommand_Unpack <$> some thunkDirectoryParser) $ progDesc "Unpack thunk into git checkout of revision it points to"

236 , command "unpack" $ info (ThunkCommand_Unpack <$> some thunkDirectoryParser) $ progDesc "Unpack thunk into git checkout of revision it points to"

254− , command "pack" $ info (ThunkCommand_Pack <$> some thunkPackOpts) $ progDesc "Pack git checkout into thunk that points at given upstream"

237+ , command "pack" $ info (ThunkCommand_Pack <$> some thunkDirectoryParser) $ progDesc "Pack git checkout into thunk that points at the current branch's upstream"

255 ]

238 ]

256

239

257parserPrefs :: ParserPrefs

240parserPrefs :: ParserPrefs

@@ -402,7 +385,7 @@ ob = \case

402 Right (ThunkData_Packed ptr) -> return ptr

385 Right (ThunkData_Packed ptr) -> return ptr

403 Right (ThunkData_Checkout (Just ptr)) -> return ptr

386 Right (ThunkData_Checkout (Just ptr)) -> return ptr

404 Right (ThunkData_Checkout Nothing) ->

387 Right (ThunkData_Checkout Nothing) ->

405− getThunkPtr' False root (T.pack $ _deployInitOpts_remote deployOpts)

388+ getThunkPtr' False root

406 let sshKeyPath = _deployInitOpts_sshKey deployOpts

389 let sshKeyPath = _deployInitOpts_sshKey deployOpts

407 hostname = _deployInitOpts_hostname deployOpts

390 hostname = _deployInitOpts_hostname deployOpts

408 route = _deployInitOpts_route deployOpts

391 route = _deployInitOpts_route deployOpts

@@ -423,7 +406,7 @@ ob = \case

423 ObCommand_Thunk tc -> case tc of

406 ObCommand_Thunk tc -> case tc of

424 ThunkCommand_Update thunks -> mapM_ updateThunkToLatest thunks

407 ThunkCommand_Update thunks -> mapM_ updateThunkToLatest thunks

425 ThunkCommand_Unpack thunks -> mapM_ unpackThunk thunks

408 ThunkCommand_Unpack thunks -> mapM_ unpackThunk thunks

426− ThunkCommand_Pack thunks -> forM_ thunks $ \(ThunkPackOpts dir upstream) -> packThunk dir (T.pack upstream)

409+ ThunkCommand_Pack thunks -> forM_ thunks packThunk

427 ObCommand_Repl -> runRepl

410 ObCommand_Repl -> runRepl

428 ObCommand_Watch -> inNixShell' $ static runWatch

411 ObCommand_Watch -> inNixShell' $ static runWatch

429 ObCommand_Upgrade branch -> do

412 ObCommand_Upgrade branch -> do

lib/command/src/Obelisk/Command/Deploy.hs+1−1

@@ -113,7 +113,7 @@ deployPush deployPath getNixBuilders = do

113 checkGitCleanStatus srcPath True >>= \case

114 True -> do

115 result <- build

116− packThunk srcPath "origin" -- get upstream

116+ packThunk srcPath

117 return result

118 False -> do

119 _ <- failWith $ T.pack $ "ob deploy push: ensure " <> srcPath <> " has no pending changes and latest is pushed upstream."

lib/command/src/Obelisk/Command/Thunk.hs+111−72

@@ -33,6 +33,7 @@ module Obelisk.Command.Thunk

34import Control.Applicative

35import Control.Exception (displayException, throwIO, try)

36+import Control.Lens.Indexed hiding ((<.>))

36import Control.Monad

37import Control.Monad

37import Control.Monad.Catch (handle)

38import Control.Monad.Catch (handle)

38import Control.Monad.Except

39import Control.Monad.Except

@@ -49,6 +50,7 @@ import qualified Data.Git.Ref as Ref

49import qualified Data.List as L

50import qualified Data.List as L

50import Data.List.NonEmpty (NonEmpty (..))

51import Data.List.NonEmpty (NonEmpty (..))

51import qualified Data.List.NonEmpty as NonEmpty

52import qualified Data.List.NonEmpty as NonEmpty

53+import Data.Map (Map)

52import qualified Data.Map as Map

54import qualified Data.Map as Map

53import Data.Maybe

55import Data.Maybe

54import Data.Set (Set)

56import Data.Set (Set)

@@ -555,7 +557,7 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do

555 p' <- copyThunkToTmp tmpDir p

557 p' <- copyThunkToTmp tmpDir p

556 unpackThunk' True p'

558 unpackThunk' True p'

557 result <- f p'

559 result <- f p'

558− updateThunkFromTmp p' "origin" -- TODO: stop hardcoding remote

560+ updateThunkFromTmp p'

559 return result

561 return result

560 where

562 where

561 copyThunkToTmp tmpDir thunkDir = readThunk thunkDir >>= \case

563 copyThunkToTmp tmpDir thunkDir = readThunk thunkDir >>= \case

@@ -566,8 +568,8 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do

566 proc "cp" ["-r", "-T", thunkDir, tmpThunk]

568 proc "cp" ["-r", "-T", thunkDir, tmpThunk]

567 return tmpThunk

569 return tmpThunk

568 Right _ -> failWith $ "Thunk is not packed"

570 Right _ -> failWith $ "Thunk is not packed"

569− updateThunkFromTmp p' remote = do

571+ updateThunkFromTmp p' = do

570− packThunk' True p' remote

572+ packThunk' True p'

571 callProcessAndLogOutput (Notice, Error) $

573 callProcessAndLogOutput (Notice, Error) $

572 proc "cp" ["-r", "-T", p', p]

574 proc "cp" ["-r", "-T", p', p]

573

575

@@ -595,7 +597,7 @@ unpackThunk' noTrail thunkDir = readThunk thunkDir >>= \case

595 Just c -> return $ T.unpack $ getUrl c

597 Just c -> return $ T.unpack $ getUrl c

596

598

597 withSpinner' ("Fetching thunk " <> T.pack thunkDir)

599 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

599 callProcessAndLogOutput (Debug, Debug) $

601 callProcessAndLogOutput (Debug, Debug) $

600 proc "hub" ["clone", "-n", githubURI, tmpRepo]

602 proc "hub" ["clone", "-n", githubURI, tmpRepo]

601 --If this directory already exists then something is weird and we should fail

603 --If this directory already exists then something is weird and we should fail

@@ -641,86 +643,123 @@ unpackThunk' noTrail thunkDir = readThunk thunkDir >>= \case

641

643

642--TODO: add force mode to pack even if changes are present

644--TODO: add force mode to pack even if changes are present

643--TODO: add a rollback mode to pack to the original thunk

645--TODO: add a rollback mode to pack to the original thunk

644−packThunk :: MonadObelisk m => FilePath -> Text -> m ()

646+packThunk :: MonadObelisk m => FilePath -> m ()

645packThunk = packThunk' False

647packThunk = packThunk' False

646

648

647−packThunk' :: MonadObelisk m => Bool -> FilePath -> Text -> m ()

649+packThunk' :: MonadObelisk m => Bool -> FilePath -> m ()

648−packThunk' noTrail thunkDir upstream = readThunk thunkDir >>= \case

650+packThunk' noTrail thunkDir = readThunk thunkDir >>= \case

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

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

650 Right (ThunkData_Packed _) -> failWith "pack: thunk is already packed"

652 Right (ThunkData_Packed _) -> failWith "pack: thunk is already packed"

651 Right (ThunkData_Checkout _) -> do

653 Right (ThunkData_Checkout _) -> do

652 withSpinner' ("Packing thunk " <> T.pack thunkDir)

654 withSpinner' ("Packing thunk " <> T.pack thunkDir)

653 (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $ do

655 (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $ do

654− thunkPtr <- getThunkPtr thunkDir upstream

656+ thunkPtr <- getThunkPtr thunkDir

655 callProcessAndLogOutput (Debug, Error) $ proc "rm" ["-rf", thunkDir]

657 callProcessAndLogOutput (Debug, Error) $ proc "rm" ["-rf", thunkDir]

656 liftIO $ createThunk thunkDir thunkPtr

658 liftIO $ createThunk thunkDir thunkPtr

657

659

658−getThunkPtr :: MonadObelisk m => FilePath -> Text -> m ThunkPtr

660+getThunkPtr :: MonadObelisk m => FilePath -> m ThunkPtr

659getThunkPtr = getThunkPtr' True

661getThunkPtr = getThunkPtr' True

660

662

661−getThunkPtr' :: MonadObelisk m => Bool -> FilePath -> Text -> m ThunkPtr

663+getThunkPtr' :: forall m. MonadObelisk m => Bool -> FilePath -> m ThunkPtr

662−getThunkPtr' checkClean thunkDir upstream = do

664+getThunkPtr' checkClean thunkDir = do

663− when checkClean $ ensureCleanGitRepo thunkDir True $

665+ when checkClean $ ensureCleanGitRepo thunkDir True $

664− "thunk pack: thunk checkout contains unsaved modifications"

666+ "thunk pack: thunk checkout contains unsaved modifications"

665−

667+

666− -- Check whether there are any stashes

668+ -- Check whether there are any stashes

667− stashOutput <- readGitProcess thunkDir ["stash", "list"]

669+ stashOutput <- readGitProcess thunkDir ["stash", "list"]

668− when checkClean $ case T.null stashOutput of

670+ when checkClean $ case T.null stashOutput of

669− False -> do

671+ False -> do

670− failWith $ T.unlines $

672+ failWith $ T.unlines $

671− [ "thunk pack: thunk checkout has stashes"

673+ [ "thunk pack: thunk checkout has stashes"

672− , "git stash list:"

674+ , "git stash list:"

673− ] ++ T.lines stashOutput

675+ ] ++ T.lines stashOutput

674− True -> return ()

676+ True -> return ()

675−

677+

676− --Check whether all local heads are pushed

678+ -- Get information on all branches and their (optional) designated upstream

679+ -- correspondents

677− repoHeads <- T.lines <$> readGitProcess thunkDir ["for-each-ref", "--format=%(refname:short)", "refs/heads/"]

680+ (headDump :: [Text]) <- T.lines <$> readGitProcess thunkDir

678− remotes <- T.lines <$> readGitProcess thunkDir ["remote"]

681+ [ "for-each-ref"

679− --Check that the upstream specified actually exists

682+ , "--format=%(refname:short) %(upstream:short)"

680− case L.find (== upstream) remotes of

683+ , "refs/heads/"

681− Nothing -> failWith $ "thunk pack: upstream " <> upstream <> " does not exist. Available upstreams are " <> T.intercalate ", " remotes

684+ ]

682− Just _ -> return ()

685+ (headInfo :: Map Text (Maybe Text)) <- fmap Map.fromList $ forM headDump $ \line -> do

683− -- iterate over cartesian product

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

684− when checkClean $ forM_ repoHeads $ \hd -> do

700+ when checkClean $ do

685− [localRev] <- T.lines <$> readGitProcess thunkDir ["rev-parse", T.unpack hd]

701+ let untrackedBranches = Map.keys errorMap

686− forM_ remotes $ \rm -> do

702+ when (not $ L.null untrackedBranches) $ failWith $ T.unlines $

687− --TODO: The error you get if a branch isn't pushed anywhere could be made more user friendly

703+ [ "thunk pack: Certain branches in the thunk have no upstream branch \

688− [remoteMergeRev] <- fmap T.lines $ readGitProcess thunkDir

704+ \ set. This means don't know to check whether all your work is \

689− ["merge-base", T.unpack localRev, "remotes/" <> T.unpack rm <> "/" <> T.unpack hd]

705+ \ saved. The offending branches are:"

690− case remoteMergeRev == localRev of

706+ , ""

691− False -> failWith $ mconcat [ "thunk unpack: branch ", hd, " has not been pushed to ", rm ]

707+ , T.unwords untrackedBranches

692− True -> return ()

708+ , ""

693−

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+

694− --We assume it's safe to pack the thunk at this point

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+

695− [remoteUri'] <- fmap T.lines $ readGitProcess thunkDir ["config", "--get", "remote." <> T.unpack upstream <> ".url"]

753+ [remoteUri'] <- fmap T.lines $ readGitProcess thunkDir

696−

754+ [ "config"

755+ , "--get"

756+ , "remote." <> T.unpack remote <> ".url"

757+ ]

758+

759+ remoteUri <- case parseGitUri remoteUri' of

697− let uriParseFailure = "Could not identify git remote: " <> remoteUri'

760+ Nothing -> failWith $ "Could not identify git remote: " <> remoteUri'

698− mRemoteUri = parseGitUri remoteUri'

761+ Just uri -> pure uri

699− case mRemoteUri of

762+ uriThunkPtr remoteUri mCurrentBranch

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

724

763

725-- | Get the latest revision available from the given source

764-- | Get the latest revision available from the given source

726getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev

765getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev