@@ -0,0 +1,366 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE LambdaCase #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+module Obelisk.Command.Upgrade where
8+
9+import Control.Monad (forM, forM_, unless, void)
10+import Control.Monad.Catch (onException)
11+import Control.Monad.IO.Class (liftIO)
12+import Data.Bool (bool)
13+import Data.Maybe (catMaybes)
14+import Data.Monoid (Any (..), getAny)
15+import Data.Semigroup ((<>))
16+import qualified Data.Set as S
17+import Data.Text (Text)
18+import qualified Data.Text as T
19+import System.Directory
20+import System.FilePath
21+import System.IO.Temp
22+import System.Posix.Process (executeFile)
23+import System.Process (cwd, proc)
24+
25+import Obelisk.App (MonadObelisk)
26+import Obelisk.CliApp
27+import Obelisk.Command.Utils
28+
29+import Obelisk.Command.Project (toImplDir)
30+import Obelisk.Command.Project (findProjectObeliskCommand)
31+import Obelisk.Command.Thunk (ThunkData (..), getThunkGitBranch, readThunk, updateThunk)
32+
33+import Obelisk.Migration
34+
35+newtype HandOffAction = HandoffAction Any
36+ deriving (Monoid, Ord, Eq, Show)
37+
38+instance Action HandOffAction where
39+ parseEdgeMeta = HandoffAction . Any . (== "True")
40+
41+data MigrationGraph
42+ = MigrationGraph_ObeliskUpgrade
43+ | MigrationGraph_ObeliskHandoff
44+ deriving (Eq, Show)
45+
46+graphName :: MigrationGraph -> Text
47+graphName = \case
48+ MigrationGraph_ObeliskHandoff -> "obelisk-handoff"
49+ MigrationGraph_ObeliskUpgrade -> "obelisk-upgrade"
50+
51+fromGraphName :: Text -> MigrationGraph
52+fromGraphName = \case
53+ "obelisk-handoff" -> MigrationGraph_ObeliskHandoff
54+ "obelisk-upgrade" -> MigrationGraph_ObeliskUpgrade
55+ _ -> error "Invalid graph name specified"
56+
57+ensureCleanProject :: MonadObelisk m => FilePath -> m ()
58+ensureCleanProject project =
59+ ensureCleanGitRepo project False "Cannot upgrade with uncommited changes"
60+
61+-- | Decide whether we (ambient ob) should handoff to project obelisk before performing upgrade
62+decideHandOffToProjectOb :: MonadObelisk m => FilePath -> m Bool
63+decideHandOffToProjectOb project = do
64+ ensureCleanProject project
65+ updateThunk (toImplDir project) $ \projectOb -> do
66+ (ambientGraph, ambientHash) <- getAmbientObInfo
67+ projectHash <- computeVertexHash projectOb
68+ case hasVertex projectHash ambientGraph of
69+ False -> do
70+ putLog Warning "Project ob not found in ambient ob's migration graph; handing off anyway"
71+ return True
72+ True -> findPathAction ambientGraph projectHash ambientHash >>= \case
73+ Nothing -> do
74+ putLog Warning "No migration path between project and ambient ob; handing off anyway"
75+ return True
76+ Just (HandoffAction dontHandoff) -> do
77+ return $ not $ getAny dontHandoff
78+ where
79+ getAmbientObInfo = do
80+ ambientOb <- getAmbientOb
81+ getMigrationGraph' ambientOb MigrationGraph_ObeliskHandoff >>= \case
82+ Nothing -> do
83+ failWith "Ambient ob has no migration (this can't be possible)"
84+ Just m -> do
85+ -- We don't have ambient's ob source code, so locate its hash from the
86+ -- graph. The last vertex should be it.
87+ ambientHash <- getLast (_migration_graph m) >>= \case
88+ Nothing -> failWith "Ambient ob has no (last) vertex"
89+ Just v -> pure v
90+ unless (hasVertex ambientHash m) $
91+ failWith "Ambient ob's hash is not in its own graph"
92+ return (m, ambientHash)
93+
94+-- | Return the path to the current ('ambient') obelisk process Nix directory
95+getAmbientOb :: MonadObelisk m => m FilePath
96+getAmbientOb = takeDirectory . takeDirectory <$> liftIO getObeliskExe
97+
98+upgradeObelisk :: MonadObelisk m => FilePath -> Maybe Text -> m ()
99+upgradeObelisk project gitBranchM = do
100+ ensureCleanProject project
101+ gitBranch <- maybe (getObeliskBranch project) pure gitBranchM
102+ updateObelisk project gitBranch >>= handOffToNewOb project
103+
104+getObeliskBranch :: MonadObelisk m => FilePath -> m Text
105+getObeliskBranch project = readThunk (toImplDir project) >>= \case
106+ Left e -> failWith $ T.pack $ show e
107+ Right (ThunkData_Checkout _) -> failWith "obelisk thunk must be packed"
108+ Right (ThunkData_Packed tptr) -> case getThunkGitBranch tptr of
109+ Just v -> pure v
110+ Nothing ->
111+ failWith "You must specify a git branch to `ob upgrade` as obelisk thunk does not specify any."
112+
113+updateObelisk :: MonadObelisk m => FilePath -> Text -> m Hash
114+updateObelisk project gitBranch =
115+ withSpinner ("Fetching new Obelisk [" <> gitBranch <> "]") $
116+ updateThunk (toImplDir project) $ \obImpl -> do
117+ fromHash <- computeVertexHash obImpl
118+ callProcessAndLogOutput (Debug, Debug) $
119+ gitProc obImpl ["checkout", T.unpack gitBranch]
120+ callProcessAndLogOutput (Debug, Debug) $
121+ gitProc obImpl ["pull"]
122+ return fromHash
123+
124+handOffToNewOb :: MonadObelisk m => FilePath -> Hash -> m ()
125+handOffToNewOb project fromHash = do
126+ impl <- withSpinner' "Preparing for handoff" (Just $ ("Handed off to new Obelisk " <>) . T.pack) $
127+ findProjectObeliskCommand project >>= \case
128+ Nothing -> failWith "Not an Obelisk project"
129+ Just impl -> pure impl
130+ let opts = ["internal", "migrate", T.unpack fromHash]
131+ liftIO $ executeFile impl False ("--no-handoff" : opts) Nothing
132+
133+migrateObelisk :: MonadObelisk m => FilePath -> Hash -> m ()
134+migrateObelisk project fromHash = void $ withSpinner' "Migrating to new Obelisk" (Just id) $ do
135+ updateThunk (toImplDir project) $ \obImpl -> revertObImplOnFail obImpl $ do
136+ toHash <- computeVertexHash obImpl
137+ g <- getMigrationGraph' obImpl MigrationGraph_ObeliskUpgrade >>= \case
138+ Nothing -> failWith "New obelisk has no migration metadata"
139+ Just m -> pure m
140+
141+ unless (hasVertex fromHash g) $ do
142+ failWith $ "Current obelisk hash " <> fromHash <> " missing in migration graph of new obelisk"
143+ unless (hasVertex toHash g) $ do
144+ -- This usually means that the target obelisk branch does not have
145+ -- migration vertex for its latest commit; typically due to developer
146+ -- negligence.
147+ failWith $ "New obelisk hash " <> toHash <> " missing in its migration graph"
148+
149+ if fromHash == toHash
150+ then do
151+ pure $ "No upgrade available (new Obelisk is the same)"
152+ else do
153+ putLog Debug $ "Migrating from " <> fromHash <> " to " <> toHash
154+ findPathAction g fromHash toHash >>= \case
155+ Nothing -> do
156+ failWith "Unable to find migration path"
157+ Just action -> do
158+ unless (action == mempty) $ do
159+ putLog Notice "To upgrade your project to the new version of obelisk, please follow these instructions:\n"
160+ putLog Notice action
161+ pure $ "Migrated from " <> fromHash <> " to " <> toHash
162+ where
163+ revertObImplOnFail impl f = f `onException` do
164+ putLog Notice $ T.pack $ "Reverting changes to " <> impl
165+ callProcessAndLogOutput (Notice, Notice) $ gitProc project ["checkout", impl]
166+
167+-- | Get the migration graph for project
168+getMigrationGraph'
169+ :: (Action action, MonadObelisk m)
170+ => FilePath -> MigrationGraph -> m (Maybe (Migration action))
171+getMigrationGraph' obDir graph = do
172+ let name = graphName graph
173+ dir = migrationDir obDir
174+ putLog Debug $ "Reading migration graph " <> name <> " from " <> T.pack dir
175+ liftIO $ readGraph dir name
176+
177+computeVertexHash :: MonadObelisk m => FilePath -> m Hash
178+computeVertexHash = getDirectoryHash [migrationDirName]
179+
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+
225+createMigrationEdgeFromHEAD :: MonadObelisk m => FilePath -> m ()
226+createMigrationEdgeFromHEAD obDir = do
227+ headHash <- getHeadVertex obDir
228+ wcHash <- getDirectoryHash migrationIgnore obDir
229+ if (headHash == wcHash)
230+ then
231+ putLog Warning "No migration necessary (working copy has not changed from HEAD)"
232+ else do
233+ -- TODO: Add `ob internal create-migration --backfill=n` do it for all revisions.
234+ -- See the failure condition in getHeadVertex
235+ written <- writeEdge (migrationDir obDir) headHash wcHash
236+ unless written $
237+ putLog Warning "No migration was created"
238+
239+-- | Return the hash corresponding to HEAD
240+--
241+-- Fail if the hash does not exist in project's migration graph.
242+getHeadVertex :: MonadObelisk m => FilePath -> m Hash
243+getHeadVertex obDir = do
244+ projectGraph :: Migration Text <- getMigrationGraph' obDir MigrationGraph_ObeliskUpgrade >>= \case
245+ Nothing -> failWith "No migration graph found"
246+ Just g -> pure g
247+ [headHash] <- getHashAtGitRevision ["HEAD"] migrationIgnore obDir
248+ unless (hasVertex headHash projectGraph) $ do
249+ -- This means that the HEAD commit has no vertex in the graph,
250+ -- possible due to developer negligence when commiting it.
251+ -- Perhaps we should use a post-commit hook or some such thing
252+ -- to reject such commits in the first place? For now, just
253+ -- error out.
254+ failWith $ "No vertex found for HEAD (" <> headHash <> ")"
255+ return headHash
256+
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+
261+-- | Create, or update, the migration graph with new edges and new vertices
262+-- corresponding to every commit in the Git history from HEAD.
263+--
264+-- NOTE: This creates a linear graph, and doesn't follow the Git graph
265+-- structure.
266+backfillGraph :: MonadObelisk m => Maybe Int -> FilePath -> m ()
267+backfillGraph lastN project = do
268+ revs <- fmap (takeM lastN . fmap (fst . T.breakOn " ") . T.lines) $
269+ readProc $ gitProc project ["log", "--pretty=oneline"]
270+ -- Note: we need to take unique hashes only; this is fine for backfilling.
271+ -- But future migrations should ensure that there are no duplicate hashes
272+ -- (which would cause cycles) such as those introduced by revert commits.
273+ vertices :: [Hash] <- withSpinnerNoTrail "Computing hash for git history" $
274+ fmap (unique . reverse) $ getHashAtGitRevision revs [migrationDirName] project
275+ void $ withSpinner'
276+ ("Backfilling with " <> tshow (length vertices) <> " vertices")
277+ (Just $ \n -> "Backfilled " <> tshow n <> " edges.") $ do
278+ let vertexPairs = zip vertices $ drop 1 vertices
279+ let edgesDir = migrationDir project
280+ liftIO $ createDirectoryIfMissing False edgesDir
281+ fmap (length . filter (== True)) $ forM vertexPairs $ \(v1, v2) -> do
282+ writeEdge edgesDir v1 v2
283+ where
284+ -- Return unique items in the list /while/ preserving order
285+ unique = loop mempty
286+ where
287+ loop _ [] = []
288+ loop s (x : xs)
289+ | S.member x s = loop s xs
290+ | otherwise = x : loop (S.insert x s) xs
291+ takeM n' xs = case n' of
292+ Just n -> take n xs
293+ Nothing -> xs
294+
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
338+
339+nixHash :: MonadObelisk m => FilePath -> m Hash
340+nixHash dir = withSpinnerNoTrail "Running `nix hash-path`" $
341+ readProc $ proc "nix" ["hash-path", "--type", "md5", dir]
342+
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 }
366+