887da01 · obelisk · git.iko.soy

git.iko.soy/obelisk

on master help sign in

Merge remote-tracking branch 'origin/master' into routes

887da01Ryan Trinkle8 years ago

lib/command/src/Obelisk/Command/Upgrade.hs+14−6

compare with master

unifiedsplit

@@ -8,7 +8,8 @@

8module Obelisk.Command.Upgrade where

10import Control.Monad (forM, unless, void)

11−import Control.Monad.Catch (onException, try)

11+import Control.Monad.Catch (onException)

12+import Control.Monad.Except

12import Control.Monad.IO.Class (liftIO)

13import Control.Monad.IO.Class (liftIO)

13import Data.Maybe (catMaybes)

14import Data.Maybe (catMaybes)

14import Data.Monoid (Any (..), getAny)

15import Data.Monoid (Any (..), getAny)

@@ -71,7 +72,7 @@ decideHandOffToProjectOb project = do

71 False -> do

72 False -> do

72 putLog Warning "Project ob not found in ambient ob's migration graph; handing off anyway"

73 putLog Warning "Project ob not found in ambient ob's migration graph; handing off anyway"

73 return True

74 return True

74− True -> findPathAction ambientGraph projectHash ambientHash >>= \case

75+ True -> handleMigrationError (findPathAction ambientGraph projectHash ambientHash) >>= \case

75 Nothing -> do

76 Nothing -> do

76 putLog Warning "No migration path between project and ambient ob; handing off anyway"

77 putLog Warning "No migration path between project and ambient ob; handing off anyway"

77 return True

78 return True

@@ -86,7 +87,7 @@ decideHandOffToProjectOb project = do

86 Just m -> do

87 Just m -> do

87 -- We don't have ambient's ob source code, so locate its hash from the

88 -- We don't have ambient's ob source code, so locate its hash from the

88 -- graph. The last vertex should be it.

89 -- graph. The last vertex should be it.

89− ambientHash <- getLast (_migration_graph m)

90+ ambientHash <- handleMigrationError $ getLast (_migration_graph m)

90 return (m, ambientHash)

91 return (m, ambientHash)

92-- | Return the path to the current ('ambient') obelisk process Nix directory

93-- | Return the path to the current ('ambient') obelisk process Nix directory

@@ -149,7 +150,7 @@ migrateObelisk project fromHash = void $ withSpinner' "Migrating to new obelisk"

149 pure $ "No upgrade available (new Obelisk is the same)"

150 pure $ "No upgrade available (new Obelisk is the same)"

150 else do

151 else do

151 putLog Debug $ "Migrating from " <> fromHash <> " to " <> toHash

152 putLog Debug $ "Migrating from " <> fromHash <> " to " <> toHash

152− findPathAction g fromHash toHash >>= \case

153+ handleMigrationError (findPathAction g fromHash toHash) >>= \case

153 Nothing -> do

154 Nothing -> do

154 failWith "Unable to find migration path"

155 failWith "Unable to find migration path"

155 Just action -> do

156 Just action -> do

@@ -188,7 +189,7 @@ verifyMigration obDir = do

188 upgradeGraph <- withSpinner "Reading migration graph" $

189 upgradeGraph <- withSpinner "Reading migration graph" $

189 getMigrationGraph @Text obDir MigrationGraph_ObeliskUpgrade

190 getMigrationGraph @Text obDir MigrationGraph_ObeliskUpgrade

190 withSpinner "Checking graph integrity" $

191 withSpinner "Checking graph integrity" $

191− ensureGraphIntegrity upgradeGraph

192+ handleMigrationError $ ensureGraphIntegrity upgradeGraph

192 headVertex <- liftIO (doesDirectoryExist $ obDir </> ".git") >>= \case

193 headVertex <- liftIO (doesDirectoryExist $ obDir </> ".git") >>= \case

193 True ->

194 True ->

194 withSpinner "Checking existence of HEAD vertex" $

195 withSpinner "Checking existence of HEAD vertex" $

@@ -201,11 +202,13 @@ verifyMigration obDir = do

201 withSpinner "Checking graph linearity" $

202 withSpinner "Checking graph linearity" $

202 -- NOTE: We don't support merge commits (i.e., diamonds in a graph) yet.

203 -- NOTE: We don't support merge commits (i.e., diamonds in a graph) yet.

