66bf5a6 · obelisk · git.iko.soy

git.iko.soy/obelisk

on master help sign in

Merge pull request #308 from obsidiansystems/ob-thunk-set

66bf5a6Luigy Leon8 years ago

lib/command/obelisk-command.cabal+1

compare with master

unifiedsplit

@@ -19,6 +19,7 @@ library

19 , data-default

20 , directory

21 , either

22+ , errors

22 , filepath

23 , filepath

23 , github

24 , github

24 , here

25 , here

lib/command/src/Obelisk/Command.hs+3−3

@@ -208,14 +208,14 @@ thunkDirectoryParser = fmap (dropTrailingPathSeparator . normalise) . strArgumen

208 ]

209

210data ThunkCommand

211− = ThunkCommand_Update [FilePath]

211+ = ThunkCommand_Update [FilePath] (Maybe String)

212 | ThunkCommand_Unpack [FilePath]

213 | ThunkCommand_Pack [FilePath]

214 deriving Show

215

216thunkCommand :: Parser ThunkCommand

217thunkCommand = hsubparser $ mconcat

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

218+ [ command "update" $ info (ThunkCommand_Update <$> some thunkDirectoryParser <*> optional (strOption (long "branch" <> metavar "BRANCH"))) $ progDesc "Update thunk to latest revision available"

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

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

221 ]

@@ -342,7 +342,7 @@ ob = \case

342 ObCommand_Run -> inNixShell' $ static run

