b0ecb34 · obelisk · git.iko.soy

git.iko.soy/obelisk

Merge pull request #700 from obsidiansystems/ts-fix-init-unpack-bug

b0ecb34Elliot Cameron6 years ago

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

@@ -93,16 +93,22 @@ initProject source force = withSystemTempDirectory "ob-init" $ \tmpDir -> do

93 | otherwise -> failWith "ob init requires an empty directory. Use the flag --force to init anyway, potentially overwriting files."

94 skeleton <- withSpinner "Setting up obelisk" $ do

95 liftIO $ createDirectory obDir

96+ -- Clone the git source and repack it with the init source obelisk

97+ -- The purpose of this is to ensure we use the correct thunk spec.

98+ let cloneAndRepack src = do

99+ putLog Debug $ "Cloning obelisk into " <> T.pack implDir <> " and repacking using itself"

100+ commit <- getLatestRev src

101+ gitCloneForThunkUnpack (thunkSourceToGitSource src) (_thunkRev_commit commit) implDir

102+ callHandoffOb implDir ["thunk", "pack", implDir]

96 case source of

103 case source of

97− InitSource_Default -> createThunkWithLatest implDir obeliskSource

104+ InitSource_Default -> cloneAndRepack obeliskSource

98− InitSource_Branch branch -> createThunkWithLatest implDir $ obeliskSourceWithBranch branch

105+ InitSource_Branch branch -> cloneAndRepack $ obeliskSourceWithBranch branch

99 InitSource_Symlink path -> do

106 InitSource_Symlink path -> do

100 let symlinkPath = if isAbsolute path

107 let symlinkPath = if isAbsolute path

101 then path

108 then path

102 else ".." </> path

109 else ".." </> path

103 liftIO $ createSymbolicLink symlinkPath implDir

110 liftIO $ createSymbolicLink symlinkPath implDir

104 _ <- nixBuildAttrWithCache implDir "command"

111 _ <- nixBuildAttrWithCache implDir "command"

105− --TODO: We should probably handoff to the impl here

106 skel <- nixBuildAttrWithCache implDir "skeleton" --TODO: I don't think there's actually any reason to cache this

112 skel <- nixBuildAttrWithCache implDir "skeleton" --TODO: I don't think there's actually any reason to cache this

107

113

108 callProcessAndLogOutput (Notice, Error) $

114 callProcessAndLogOutput (Notice, Error) $

@@ -128,6 +134,24 @@ initProject source force = withSystemTempDirectory "ob-init" $ \tmpDir -> do

128 createDirectoryIfMissing False configDir

134 createDirectoryIfMissing False configDir

129 mapM_ (createDirectoryIfMissing False . (configDir </>)) ["backend", "common", "frontend"]

135 mapM_ (createDirectoryIfMissing False . (configDir </>)) ["backend", "common", "frontend"]

130

136

137+callHandoffOb

138+ :: MonadObelisk m

139+ => FilePath -- ^ Directory of the obelisk we want to handoff to

140+ -> [String] -- ^ Arguments to pass to ob

141+ -> m ()

142+callHandoffOb dir args = do

143+ obeliskCommandPkg <- nixCmd $ NixCmd_Build $ def

144+ & nixBuildConfig_outLink .~ OutLink_None

145+ & nixCmdConfig_target .~ Target

146+ { _target_path = Just dir

147+ , _target_attr = Just "command"

148+ , _target_expr = Nothing

149+ }

150+ let impl = obeliskCommandPkg </> "bin" </> "ob"

151+ -- Invoke the real implementation, using --no-handoff to prevent infinite recursion

152+ putLog Debug $ "Running '" <> T.pack (unwords args) <> "' with " <> T.pack impl

153+ callProcessAndLogOutput (Debug, Warning) (proc impl ("--no-handoff" : args))

154+

131--TODO: Allow the user to ignore our security concerns