203 -- Until we do, ensure that the graph is a fully connected linear list.

204 -- Until we do, ensure that the graph is a fully connected linear list.

204− try (ensureGraphLinearity upgradeGraph) >>= \case

205+ runExceptT (ensureGraphLinearity upgradeGraph) >>= \case

205 Left (NonLinearGraph_MultipleAdjacents vertex) ->

206 Left (NonLinearGraph_MultipleAdjacents vertex) ->

206 failWith $ "Graph is not linear; branches at vertex: " <> tshow vertex

207 failWith $ "Graph is not linear; branches at vertex: " <> tshow vertex

207 Left (NonLinearGraph_NotConnected isolatedVertices) ->

208 Left (NonLinearGraph_NotConnected isolatedVertices) ->

208 failWith $ "Graph is partly linear, with isolated vertices: " <> tshow isolatedVertices

209 failWith $ "Graph is partly linear, with isolated vertices: " <> tshow isolatedVertices

210+ Left e ->

211+ failWith $ "Error in migration graph: " <> tshow e

209 Right lastVertex -> unless (lastVertex == headVertex) $

212 Right lastVertex -> unless (lastVertex == headVertex) $

210 failWith $ "Graph is linear, but its last vertex (" <> lastVertex <> ") is different from head vertex (" <> headVertex <> ")"

213 failWith $ "Graph is linear, but its last vertex (" <> lastVertex <> ") is different from head vertex (" <> headVertex <> ")"

211

214

@@ -275,6 +278,11 @@ backfillGraph lastN obDir = do

275 Just n -> take n xs

278 Just n -> take n xs

276 Nothing -> xs

279 Nothing -> xs

277

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+

278migrationDir :: FilePath -> FilePath

286migrationDir :: FilePath -> FilePath

279migrationDir project = project </> migrationDirName

287migrationDir project = project </> migrationDirName

280

288

lib/migration/src/Obelisk/Migration.hs+26−46

@@ -6,7 +6,7 @@

6module Obelisk.Migration where

8import Control.Monad (forM, forM_, unless, void)

9−import Control.Monad.Catch (Exception, MonadThrow, throwM)

9+import Control.Monad.Except

10import Control.Monad.IO.Class (MonadIO, liftIO)

11import Control.Monad.State.Strict (evalStateT, get, put)

12import Data.Map (Map)

@@ -34,36 +34,16 @@ data Migration action = Migration

34-- A path is a list of edges

35type Path = [(Hash, Hash)]

37+data MigrationError

37−data GraphInternalError = GraphInternalError Text

38+ = GraphInternalError Text

38− deriving Show

39−

40−data CyclicGraphError = CyclicGraphError

39+ | CyclicGraphError

41− deriving Show

42−

43−data MultipleTerminalVertices = MultipleTerminalVertices

40+ | MultipleTerminalVertices

44− deriving Show

45−

46−data NoTerminalVertex = NoTerminalVertex

41+ | NoTerminalVertex

47− deriving Show

48−

49−data NonEquivalentPaths = NonEquivalentPaths Hash Hash

42+ | NonEquivalentPaths Hash Hash

50− deriving Show

51−

52−data MissingEdgeInActionMap = MissingEdgeInActionMap (Hash, Hash)

43+ | MissingEdgeInActionMap (Hash, Hash)

53− deriving Show

54−

55−data NonLinearGraph

56− = NonLinearGraph_MultipleAdjacents Hash

44+ | NonLinearGraph_MultipleAdjacents Hash

57 | NonLinearGraph_NotConnected (Set Hash)

45 | NonLinearGraph_NotConnected (Set Hash)

58− deriving Show

46+ deriving (Eq, Ord, Show)

59−

60−instance Exception GraphInternalError

61−instance Exception CyclicGraphError

62−instance Exception MultipleTerminalVertices

63−instance Exception NoTerminalVertex

64−instance Exception NonEquivalentPaths

65−instance Exception MissingEdgeInActionMap

66−instance Exception NonLinearGraph

68class Action action where

48class Action action where

69 parseEdgeMeta :: String -> action

49 parseEdgeMeta :: String -> action

@@ -73,10 +53,10 @@ instance Action Text where

74-- | Get the directed-acylic graph of migration

54-- | Get the directed-acylic graph of migration

75-- TODO: Consider calling getDag only when reading the graph for efficiency.

