@@ -6,10 +6,9 @@
66{-# LANGUAGE ScopedTypeVariables #-}
77module Obelisk.Command.Upgrade where
88
9−import Control.Monad (forM, forM_, unless, void)
9+import Control.Monad (forM, unless, void)
1010import Control.Monad.Catch (onException)
1111import Control.Monad.IO.Class (liftIO)
12−import Data.Bool (bool)
1312import Data.Maybe (catMaybes)
1413import Data.Monoid (Any (..), getAny)
1514import Data.Semigroup ((<>))
@@ -18,9 +17,7 @@ import Data.Text (Text)
1817import qualified Data.Text as T
1918import System.Directory
2019import System.FilePath
21−import System.IO.Temp
2220import System.Posix.Process (executeFile)
23−import System.Process (cwd, proc)
2421
2522import Obelisk.App (MonadObelisk)
2623import Obelisk.CliApp
@@ -30,6 +27,7 @@ import Obelisk.Command.Project (toImplDir)
3027import Obelisk.Command.Project (findProjectObeliskCommand)
3128import Obelisk.Command.Thunk (ThunkData (..), getThunkGitBranch, readThunk, updateThunk)
3229
30+import Obelisk.Command.Upgrade.Hash
3331import Obelisk.Migration
3432
3533newtype HandOffAction = HandoffAction Any
@@ -41,7 +39,7 @@ instance Action HandOffAction where
4139data MigrationGraph
4240 = MigrationGraph_ObeliskUpgrade
4341 | MigrationGraph_ObeliskHandoff
44− deriving (Eq, Show)
42+ deriving (Eq, Show, Bounded, Enum)
4543
4644graphName :: MigrationGraph -> Text
4745graphName = \case
@@ -54,6 +52,9 @@ fromGraphName = \case
5452 "obelisk-upgrade" -> MigrationGraph_ObeliskUpgrade
5553 _ -> error "Invalid graph name specified"
5654
55+graphNames :: [Text]
56+graphNames = fmap graphName $ [minBound .. maxBound]
57+
5758ensureCleanProject :: MonadObelisk m => FilePath -> m ()
5859ensureCleanProject project =
5960 ensureCleanGitRepo project False "Cannot upgrade with uncommited changes"
@@ -177,51 +178,6 @@ getMigrationGraph' obDir graph = do
177178computeVertexHash :: MonadObelisk m => FilePath -> m Hash
178179computeVertexHash = getDirectoryHash [migrationDirName]
179180
180−migrationDir :: FilePath -> FilePath
181−migrationDir project = project </> migrationDirName
182−
183−migrationIgnore :: [FilePath]
184−migrationIgnore = [migrationDirName]
185−
186−migrationDirName :: FilePath
187−migrationDirName = "migration"
188−
189−-- TODO: Move this to migration library? (but we rely on wrapProgram exes)
190−
191−-- | Get the unique hash of the given directory
192−--
193−-- Excludes the following before computing the hash:
194−-- * the specified top-level files/ directories.
195−-- * .git directory
196−-- * untracked Git files
197−-- * ignored Git files
198−--
199−-- Uses the same predictive algorithm that Nix (`nix hash-path`).
200−--
201−-- This function will do a full copy of the directory to a temporary location before
202−-- computing the hash. Because it will be deleting the files in exclude list, and
203−-- other files if the directory is a git repo. This needs to be done as `nix hash-path`
204−-- doesn't support taking an excludes list.
205−getDirectoryHash :: MonadObelisk m => [FilePath] -> FilePath -> m Hash
206−getDirectoryHash excludes dir = withSystemTempDirectory "obelisk-hash-" $ \tmpDir -> do
207− withSpinnerNoTrail (T.pack $ "Copying " <> dir <> " to " <> tmpDir) $ do
208− runProc $ copyDir dir tmpDir
209− getDirectoryHashDestructive excludes tmpDir
210−
211−-- Do /not/ call this directly! Call `getDirectoryHash` instead.
212−getDirectoryHashDestructive :: MonadObelisk m => [FilePath] -> FilePath -> m Hash
213−getDirectoryHashDestructive excludes dir = do
214− liftIO (doesDirectoryExist $ dir </> ".git") >>= \case
215− True -> do
216− tidyUpGitWorkingCopy dir
217− withSpinnerNoTrail "Removing .git directory" $
218− liftIO $ removePathForcibly $ dir </> ".git"
219− False -> pure ()
220− withSpinnerNoTrail "Removing excluded paths" $ do
221− forM_ (fmap (dir </>) excludes) $
222− liftIO . removePathForcibly
223− nixHash dir
224−
225181createMigrationEdgeFromHEAD :: MonadObelisk m => FilePath -> m ()
226182createMigrationEdgeFromHEAD obDir = do
227183 headHash <- getHeadVertex obDir
@@ -232,9 +188,11 @@ createMigrationEdgeFromHEAD obDir = do
232188 else do
233189 -- TODO: Add `ob internal create-migration --backfill=n` do it for all revisions.
234190 -- See the failure condition in getHeadVertex
235− written <- writeEdge (migrationDir obDir) headHash wcHash
236− unless written $
237− putLog Warning "No migration was created"
191+ writeEdge (migrationDir obDir) graphNames headHash wcHash >>= \case
192+ Nothing ->
193+ putLog Warning "No migration was created"
194+ Just edgeDir ->
195+ putLog Notice $ "Created edge: " <> T.pack edgeDir
238196
239197-- | Return the hash corresponding to HEAD
240198--
@@ -254,32 +212,28 @@ getHeadVertex obDir = do
254212 failWith $ "No vertex found for HEAD (" <> headHash <> ")"
255213 return headHash
256214
257−-- | TODO: Verify the integrity of the migration graph in relation to the Git repo.
258−verifyGraph :: MonadObelisk m => FilePath -> m ()
259−verifyGraph = undefined
260−
261215-- | Create, or update, the migration graph with new edges and new vertices
262216-- corresponding to every commit in the Git history from HEAD.
263217--
264218-- NOTE: This creates a linear graph, and doesn't follow the Git graph
265219-- structure.
266220backfillGraph :: MonadObelisk m => Maybe Int -> FilePath -> m ()
267−backfillGraph lastN project = do
221+backfillGraph lastN obDir = do
268222 revs <- fmap (takeM lastN . fmap (fst . T.breakOn " ") . T.lines) $
269− readProc $ gitProc project ["log", "--pretty=oneline"]
223+ readProc $ gitProc obDir ["log", "--pretty=oneline"]
270224 -- Note: we need to take unique hashes only; this is fine for backfilling.
271225 -- But future migrations should ensure that there are no duplicate hashes
272226 -- (which would cause cycles) such as those introduced by revert commits.
273227 vertices :: [Hash] <- withSpinnerNoTrail "Computing hash for git history" $
274− fmap (unique . reverse) $ getHashAtGitRevision revs [migrationDirName] project
228+ fmap (unique . reverse) $ getHashAtGitRevision revs [migrationDirName] obDir
275229 void $ withSpinner'
276230 ("Backfilling with " <> tshow (length vertices) <> " vertices")
277231 (Just $ \n -> "Backfilled " <> tshow n <> " edges.") $ do
278232 let vertexPairs = zip vertices $ drop 1 vertices
279− let edgesDir = migrationDir project
233+ let edgesDir = migrationDir obDir
280234 liftIO $ createDirectoryIfMissing False edgesDir
281− fmap (length . filter (== True)) $ forM vertexPairs $ \(v1, v2) -> do
282− writeEdge edgesDir v1 v2
235+ fmap (length . catMaybes) $ forM vertexPairs $ \(v1, v2) -> do
236+ writeEdge edgesDir graphNames v1 v2
283237 where
284238 -- Return unique items in the list /while/ preserving order
285239 unique = loop mempty
@@ -292,75 +246,15 @@ backfillGraph lastN project = do
292246 Just n -> take n xs
293247 Nothing -> xs
294248
295−-- | Write the edge to filesystem.
296−--
297−-- Return True if the edge was created, False if already exists.
298−writeEdge :: MonadObelisk m => FilePath -> Hash -> Hash -> m Bool
299−writeEdge dir v1 v2 = do
300− unless (v1 /= v2) $
301− failWith $ "Cannot create self loop with: " <> v1
302− let edgeDir = dir </> (T.unpack $ v1 <> "-" <> v2)
303− liftIO (doesDirectoryExist edgeDir) >>= \case
304− True -> pure False
305− False -> do
306− putLog Notice $ T.pack $ "Creating edge " <> edgeDir
307− liftIO $ createDirectory edgeDir
308− forM_ actionFiles $ \fp -> liftIO $
309− writeFile (edgeDir </> fp) ""
310− pure True
311− where
312− actionFiles = ["obelisk-handoff", "obelisk-upgrade"]
313−
314−getHashAtGitRevision :: MonadObelisk m => [Text] -> [FilePath] -> FilePath -> m [Hash]
315−getHashAtGitRevision revs excludes dir = withSystemTempDirectory "obelisk-hashrev-" $ \tmpDir -> do
316− withSpinner (T.pack $ "Copying " <> dir <> " to " <> tmpDir) $ do
317− runProc $ copyDir dir tmpDir
318− tidyUpGitWorkingCopy tmpDir
319− -- Discard changes to tracked files
320− runProcSilently $ gitProc tmpDir ["reset", "--hard"]
321− forM revs $ \rev -> do
322− runProcSilently $ gitProc tmpDir ["checkout", T.unpack rev]
323− -- Checking out an arbitrary revision can leave untracked files (from
324− -- previous revison) around, so tidy them up.
325− tidyUpGitWorkingCopy tmpDir
326− withFilesStashed tmpDir (excludes <> [".git"]) $
327− nixHash tmpDir
328− where
329− withFilesStashed base fs m = withSystemTempDirectory "obelisk-hashrev-stash-" $ \stashDir -> do
330− existingPaths <- fmap catMaybes $ forM fs $ \p -> do
331− liftIO (doesPathExist $ base </> p) >>= pure . bool Nothing (Just p)
332− forM_ existingPaths $ \p ->
333− liftIO $ renamePath (base </> p) (stashDir </> p)
334− result <- m
335− forM_ existingPaths $ \p ->
336− liftIO $ renamePath (stashDir </> p) (base </> p)
337− return result
249+-- | TODO: Verify the integrity of the migration graph in relation to the Git repo.
250+verifyGraph :: MonadObelisk m => FilePath -> m ()
251+verifyGraph = undefined
338252
339−nixHash :: MonadObelisk m => FilePath -> m Hash
340−nixHash dir = withSpinnerNoTrail "Running `nix hash-path`" $
341− readProc $ proc "nix" ["hash-path", "--type", "md5", dir]
253+migrationDir :: FilePath -> FilePath
254+migrationDir project = project </> migrationDirName
342255
343−-- | Clean up the following files in the git working copy
344−--
345−-- * Paths ignored by .gitignored, but still present in the filesystem
346−-- * Untracked files (not added to git index)
347−-- * Any empty directories (these are not tracked by git)
348−--
349−-- Note that this leaves modified (staged or unstaged) files as they are.
350−tidyUpGitWorkingCopy :: MonadObelisk m => FilePath -> m ()
351−tidyUpGitWorkingCopy dir = withSpinnerNoTrail "Tidying up git working copy" $ do
352− ignored <- gitLsFiles dir ["--ignored", "--exclude-standard", "--others"]
353− untracked <- gitLsFiles dir ["--exclude-standard", "--others"]
354− putLog Debug $ T.pack $ "Found " <> show (length ignored) <> " ignored files."
355− putLog Debug $ T.pack $ "Untracked:\n" <> unlines untracked
356− putLog Debug $ T.pack $ "Ignored:\n" <> unlines ignored
357− withSpinnerNoTrail "Removing untracked and ignored files" $ do
358− forM_ (fmap (dir </>) $ ignored <> untracked) $
359− liftIO . removePathForcibly
360− -- Empty directories won't be included in these lists. Git doesn't track them
361− -- So we must delete these separately.
362− runProc $ proc "find" [dir, "-depth", "-empty", "-type", "d", "-delete"]
363− where
364− gitLsFiles pwd opts = fmap lines $ readProcessAndLogStderr Error $
365− (proc "git" $ ["ls-files", "."] <> opts) { cwd = Just pwd }
256+migrationIgnore :: [FilePath]
257+migrationIgnore = [migrationDirName]
366258
259+migrationDirName :: FilePath
260+migrationDirName = "migration"