155--TODO: Allow the user to ignore our security concerns

132-- | Find the Obelisk implementation for the project at the given path

156-- | Find the Obelisk implementation for the project at the given path

133findProjectObeliskCommand :: MonadObelisk m => FilePath -> m (Maybe FilePath)

157findProjectObeliskCommand :: MonadObelisk m => FilePath -> m (Maybe FilePath)

lib/command/src/Obelisk/Command/Thunk.hs+28−20

@@ -93,6 +93,11 @@ data ThunkSource

93 | ThunkSource_Git GitSource

94 deriving (Show, Eq, Ord)

96+thunkSourceToGitSource :: ThunkSource -> GitSource

97+thunkSourceToGitSource = \case

98+ ThunkSource_GitHub s -> forgetGithub False s

99+ ThunkSource_Git s -> s

100+

96data GitHubSource = GitHubSource

101data GitHubSource = GitHubSource

97 { _gitHubSource_owner :: Name Owner

102 { _gitHubSource_owner :: Name Owner

98 , _gitHubSource_repo :: Name Repo

103 , _gitHubSource_repo :: Name Repo

@@ -463,11 +468,7 @@ updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = spinner $ d

463 Just branch -> readThunk target >>= \case

468 Just branch -> readThunk target >>= \case

464 Left err -> failWith [i|Thunk update: ${err}|]

469 Left err -> failWith [i|Thunk update: ${err}|]

465 Right c -> case c of

470 Right c -> case c of

466− ThunkData_Packed _ t -> case _thunkPtr_source t of

471+ ThunkData_Packed _ t -> setThunk thunkConfig target (thunkSourceToGitSource $ _thunkPtr_source t) branch

467− ThunkSource_Git tsg -> setThunk thunkConfig target tsg branch

468− ThunkSource_GitHub tsgh -> do

469− let tsg = forgetGithub False tsgh

470− setThunk thunkConfig target tsg branch

471 ThunkData_Checkout -> failWith [i|Thunk located at ${target} is unpacked. Use 'ob thunk pack' on the desired directory and then try 'ob thunk update' again.|]

472 ThunkData_Checkout -> failWith [i|Thunk located at ${target} is unpacked. Use 'ob thunk pack' on the desired directory and then try 'ob thunk update' again.|]

472 where

473 where

473 spinner = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest")

474 spinner = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest")

@@ -798,20 +799,13 @@ unpackThunk' noTrail thunkDir = checkThunkDirectory thunkDir *> readThunk thunkD

798 let (thunkParent, thunkName) = splitFileName thunkDir

799 let (thunkParent, thunkName) = splitFileName thunkDir

799 withTempDirectory thunkParent thunkName $ \tmpThunk -> do

800 withTempDirectory thunkParent thunkName $ \tmpThunk -> do

800 let

801 let

802+ gitSrc = thunkSourceToGitSource $ _thunkPtr_source tptr

801− (gitSrc, newSpec) = case _thunkPtr_source tptr of

803+ newSpec = case _thunkPtr_source tptr of

802− ThunkSource_GitHub s' -> (forgetGithub False s', NonEmpty.head gitHubThunkSpecs)

804+ ThunkSource_GitHub _ -> NonEmpty.head gitHubThunkSpecs

803− ThunkSource_Git s' -> (s', NonEmpty.head gitThunkSpecs)

805+ ThunkSource_Git _ -> NonEmpty.head gitThunkSpecs

804 withSpinner' ("Fetching thunk " <> T.pack thunkName)

806 withSpinner' ("Fetching thunk " <> T.pack thunkName)

805 (finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkName) $ do

807 (finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkName) $ do

806− let git = callProcessAndLogOutput (Notice, Notice) . gitProc (tmpThunk </> unpackedDirName)

808+ gitCloneForThunkUnpack gitSrc (_thunkRev_commit $ _thunkPtr_rev tptr) (tmpThunk </> unpackedDirName)