55-- TODO: Consider calling getDag only when reading the graph for efficiency.

76−getDag :: (MonadThrow m, Ord a) => AdjacencyMap a -> m (AdjacencyMap a)

56+getDag :: (MonadError MigrationError m, Ord a) => AdjacencyMap a -> m (AdjacencyMap a)

77getDag g = case topSort g of

57getDag g = case topSort g of

78 Just _ -> pure g

58 Just _ -> pure g

79− Nothing -> throwM CyclicGraphError

59+ Nothing -> throwError CyclicGraphError

81-- | Read the graph from a directory of files.

61-- | Read the graph from a directory of files.

82readGraph :: Action action => FilePath -> Text -> IO (Maybe (Migration action))

62readGraph :: Action action => FilePath -> Text -> IO (Maybe (Migration action))

@@ -111,7 +91,7 @@ readGraph root name = doesDirectoryExist root >>= \case

111--

91--

112-- Complexity: O(V+E)

92-- Complexity: O(V+E)

113ensureGraphIntegrity

93ensureGraphIntegrity

114− :: (MonadThrow m, Monoid action, Ord action)

94+ :: (MonadError MigrationError m, Monoid action, Ord action)

115 => Migration action -> m ()

95 => Migration action -> m ()

116ensureGraphIntegrity m = do

96ensureGraphIntegrity m = do

117 graph <- fmap adjacencyMap $ getDag $ _migration_graph m

97 graph <- fmap adjacencyMap $ getDag $ _migration_graph m

@@ -125,7 +105,7 @@ ensureGraphIntegrity m = do

125 Nothing -> pure $ Map.insert adj acc' visited

105 Nothing -> pure $ Map.insert adj acc' visited

126 Just adjAcc -> if acc' == adjAcc

106 Just adjAcc -> if acc' == adjAcc

127 then pure visited

107 then pure visited

128− else throwM $ NonEquivalentPaths start adj

108+ else throwError $ NonEquivalentPaths start adj

129 visitFrom visited' acc' adj

109 visitFrom visited' acc' adj

130 -- We only check all paths from the _first_ vertex; it is not necessary to

110 -- We only check all paths from the _first_ vertex; it is not necessary to

131 -- check all paths between _all_ pairs of vertices as that can be proved by

111 -- check all paths between _all_ pairs of vertices as that can be proved by

@@ -136,23 +116,23 @@ ensureGraphIntegrity m = do

136-- | Ensure that the graph is a fully connected linear list

116-- | Ensure that the graph is a fully connected linear list

137--

117--

138-- Returns the last vertex in the linear list.

118-- Returns the last vertex in the linear list.

139−ensureGraphLinearity :: MonadThrow m => Migration action -> m Hash

119+ensureGraphLinearity :: MonadError MigrationError m => Migration action -> m Hash

140ensureGraphLinearity m = do

120ensureGraphLinearity m = do

141 graph <- fmap adjacencyMap $ getDag $ _migration_graph m

121 graph <- fmap adjacencyMap $ getDag $ _migration_graph m

142 firstVertex <- getFirst $ _migration_graph m

122 firstVertex <- getFirst $ _migration_graph m

143 let

123 let

144 allVertices = vertexSet $ _migration_graph m

124 allVertices = vertexSet $ _migration_graph m

145 visitFrom start = case Map.lookup start graph of

125 visitFrom start = case Map.lookup start graph of

146− Nothing -> throwM $ GraphInternalError $ "Vertex not found: " <> start

126+ Nothing -> throwError $ GraphInternalError $ "Vertex not found: " <> start

147 Just adjs -> case (Set.toList adjs) of

127 Just adjs -> case (Set.toList adjs) of

148 [] -> pure (start, [start])

128 [] -> pure (start, [start])

149 [adj] -> fmap (start :) <$> visitFrom adj

129 [adj] -> fmap (start :) <$> visitFrom adj

150− _ -> throwM $ NonLinearGraph_MultipleAdjacents start

130+ _ -> throwError $ NonLinearGraph_MultipleAdjacents start

151 (lastVertex, visitedVertices) <- visitFrom firstVertex

131 (lastVertex, visitedVertices) <- visitFrom firstVertex

152 let unvisitedVertices = Set.difference allVertices $ Set.fromList visitedVertices

132 let unvisitedVertices = Set.difference allVertices $ Set.fromList visitedVertices