343 -- inNixShell ($(mkClosure 'ghcidAction) ())

344 ObCommand_Thunk tc -> case tc of

345− ThunkCommand_Update thunks -> mapM_ updateThunkToLatest thunks

345+ ThunkCommand_Update thunks mBranch -> mapM_ ((flip updateThunkToLatest) mBranch) thunks

346 ThunkCommand_Unpack thunks -> mapM_ unpackThunk thunks

347 ThunkCommand_Pack thunks -> forM_ thunks packThunk

348 ObCommand_Repl -> runRepl

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

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

159 callProcessAndLogOutput (Notice, Notice) p

160

161deployUpdate :: MonadObelisk m => FilePath -> m ()

162−deployUpdate deployPath = updateThunkToLatest $ deployPath </> "src"

162+deployUpdate deployPath = updateThunkToLatest (deployPath </> "src") Nothing

163

164keytoolToAndroidConfig :: KeytoolConfig -> HM.HashMap Text (NValueNF Identity)

165keytoolToAndroidConfig conf = runIdentity $ do

lib/command/src/Obelisk/Command/Thunk.hs+33−14

@@ -378,20 +378,38 @@ createThunkWithLatest target s = do

378 , _thunkPtr_rev = rev

379 }

380

381−updateThunkToLatest :: MonadObelisk m => FilePath -> m ()

381+updateThunkToLatest :: MonadObelisk m => FilePath -> Maybe String -> m ()

382−updateThunkToLatest target = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest") $ do

382+updateThunkToLatest target mBranch = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest") $ do

383 checkThunkDirectory "ob thunk update directory cannot be '.'" target

384+ -- check to see if thunk should be updated to a specific branch or just update it's current branch

385+ case mBranch of

386+ Nothing -> do

384− (overwrite, ptr) <- readThunk target >>= \case

387+ (overwrite, ptr) <- readThunk target >>= \case

385− Left err -> failWith $ T.pack $ "thunk update: " <> show err

388+ Left err -> failWith $ T.pack $ "thunk update: " <> show err

386− Right c -> case c of

389+ Right c -> case c of

387− ThunkData_Packed t -> return (target, t)

390+ ThunkData_Packed t -> return (target, t)

388− ThunkData_Checkout _ -> failWith "cannot update an unpacked thunk"

391+ ThunkData_Checkout _ -> failWith "cannot update an unpacked thunk"

389− let src = _thunkPtr_source ptr

392+ let src = _thunkPtr_source ptr

390− rev <- getLatestRev src

393+ rev <- getLatestRev src

391− overwriteThunk overwrite $ ThunkPtr

394+ overwriteThunk overwrite $ ThunkPtr

392− { _thunkPtr_source = src

395+ { _thunkPtr_source = src

393− , _thunkPtr_rev = rev

396+ , _thunkPtr_rev = rev

394− }

397+ }

398+ Just branch -> readThunk target >>= \case

399+ Left err -> failWith $ T.pack $ "thunk update: " <> show err

400+ Right c -> case c of

401+ ThunkData_Packed t -> case _thunkPtr_source t of

402+ ThunkSource_Git tsg -> setThunk target tsg branch

403+ ThunkSource_GitHub tsgh -> do

404+ let tsg = forgetGithub False tsgh

405+ setThunk target tsg branch

406+ ThunkData_Checkout _ -> failWith $ T.pack $ "thunk located at " <> (show target) <> " is unpacked. Use ob thunk pack on the desired directory and then try ob thunk update again."

407+

408+setThunk :: MonadObelisk m => FilePath -> GitSource -> String -> m ()

409+setThunk target gs branch = do

410+ newThunkPtr <- uriThunkPtr (_gitSource_url gs) (Just $ T.pack branch) Nothing

411+ overwriteThunk target newThunkPtr

412+ updateThunkToLatest target Nothing

395

413

396-- | All recognized github standalone loaders, ordered from newest to oldest.

414-- | All recognized github standalone loaders, ordered from newest to oldest.

397-- This tool will only ever produce the newest one when it writes a thunk.

415-- This tool will only ever produce the newest one when it writes a thunk.

@@ -878,9 +896,10 @@ gitThunkRev s commit = do

878gitGetCommitBranch

896gitGetCommitBranch

879 :: MonadObelisk m => URI -> Maybe Text -> m (Text, CommitId)

897 :: MonadObelisk m => URI -> Maybe Text -> m (Text, CommitId)

880gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote " <> uriMsg) $ do

898gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote " <> uriMsg) $ do

881− bothMaps <- gitLsRemote

899+ (_, bothMaps) <- gitLsRemote

882 (T.unpack $ render uri)

900 (T.unpack $ render uri)

883 (GitRef_Branch <$> mbranch)

901 (GitRef_Branch <$> mbranch)

902+ Nothing

884 branch <- case mbranch of

903 branch <- case mbranch of

885 Nothing -> withExitFailMessage "Failed to find default branch" $ do

904 Nothing -> withExitFailMessage "Failed to find default branch" $ do

886 b <- rethrowE $ gitLookupDefaultBranch bothMaps

905 b <- rethrowE $ gitLookupDefaultBranch bothMaps

lib/command/src/Obelisk/Command/Utils.hs+15−6

@@ -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

@@ -78,6 +79,9 @@ copyDir src dest =

78readGitProcess :: MonadObelisk m => FilePath -> [String] -> m Text

79readGitProcess :: MonadObelisk m => FilePath -> [String] -> m Text

79readGitProcess repo = readProcessAndLogOutput (Debug, Notice) . gitProc repo

80readGitProcess repo = readProcessAndLogOutput (Debug, Notice) . gitProc repo

82+readGitProcessNoRepo :: MonadObelisk m => [String] -> m Text

83+readGitProcessNoRepo = readProcessAndLogOutput (Debug, Notice) . gitProcNoRepo

84+

81processToShellString :: FilePath -> [String] -> String

85processToShellString :: FilePath -> [String] -> String

82processToShellString cmd args = unwords $ map quoteAndEscape (cmd : args)

86processToShellString cmd args = unwords $ map quoteAndEscape (cmd : args)

83 where quoteAndEscape x = T.unpack $ "'" <> T.replace "'" "'\''" (T.pack x) <> "'"

87 where quoteAndEscape x = T.unpack $ "'" <> T.replace "'" "'\''" (T.pack x) <> "'"

@@ -119,16 +123,21 @@ gitLsRemote

119 :: MonadObelisk m

123 :: MonadObelisk m

120 => String

124 => String

121 -> Maybe GitRef

125 -> Maybe GitRef

126+ -> Maybe String

122− -> m GitLsRemoteMaps

127+ -> m (ExitCode, GitLsRemoteMaps)

123−gitLsRemote repository mRef = do

128+gitLsRemote repository mRef mBranch = do

124− t <- readProc $ gitProcNoRepo $

129+ (exitCode, out, _err) <- case mBranch of

130+ Nothing -> readCreateProcessWithExitCode $ gitProcNoRepo $

125− ["ls-remote", "--symref", repository]

131+ ["ls-remote", "--exit-code", "--symref", repository]

126− ++ (maybeToList $ T.unpack . showGitRef <$> mRef)

132+ ++ (maybeToList $ T.unpack . showGitRef <$> mRef)

133+ Just branchName -> readCreateProcessWithExitCode $ gitProcNoRepo $

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

135+ let t = T.pack out

127 maps <- case MP.runParser parseLsRemote "" t of

136 maps <- case MP.runParser parseLsRemote "" t of

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

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

129 Right table -> pure $ bimap M.fromList M.fromList $ partitionEithers $ table

138 Right table -> pure $ bimap M.fromList M.fromList $ partitionEithers $ table

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

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

131− pure maps

140+ pure (exitCode, maps)

132

141

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

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

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

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

lib/selftest/src/Obelisk/SelfTest.hs+18−1

@@ -22,7 +22,7 @@ import qualified Network.HTTP.Client as HTTP

22import qualified Network.HTTP.Types as HTTP

23import qualified Network.Socket as Socket

24import Shelly

25−import System.Directory (withCurrentDirectory)

25+import System.Directory (withCurrentDirectory, getDirectoryContents)

26import System.Environment

27import System.Exit (ExitCode (..))

28import System.Info

@@ -213,6 +213,23 @@ main = do

213 void $ unpack

214 testThunkPack (dir </> thunk)

215

216+ describe "ob thunk update --branch" $ parallel $ do

217+ it "can change a thunk to the latest version of a desired branch" $ withTmp $ \dir -> do

218+ let branch1 = "master"

219+ branch2 = "develop"

220+ run_ "git" ["clone", "https://github.com/reflex-frp/reflex.git", toTextIgnore dir, "--branch", branch1]

221+ run_ "ob" ["thunk" , "pack", toTextIgnore dir]

222+ run_ "ob" ["thunk", "update", toTextIgnore dir, "--branch", branch2]

223+

224+ it "doesn't create anything when given an invalid branch" $ withTmp $ \dir -> do

225+ let checkDir dir' = liftIO $ getDirectoryContents $ T.unpack $ toTextIgnore dir'

226+ run_ "git" ["clone", "https://github.com/reflex-frp/reflex.git", toTextIgnore dir, "--branch", "master"]

227+ run_ "ob" ["thunk" , "pack", toTextIgnore dir]

228+ startingContents <- checkDir dir

229+ void $ errExit False $ run "ob" ["thunk", "update", toTextIgnore dir, "--branch", "dumble-palooza"]

230+ checkDir dir >>= liftIO . assertEqual "" startingContents

231+

232+

216-- | Run `ob run` in the given directory (maximum of one level deep)

233-- | Run `ob run` in the given directory (maximum of one level deep)

217testObRunInDir :: Socket.PortNumber -> Socket.PortNumber -> Maybe Shelly.FilePath -> HTTP.Manager -> Sh ()

234testObRunInDir :: Socket.PortNumber -> Socket.PortNumber -> Maybe Shelly.FilePath -> HTTP.Manager -> Sh ()

218testObRunInDir p0 p1 mdir httpManager = handle_sh (\case ExitSuccess -> pure (); e -> throw e) $ do

235testObRunInDir p0 p1 mdir httpManager = handle_sh (\case ExitSuccess -> pure (); e -> throw e) $ do