@@ -1,293 +0,0 @@
1−{-# LANGUAGE FlexibleContexts #-}
2−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3−{-# LANGUAGE LambdaCase #-}
4−{-# LANGUAGE MultiParamTypeClasses #-}
5−{-# LANGUAGE OverloadedStrings #-}
6−{-# LANGUAGE ScopedTypeVariables #-}
7−{-# LANGUAGE TypeApplications #-}
8−module Obelisk.Command.Upgrade where
9−
10−import Control.Monad (forM, unless, void)
11−import Control.Monad.Catch (onException)
12−import Control.Monad.Except
13−import Control.Monad.IO.Class (liftIO)
14−import Data.Maybe (catMaybes)
15−import Data.Monoid (Any (..), getAny)
16−import Data.Semigroup ((<>))
17−import qualified Data.Set as S
18−import Data.Text (Text)
19−import qualified Data.Text as T
20−import System.Directory
21−import System.FilePath
22−import System.Posix.Process (executeFile)
23−
24−import Obelisk.App (MonadObelisk)
25−import Obelisk.CliApp
26−import Obelisk.Command.Utils
27−
28−import Obelisk.Command.Project (toImplDir)
29−import Obelisk.Command.Project (findProjectObeliskCommand)
30−import Obelisk.Command.Thunk (ThunkData (..), getThunkGitBranch, readThunk, updateThunk)
31−
32−import Obelisk.Command.Upgrade.Hash
33−import Obelisk.Migration
34−
35−newtype HandOffAction = HandoffAction Any
36− deriving (Monoid, Semigroup, 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, Bounded, Enum)
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−graphNames :: [Text]
58−graphNames = fmap graphName $ [minBound .. maxBound]
59−
60−ensureCleanProject :: MonadObelisk m => FilePath -> m ()
61−ensureCleanProject project =
62− ensureCleanGitRepo project False "Cannot upgrade with uncommited changes"
63−
64−-- | Decide whether we (ambient ob) should handoff to project obelisk before performing upgrade
65−decideHandOffToProjectOb :: MonadObelisk m => FilePath -> m Bool
66−decideHandOffToProjectOb project = do
67− ensureCleanProject project
68− updateThunk (toImplDir project) $ \projectOb -> do
69− (ambientGraph, ambientHash) <- getAmbientObInfo
70− projectHash <- computeVertexHash projectOb
71− case hasVertex projectHash ambientGraph of
72− False -> do
73− putLog Warning "Project ob not found in ambient ob's migration graph; handing off anyway"
74− return True
75− True -> handleMigrationError (findPathAction ambientGraph projectHash ambientHash) >>= \case
76− Nothing -> do
77− putLog Warning "No migration path between project and ambient ob; handing off anyway"
78− return True
79− Just (HandoffAction dontHandoff) -> do
80− return $ not $ getAny dontHandoff
81− where
82− getAmbientObInfo = do
83− ambientOb <- getAmbientOb
84− getMigrationGraph' ambientOb MigrationGraph_ObeliskHandoff >>= \case
85− Nothing -> do
86− failWith "Ambient ob has no migration (this can't be possible)"
87− Just m -> do
88− -- We don't have ambient's ob source code, so locate its hash from the
89− -- graph. The last vertex should be it.
90− ambientHash <- handleMigrationError $ getLast (_migration_graph m)
91− return (m, ambientHash)
92−
93−-- | Return the path to the current ('ambient') obelisk process Nix directory
94−getAmbientOb :: MonadObelisk m => m FilePath
95−getAmbientOb = takeDirectory . takeDirectory <$> liftIO getObeliskExe
96−
97−upgradeObelisk :: MonadObelisk m => FilePath -> Maybe Text -> m ()
98−upgradeObelisk project gitBranchM = do
99− ensureCleanProject project
100− gitBranch <- maybe (getObeliskBranch project) pure gitBranchM
101− updateObelisk project gitBranch >>= handOffToNewOb project
102−
103−getObeliskBranch :: MonadObelisk m => FilePath -> m Text
104−getObeliskBranch project = readThunk (toImplDir project) >>= \case
105− Left e -> failWith $ T.pack $ show e
106− Right (ThunkData_Checkout _) -> failWith "obelisk thunk must be packed"
107− Right (ThunkData_Packed tptr) -> case getThunkGitBranch tptr of
108− Just v -> pure v
109− Nothing ->
110− failWith "You must run `ob upgrade` with the Git branch specified explicitly, as the project's obelisk thunk does not specify any."
111−
112−updateObelisk :: MonadObelisk m => FilePath -> Text -> m Hash
113−updateObelisk project gitBranch =
114− withSpinner ("Fetching new obelisk [" <> gitBranch <> "]") $
115− updateThunk (toImplDir project) $ \obImpl -> do
116− fromHash <- computeVertexHash obImpl
117− callProcessAndLogOutput (Debug, Debug) $
118− gitProc obImpl ["checkout", T.unpack gitBranch]
119− callProcessAndLogOutput (Debug, Debug) $
120− gitProc obImpl ["pull"]
121− return fromHash
122−
123−handOffToNewOb :: MonadObelisk m => FilePath -> Hash -> m ()
124−handOffToNewOb project fromHash = do
125− impl <- withSpinner' "Preparing for handoff" (Just $ ("Handed off to new obelisk " <>) . T.pack) $
126− findProjectObeliskCommand project >>= \case
127− Nothing -> failWith "Not an obelisk project"
128− Just impl -> pure impl
129− let opts = ["internal", "migrate", T.unpack fromHash]
130− liftIO $ executeFile impl False ("--no-handoff" : opts) Nothing
131−
132−migrateObelisk :: MonadObelisk m => FilePath -> Hash -> m ()
133−migrateObelisk project fromHash = void $ withSpinner' "Migrating to new obelisk" (Just id) $ do
134− updateThunk (toImplDir project) $ \obImpl -> revertObImplOnFail obImpl $ do
135− toHash <- computeVertexHash obImpl
136− g <- getMigrationGraph' obImpl MigrationGraph_ObeliskUpgrade >>= \case
137− Nothing -> failWith "New obelisk has no migration metadata"
138− Just m -> pure m
139−
140− unless (hasVertex fromHash g) $ do
141− failWith $ "Current obelisk hash " <> fromHash <> " missing in migration graph of new obelisk"
142− unless (hasVertex toHash g) $ do
143− -- This usually means that the target obelisk branch does not have
144− -- migration vertex for its latest commit; typically due to developer
145− -- negligence.
146− failWith $ "New obelisk hash " <> toHash <> " missing in its migration graph"
147−
148− if fromHash == toHash
149− then do
150− pure $ "No upgrade available (new Obelisk is the same)"
151− else do
152− putLog Debug $ "Migrating from " <> fromHash <> " to " <> toHash
153− handleMigrationError (findPathAction g fromHash toHash) >>= \case
154− Nothing -> do
155− failWith "Unable to find migration path"
156− Just action -> do
157− unless (action == mempty) $ do
158− putLog Notice "To upgrade your project to the new version of obelisk, please follow these instructions:\n"
159− putLog Notice action
160− pure $ "Migrated from " <> fromHash <> " to " <> toHash
161− where
162− revertObImplOnFail impl f = f `onException` do
163− putLog Notice $ T.pack $ "Reverting changes to " <> impl
164− callProcessAndLogOutput (Notice, Notice) $ gitProc project ["checkout", impl]
165−
166−-- | Get the migration graph for project
167−getMigrationGraph
168− :: (Action action, MonadObelisk m)
169− => FilePath -> MigrationGraph -> m (Migration action)
170−getMigrationGraph obDir graph = getMigrationGraph' obDir graph >>= \case
171− Nothing -> failWith "Migration graph missing"
172− Just m -> pure m
173−
174−getMigrationGraph'
175− :: (Action action, MonadObelisk m)
176− => FilePath -> MigrationGraph -> m (Maybe (Migration action))
177−getMigrationGraph' obDir graph = do
178− let name = graphName graph
179− dir = migrationDir obDir
180− putLog Debug $ "Reading migration graph " <> name <> " from " <> T.pack dir
181− liftIO $ readGraph dir name
182−
183−computeVertexHash :: MonadObelisk m => FilePath -> m Hash
184−computeVertexHash = getDirectoryHash [migrationDirName]
185−
186−-- | Verify the integrity of the migration graph in relation to the Git repo.
187−verifyMigration :: MonadObelisk m => FilePath -> m ()
188−verifyMigration obDir = do
189− upgradeGraph <- withSpinner "Reading migration graph" $
190− getMigrationGraph @Text obDir MigrationGraph_ObeliskUpgrade
191− withSpinner "Checking graph integrity" $
192− handleMigrationError $ ensureGraphIntegrity upgradeGraph
193− headVertex <- liftIO (doesDirectoryExist $ obDir </> ".git") >>= \case
194− True ->
195− withSpinner "Checking existence of HEAD vertex" $
196− getHeadVertex obDir
197− False -> do
198− hash <- computeVertexHash obDir
199− unless (hasVertex hash upgradeGraph) $
200− failWith $ "No vertex found for obelisk hash " <> hash
201− pure hash
202− withSpinner "Checking graph linearity" $
203− -- NOTE: We don't support merge commits (i.e., diamonds in a graph) yet.
204− -- Until we do, ensure that the graph is a fully connected linear list.
205− runExceptT (ensureGraphLinearity upgradeGraph) >>= \case
206− Left (NonLinearGraph_MultipleAdjacents vertex) ->
207− failWith $ "Graph is not linear; branches at vertex: " <> tshow vertex
208− Left (NonLinearGraph_NotConnected isolatedVertices) ->
209− failWith $ "Graph is partly linear, with isolated vertices: " <> tshow isolatedVertices
210− Left e ->
211− failWith $ "Error in migration graph: " <> tshow e
212− Right lastVertex -> unless (lastVertex == headVertex) $
213− failWith $ "Graph is linear, but its last vertex (" <> lastVertex <> ") is different from head vertex (" <> headVertex <> ")"
214−
215−-- | Create an edge from HEAD vertex to the hash corresponding to the Git
216−-- working copy. The HEAD vertex must already exist.
217−createMigrationEdgeFromHEAD :: MonadObelisk m => FilePath -> m ()
218−createMigrationEdgeFromHEAD obDir = do
219− headHash <- getHeadVertex obDir
220− wcHash <- getDirectoryHash migrationIgnore obDir
221− if (headHash == wcHash)
222− then
223− putLog Warning "No migration necessary (working copy has the same hash as that of HEAD)"
224− else do
225− writeEdge (migrationDir obDir) graphNames headHash wcHash >>= \case
226− Nothing ->
227− putLog Warning "No migration was created"
228− Just edgeDir ->
229− putLog Notice $ "Created edge: " <> T.pack edgeDir
230−
231−-- | Return the hash corresponding to HEAD
232−--
233−-- Fail if the hash does not exist in project's migration graph.
234−getHeadVertex :: MonadObelisk m => FilePath -> m Hash
235−getHeadVertex obDir = do
236− projectGraph <- getMigrationGraph @Text obDir MigrationGraph_ObeliskUpgrade
237− [headHash] <- getHashAtGitRevision ["HEAD"] migrationIgnore obDir
238− unless (hasVertex headHash projectGraph) $ do
239− -- This means that the HEAD commit has no vertex in the graph,
240− -- possibly due to developer negligence when commiting it.
241− -- Perhaps we should use a post-commit hook or some such thing
242− -- to reject such commits in the first place? For now, just
243− -- error out.
244− failWith $ "No vertex found for HEAD (" <> headHash <> ")"
245− return headHash
246−
247−-- | Create, or update, the migration graph with new edges and new vertices
248−-- corresponding to every commit in the Git history from HEAD.
249−--
250−-- NOTE: This creates a linear graph, and doesn't follow the Git graph
251−-- structure.
252−backfillGraph :: MonadObelisk m => Maybe Int -> FilePath -> m ()
253−backfillGraph lastN obDir = do
254− revs <- fmap (takeM lastN . fmap (fst . T.breakOn " ") . T.lines) $
255− readProc $ gitProc obDir ["log", "--pretty=oneline"]
256− -- Note: we need to take unique hashes only; this is fine for backfilling.
257− -- But future migrations should ensure that there are no duplicate hashes
258− -- (which would cause cycles) such as those introduced by revert commits.
259− vertices :: [Hash] <- withSpinnerNoTrail "Computing hash for git history" $
260− fmap (unique . reverse) $ getHashAtGitRevision revs [migrationDirName] obDir
261− void $ withSpinner'
262− ("Backfilling with " <> tshow (length vertices) <> " vertices")
263− (Just $ \n -> "Backfilled " <> tshow n <> " edges.") $ do
264− let vertexPairs = zip vertices $ drop 1 vertices
265− let edgesDir = migrationDir obDir
266− liftIO $ createDirectoryIfMissing False edgesDir
267− fmap (length . catMaybes) $ forM vertexPairs $ \(v1, v2) -> do
268− writeEdge edgesDir graphNames v1 v2
269− where
270− -- Return unique items in the list /while/ preserving order
271− unique = loop mempty
272− where
273− loop _ [] = []
274− loop s (x : xs)
275− | S.member x s = loop s xs
276− | otherwise = x : loop (S.insert x s) xs
277− takeM n' xs = case n' of
278− Just n -> take n xs
279− Nothing -> xs
280−
281−handleMigrationError :: MonadObelisk m => Except MigrationError a -> m a
282−handleMigrationError m = case runExcept m of
283− Left e -> failWith $ "Error in migration graph: " <> tshow e
284− Right a -> return a
285−
286−migrationDir :: FilePath -> FilePath
287−migrationDir project = project </> migrationDirName
288−
289−migrationIgnore :: [FilePath]
290−migrationIgnore = [migrationDirName]
291−
292−migrationDirName :: FilePath
293−migrationDirName = "migration"