153 if Set.null unvisitedVertices

133 if Set.null unvisitedVertices

154 then pure lastVertex

134 then pure lastVertex

155− else throwM $ NonLinearGraph_NotConnected unvisitedVertices

135+ else throwError $ NonLinearGraph_NotConnected unvisitedVertices

156

136

157-- | Find the concatenated actions between two vertices

137-- | Find the concatenated actions between two vertices

158--

138--

@@ -161,7 +141,7 @@ ensureGraphLinearity m = do

161--

141--

162-- Complexity: O(V+E)

142-- Complexity: O(V+E)

163findPathAction

143findPathAction

164− :: (MonadThrow m, Action action, Monoid action, Ord action)

144+ :: (MonadError MigrationError m, Action action, Monoid action, Ord action)

165 => Migration action -> Hash -> Hash -> m (Maybe action)

145 => Migration action -> Hash -> Hash -> m (Maybe action)

166findPathAction m start end = flip evalStateT Map.empty $ do

146findPathAction m start end = flip evalStateT Map.empty $ do

167 graph <- fmap adjacencyMap $ getDag $ _migration_graph m

147 graph <- fmap adjacencyMap $ getDag $ _migration_graph m

@@ -188,7 +168,7 @@ findPathAction m start end = flip evalStateT Map.empty $ do

188 case uniqs actions of

168 case uniqs actions of

189 [] -> pure Nothing

169 [] -> pure Nothing

190 [v] -> pure $ Just v -- Exactly one monoidal value; accept.

170 [v] -> pure $ Just v -- Exactly one monoidal value; accept.

191− _ -> throwM $ NonEquivalentPaths start' end

171+ _ -> throwError $ NonEquivalentPaths start' end

192 Nothing ->

172 Nothing ->

193 pure Nothing

173 pure Nothing

194 uniqs = Set.toList . Set.fromList

174 uniqs = Set.toList . Set.fromList

@@ -198,19 +178,19 @@ hasVertex :: Hash -> Migration action -> Bool

198hasVertex h (Migration g _) = Set.member h $ vertexSet g

178hasVertex h (Migration g _) = Set.member h $ vertexSet g

199

179

200-- | Get the action for the given edge (which must exist)

180-- | Get the action for the given edge (which must exist)

201−getAction :: MonadThrow m => Migration action -> (Hash, Hash) -> m action

181+getAction :: MonadError MigrationError m => Migration action -> (Hash, Hash) -> m action

202getAction (Migration _ h) e = case Map.lookup e h of

182getAction (Migration _ h) e = case Map.lookup e h of

203 Just v -> pure v

183 Just v -> pure v

204− Nothing -> throwM $ MissingEdgeInActionMap e

184+ Nothing -> throwError $ MissingEdgeInActionMap e

205

185

206-- | Get the last vertex of the given DAG. Nothing if empty graph.

186-- | Get the last vertex of the given DAG. Nothing if empty graph.

207--

187--

208-- Assumes that the graph is fully connected.

188-- Assumes that the graph is fully connected.

209−getLast :: (MonadThrow m, Ord a, Eq a) => AdjacencyMap a -> m a

189+getLast :: (MonadError MigrationError m, Ord a, Eq a) => AdjacencyMap a -> m a

210getLast g = lastVertices >>= \case

190getLast g = lastVertices >>= \case

211− [] -> throwM NoTerminalVertex

191+ [] -> throwError NoTerminalVertex

212 [x] -> pure x

192 [x] -> pure x

213− _ -> throwM MultipleTerminalVertices

193+ _ -> throwError MultipleTerminalVertices

214 where

194 where

215 lastVertices

195 lastVertices

216 = pure

196 = pure

@@ -220,7 +200,7 @@ getLast g = lastVertices >>= \case

220 =<< getDag g

200 =<< getDag g

221

201

222-- | Get the first vertex of the given DAG. Nothing if empty graph.

202-- | Get the first vertex of the given DAG. Nothing if empty graph.

223−getFirst :: (MonadThrow m, Ord a, Eq a) => AdjacencyMap a -> m a

203+getFirst :: (MonadError MigrationError m, Ord a, Eq a) => AdjacencyMap a -> m a

224getFirst = getLast . transpose

204getFirst = getLast . transpose

225

205

226-- | Write an edge directly to the filesystem.

206-- | Write an edge directly to the filesystem.