diff --git a/b9.cabal b/b9.cabal --- a/b9.cabal +++ b/b9.cabal @@ -1,5 +1,5 @@ name: b9 -version: 0.5.42 +version: 0.5.43 synopsis: A tool and library for building virtual machine images. diff --git a/src/cli/Main.hs b/src/cli/Main.hs --- a/src/cli/Main.hs +++ b/src/cli/Main.hs @@ -1,17 +1,32 @@ -module Main where +module Main(main) where import Options.Applicative hiding (action) import Options.Applicative.Help.Pretty hiding (()) import B9 -import Control.Lens ((.~), (&)) +import Control.Lens ((.~), (&), over, (^.)) main :: IO () main = do b9Opts <- parseCommandLine - (_, result) <- runB9 b9Opts - exit result + result <- invokeB9 (applyB9RunParameters b9Opts) + exit (maybe False (const True) result) where exit success = when (not success) (exitWith (ExitFailure 128)) +-- | A data structure that contains the `B9Invokation` +-- as well as build parameters. +data B9RunParameters a = + B9RunParameters + B9ConfigOverride + (B9Invokation a ()) + BuildVariables + +applyB9RunParameters :: B9RunParameters a -> B9Invokation a () +applyB9RunParameters (B9RunParameters overrides action vars) = do + modifyInvokationConfig + (over envVars (++ vars) . const (overrides ^. customB9Config)) + mapM_ overrideB9ConfigPath (overrides ^. customB9ConfigPath) + action + parseCommandLine :: IO (B9RunParameters ()) parseCommandLine = execParser ( info @@ -124,23 +139,23 @@ , _customB9Config = b9cfg } -cmds :: Parser (B9Invokation ()) +cmds :: Parser (B9Invokation () ()) cmds = subparser ( command "version" - ( info (pure runShowVersion) + ( info (pure (ignoreActionResults runShowVersion)) (progDesc "Show program version and exit.") ) <> command "build" ( info - (runBuildArtifacts <$> buildFileParser) + (ignoreActionResults . runBuildArtifacts <$> buildFileParser) (progDesc "Merge all build file and generate all artifacts.") ) <> command "run" ( info - (runRun <$> sharedImageNameParser <*> many (strArgument idm)) + (ignoreActionResults <$> (runRun <$> sharedImageNameParser <*> many (strArgument idm))) ( progDesc "Run a command on the lastest version of the specified shared image. All modifications are lost on exit." ) @@ -148,7 +163,7 @@ <> command "push" ( info - (runPush <$> sharedImageNameParser) + (ignoreActionResults . runPush <$> sharedImageNameParser) ( progDesc "Push the lastest shared image from cache to the selected remote repository." ) @@ -156,7 +171,7 @@ <> command "pull" ( info - (runPull <$> optional sharedImageNameParser) + (ignoreActionResults . runPull <$> optional sharedImageNameParser) ( progDesc "Either pull shared image meta data from all repositories, or only from just a selected one. If additionally the name of a shared images was specified, pull the newest version from either the selected repo, or from the repo with the most recent version." ) @@ -164,7 +179,7 @@ <> command "clean-local" ( info - (pure runGcLocalRepoCache) + (pure (ignoreActionResults runGcLocalRepoCache)) ( progDesc "Remove old versions of shared images from the local cache." ) @@ -172,22 +187,22 @@ <> command "clean-remote" ( info - (pure runGcRemoteRepoCache) + (pure (ignoreActionResults runGcRemoteRepoCache)) ( progDesc "Remove cached meta-data of a remote repository. If no '-r' is given, clean the meta data of ALL remote repositories." ) ) <> command "list" - (info (pure runListSharedImages) (progDesc "List shared images.")) + (info (pure (ignoreActionResults runListSharedImages)) (progDesc "List shared images.")) <> command "add-repo" - ( info (runAddRepo <$> remoteRepoParser) + ( info (ignoreActionResults . runAddRepo <$> remoteRepoParser) (progDesc "Add a remote repo.") ) <> command "reformat" - ( info (runFormatBuildFiles <$> buildFileParser) + ( info (ignoreActionResults . runFormatBuildFiles <$> buildFileParser) (progDesc "Re-Format all build files.") ) ) diff --git a/src/lib/B9.hs b/src/lib/B9.hs --- a/src/lib/B9.hs +++ b/src/lib/B9.hs @@ -12,9 +12,6 @@ -} module B9 ( b9Version, b9VersionString - , B9RunParameters(..) - , runB9 - , defaultB9RunParameters , runShowVersion , runBuildArtifacts , runFormatBuildFiles @@ -34,7 +31,6 @@ import System.IO.Error (isDoesNotExistError) import System.Directory (removeFile) import Data.Monoid as X -import Data.IORef import Data.List as X import Data.Maybe as X import Text.Show.Pretty as X (ppShow) @@ -58,50 +54,28 @@ b9VersionString :: String b9VersionString = showVersion version --- | A data structure that contains the `B9Invokation` --- as well as build parameters. -data B9RunParameters a = - B9RunParameters - B9ConfigOverride - (B9Invokation a) - BuildVariables - --- | Run a b9 build. --- Return `True` if the build was successful. -runB9 :: B9RunParameters a -> IO (a, Bool) -runB9 (B9RunParameters overrides action vars) = do - invokeB9 $ do - modifyInvokationConfig - (over envVars (++ vars) . const (overrides ^. customB9Config)) - mapM_ overrideB9ConfigPath (overrides ^. customB9ConfigPath) - action - -defaultB9RunParameters :: B9Invokation a -> B9RunParameters a -defaultB9RunParameters ba = - B9RunParameters (B9ConfigOverride Nothing mempty) ba mempty - -runShowVersion :: B9Invokation () -runShowVersion = doAfterConfiguration $ do +runShowVersion :: B9Invokation Bool () +runShowVersion = doAfterConfiguration $ const $ do liftIO $ putStrLn b9VersionString return True -runBuildArtifacts :: [FilePath] -> B9Invokation () +runBuildArtifacts :: [FilePath] -> B9Invokation String () runBuildArtifacts buildFiles = do generators <- mapM consult buildFiles buildArtifacts (mconcat generators) -runFormatBuildFiles :: [FilePath] -> B9Invokation () -runFormatBuildFiles buildFiles = doAfterConfiguration $ liftIO $ do +runFormatBuildFiles :: [FilePath] -> B9Invokation Bool () +runFormatBuildFiles buildFiles = doAfterConfiguration $ const $ liftIO $ do generators <- mapM consult buildFiles let generatorsFormatted = map ppShow (generators :: [ArtifactGenerator]) putStrLn `mapM` (generatorsFormatted) (uncurry writeFile) `mapM` (buildFiles `zip` generatorsFormatted) return True -runPush :: SharedImageName -> B9Invokation () +runPush :: SharedImageName -> B9Invokation Bool () runPush name = do modifyInvokationConfig (keepTempDirs .~ False) - run $ do + run $ const $ do conf <- getConfig if not (isJust (conf ^. repository)) then do @@ -113,13 +87,13 @@ return True -runPull :: Maybe SharedImageName -> B9Invokation () +runPull :: Maybe SharedImageName -> B9Invokation Bool () runPull mName = do modifyInvokationConfig (keepTempDirs .~ False) - run (pullRemoteRepos >> maybePullImage) + run (const (pullRemoteRepos >> maybePullImage)) where maybePullImage = maybe (return True) pullLatestImage mName -runRun :: SharedImageName -> [String] -> B9Invokation () +runRun :: SharedImageName -> [String] -> B9Invokation String () runRun (SharedImageName name) cmdAndArgs = do modifyInvokationConfig (Lens.set keepTempDirs False . Lens.set interactive True) @@ -138,12 +112,12 @@ cmdAndArgs' = if null cmdAndArgs then ["/usr/bin/zsh"] else cmdAndArgs -runGcLocalRepoCache :: B9Invokation () +runGcLocalRepoCache :: B9Invokation Bool () runGcLocalRepoCache = do modifyInvokationConfig (keepTempDirs .~ False) impl where - impl = run $ do + impl = run $ const $ do toDelete <- (obsoleteSharedmages . map snd) <$> lookupSharedImages (== Cache) (const True) imgDir <- getSharedImagesCacheDir @@ -169,19 +143,19 @@ handleExists e | isDoesNotExistError e = return () | otherwise = throwIO e -runGcRemoteRepoCache :: B9Invokation () +runGcRemoteRepoCache :: B9Invokation Bool () runGcRemoteRepoCache = do modifyInvokationConfig (keepTempDirs .~ False) - run $ do + run $ const $ do repos <- getSelectedRepos cache <- getRepoCache mapM_ (cleanRemoteRepo cache) repos return True -runListSharedImages :: B9Invokation () +runListSharedImages :: B9Invokation [SharedImage] () runListSharedImages = do modifyInvokationConfig (keepTempDirs .~ False) - run $ do + run $ const $ do remoteRepo <- getSelectedRemoteRepo let repoPred = maybe (== Cache) ((==) . toRemoteRepository) remoteRepo allRepos <- getRemoteRepos @@ -203,10 +177,10 @@ else liftIO $ do putStrLn "" putStrLn $ prettyPrintSharedImages $ map snd imgs - return True + return $ map snd imgs -runAddRepo :: RemoteRepo -> B9Invokation () +runAddRepo :: RemoteRepo -> B9Invokation Bool () runAddRepo repo = do repo' <- remoteRepoCheckSshPrivKey repo modifyPermanentConfig @@ -217,22 +191,18 @@ ) runLookupLocalSharedImage - :: SharedImageName -> B9Invokation (Maybe SharedImageBuildId) -runLookupLocalSharedImage n = do - ref <- liftIO (newIORef Nothing) - run (go ref) - liftIO (readIORef ref) + :: SharedImageName -> B9Invokation (Maybe SharedImageBuildId) () +runLookupLocalSharedImage n = run $ const $ do + traceL (printf "Searching for cached image: %s" (show n)) + imgs <- lookupSharedImages isAvailableOnLocalHost hasTheDesiredName + traceL "Candidate images: " + traceL (printf "%s\n" (prettyPrintSharedImages (map snd imgs))) + let res = extractNewestImageFromResults imgs + traceL (printf "Returning result: %s" (show res)) + return res where - go ref = do - res <- - extractNewestImageFromResults - <$> lookupSharedImages isAvailableOnLocalHost hasTheDesiredName - liftIO $ writeIORef ref res - return True - where - extractNewestImageFromResults = - listToMaybe . map toBuildId . take 1 . reverse . map snd - where toBuildId (SharedImage _ _ i _ _) = i - isAvailableOnLocalHost = (Cache ==) - hasTheDesiredName (SharedImage n' _ _ _ _) = n == n' - + extractNewestImageFromResults = + listToMaybe . map toBuildId . take 1 . reverse . map snd + where toBuildId (SharedImage _ _ i _ _) = i + isAvailableOnLocalHost = (Cache ==) + hasTheDesiredName (SharedImage n' _ _ _ _) = n == n' diff --git a/src/lib/B9/B9Monad.hs b/src/lib/B9/B9Monad.hs --- a/src/lib/B9/B9Monad.hs +++ b/src/lib/B9/B9Monad.hs @@ -57,13 +57,14 @@ String deriving (Eq,Show) -run :: B9 Bool -> B9Invokation () -run action = doAfterConfiguration $ do +run :: (Maybe a -> B9 a) -> B9Invokation a () +run actionFunction = doAfterConfiguration $ \previousResult -> do cfg <- ask liftIO $ do buildId <- generateBuildId now <- getCurrentTime - withBuildDir cfg buildId (withLogFile cfg . run' cfg buildId now) + let action = actionFunction previousResult + withBuildDir cfg buildId (withLogFile cfg . runImpl action cfg buildId now) where withLogFile cfg f = maybe (f Nothing) @@ -71,12 +72,12 @@ (_logFile cfg) withBuildDir cfg buildId = bracket (createBuildDir cfg buildId) (removeBuildDir cfg) - run' cfg buildId now buildDir logFileHandle = do + runImpl action cfg buildId now buildDir logFileHandle = do maybe (return ()) setCurrentDirectory (_buildDirRoot cfg) -- Check repositories repoCache <- initRepoCache (fromMaybe defaultRepositoryCache (_repositoryCache cfg)) - let buildDate = formatTime undefined "%F-%T" now + let buildDate = formatTime undefined "%F-%T" now remoteRepos' <- mapM (initRemoteRepo repoCache) (_remoteRepos cfg) let ctx = BuildState buildId @@ -97,7 +98,7 @@ sel (show remoteRepos') ) - (r, ctxOut) <- runStateT (runB9 wrappedAction) ctx + (r, ctxOut) <- runStateT (runB9 (wrappedAction action)) ctx -- Write a profiling report when (isJust (_profileFile cfg)) $ writeFile (fromJust (_profileFile cfg)) @@ -126,7 +127,7 @@ $ removeDirectoryRecursive buildDir generateBuildId = printf "%08X" <$> (randomIO :: IO Word32) -- Run the action build action - wrappedAction = do + wrappedAction action = do startTime <- gets bsStartTime r <- action now <- liftIO getCurrentTime @@ -134,7 +135,7 @@ infoL (printf "DURATION: %s" duration) return r -getBuildId :: B9 FilePath +getBuildId :: B9 String getBuildId = gets bsBuildId getBuildDate :: B9 String @@ -207,7 +208,7 @@ lv <- gets $ _verbosity . bsCfg lfh <- gets bsLogFileHandle return $ \level -> CL.mapM_ (logImpl lv lfh level . B.unpack) - checkExitCode ExitSuccess = + checkExitCode ExitSuccess = traceL $ printf "COMMAND '%s' exited with exit code: 0" cmdStr checkExitCode ec@(ExitFailure e) = do errorL $ printf "COMMAND '%s' exited with exit code: %i" cmdStr e @@ -266,6 +267,12 @@ let durMS = IoActionDuration (stop `diffUTCTime` start) modify $ \ctx -> ctx {bsProf = durMS : bsProf ctx} return res + + + + + + diff --git a/src/lib/B9/Builder.hs b/src/lib/B9/Builder.hs --- a/src/lib/B9/Builder.hs +++ b/src/lib/B9/Builder.hs @@ -30,11 +30,12 @@ import Control.Monad.IO.Class import System.Directory -buildArtifacts :: ArtifactGenerator -> B9Invokation () -buildArtifacts artifactGenerator = run $ do +-- | Execute an 'ArtifactGenerator' and return a 'B9Invokation' that returns +-- the build id obtained by 'getBuildId'. +buildArtifacts :: ArtifactGenerator -> B9Invokation String () +buildArtifacts artifactGenerator = run $ const $ do traceL . ("CWD: " ++) =<< liftIO getCurrentDirectory infoL "BUILDING ARTIFACTS" getConfig >>= traceL . printf "USING BUILD CONFIGURATION: %v" . ppShow assemble artifactGenerator - return True - + getBuildId diff --git a/src/lib/B9/Invokation.hs b/src/lib/B9/Invokation.hs --- a/src/lib/B9/Invokation.hs +++ b/src/lib/B9/Invokation.hs @@ -1,7 +1,8 @@ module B9.Invokation ( B9Invokation() , invokeB9 - , invokeB9_ , overrideWorkingDirectory + , mergeAfterConfigurationActionResults + , ignoreActionResults , doAfterConfiguration , overrideB9ConfigPath , modifyInvokationConfig @@ -23,27 +24,26 @@ -- build actions are performed. Use 'invokeB9' to execute these things. -- Inside the 'B9Invokation' monad you can influence and inspect the b9 -- configuration, the permanent, as well as the transient. -newtype B9Invokation a = B9Inv {runB9Invokation :: StateT InternalState IO a} - deriving (MonadState InternalState, Monad, Applicative, Functor, MonadIO) +newtype B9Invokation res a = B9Inv {runB9Invokation :: StateT (InternalState res) IO a} + deriving (MonadState (InternalState res), Monad, Applicative, Functor, MonadIO) -- | Internal state of the 'B9Invokation' -data InternalState = IS { _initialConfigOverride :: B9ConfigOverride - , _permanentB9ConfigUpdate :: Maybe (ConfigParser -> Either CPError ConfigParser) - , _changeWorkingDirectory :: Maybe FilePath - , _buildAction :: ReaderT B9Config IO Bool - } +data InternalState a = IS { _initialConfigOverride :: B9ConfigOverride + , _permanentB9ConfigUpdate :: Maybe (ConfigParser -> Either CPError ConfigParser) + , _changeWorkingDirectory :: Maybe FilePath + , _buildAction :: Maybe (ReaderT B9Config IO a) + } makeLenses ''InternalState -initialState :: InternalState -initialState = - IS (B9ConfigOverride Nothing mempty) Nothing Nothing (return True) +initialState :: InternalState a +initialState = IS (B9ConfigOverride Nothing mempty) Nothing Nothing Nothing -- | Run a 'B9Invokation'. -- If the user has no B9 config file yet, a default config file will be created. -invokeB9 :: B9Invokation a -> IO (a, Bool) +invokeB9 :: B9Invokation res () -> IO (Maybe res) invokeB9 act = do - (a, st) <- runStateT (runB9Invokation act) initialState + st <- execStateT (runB9Invokation act) initialState let cfgPath = st ^. initialConfigOverride . customB9ConfigPath cp0 <- openOrCreateB9Config cfgPath let cpExtErr = fmap ($ cp0) (st ^. permanentB9ConfigUpdate) @@ -62,7 +62,8 @@ case parseB9Config cp of Left e -> fail (printf "Configuration error: %s\n" (show e)) Right permanentConfig -> do - let runtimeCfg = + let + runtimeCfg = permanentConfig Sem.<> st ^. initialConfigOverride @@ -74,43 +75,79 @@ ( do mapM_ setCurrentDirectory (st ^. changeWorkingDirectory) - runReaderT (st ^. buildAction) runtimeCfg + runReaderT (sequence (st ^. buildAction)) runtimeCfg ) ) - res <- completeBuildAction - return (a, res) - --- | Run a 'B9Invokation' and ignore the results of the invokation monad and --- instead return the results of the '_buildAction'. --- See: 'invokeB9' -invokeB9_ :: B9Invokation a -> IO Bool -invokeB9_ act = snd <$> invokeB9 act + completeBuildAction -- | Add an action to be executed once the configuration has been done. -doAfterConfiguration :: ReaderT B9Config IO Bool -> B9Invokation () -doAfterConfiguration action = buildAction %= (>> action) +-- The action will be called with the result of the previous action defined by +-- this function. In case this is the first action added 'Nothing' is passed. +doAfterConfiguration :: (Maybe a -> ReaderT B9Config IO a) -> B9Invokation a () +doAfterConfiguration action = buildAction %= appendOrSet + where + appendOrSet Nothing = Just (action Nothing) + appendOrSet (Just x) = Just (x >>= action . Just) +-- | Combine the result of a given 'B9Invokation' and the results of the action +-- defined by 'doAfterConfiguration' in the current state. +mergeAfterConfigurationActionResults + :: (Maybe a -> Maybe b -> ReaderT B9Config IO b) + -> B9Invokation a () + -> B9Invokation b () +mergeAfterConfigurationActionResults f ba = do + st <- liftIO $ execStateT (runB9Invokation ba) initialState + let fb mbAction = Just $ do + ma <- sequence (st ^. buildAction) + mb <- sequence mbAction + f ma mb + buildAction %= fb + +-- | Ignore the results of the actions defined by 'doAfterConfiguration'. +-- All actions will be executed, but the result will be replaced with '()'. +ignoreActionResults :: B9Invokation a () -> B9Invokation () () +ignoreActionResults = + mergeAfterConfigurationActionResults (const (const (return ()))) + -- | Override the B9 configuration path -overrideB9ConfigPath :: SystemPath -> B9Invokation () +overrideB9ConfigPath :: SystemPath -> B9Invokation a () overrideB9ConfigPath p = initialConfigOverride . customB9ConfigPath .= Just p -- | Override the current working directory during execution of the actions -- added with 'doAfterConfiguration'. -overrideWorkingDirectory :: FilePath -> B9Invokation () +overrideWorkingDirectory :: FilePath -> B9Invokation a () overrideWorkingDirectory p = changeWorkingDirectory .= Just p -- | Modify the current 'B9Config'. The modifications are not reflected in the -- config file or the 'ConfigParser' returned by 'askInvokationConfigParser'. -modifyInvokationConfig :: (B9Config -> B9Config) -> B9Invokation () +modifyInvokationConfig :: (B9Config -> B9Config) -> B9Invokation a () modifyInvokationConfig f = initialConfigOverride . customB9Config %= f -- | Modify the current 'B9Config'. The modifications are not reflected in the -- config file or the 'ConfigParser' returned by 'askInvokationConfigParser'. -modifyPermanentConfig :: (B9Config -> B9Config) -> B9Invokation () +modifyPermanentConfig :: (B9Config -> B9Config) -> B9Invokation a () modifyPermanentConfig g = permanentB9ConfigUpdate %= go where go Nothing = go (Just return) go (Just f) = Just (\cp -> f cp >>= modifyConfigParser g) + + + + + + + + + + + + + + + + + + diff --git a/src/lib/B9/Shake/Actions.hs b/src/lib/B9/Shake/Actions.hs --- a/src/lib/B9/Shake/Actions.hs +++ b/src/lib/B9/Shake/Actions.hs @@ -6,18 +6,20 @@ import B9 -- | Convert a 'B9Invokation' action into a Shake 'Action'. -b9InvokationAction :: B9Invokation a -> Action (a, Bool) -b9InvokationAction = liftIO . runB9 . defaultB9RunParameters +b9InvokationAction :: B9Invokation a () -> Action a +b9InvokationAction invokationAction = do + mres <- liftIO (invokeB9 invokationAction) + maybe (fail "ERROR: Internal error while invoking a b9 action!") return mres -- | An action that does the equivalent of -- @b9c build -f -- (args !! 0) (args !! 1) ... (args !! (length args - 1))@ -- with the current working directory changed to @b9Root@. -buildB9File :: FilePath -> FilePath -> [String] -> Action () +-- The return value is the buildid, see 'getBuildId' +buildB9File :: FilePath -> FilePath -> [String] -> Action String buildB9File b9Root b9File args = do let f = b9Root b9File need [f] - (_, success) <- b9InvokationAction $ do + b9InvokationAction $ do modifyInvokationConfig (appendPositionalArguments args) overrideWorkingDirectory b9Root runBuildArtifacts [f] - if success then return () else fail $ "ERROR: Build failed: " ++ f diff --git a/src/lib/B9/Shake/SharedImageRules.hs b/src/lib/B9/Shake/SharedImageRules.hs --- a/src/lib/B9/Shake/SharedImageRules.hs +++ b/src/lib/B9/Shake/SharedImageRules.hs @@ -22,47 +22,35 @@ -> Maybe ByteString.ByteString -> Bool -> Action (RunResult SharedImageBuildId) - go nameQ mSerlializedBuildId dependenciesChanged = do - (mCurrentBuildId, success) <- b9InvokationAction (runLookupLocalSharedImage nameQ) - unless success - (internalErrorSharedImageNotFound nameQ) - - case (decodeBuildId <$> mSerlializedBuildId, mCurrentBuildId) of - - (Nothing, Nothing) -> - do newBuildId <- rebuild - return (RunResult ChangedRecomputeDiff (encodeBuildId newBuildId) newBuildId) - - (Nothing, Just currentBuildId) -> - if dependenciesChanged then - do newBuildId <- rebuild - let changed = if newBuildId == currentBuildId - then ChangedStore - else ChangedRecomputeDiff - return (RunResult changed (encodeBuildId newBuildId) newBuildId) - else - return (RunResult ChangedStore (encodeBuildId currentBuildId) currentBuildId) - - (Just oldBuildId, Nothing) -> - do newBuildId <- rebuild - let changed = if oldBuildId == newBuildId - then ChangedRecomputeSame - else ChangedRecomputeDiff - return (RunResult changed (encodeBuildId newBuildId) newBuildId) - - (Just oldBuildId, Just currentBuildId) -> - do newBuildId <- if dependenciesChanged - then rebuild - else return currentBuildId - let changed = if oldBuildId == newBuildId - then if dependenciesChanged - then ChangedRecomputeSame - else ChangedNothing - else ChangedRecomputeDiff - - return (RunResult changed (encodeBuildId newBuildId) newBuildId) - + go nameQ mSerlializedBuildId dependenciesChanged = + let mOld = decodeBuildId <$> mSerlializedBuildId + in do + (rebuilt, newBuildId) <- + if dependenciesChanged then (True,) <$> rebuild + else + do mNewBuildId <- getImgBuildId + maybe ((\i -> (True, i)) <$> rebuild) + (\i -> return (False, i)) + mNewBuildId + let newBuildIdBin = encodeBuildId newBuildId + change = + if rebuilt then + maybe ChangedRecomputeDiff + (\buildIdChanged -> + if buildIdChanged then ChangedRecomputeSame + else ChangedRecomputeSame ) + ((/= newBuildId) <$> mOld) + else + maybe ChangedStore + (\buildIdChanged -> + if buildIdChanged then ChangedRecomputeSame + else ChangedRecomputeSame ) + ((/= newBuildId) <$> mOld) + result = RunResult change newBuildIdBin newBuildId + return result where + getImgBuildId = b9InvokationAction (runLookupLocalSharedImage nameQ) + decodeBuildId :: ByteString.ByteString -> SharedImageBuildId decodeBuildId = Binary.decode . LazyByteString.fromStrict @@ -91,30 +79,24 @@ -- NOTE: You must call 'enableSharedImageRules' before this action works. customSharedImageAction :: SharedImageName -> Action () -> Rules () customSharedImageAction b9img customAction = - addUserRule $ SharedImageCustomActionRule b9img $ do - customAction - (after, success) <- b9InvokationAction (runLookupLocalSharedImage b9img) - unless success - (internalErrorSharedImageNotFound b9img) - maybe - (errorSharedImageNotFound b9img) - return - after + addUserRule (SharedImageCustomActionRule b9img customAction') + where + customAction' = do + customAction + mCurrentBuildId <- b9InvokationAction (runLookupLocalSharedImage b9img) + putLoud (printf "Finished custom action, for %s, build-id is: %s" + (show b9img) (show mCurrentBuildId)) + maybe (errorSharedImageNotFound b9img) return mCurrentBuildId + type instance RuleResult SharedImageName = SharedImageBuildId data SharedImageCustomActionRule = SharedImageCustomActionRule SharedImageName (Action SharedImageBuildId) deriving Typeable -internalErrorSharedImageNotFound :: Monad m => SharedImageName -> m a -internalErrorSharedImageNotFound = - fail - . printf "Internal Error: SharedImage %s not found. Please report this." - . show - errorSharedImageNotFound :: Monad m => SharedImageName -> m a errorSharedImageNotFound = fail - . printf "Error: SharedImage %s not found." + . printf "Error: %s not found." . show diff --git a/stack-lts-9.4.yaml b/stack-lts-9.4.yaml --- a/stack-lts-9.4.yaml +++ b/stack-lts-9.4.yaml @@ -1,6 +1,7 @@ flags: {} packages: - '.' -extra-deps: [] +extra-deps: +- shake-0.16.3 resolver: lts-9.4 # pvp-bounds: lower