807− git $ [ "clone" ]

808− ++ ["--recursive" | _gitSource_fetchSubmodules gitSrc]

809− ++ [ T.unpack $ gitUriToText $ _gitSource_url gitSrc ]

810− ++ do branch <- maybeToList $ _gitSource_branch gitSrc

811− [ "--branch", T.unpack $ untagName branch ]

812− git ["reset", "--hard", Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr]

813− when (_gitSource_fetchSubmodules gitSrc) $

814− git ["submodule", "update", "--recursive", "--init"]

815

809

816 createThunk tmpThunk $ Left newSpec

810 createThunk tmpThunk $ Left newSpec

817

811

@@ -819,6 +813,22 @@ unpackThunk' noTrail thunkDir = checkThunkDirectory thunkDir *> readThunk thunkD

819 removePathForcibly thunkDir

813 removePathForcibly thunkDir

820 renameDirectory tmpThunk thunkDir

814 renameDirectory tmpThunk thunkDir

821

815

816+gitCloneForThunkUnpack

817+ :: MonadObelisk m

818+ => GitSource -- ^ Git source to use

819+ -> Ref hash -- ^ Commit hash to reset to

820+ -> FilePath -- ^ Directory to clone into

821+ -> m ()

822+gitCloneForThunkUnpack gitSrc commit dir = do

823+ let git = callProcessAndLogOutput (Notice, Notice) . gitProc dir

824+ git $ [ "clone" ]

825+ ++ ["--recursive" | _gitSource_fetchSubmodules gitSrc]

826+ ++ [ T.unpack $ gitUriToText $ _gitSource_url gitSrc ]

827+ ++ do branch <- maybeToList $ _gitSource_branch gitSrc

828+ [ "--branch", T.unpack $ untagName branch ]

829+ git ["reset", "--hard", Ref.toHexString commit]

830+ when (_gitSource_fetchSubmodules gitSrc) $

831+ git ["submodule", "update", "--recursive", "--init"]

822

832

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

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

824packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr

834packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr

@@ -981,9 +991,7 @@ getThunkPtr gitCheckClean dir mPrivate = do

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

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

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

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

983getLatestRev os = do

993getLatestRev os = do

984− let gitS = case os of

994+ let gitS = thunkSourceToGitSource os

985− ThunkSource_GitHub s -> forgetGithub False s

986− ThunkSource_Git s -> s

987 (_, commit) <- gitGetCommitBranch (_gitSource_url gitS) (untagName <$> _gitSource_branch gitS)

995 (_, commit) <- gitGetCommitBranch (_gitSource_url gitS) (untagName <$> _gitSource_branch gitS)

988 case os of

996 case os of

989 ThunkSource_GitHub s -> githubThunkRev s commit

997 ThunkSource_GitHub s -> githubThunkRev s commit

lib/selftest/src/Obelisk/SelfTest.hs+5

@@ -194,6 +194,11 @@ main' isVerbose httpManager obeliskRepoReadOnly = withInitCache $ \initCache ->

194 configs <- getConfigs

195 return (either (const Nothing) Just $ getConfigRoute configs) `shouldNotReturn` Nothing

196

197+ it "can unpack and repack .obelisk/impl after init with master branch impl" $ inTmp $ \_ -> do

198+ runOb_ ["init", "--branch", "master"]

199+ runOb_ ["thunk", "unpack", ".obelisk/impl"]

200+ runOb_ ["thunk", "pack", ".obelisk/impl"]

201+

197 -- These tests fail with "Could not find module 'Obelisk.Generated.Static'"

202 -- These tests fail with "Could not find module 'Obelisk.Generated.Static'"

198 -- when not run by 'nix-build --attr selftest'

203 -- when not run by 'nix-build --attr selftest'

199 describe "ob run" $ {- NOT parallel $ -} do

204 describe "ob run" $ {- NOT parallel $ -} do