diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ +.shake *.hi *.ho TAGS diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,20 @@ # Changelog for B9 +## 1.1.0 + +* Fix unintended deletion of images that are wrongly classified as obsolete. +* Add a configuration parameter for guarding operations, for which + no timeout values was specified: `default_timeout_seconds`. +* Introduce a configuration parameter to specify an optional **timeout factor**. + Since the introduction of __SystemdNspawn__ support, most invokation of + external system commands, e.g. `mount`, are guarded by short timeouts. + During testing I discovered that some systems are just slower and might + run into a timeout. + To mitigate that, a user can now configure a **timeout factor** that is + applied to the internal, hard-coded time values. +* Change NIX expressions to use `haskellPackages` + instead of `myHaskellPackages`. + ## 1.0.1 * Remove dhall diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -384,6 +384,8 @@ repository_cache: Just (InB9UserDir "repo-cache") unique_build_dirs: True verbosity: Just LogInfo + default_timeout_seconds: Just 3600 + timeout_factor: Just 4 [libvirt-lxc] connection: lxc:/// @@ -460,6 +462,16 @@ * Default: `Just LogInfo` _TODO document this option._ + +#### `default_timeout_seconds` + +* optional default timeout, applied to all external calls: + + +#### `timeout_factor` + +* optional factor(natural numbers) that every timeout value is multiplied by, + for slower systems. ### The `[libvirt-lxc]` Section diff --git a/b9.cabal b/b9.cabal --- a/b9.cabal +++ b/b9.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: b9 -version: 1.0.1 +version: 1.1.0 synopsis: A tool and library for building virtual machine images. @@ -64,6 +64,7 @@ , hspec , hspec-expectations , lens >= 4 + , shake >= 0.17.6 && < 0.19 , text >= 1.2 common b9Extensions @@ -160,6 +161,7 @@ , conduit >= 1.2 , conduit-extra >= 1.1 -- , dhall >= 1 TODO + , containers , exceptions >= 0.10 , filepath >= 1.4 , free >= 4.12 @@ -173,7 +175,6 @@ , pretty-show >= 1.6 , process >= 1.4 , random >= 1.1 - , shake >= 0.17.6 && < 0.19 , syb >= 0.6 , tagged >= 0.8 && < 0.9 , template >= 0.2 @@ -202,17 +203,23 @@ hs-source-dirs: src/tests main-is: Spec.hs autogen-modules: Paths_b9 - other-modules: B9.Content.ErlTermsSpec - , B9.ArtifactGeneratorImplSpec + other-modules: B9.ArtifactGeneratorImplSpec + , B9.B9ExecSpec + , B9.Content.ErlTermsSpec , B9.Content.ErlangPropListSpec , B9.Content.YamlObjectSpec , B9.DiskImagesSpec , B9.EnvironmentSpec + , B9.RepositoryIOSpec + , B9.RepositorySpec + , B9.Shake.SharedImageRulesSpec , Paths_b9 build-depends: QuickCheck >= 2.5 , b9 , aeson >= 1.0 , binary >= 0.8 && < 0.9 + , containers + , filepath , hspec , hspec-expectations , unordered-containers >= 0.2 diff --git a/src/cli/Main.hs b/src/cli/Main.hs --- a/src/cli/Main.hs +++ b/src/cli/Main.hs @@ -128,7 +128,8 @@ in B9ConfigOverride { _customB9ConfigPath = Path <$> cfg, _customB9Config = b9cfg, - _customEnvironment = mempty + _customEnvironment = mempty, + _customDefaulB9ConfigPath = Nothing } cmds :: Parser (B9ConfigAction ()) diff --git a/src/lib/B9.hs b/src/lib/B9.hs --- a/src/lib/B9.hs +++ b/src/lib/B9.hs @@ -56,10 +56,6 @@ import B9.Vm as X import B9.VmBuilder as X import Control.Applicative as X -import Control.Exception - ( catch, - throwIO, - ) import Control.Lens as X ( (%~), (&), @@ -74,13 +70,13 @@ ask, local, ) -import Data.Function (on) +import Data.Foldable (fold) import Data.List as X import Data.Maybe as X import Data.Monoid as X +import Data.Set (Set) import Data.Version as X import Paths_b9 (version) -import System.Directory (removeFile) import System.Exit as X ( ExitCode (..), exitWith, @@ -93,7 +89,6 @@ takeFileName, ) import System.IO.B9Extras as X -import System.IO.Error (isDoesNotExistError) import Text.Printf as X ( printf, ) @@ -184,37 +179,10 @@ -- | Delete all obsolete versions of all 'SharedImageName's. runGcLocalRepoCache :: B9ConfigAction () -runGcLocalRepoCache = localB9Config (keepTempDirs .~ False) (runB9 impl) - where - impl = do - toDelete <- - obsoleteSharedmages . map snd - <$> lookupSharedImages - (== Cache) - (const True) - imgDir <- getSharedImagesCacheDir - let filesToDelete = (imgDir ) <$> (infoFiles ++ imgFiles) - infoFiles = sharedImageFileName <$> toDelete - imgFiles = imageFileName . sharedImageImage <$> toDelete - if null filesToDelete - then liftIO $ putStrLn "\n\nNO IMAGES TO DELETE\n" - else liftIO $ do - putStrLn "DELETING FILES:" - putStrLn (unlines filesToDelete) - mapM_ removeIfExists filesToDelete - where - obsoleteSharedmages :: [SharedImage] -> [SharedImage] - obsoleteSharedmages = - concatMap (tail . reverse) . filter ((> 1) . length) - . groupBy - ((==) `on` sharedImageName) - removeIfExists :: FilePath -> IO () - removeIfExists fileName = removeFile fileName `catch` handleExists - where - handleExists e - | isDoesNotExistError e = return () - | otherwise = throwIO e +runGcLocalRepoCache = localB9Config (keepTempDirs .~ False) (runB9 cleanLocalRepoCache) +-- TODO delete-too-many-revisions + -- | Clear the shared image cache for a remote. Note: The remote repository is -- specified in the 'B9Config'. runGcRemoteRepoCache :: B9ConfigAction () @@ -232,7 +200,7 @@ -- | Print a list of shared images cached locally or remotely, if a remote -- repository was selected. Note: The remote repository is -- specified in the 'B9Config'. -runListSharedImages :: B9ConfigAction [SharedImage] +runListSharedImages :: B9ConfigAction (Set SharedImage) runListSharedImages = localB9Config (keepTempDirs .~ False) @@ -256,13 +224,16 @@ unless (null allRepos) $ liftIO $ do putStrLn "\nAvailable remote repositories:" mapM_ (putStrLn . (" * " ++) . remoteRepoRepoId) allRepos - imgs <- lookupSharedImages repoPred (const True) + imgs <- + fold + . filterRepoImagesMap repoPred (const True) + <$> getSharedImages if null imgs then liftIO $ putStrLn "\n\nNO SHARED IMAGES\n" else liftIO $ do putStrLn "" - putStrLn $ prettyPrintSharedImages $ map snd imgs - return (map snd imgs) + putStrLn $ prettyPrintSharedImages imgs + return imgs ) ) @@ -285,16 +256,9 @@ SharedImageName -> B9ConfigAction (Maybe SharedImageBuildId) runLookupLocalSharedImage n = runB9 $ do traceL (printf "Searching for cached image: %s" (show n)) - imgs <- lookupSharedImages isAvailableOnLocalHost hasTheDesiredName + imgs <- lookupCachedImages n <$> getSharedImages traceL "Candidate images: " - traceL (printf "%s\n" (prettyPrintSharedImages (map snd imgs))) - let res = extractNewestImageFromResults imgs + traceL (printf "%s\n" (prettyPrintSharedImages imgs)) + let res = if null imgs then Nothing else Just (sharedImageBuildId (maximum imgs)) traceL (printf "Returning result: %s" (show res)) return res - where - 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/B9Config.hs b/src/lib/B9/B9Config.hs --- a/src/lib/B9/B9Config.hs +++ b/src/lib/B9/B9Config.hs @@ -1,8 +1,11 @@ +{-# LANGUAGE NumericUnderscores #-} + -- | -- Static B9 configuration. Read, write and merge configurable properties. -- The properties are independent of specific build targets. module B9.B9Config ( B9Config (..), + Timeout (..), runB9ConfigReader, B9ConfigReader, getB9Config, @@ -20,11 +23,14 @@ repositoryCache, repository, interactive, + defaultTimeout, libVirtLXCConfigs, dockerConfigs, podmanConfigs, systemdNspawnConfigs, remoteRepos, + timeoutFactor, + maxLocalSharedImageRevisionsK, maxLocalSharedImageRevisions, B9ConfigOverride (..), noB9ConfigOverride, @@ -36,9 +42,13 @@ customB9Config, customB9ConfigPath, customEnvironment, + customDefaulB9ConfigPath, overrideB9ConfigPath, + overrideDefaultB9ConfigPath, overrideB9Config, overrideWorkingDirectory, + overrideDefaultTimeout, + overrideTimeoutFactor, overrideVerbosity, overrideKeepBuildDirs, defaultB9ConfigFile, @@ -97,6 +107,13 @@ import System.IO.B9Extras (SystemPath (..), ensureDir, resolve) import Text.Printf (printf) +-- | A way to specify a time intervall for example for the timeouts +-- of system commands. +-- +-- @since 1.1.0 +newtype Timeout = TimeoutMicros Int + deriving (Show, Eq, Ord, Read) + data LogLevel = LogTrace | LogDebug @@ -120,7 +137,9 @@ _podmanConfigs :: Maybe PodmanConfig, _dockerConfigs :: Maybe DockerConfig, _libVirtLXCConfigs :: Maybe LibVirtLXCConfig, - _remoteRepos :: [RemoteRepo] + _remoteRepos :: [RemoteRepo], + _defaultTimeout :: Maybe Timeout, + _timeoutFactor :: Maybe Int } deriving (Show, Eq) @@ -140,12 +159,14 @@ _podmanConfigs = getLast ((mappend `on` (Last . _podmanConfigs)) c c'), _dockerConfigs = getLast ((mappend `on` (Last . _dockerConfigs)) c c'), _libVirtLXCConfigs = getLast ((mappend `on` (Last . _libVirtLXCConfigs)) c c'), - _remoteRepos = (mappend `on` _remoteRepos) c c' + _remoteRepos = (mappend `on` _remoteRepos) c c', + _defaultTimeout = getLast $ on mappend (Last . _defaultTimeout) c c', + _timeoutFactor = getLast $ on mappend (Last . _timeoutFactor) c c' } instance Monoid B9Config where mappend = (<>) - mempty = B9Config Nothing Nothing Nothing False True Nothing Nothing False Nothing Nothing Nothing Nothing Nothing [] + mempty = B9Config Nothing Nothing Nothing False True Nothing Nothing False Nothing Nothing Nothing Nothing Nothing [] (Just (TimeoutMicros (60 * 60 * 1_000_000))) Nothing -- | Reader for 'B9Config'. See 'getB9Config' and 'localB9Config'. -- @@ -211,7 +232,8 @@ = B9ConfigOverride { _customB9ConfigPath :: Maybe SystemPath, _customB9Config :: Endo B9Config, - _customEnvironment :: Environment + _customEnvironment :: Environment, + _customDefaulB9ConfigPath :: Maybe SystemPath } instance Show B9ConfigOverride where @@ -219,13 +241,14 @@ unlines [ "config file path: " ++ show (_customB9ConfigPath x), "config modification: " ++ show (appEndo (_customB9Config x) mempty), - "environment: " ++ show (_customEnvironment x) + "environment: " ++ show (_customEnvironment x), + "default config file: " ++ show (_customDefaulB9ConfigPath x) ] -- | An empty default 'B9ConfigOverride' value, that will neither apply any -- additional 'B9Config' nor change the path of the configuration file. noB9ConfigOverride :: B9ConfigOverride -noB9ConfigOverride = B9ConfigOverride Nothing mempty mempty +noB9ConfigOverride = B9ConfigOverride Nothing mempty mempty Nothing makeLenses ''B9Config @@ -239,10 +262,28 @@ overrideB9Config :: (B9Config -> B9Config) -> B9ConfigOverride -> B9ConfigOverride overrideB9Config e = customB9Config <>~ Endo e +-- | Convenience utility to override the *default* B9 configuration file path. +-- +-- @since 1.1.0 +overrideDefaultB9ConfigPath :: SystemPath -> B9ConfigOverride -> B9ConfigOverride +overrideDefaultB9ConfigPath p = customDefaulB9ConfigPath ?~ p + -- | Define the current working directory to be used when building. overrideWorkingDirectory :: FilePath -> B9ConfigOverride -> B9ConfigOverride overrideWorkingDirectory p = overrideB9Config (projectRoot ?~ p) +-- | Define the default timeout for external commands. +-- +-- @since 1.1.0 +overrideDefaultTimeout :: Maybe Timeout -> B9ConfigOverride -> B9ConfigOverride +overrideDefaultTimeout = overrideB9Config . Lens.set defaultTimeout + +-- | Define the timeout factor for external commands. +-- +-- @since 1.1.0 +overrideTimeoutFactor :: Maybe Int -> B9ConfigOverride -> B9ConfigOverride +overrideTimeoutFactor = overrideB9Config . Lens.set timeoutFactor + -- | Overwrite the 'verbosity' settings in the configuration with those given. overrideVerbosity :: LogLevel -> B9ConfigOverride -> B9ConfigOverride overrideVerbosity = overrideB9Config . Lens.set verbosity . Just @@ -287,7 +328,7 @@ runB9ConfigActionWithOverrides :: HasCallStack => B9ConfigAction a -> B9ConfigOverride -> IO a runB9ConfigActionWithOverrides act cfg = do configuredCfgPaths <- traverse resolve (cfg ^. customB9ConfigPath) - defCfgPath <- resolve defaultB9ConfigFile + defCfgPath <- resolve (fromMaybe defaultB9ConfigFile (cfg ^. customDefaulB9ConfigPath)) let (Version myVer _) = My.version appendVersionVariations name = (\v' -> name <.> showVersion (makeVersion v')) <$> reverse (inits myVer) @@ -378,7 +419,9 @@ _podmanConfigs = Just defaultPodmanConfig, _libVirtLXCConfigs = Just defaultLibVirtLXCConfig, _dockerConfigs = Just defaultDockerConfig, - _remoteRepos = [] + _remoteRepos = [], + _defaultTimeout = Just (TimeoutMicros (3_600_000_000)), + _timeoutFactor = Nothing } defaultRepositoryCache :: SystemPath @@ -411,6 +454,12 @@ repositoryK :: String repositoryK = "repository" +defaultTimeoutK :: String +defaultTimeoutK = "default_timeout_seconds" + +timeoutFactorK :: String +timeoutFactorK = "timeout_factor" + cfgFileSection :: String cfgFileSection = "global" @@ -436,8 +485,10 @@ cpB <- foldr (>=>) return (podmanConfigToCPDocument <$> _podmanConfigs c) cpA cpC <- foldr (>=>) return (dockerConfigToCPDocument <$> _dockerConfigs c) cpB cpD <- foldr (>=>) return (libVirtLXCConfigToCPDocument <$> _libVirtLXCConfigs c) cpC - cpFinal <- foldr (>=>) return (remoteRepoToCPDocument <$> _remoteRepos c) cpD - setShowCP cpFinal cfgFileSection repositoryK (_repository c) + cpE <- foldr (>=>) return (remoteRepoToCPDocument <$> _remoteRepos c) cpD + cpF <- setShowCP cpE cfgFileSection repositoryK (_repository c) + cpFinal <- setShowCP cpF cfgFileSection defaultTimeoutK (_defaultTimeout c) + setShowCP cpFinal cfgFileSection timeoutFactorK (_timeoutFactor c) readB9Config :: (HasCallStack, MonadIO m) => Maybe SystemPath -> m CPDocument readB9Config cfgFile = readCPDocument (fromMaybe defaultB9ConfigFile cfgFile) @@ -457,3 +508,11 @@ <*> pure (either (const Nothing) Just (parseDockerConfig cp)) <*> pure (either (const Nothing) Just (parseLibVirtLXCConfig cp)) <*> parseRemoteRepos cp + <*> pure (either (const Nothing) Just (parseDefaultTimeoutConfig cp)) + <*> pure (either (const Nothing) Just (getr timeoutFactorK)) + +parseDefaultTimeoutConfig :: CPDocument -> Either CPError Timeout +parseDefaultTimeoutConfig cp = do + seconds <- readCP cp cfgFileSection defaultTimeoutK + let mu = seconds * 1_000_000 + return (TimeoutMicros mu) diff --git a/src/lib/B9/B9Error.hs b/src/lib/B9/B9Error.hs --- a/src/lib/B9/B9Error.hs +++ b/src/lib/B9/B9Error.hs @@ -24,9 +24,9 @@ import Control.Exception ( Exception, SomeException, - displayException, toException, ) +import qualified Control.Exception as IOExc import Control.Monad import Data.String (IsString (..)) @@ -63,8 +63,8 @@ -- | Run an `ExcB9` and rethrow the exception with `error`. -- -- @since 0.5.64 -errorOnException :: Eff (ExcB9 ': e) a -> Eff e a -errorOnException = runError >=> either (error . displayException) pure +errorOnException :: Lifted IO e => Eff (ExcB9 ': e) a -> Eff e a +errorOnException = runError >=> either (lift . IOExc.throw) pure -- | 'SomeException' wrapped into 'Exc'ecption 'Eff'ects -- diff --git a/src/lib/B9/B9Exec.hs b/src/lib/B9/B9Exec.hs --- a/src/lib/B9/B9Exec.hs +++ b/src/lib/B9/B9Exec.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE Strict #-} - -- | This modules contains support for external command execution. -- -- @since 0.5.65 @@ -8,7 +6,7 @@ hostCmdEither, hostCmd, hostCmdStdIn, - CommandTimeout (..), + Timeout (..), HostCommandStdin (..), ) where @@ -23,7 +21,7 @@ import Control.Concurrent.Async (Concurrently (..), race) import Control.Eff import qualified Control.Exception as ExcIO -import Control.Monad +import Control.Lens (view) import Control.Monad.IO.Class import Control.Monad.Trans.Control (control, embed_, restoreM) import qualified Data.ByteString as Strict @@ -37,11 +35,10 @@ import qualified Data.Conduit.List as CL import Data.Conduit.Process import Data.Functor () +import Data.Maybe import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import qualified Data.Text.Encoding.Error as Text +import GHC.Stack import System.Exit -import Text.Printf -- | Execute the given shell command. -- @@ -55,51 +52,22 @@ -- exit code. -- -- @since 0.5.65 -cmd :: CommandIO e => String -> Eff e () +cmd :: + (HasCallStack, Member ExcB9 e, CommandIO e) => + String -> + Eff e () cmd str = do + t <- view defaultTimeout <$> getB9Config inheritStdIn <- isInteractive - if inheritStdIn then interactiveCmd str else nonInteractiveCmd str - -interactiveCmd :: forall e. CommandIO e => String -> Eff e () -interactiveCmd str = void (cmdWithStdIn True str :: Eff e Inherited) - -nonInteractiveCmd :: forall e. CommandIO e => String -> Eff e () --- TODO if we use 'ClosedStream' we get an error from 'virsh console' --- complaining about a missing controlling tty. Original source line: --- nonInteractiveCmd str = void (cmdWithStdIn False str :: B9 ClosedStream) -nonInteractiveCmd str = void (cmdWithStdIn False str :: Eff e Inherited) - -cmdWithStdIn :: - (CommandIO e, InputSource stdin) => Bool -> String -> Eff e stdin -cmdWithStdIn toStdOut cmdStr = do - traceL $ "COMMAND: " ++ cmdStr - traceLIO <- - embed_ - (traceL . Text.unpack . Text.decodeUtf8With Text.lenientDecode) - errorLIO <- - embed_ - (errorL . Text.unpack . Text.decodeUtf8With Text.lenientDecode) - let errorLC = CL.mapM_ (liftIO . errorLIO) - let traceLC = - if toStdOut - then CL.mapM_ Strict.putStr - else CL.mapM_ (liftIO . traceLIO) - (cpIn, cpOut, cpErr, cph) <- streamingProcess (shell cmdStr) - e <- - liftIO - $ runConcurrently - $ Concurrently (runConduit (cpOut .| traceLC)) - *> Concurrently (runConduit (cpErr .| errorLC)) - *> Concurrently (waitForStreamingProcess cph) - closeStreamingProcessHandle cph - checkExitCode e - return cpIn - where - 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 - liftIO $ exitWith ec + ok <- + if inheritStdIn + then hostCmdEither HostCommandInheritStdin str t + else hostCmdEither HostCommandNoStdin str t + case ok of + Right _ -> + return () + Left e -> + errorExitL ("SYSTEM COMMAND FAILED: " ++ show e) -- | Run a shell command defined by a string and optionally interrupt the command -- after a given time has elapsed. @@ -113,8 +81,8 @@ (CommandIO e, Member ExcB9 e) => -- | The shell command to execute. String -> - -- | An optional 'CommandTimeout' - Maybe CommandTimeout -> + -- | An optional 'Timeout' + Maybe Timeout -> -- | An action that performs the shell command and returns 'True' on success Eff e Bool hostCmd cmdStr timeout = do @@ -140,8 +108,8 @@ HostCommandStdin -> -- | The shell command to execute. String -> - -- | An optional 'CommandTimeout' - Maybe CommandTimeout -> + -- | An optional 'Timeout' + Maybe Timeout -> -- | An action that performs the shell command and returns 'True' on success Eff e Bool hostCmdStdIn hostStdIn cmdStr timeout = do @@ -181,27 +149,34 @@ HostCommandStdin -> -- | The shell command to execute. String -> - -- | An optional 'CommandTimeout' - Maybe CommandTimeout -> - Eff e (Either CommandTimeout ExitCode) -hostCmdEither inputSource cmdStr timeout = do + -- | An optional 'Timeout' + Maybe Timeout -> + Eff e (Either Timeout ExitCode) +hostCmdEither inputSource cmdStr timeoutArg = do let tag = "[" ++ printHash cmdStr ++ "]" traceL $ "COMMAND " ++ tag ++ ": " ++ cmdStr + tf <- fromMaybe 1 . view timeoutFactor <$> getB9Config + timeout <- + fmap (TimeoutMicros . \(TimeoutMicros t) -> tf * t) + <$> maybe + (view defaultTimeout <$> getB9Config) + (return . Just) + timeoutArg control $ \runInIO -> do ExcIO.catch - (runInIO (go tag)) + (runInIO (go timeout tag)) ( \(e :: ExcIO.SomeException) -> do - putStrLn ("COMMAND " ++ tag ++ " interrupted: " ++ show e) - runInIO (return (Right (ExitFailure 126) :: Either CommandTimeout ExitCode)) + runInIO (errorL ("COMMAND " ++ tag ++ " interrupted: " ++ show e)) + runInIO (return (Right (ExitFailure 126) :: Either Timeout ExitCode)) ) >>= restoreM where - go :: String -> Eff e (Either CommandTimeout ExitCode) - go tag = do + go :: Maybe Timeout -> String -> Eff e (Either Timeout ExitCode) + go timeout tag = do traceLC <- traceMsgProcessLogger tag errorLC <- errorMsgProcessLogger tag - let timer t@(CommandTimeout micros) = do + let timer t@(TimeoutMicros micros) = do threadDelay micros return t (cph, runCmd) <- case inputSource of @@ -238,9 +213,6 @@ Right (ExitFailure ec) -> errorL $ "COMMAND FAILED EXIT CODE: " ++ show ec ++ " " ++ tag return e - -data CommandTimeout = CommandTimeout Int - deriving (Show) newtype ProcessLogger = MkProcessLogger 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 @@ -12,6 +12,7 @@ import B9.BuildInfo import B9.Environment import B9.Repository +import B9.RepositoryIO import Control.Eff import Data.Functor () import GHC.Stack diff --git a/src/lib/B9/BuildInfo.hs b/src/lib/B9/BuildInfo.hs --- a/src/lib/B9/BuildInfo.hs +++ b/src/lib/B9/BuildInfo.hs @@ -76,8 +76,8 @@ Eff (BuildInfoReader ': e) a -> Eff e a withBuildInfo action = withRootDir $ do - now <- lift getCurrentTime - let buildDate = formatTime undefined "%F-%T" now + now <- lift getCurrentTime -- TODO reproducability: make configurable how the build-date is generated, e.g. by using always 1970/01/01-00:01 + let buildDate = formatTime undefined "%F-%T" now -- TODO make configurable how the build date is formatted buildId <- generateBuildId buildDate withBuildDir buildId (runImpl buildId buildDate now) where diff --git a/src/lib/B9/DiskImageBuilder.hs b/src/lib/B9/DiskImageBuilder.hs --- a/src/lib/B9/DiskImageBuilder.hs +++ b/src/lib/B9/DiskImageBuilder.hs @@ -15,13 +15,6 @@ convertImage, shareImage, ensureAbsoluteImageDirExists, - pushSharedImageLatestVersion, - lookupSharedImages, - getSharedImages, - getSharedImagesCacheDir, - getSelectedRepos, - pullRemoteRepos, - pullLatestImage, ) where @@ -35,27 +28,25 @@ import B9.DiskImages import B9.Environment import qualified B9.PartitionTable as P -import B9.Repository import B9.RepositoryIO import Control.Eff -import Control.Exception +import qualified Control.Exception as IO import Control.Lens ((^.)) import Control.Monad import Control.Monad.IO.Class -import Data.Function import Data.Generics.Aliases import Data.Generics.Schemes import Data.List import Data.Maybe +import qualified Foreign.C.Error as IO +import qualified GHC.IO.Exception as IO import GHC.Stack import System.Directory import System.FilePath import System.IO.B9Extras - ( consult, - ensureDir, + ( ensureDir, prettyPrintToFile, ) -import System.IO.Error (isDoesNotExistError) import Text.Printf (printf) import Text.Show.Pretty (ppShow) @@ -401,7 +392,12 @@ | doMove && fmtIn == fmtOut = do ensureDir imgOut dbgL (printf "Moving '%s' to '%s'" imgIn imgOut) - liftIO (renameFile imgIn imgOut) + liftIO $ do + let exdev e = + if IO.ioe_errno e == Just ((\(IO.Errno a) -> a) IO.eXDEV) + then copyFile imgIn imgOut >> removeFile imgIn + else IO.throw e + renameFile imgIn imgOut `IO.catch` exdev | otherwise = do ensureDir imgOut dbgL @@ -447,6 +443,8 @@ pushToSelectedRepo sharedImage return sharedImage +-- TODO Move the functions below to RepositoryIO??? + -- | Return a 'SharedImage' with the current build data and build id from the -- name and disk image. getSharedImageFromImageInfo :: @@ -477,187 +475,33 @@ dbgL (printf "CREATED SHARED IMAGE IN CACHE '%s'" (ppShow sharedImg)) cleanOldSharedImageRevisionsFromCache sname return sharedImg - --- | Publish the latest version of a shared image identified by name to the --- selected repository from the cache. -pushSharedImageLatestVersion :: IsB9 e => SharedImageName -> Eff e () -pushSharedImageLatestVersion name@(SharedImageName imgName) = - getLatestSharedImageByNameFromCache name - >>= maybe - (errorExitL (printf "Nothing found for %s." (show imgName))) - ( \sharedImage -> do - dbgL (printf "PUSHING '%s'" (ppShow sharedImage)) - pushToSelectedRepo sharedImage - infoL (printf "PUSHED '%s'" imgName) - ) - --- | Upload a shared image from the cache to a selected remote repository -pushToSelectedRepo :: IsB9 e => SharedImage -> Eff e () -pushToSelectedRepo i = do - c <- getSharedImagesCacheDir - MkSelectedRemoteRepo r <- getSelectedRemoteRepo - when (isJust r) $ do - let (Image imgFile' _imgType _imgFS) = sharedImageImage i - cachedImgFile = c imgFile' - cachedInfoFile = c sharedImageFileName i - repoImgFile = sharedImagesRootDirectory imgFile' - repoInfoFile = sharedImagesRootDirectory sharedImageFileName i - pushToRepo (fromJust r) cachedImgFile repoImgFile - pushToRepo (fromJust r) cachedInfoFile repoInfoFile - --- | Pull metadata files from all remote repositories. -pullRemoteRepos :: IsB9 e => Eff e () -pullRemoteRepos = do - repos <- getSelectedRepos - mapM_ dl repos - where - dl = - pullGlob - sharedImagesRootDirectory - (FileExtension sharedImageFileExtension) - --- | Pull the latest version of an image, either from the selected remote --- repo or from the repo that has the latest version. -pullLatestImage :: IsB9 e => SharedImageName -> Eff e (Maybe SharedImageBuildId) -pullLatestImage name@(SharedImageName dbgName) = do - repos <- getSelectedRepos - let repoPredicate Cache = False - repoPredicate (Remote repoId) = repoId `elem` repoIds - repoIds = map remoteRepoRepoId repos - hasName sharedImage = name == sharedImageName sharedImage - candidates <- lookupSharedImages repoPredicate hasName - let (Remote repoId, image) = last candidates - if null candidates - then do - errorL - ( printf - "No shared image named '%s' on these remote repositories: '%s'" - dbgName - (ppShow repoIds) - ) - return Nothing - else do - dbgL (printf "PULLING SHARED IMAGE: '%s'" (ppShow image)) - cacheDir <- getSharedImagesCacheDir - let (Image imgFile' _imgType _fs) = sharedImageImage image - cachedImgFile = cacheDir imgFile' - cachedInfoFile = cacheDir sharedImageFileName image - repoImgFile = sharedImagesRootDirectory imgFile' - repoInfoFile = sharedImagesRootDirectory sharedImageFileName image - repo = fromJust (lookupRemoteRepo repos repoId) - pullFromRepo repo repoImgFile cachedImgFile - pullFromRepo repo repoInfoFile cachedInfoFile - infoL (printf "PULLED '%s' FROM '%s'" dbgName repoId) - cleanOldSharedImageRevisionsFromCache name - return (Just (sharedImageBuildId image)) - --- | Return the 'Image' of the latest version of a shared image named 'name' --- from the local cache. -getLatestImageByName :: IsB9 e => SharedImageName -> Eff e (Maybe Image) -getLatestImageByName name = do - sharedImage <- getLatestSharedImageByNameFromCache name - cacheDir <- getSharedImagesCacheDir - let image = changeImageDirectory cacheDir . sharedImageImage <$> sharedImage - case image of - Just i -> dbgL (printf "USING SHARED SOURCE IMAGE '%s'" (show i)) - Nothing -> errorL (printf "SOURCE IMAGE '%s' NOT FOUND" (show name)) - return image - --- | Return the latest version of a shared image named 'name' from the local cache. -getLatestSharedImageByNameFromCache :: - IsB9 e => SharedImageName -> Eff e (Maybe SharedImage) -getLatestSharedImageByNameFromCache name@(SharedImageName dbgName) = do - imgs <- lookupSharedImages (== Cache) ((== name) . sharedImageName) - case reverse imgs of - (Cache, sharedImage) : _rest -> return (Just sharedImage) - _ -> do - errorL (printf "No image(s) named '%s' found." dbgName) - return Nothing - --- | Return a list of all existing sharedImages from cached repositories. -getSharedImages :: IsB9 e => Eff e [(Repository, [SharedImage])] -getSharedImages = do - reposAndFiles <- - repoSearch - sharedImagesRootDirectory - (FileExtension sharedImageFileExtension) - mapM - (\(repo, files) -> (repo,) . catMaybes <$> mapM consult' files) - reposAndFiles - where - consult' f = do - r <- liftIO (try (consult f)) - case r of - Left (e :: SomeException) -> do - dbgL - ( printf - "Failed to load shared image meta-data from '%s': '%s'" - (takeFileName f) - (show e) - ) - dbgL (printf "Removing bad meta-data file '%s'" f) - liftIO (removeFile f) - return Nothing - Right c -> return (Just c) - --- | Find shared images and the associated repos from two predicates. The result --- is the concatenated result of the sorted shared images satisfying 'imgPred'. -lookupSharedImages :: - IsB9 e => - (Repository -> Bool) -> - (SharedImage -> Bool) -> - Eff e [(Repository, SharedImage)] -lookupSharedImages repoPred imgPred = do - xs <- getSharedImages - let rs = [(r, s) | (r, ss) <- xs, s <- ss] - matchingRepo = filter (repoPred . fst) rs - matchingImg = filter (imgPred . snd) matchingRepo - sorted = sortBy (compare `on` snd) matchingImg - return (mconcat (pure <$> sorted)) - --- | Return either all remote repos or just the single selected repo. -getSelectedRepos :: IsB9 e => Eff e [RemoteRepo] -getSelectedRepos = do - allRepos <- getRemoteRepos - MkSelectedRemoteRepo selectedRepo <- getSelectedRemoteRepo - let repos = maybe allRepos return selectedRepo -- 'Maybe' a repo - return repos - --- | Return the path to the sub directory in the cache that contains files of --- shared images. -getSharedImagesCacheDir :: IsB9 e => Eff e FilePath -getSharedImagesCacheDir = do - cacheDir <- localRepoDir <$> getRepoCache - return (cacheDir sharedImagesRootDirectory) - --- | Depending on the 'maxLocalSharedImageRevisions' 'B9Config' settings either --- do nothing or delete all but the configured number of most recent shared --- images with the given name from the local cache. -cleanOldSharedImageRevisionsFromCache :: IsB9 e => SharedImageName -> Eff e () -cleanOldSharedImageRevisionsFromCache sn = do - b9Cfg <- getConfig - forM_ (b9Cfg ^. maxLocalSharedImageRevisions) $ \maxRevisions -> do - toDelete <- take maxRevisions <$> newestSharedImages - imgDir <- getSharedImagesCacheDir - let filesToDelete = (imgDir ) <$> (infoFiles ++ imgFiles) - infoFiles = sharedImageFileName <$> toDelete - imgFiles = imageFileName . sharedImageImage <$> toDelete - unless (null filesToDelete) $ do - traceL - ( printf - "DELETING %d OBSOLETE REVISIONS OF: %s" - (length filesToDelete) - (show sn) - ) - mapM_ traceL filesToDelete - mapM_ removeIfExists filesToDelete - where - newestSharedImages :: IsB9 e => Eff e [SharedImage] - newestSharedImages = - reverse . map snd - <$> lookupSharedImages (== Cache) ((sn ==) . sharedImageName) - removeIfExists fileName = liftIO $ removeFile fileName `catch` handleExists - where - handleExists e - | isDoesNotExistError e = return () - | otherwise = throwIO e +-- +-- +-- +-- +-- +-- +-- imgDir <- getSharedImagesCacheDir +-- let filesToDelete = (imgDir ) <$> (infoFiles ++ imgFiles) +-- infoFiles = sharedImageFileName <$> toDelete +-- imgFiles = imageFileName . sharedImageImage <$> toDelete +-- unless (null filesToDelete) $ do +-- traceL +-- ( printf +-- "DELETING %d OBSOLETE REVISIONS OF: %s" +-- (length filesToDelete) +-- (show sn) +-- ) +-- mapM_ traceL filesToDelete +-- mapM_ removeIfExists filesToDelete +-- where +-- newestSharedImages :: IsB9 e => Eff e [SharedImage] +-- newestSharedImages = +-- reverse . map snd +-- <$> lookupSharedImages (== Cache) ((sn ==) . sharedImageName) +-- removeIfExists fileName = liftIO $ removeFile fileName `catch` handleExists +-- where +-- handleExists e +-- | isDoesNotExistError e = return () +-- | otherwise = throwIO e +-- diff --git a/src/lib/B9/DiskImages.hs b/src/lib/B9/DiskImages.hs --- a/src/lib/B9/DiskImages.hs +++ b/src/lib/B9/DiskImages.hs @@ -7,8 +7,14 @@ import Data.Binary import Data.Data import Data.Hashable +import Data.Map (Map) import Data.Maybe import Data.Semigroup as Sem +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Time.Calendar (Day (ModifiedJulianDay)) +import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, secondsToDiffTime) +import Data.Time.Format (defaultTimeLocale, formatTime, parseTimeOrError) import GHC.Generics (Generic) import System.FilePath import Test.Hspec (Spec, describe, it) @@ -122,6 +128,10 @@ data ImageType = Raw | QCow2 | Vmdk deriving (Eq, Read, Typeable, Data, Show, Generic) +instance CoArbitrary ImageType + +instance Function ImageType + instance Hashable ImageType instance Binary ImageType @@ -132,6 +142,10 @@ data FileSystem = NoFileSystem | Ext4 | Ext4_64 | ISO9660 | VFAT deriving (Eq, Show, Read, Typeable, Data, Generic) +instance Function FileSystem + +instance CoArbitrary FileSystem + instance Hashable FileSystem instance Binary FileSystem @@ -238,6 +252,19 @@ FileSystem deriving (Eq, Read, Show, Typeable, Data, Generic) +instance Arbitrary SharedImage where + arbitrary = + SharedImage + <$> smaller arbitrary + <*> smaller arbitrary + <*> smaller arbitrary + <*> smaller arbitrary + <*> smaller arbitrary + +instance CoArbitrary SharedImage + +instance Function SharedImage + instance Hashable SharedImage instance Binary SharedImage @@ -248,7 +275,9 @@ -- 'Share'. B9 always selects the newest version the shared image identified -- by that name when using a shared image as an 'ImageSource'. This is a -- wrapper around a string that identifies a 'SharedImage' -newtype SharedImageName = SharedImageName String deriving (Eq, Ord, Read, Show, Typeable, Data, Hashable, Binary, NFData) +newtype SharedImageName + = SharedImageName String + deriving (Eq, Ord, Read, Show, Typeable, Data, Hashable, Binary, NFData, CoArbitrary) -- | Get the String representation of a 'SharedImageName'. fromSharedImageName :: SharedImageName -> String @@ -257,7 +286,9 @@ -- | The exact time that build job __started__. -- This is a wrapper around a string contains the build date of a -- 'SharedImage'; this is purely additional convenience and typesafety -newtype SharedImageDate = SharedImageDate String deriving (Eq, Ord, Read, Show, Typeable, Data, Hashable, Binary, NFData) +newtype SharedImageDate + = SharedImageDate String + deriving (Eq, Ord, Read, Show, Typeable, Data, Hashable, Binary, NFData, CoArbitrary) -- | Every B9 build running in a 'B9Monad' -- contains a random unique id that is generated once per build (no matter how @@ -265,7 +296,10 @@ -- of the build that created the shared image instance. This is A wrapper -- around a string contains the build id of a 'SharedImage'; this is purely -- additional convenience and typesafety -newtype SharedImageBuildId = SharedImageBuildId String deriving (Eq, Ord, Read, Show, Typeable, Data, Hashable, Binary, NFData) +newtype SharedImageBuildId + = SharedImageBuildId String + deriving + (Eq, Ord, Read, Show, Typeable, Data, Hashable, Binary, NFData, CoArbitrary) -- | Get the String representation of a 'SharedImageBuildId'. fromSharedImageBuildId :: SharedImageBuildId -> String @@ -276,6 +310,26 @@ compare (SharedImage n d b _ _) (SharedImage n' d' b' _ _) = compare n n' Sem.<> compare d d' Sem.<> compare b b' +-- | Transform a list of 'SharedImage' values into a 'Map' that associates +-- each 'SharedImageName' with a 'Set' of the actual images with that name. +-- +-- The 'Set' contains values of type @'SharedImage'@. +-- +-- The 'Ord' instance of 'SharedImage' sorts by name first and then by +-- 'sharedImageDate', since the values in a 'Set' share the same 'sharedImageName', +-- they are effectively orderd by build date, which is useful the shared image cleanup. +-- +-- @since 1.1.0 +sharedImagesToMap :: [SharedImage] -> Map SharedImageName (Set SharedImage) +sharedImagesToMap _ = error "TODO IMPLEMENT ME" + +-- | Return the 'SharedImage' with the highest 'sharedImageDate'. +-- +-- @since 1.1.0 +takeLatestSharedImage :: [SharedImage] -> Maybe SharedImage +takeLatestSharedImage _ss = do + error "TODO IMPLEMENT ME" + -- * Constructor and accessors for 'Image' 'ImageTarget' 'ImageSource' -- 'ImageDestination' and 'SharedImage' @@ -377,7 +431,7 @@ sharedImageBuildId (SharedImage _ _ n _ _) = n -- | Print the contents of the shared image in one line -prettyPrintSharedImages :: [SharedImage] -> String +prettyPrintSharedImages :: Set SharedImage -> String prettyPrintSharedImages imgs = Boxes.render table where table = Boxes.hsep 1 Boxes.left cols @@ -393,7 +447,7 @@ col title accessor = Boxes.text title Boxes.// Boxes.vcat Boxes.left cells where - cells = Boxes.text . accessor <$> imgs + cells = Boxes.text . accessor <$> Set.toList imgs -- | Return the disk image of an sharedImage sharedImageImage :: SharedImage -> Image @@ -531,9 +585,10 @@ instance Arbitrary ImageSource where arbitrary = oneof - [ EmptyImage "img-label" - <$> smaller arbitrary + [ EmptyImage . printf "img-label-%0X" + <$> choose (0, 63 :: Int) <*> smaller arbitrary + <*> smaller arbitrary <*> smaller arbitrary, CopyOnWrite <$> smaller arbitrary, SourceImage @@ -569,11 +624,14 @@ ] instance Arbitrary Partition where - arbitrary = oneof [Partition <$> elements [0, 1, 2], pure NoPT] + arbitrary = oneof [Partition <$> choose (0, 2), pure NoPT] instance Arbitrary Image where arbitrary = - Image "img-file-name" <$> smaller arbitrary <*> smaller arbitrary + Image . printf "img-file-name-%0X" + <$> choose (0, 63 :: Int) + <*> smaller arbitrary + <*> smaller arbitrary instance Arbitrary FileSystem where arbitrary = elements [Ext4] @@ -590,9 +648,40 @@ instance Arbitrary SharedImageName where arbitrary = SharedImageName <$> arbitrarySharedImageName +instance Function SharedImageName where + function = functionShow + arbitrarySharedImageName :: Gen String arbitrarySharedImageName = - elements [printf "arbitrary-shared-img-name-%d" x | x <- [0 :: Int .. 3]] + printf "shared-img-%0X" <$> choose (0, 63 :: Int) + +instance Arbitrary SharedImageBuildId where + arbitrary = do + SharedImageBuildId . printf "shared-img-build-id-%0X" <$> choose (0, maxBound `div` 1024 :: Int) + +instance Function SharedImageBuildId where + function = functionMap fromSharedImageBuildId SharedImageBuildId + +instance Function SharedImageDate where + function = + functionMap + ( ( \(UTCTime (ModifiedJulianDay d) dt) -> + (d, diffTimeToPicoseconds dt `div` 1000000000000) + ) + . parseTimeOrError False defaultTimeLocale "%F-%T" + . (\(SharedImageDate d) -> d) + ) + ( SharedImageDate + . (formatTime defaultTimeLocale "%F-%T") + . (\(d, dt) -> UTCTime (ModifiedJulianDay d) (secondsToDiffTime dt)) + ) + +instance Arbitrary SharedImageDate where + arbitrary = + SharedImageDate + . (formatTime defaultTimeLocale "%F-%T") + . (\(d, dt) -> UTCTime (ModifiedJulianDay d) (secondsToDiffTime dt)) + <$> arbitrary unitTests :: Spec unitTests = diff --git a/src/lib/B9/Docker.hs b/src/lib/B9/Docker.hs --- a/src/lib/B9/Docker.hs +++ b/src/lib/B9/Docker.hs @@ -5,30 +5,14 @@ where import B9.B9Config - ( ContainerCapability, - dockerConfigs, + ( dockerConfigs, getB9Config, ) import B9.B9Config.Docker as X -import B9.B9Exec -import B9.BuildInfo import B9.Container import B9.DiskImages -import B9.ExecEnv import B9.ShellScript import Control.Lens (view) -import Control.Monad.IO.Class - ( MonadIO, - liftIO, - ) -import Data.Char (toLower) -import System.Directory -import System.FilePath -import System.IO.B9Extras - ( UUID (), - randomUUID, - ) -import Text.Printf (printf) newtype Docker = Docker DockerConfig @@ -46,7 +30,7 @@ -- ExecEnv -> -- Script -> -- Eff e Bool - runInEnvironment (Docker dcfg) env scriptIn = do + runInEnvironment (Docker _dcfg) _env scriptIn = do if emptyScript scriptIn then return True else do error "TODO" diff --git a/src/lib/B9/LibVirtLXC.hs b/src/lib/B9/LibVirtLXC.hs --- a/src/lib/B9/LibVirtLXC.hs +++ b/src/lib/B9/LibVirtLXC.hs @@ -12,6 +12,7 @@ libVirtLXCConfigs, ) import B9.B9Config.LibVirtLXC as X +import B9.B9Error import B9.B9Exec import B9.B9Logging import B9.BuildInfo @@ -77,7 +78,7 @@ successMarkerFile :: [Char] successMarkerFile = "SUCCESS" -execute :: (CommandIO e, Member B9ConfigReader e) => Context -> Eff e Bool +execute :: (Member ExcB9 e, CommandIO e, Member B9ConfigReader e) => Context -> Eff e Bool execute (Context scriptDirHost _uuid domainFile cfg) = do cmd $ printf "%s create '%s' --console --autodestroy" virshCommand domainFile -- cmd $ printf "%s console %U" virsh uuid diff --git a/src/lib/B9/Podman.hs b/src/lib/B9/Podman.hs --- a/src/lib/B9/Podman.hs +++ b/src/lib/B9/Podman.hs @@ -5,30 +5,14 @@ where import B9.B9Config - ( ContainerCapability, - getB9Config, + ( getB9Config, podmanConfigs, ) import B9.B9Config.Podman as X -import B9.B9Exec -import B9.BuildInfo import B9.Container import B9.DiskImages -import B9.ExecEnv import B9.ShellScript import Control.Lens (view) -import Control.Monad.IO.Class - ( MonadIO, - liftIO, - ) -import Data.Char (toLower) -import System.Directory -import System.FilePath -import System.IO.B9Extras - ( UUID (), - randomUUID, - ) -import Text.Printf (printf) newtype Podman = Podman PodmanConfig @@ -46,7 +30,7 @@ -- ExecEnv -> -- Script -> -- Eff e Bool - runInEnvironment (Podman dcfg) env scriptIn = do + runInEnvironment (Podman _dcfg) _env scriptIn = do if emptyScript scriptIn then return True else do error "TODO" diff --git a/src/lib/B9/Repository.hs b/src/lib/B9/Repository.hs --- a/src/lib/B9/Repository.hs +++ b/src/lib/B9/Repository.hs @@ -4,20 +4,29 @@ -- shall interfere with each other. This is accomplished by refraining from -- automatic cache updates from/to remote repositories. module B9.Repository - ( initRepoCache, - RepoCacheReader, + ( RepoCacheReader, getRepoCache, - withRemoteRepos, withSelectedRemoteRepo, getSelectedRemoteRepo, SelectedRemoteRepoReader, + Repository (..), + RepoImagesMap, + toRemoteRepository, SelectedRemoteRepo (..), - initRemoteRepo, - cleanRemoteRepo, - remoteRepoCheckSshPrivKey, remoteRepoCacheDir, localRepoDir, lookupRemoteRepo, + filterRepoImagesMap, + lookupCachedImages, + allCachedSharedImages, + allSharedImagesWithRepo, + maxSharedImageOfAllRepos, + allSharedImagesInRepo, + allSharedImages, + allRepositories, + groupBySharedImageName, + keepNLatestSharedImages, + dropAllButNLatestSharedImages, module X, ) where @@ -25,35 +34,40 @@ import B9.B9Config import B9.B9Config.Repository as X import B9.B9Error +import B9.DiskImages import Control.Eff import Control.Eff.Reader.Lazy -import Control.Lens -import Control.Monad -import Control.Monad.IO.Class +import Data.Foldable +import Data.Map (Map) +import qualified Data.Map as Map import Data.Maybe -import System.Directory +import Data.Set (Set) +import qualified Data.Set as Set +import GHC.Generics import System.FilePath -import System.IO.B9Extras +import Test.QuickCheck import Text.Printf --- | Initialize the local repository cache directory and the 'RemoteRepo's. --- Run the given action with a 'B9Config' that contains the initialized --- repositories in '_remoteRepos'. --- --- @since 0.5.65 -withRemoteRepos :: - (Member B9ConfigReader e, Lifted IO e) => - Eff (RepoCacheReader ': e) a -> - Eff e a -withRemoteRepos f = do - cfg <- getB9Config - repoCache <- - lift - (initRepoCache (fromMaybe defaultRepositoryCache (_repositoryCache cfg))) - remoteRepos' <- mapM (initRemoteRepo repoCache) (_remoteRepos cfg) - let setRemoteRepos = remoteRepos .~ remoteRepos' - localB9Config setRemoteRepos (runReader repoCache f) +data Repository + = Cache + | Remote String -- TODO use a newtype + deriving (Eq, Ord, Read, Show, Generic) +instance Arbitrary Repository where + arbitrary = + Test.QuickCheck.oneof + [ pure Cache, + Remote . printf "remote-repo-%0X" <$> choose (0, 31 :: Int) + ] + +instance Function Repository + +instance CoArbitrary Repository + +-- | Convert a `RemoteRepo` down to a mere `Repository` +toRemoteRepository :: RemoteRepo -> Repository +toRemoteRepository = Remote . remoteRepoRepoId + -- | Alias for a 'Reader' 'Eff'ect that reads a list of 'RemoteRepo's. -- -- @since 0.5.65 @@ -111,49 +125,6 @@ Member SelectedRemoteRepoReader e => Eff e SelectedRemoteRepo getSelectedRemoteRepo = ask --- | Initialize the local repository cache directory. -initRepoCache :: MonadIO m => SystemPath -> m RepoCache -initRepoCache repoDirSystemPath = do - repoDir <- resolve repoDirSystemPath - ensureDir (repoDir ++ "/") - return (RepoCache repoDir) - --- | Check for existance of priv-key and make it an absolute path. -remoteRepoCheckSshPrivKey :: MonadIO m => RemoteRepo -> m RemoteRepo -remoteRepoCheckSshPrivKey (RemoteRepo rId rp (SshPrivKey keyFile) h u) = do - exists <- liftIO (doesFileExist keyFile) - keyFile' <- liftIO (canonicalizePath keyFile) - unless - exists - ( error - (printf "SSH Key file '%s' for repository '%s' is missing." keyFile' rId) - ) - return (RemoteRepo rId rp (SshPrivKey keyFile') h u) - --- | Initialize the repository; load the corresponding settings from the config --- file, check that the priv key exists and create the correspondig cache --- directory. -initRemoteRepo :: MonadIO m => RepoCache -> RemoteRepo -> m RemoteRepo -initRemoteRepo cache repo = do - -- TODO logging traceL $ printf "Initializing remote repo: %s" (remoteRepoRepoId repo) - repo' <- remoteRepoCheckSshPrivKey repo - let (RemoteRepo repoId _ _ _ _) = repo' - ensureDir (remoteRepoCacheDir cache repoId ++ "/") - return repo' - --- | Empty the repository; load the corresponding settings from the config --- file, check that the priv key exists and create the correspondig cache --- directory. -cleanRemoteRepo :: MonadIO m => RepoCache -> RemoteRepo -> m () -cleanRemoteRepo cache repo = do - let repoId = remoteRepoRepoId repo - repoDir = remoteRepoCacheDir cache repoId ++ "/" - -- TODO logging infoL $ printf "Cleaning remote repo: %s" repoId - ensureDir repoDir - -- TODO logging traceL $ printf "Deleting directory: %s" repoDir - liftIO $ removeDirectoryRecursive repoDir - ensureDir repoDir - -- | Return the cache directory for a remote repository relative to the root -- cache dir. remoteRepoCacheDir :: @@ -181,3 +152,169 @@ lookupRemoteRepo repos repoId = lookup repoId repoIdRepoPairs where repoIdRepoPairs = map (\r@(RemoteRepo rid _ _ _ _) -> (rid, r)) repos + +-- | A 'Map' that maps 'Repository's to the 'SharedImage's they hold. +-- +-- @since 1.1.0 +type RepoImagesMap = Map Repository (Set SharedImage) + +-- | Filter the 'SharedImage's returned by 'getSharedImages' +-- using a 'Repository'-, and a 'SharedImage' predicate. +-- +-- @since 1.1.0 +filterRepoImagesMap :: + (Repository -> Bool) -> + (SharedImage -> Bool) -> + RepoImagesMap -> + RepoImagesMap +filterRepoImagesMap repoPred imgPred = + Map.map (Set.filter imgPred) + . Map.filterWithKey (const . repoPred) + +-- | Return the versions of a shared image named 'name' from the local cache. +-- +-- @since 1.1.0 +lookupCachedImages :: + SharedImageName -> + RepoImagesMap -> + Set SharedImage +lookupCachedImages name = + allSharedImages + . filterRepoImagesMap (== Cache) ((== name) . sharedImageName) + +-- | Return a 'Set' of 'Repository' names from a 'RepoImagesMap' +-- +-- @since 1.1.0 +allRepositories :: RepoImagesMap -> Set Repository +allRepositories = Map.keysSet + +-- | Get a 'Set' of all 'SharedImage's in all 'Repository's. +-- +-- @since 1.1.0 +allSharedImages :: RepoImagesMap -> Set SharedImage +allSharedImages = fold + +-- | Fetch all 'SharedImage's like 'allSharedImages' but attach +-- the 'Repository' that the image belongs to. +-- +-- Usage example: In combination with 'filterRepoImagesMap' to find +-- the latest version of a certain image in all known repositories. +-- +-- @since 1.1.0 +allSharedImagesWithRepo :: RepoImagesMap -> Set (SharedImage, Repository) +allSharedImagesWithRepo = Map.foldMapWithKey (Set.map . flip (,)) + +-- | Return the maximum with regard to the 'Ord' instance of 'SharedImage' +-- from an 'RepoImagesMap' +-- +-- @since 1.1.0 +maxSharedImageOfAllRepos :: RepoImagesMap -> Maybe (SharedImage, Repository) +maxSharedImageOfAllRepos = Set.lookupMax . allSharedImagesWithRepo + +-- | Return the 'SharedImage's, that are contained in a 'Repository'. +-- +-- @since 1.1.0 +allSharedImagesInRepo :: Repository -> RepoImagesMap -> Set SharedImage +allSharedImagesInRepo repo = fromMaybe Set.empty . Map.lookup repo + +-- | Keep 'SharedImage's that are in the 'Cache' 'Repository'. +-- +-- @since 1.1.0 +allCachedSharedImages :: + RepoImagesMap -> + Set SharedImage +allCachedSharedImages = allSharedImagesInRepo Cache + +-- | Take a subset that contains the @n@ +-- latest versions of 'SharedImage's with the same name. +-- +-- For example, if the input contains: +-- +-- @@@ +-- fromList +-- [ SharedImage "foo" "2020-07-07 13:34:31" +-- , SharedImage "foo" "2020-07-07 13:34:32" +-- , SharedImage "foo" "2020-07-07 13:34:33" +-- , SharedImage "bar" "2020-07-07 13:34:34" +-- , SharedImage "bar" "2020-07-07 13:34:35" +-- , SharedImage "bar" "2020-07-07 13:34:36" +-- ] +-- @@@ +-- +-- The output of @keepNLatestSharedImages 2@ will be: +-- +-- @@@ +-- fromList +-- [ SharedImage "foo" "2020-07-07 13:34:32" +-- , SharedImage "foo" "2020-07-07 13:34:33" +-- , SharedImage "bar" "2020-07-07 13:34:35" +-- , SharedImage "bar" "2020-07-07 13:34:36" +-- ] +-- @@@ +-- +-- @since 1.1.0 +keepNLatestSharedImages :: Int -> Set SharedImage -> Set SharedImage +keepNLatestSharedImages n = + fold + . Map.map + ( \s -> + let nOld = max 0 (length s - n) + in Set.drop nOld s + ) + . groupBySharedImageName + +-- | Take a subset that contains obsolete images. +-- +-- Do the opposite of 'keepNLatestSharedImages', +-- and return all **but** the @n@ +-- latest versions of 'SharedImage's with the same name. +-- +-- For example, if the input contains: +-- +-- @@@ +-- fromList +-- [ SharedImage "foo" "2020-07-07 13:34:31" +-- , SharedImage "foo" "2020-07-07 13:34:32" +-- , SharedImage "foo" "2020-07-07 13:34:33" +-- , SharedImage "bar" "2020-07-07 13:34:34" +-- , SharedImage "bar" "2020-07-07 13:34:35" +-- , SharedImage "bar" "2020-07-07 13:34:36" +-- ] +-- @@@ +-- +-- The output of @keepNLatestSharedImages 2@ will be: +-- +-- @@@ +-- fromList +-- [ SharedImage "foo" "2020-07-07 13:34:31" +-- , SharedImage "bar" "2020-07-07 13:34:34" +-- ] +-- @@@ +-- +-- @since 1.1.0 +dropAllButNLatestSharedImages :: Int -> Set SharedImage -> Set SharedImage +dropAllButNLatestSharedImages n = + fold + . Map.map + ( \s -> + let nOld = max 0 (length s - n) + in Set.take nOld s + ) + . groupBySharedImageName + +-- | Group by 'SharedImageName'. +-- +-- @since 1.1.0 +groupBySharedImageName :: Set SharedImage -> Map SharedImageName (Set SharedImage) +groupBySharedImageName = + foldr + ( \img -> + Map.alter + ( Just + . maybe + (Set.singleton img) + (Set.insert img) + ) + (sharedImageName img) + ) + Map.empty diff --git a/src/lib/B9/RepositoryIO.hs b/src/lib/B9/RepositoryIO.hs --- a/src/lib/B9/RepositoryIO.hs +++ b/src/lib/B9/RepositoryIO.hs @@ -1,37 +1,116 @@ -- | Effectful functions executing shared image respository operations. -- See "B9.Repository" module B9.RepositoryIO - ( repoSearch, - pushToRepo, - pullFromRepo, + ( repoSearch, -- internal + pushToRepo, -- internal + pullFromRepo, -- internal + withRemoteRepos, pullGlob, - Repository (..), - toRemoteRepository, FilePathGlob (..), + getSharedImages, + getSharedImagesCacheDir, + getSelectedRepos, + pullRemoteRepos, + pullLatestImage, + cleanOldSharedImageRevisionsFromCache, + cleanLocalRepoCache, + pushToSelectedRepo, + pushSharedImageLatestVersion, + getLatestImageByName, + -- initRemoteRepo, + cleanRemoteRepo, + remoteRepoCheckSshPrivKey, ) where -import B9.B9Config (getRemoteRepos) +import B9.B9Config +import B9.B9Error import B9.B9Exec import B9.B9Logging +import B9.DiskImages import B9.Repository import Control.Eff +import Control.Eff.Reader.Lazy +import Control.Exception +import Control.Lens ((.~), (^.), view) +import Control.Monad (forM_, unless, when) import Control.Monad.IO.Class +import Data.Foldable import Data.List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as Set +import GHC.Stack import System.Directory import System.FilePath -import System.IO.B9Extras (ensureDir) +import System.IO.B9Extras +import System.IO.B9Extras (SystemPath, consult, ensureDir, resolve) import Text.Printf (printf) +import Text.Show.Pretty (ppShow) -data Repository - = Cache - | Remote String - deriving (Eq, Ord, Read, Show) +-- | Initialize the local repository cache directory and the 'RemoteRepo's. +-- Run the given action with a 'B9Config' that contains the initialized +-- repositories in '_remoteRepos'. +-- +-- @since 0.5.65 +withRemoteRepos :: + (Member B9ConfigReader e, Lifted IO e) => + Eff (RepoCacheReader ': e) a -> + Eff e a +withRemoteRepos f = do + cfg <- getB9Config + repoCache <- + lift + (initRepoCache (fromMaybe defaultRepositoryCache (_repositoryCache cfg))) + remoteRepos' <- mapM (initRemoteRepo repoCache) (_remoteRepos cfg) + let setRemoteRepos = remoteRepos .~ remoteRepos' + localB9Config setRemoteRepos (runReader repoCache f) --- | Convert a `RemoteRepo` down to a mere `Repository` -toRemoteRepository :: RemoteRepo -> Repository -toRemoteRepository = Remote . remoteRepoRepoId +-- | Initialize the local repository cache directory. +initRepoCache :: MonadIO m => SystemPath -> m RepoCache +initRepoCache repoDirSystemPath = do + repoDir <- resolve repoDirSystemPath + ensureDir (repoDir ++ "/") + return (RepoCache repoDir) +-- | Check for existance of priv-key and make it an absolute path. +remoteRepoCheckSshPrivKey :: MonadIO m => RemoteRepo -> m RemoteRepo +remoteRepoCheckSshPrivKey (RemoteRepo rId rp (SshPrivKey keyFile) h u) = do + exists <- liftIO (doesFileExist keyFile) + keyFile' <- liftIO (canonicalizePath keyFile) + unless + exists + ( error + (printf "SSH Key file '%s' for repository '%s' is missing." keyFile' rId) + ) + return (RemoteRepo rId rp (SshPrivKey keyFile') h u) + +-- | Initialize the repository; load the corresponding settings from the config +-- file, check that the priv key exists and create the correspondig cache +-- directory. +initRemoteRepo :: MonadIO m => RepoCache -> RemoteRepo -> m RemoteRepo +initRemoteRepo cache repo = do + -- TODO logging traceL $ printf "Initializing remote repo: %s" (remoteRepoRepoId repo) + repo' <- remoteRepoCheckSshPrivKey repo + let (RemoteRepo repoId _ _ _ _) = repo' + ensureDir (remoteRepoCacheDir cache repoId ++ "/") + return repo' + +-- | Empty the repository; load the corresponding settings from the config +-- file, check that the priv key exists and create the correspondig cache +-- directory. +cleanRemoteRepo :: MonadIO m => RepoCache -> RemoteRepo -> m () +cleanRemoteRepo cache repo = do + let repoId = remoteRepoRepoId repo + repoDir = remoteRepoCacheDir cache repoId ++ "/" + -- TODO logging infoL $ printf "Cleaning remote repo: %s" repoId + ensureDir repoDir + -- TODO logging traceL $ printf "Deleting directory: %s" repoDir + liftIO $ removeDirectoryRecursive repoDir + ensureDir repoDir + -- | Find files which are in 'subDir' and match 'glob' in the repository -- cache. NOTE: This operates on the repository cache, but does not enforce a -- repository cache update. @@ -43,9 +122,8 @@ Eff e [(Repository, [FilePath])] repoSearch subDir glob = (:) <$> localMatches <*> remoteRepoMatches where - remoteRepoMatches = do - remoteRepos <- getRemoteRepos - mapM remoteRepoSearch remoteRepos + remoteRepoMatches = + getRemoteRepos >>= mapM remoteRepoSearch localMatches :: Eff e (Repository, [FilePath]) localMatches = do cache <- getRepoCache @@ -67,14 +145,14 @@ return ((dir ) <$> filter (matchGlob glob) files) -- | Push a file from the cache to a remote repository -pushToRepo :: (CommandIO e) => RemoteRepo -> FilePath -> FilePath -> Eff e () +pushToRepo :: (Member ExcB9 e, CommandIO e) => RemoteRepo -> FilePath -> FilePath -> Eff e () pushToRepo repo@(RemoteRepo repoId _ _ _ _) src dest = do dbgL (printf "PUSHING '%s' TO REPO '%s'" (takeFileName src) repoId) cmd (repoEnsureDirCmd repo dest) cmd (pushCmd repo src dest) -- | Pull a file from a remote repository to cache -pullFromRepo :: (CommandIO e) => RemoteRepo -> FilePath -> FilePath -> Eff e () +pullFromRepo :: (Member ExcB9 e, CommandIO e) => RemoteRepo -> FilePath -> FilePath -> Eff e () pullFromRepo repo@(RemoteRepo repoId rootDir _key (SshRemoteHost (host, _port)) (SshRemoteUser user)) src dest = do dbgL (printf "PULLING '%s' FROM REPO '%s'" (takeFileName src) repoId) @@ -90,7 +168,7 @@ -- | Push a file from the cache to a remote repository pullGlob :: - (CommandIO e, Member RepoCacheReader e) => + (Member ExcB9 e, CommandIO e, Member RepoCacheReader e) => FilePath -> FilePathGlob -> RemoteRepo -> @@ -161,3 +239,225 @@ "-o", "IdentityFile=" ++ key ] + +-- | Return a list of all existing sharedImages from cached repositories. +getSharedImages :: + (HasCallStack, CommandIO e, Lifted IO e, Member RepoCacheReader e) => + Eff e (Map Repository (Set SharedImage)) +getSharedImages = do + reposAndFiles <- + repoSearch + sharedImagesRootDirectory + (FileExtension sharedImageFileExtension) + foldrM + ( \(repo, files) acc -> do + imgs <- catMaybes <$> mapM consult' files + let imgSet = Set.fromList imgs + return (Map.insert repo imgSet acc) + ) + Map.empty + reposAndFiles + where + consult' f = do + r <- liftIO (try (consult f)) + case r of + Left (e :: SomeException) -> do + dbgL + ( printf + "Failed to load shared image meta-data from '%s': '%s'" + (takeFileName f) + (show e) + ) + dbgL (printf "Removing bad meta-data file '%s'" f) + liftIO (removeFile f) + return Nothing + Right c -> return (Just c) + +-- | Pull metadata files from all remote repositories. +pullRemoteRepos :: + (HasCallStack, Member ExcB9 e, Lifted IO e, CommandIO e, '[SelectedRemoteRepoReader, RepoCacheReader] <:: e) => + Eff e () +pullRemoteRepos = do + repos <- getSelectedRepos + mapM_ dl repos + where + dl = + pullGlob + sharedImagesRootDirectory + (FileExtension sharedImageFileExtension) + +-- | Pull the latest version of an image, either from the selected remote +-- repo or from the repo that has the latest version. +pullLatestImage :: + (HasCallStack, Lifted IO e, CommandIO e, '[ExcB9, RepoCacheReader, SelectedRemoteRepoReader] <:: e) => + SharedImageName -> + Eff e (Maybe SharedImageBuildId) +pullLatestImage name@(SharedImageName dbgName) = do + repos <- getSelectedRepos + let repoPredicate Cache = False + repoPredicate (Remote repoId) = repoId `elem` repoIds + repoIds = map remoteRepoRepoId repos + hasName sharedImage = name == sharedImageName sharedImage + candidates <- + filterRepoImagesMap repoPredicate hasName <$> getSharedImages + case maxSharedImageOfAllRepos candidates of + Nothing -> + do + errorL + ( printf + "No shared image named '%s' on these remote repositories: '%s'" + dbgName + (ppShow repoIds) + ) + return Nothing + Just (image, Cache) -> do + errorExitL (printf "Unreachable code reached in `pullLastestImage`: '%s' %s" dbgName (ppShow image)) + Just (image, Remote repoId) -> do + dbgL (printf "PULLING SHARED IMAGE: '%s'" (ppShow image)) + cacheDir <- getSharedImagesCacheDir + let (Image imgFile' _imgType _fs) = sharedImageImage image + cachedImgFile = cacheDir imgFile' + cachedInfoFile = cacheDir sharedImageFileName image + repoImgFile = sharedImagesRootDirectory imgFile' + repoInfoFile = sharedImagesRootDirectory sharedImageFileName image + repo = fromJust (lookupRemoteRepo repos repoId) + pullFromRepo repo repoImgFile cachedImgFile + pullFromRepo repo repoInfoFile cachedInfoFile + infoL (printf "PULLED '%s' FROM '%s'" dbgName repoId) + cleanOldSharedImageRevisionsFromCache name + return (Just (sharedImageBuildId image)) + +-- | Return the 'Image' of the latest version of a shared image named 'name' +-- from the local cache. +getLatestImageByName :: + (HasCallStack, Lifted IO e, CommandIO e, Member RepoCacheReader e) => + SharedImageName -> + Eff e (Maybe Image) +getLatestImageByName name = do + sharedImageRevisions <- lookupCachedImages name <$> getSharedImages + cacheDir <- getSharedImagesCacheDir + let image = + changeImageDirectory cacheDir . sharedImageImage + <$> Set.lookupMax sharedImageRevisions + case image of + Just i -> dbgL (printf "USING SHARED SOURCE IMAGE '%s'" (show i)) + Nothing -> errorL (printf "SOURCE IMAGE '%s' NOT FOUND" (show name)) + return image + +-- | Depending on the 'maxLocalSharedImageRevisions' 'B9Config' settings either +-- do nothing or delete all but the configured number of most recent shared +-- images with the given name from the local cache. +cleanOldSharedImageRevisionsFromCache :: + ('[RepoCacheReader, ExcB9] <:: e, Lifted IO e, CommandIO e) => + SharedImageName -> + Eff e () +cleanOldSharedImageRevisionsFromCache sn = do + b9Cfg <- getConfig + forM_ (b9Cfg ^. maxLocalSharedImageRevisions) $ \maxRevisions -> do + when + (maxRevisions < 1) + ( throwB9Error_ + ( printf + "Invalid maximum local shared images revision configuration value: %d. Please change the [global] '%s' key in the B9 configuration file to 'Just x' with 'x > 0', or to 'Nothing'." + maxRevisions + maxLocalSharedImageRevisionsK + ) + ) + allRevisions <- lookupCachedImages sn <$> getSharedImages + let toDelete = dropAllButNLatestSharedImages maxRevisions allRevisions + removeCachedSharedImages toDelete + +-- | Clean all obsolete images in the local image cache. +-- +-- @since 1.1.0 +cleanLocalRepoCache :: + ('[RepoCacheReader, ExcB9] <:: e, Lifted IO e, CommandIO e) => + Eff e () +cleanLocalRepoCache = do + allCached <- allCachedSharedImages <$> getSharedImages + maxRevConfig <- view maxLocalSharedImageRevisions <$> getConfig + let maxRev = maybe 0 (max 0) maxRevConfig + byName = groupBySharedImageName allCached + toKeep = + fold + ( Map.map + (keepNLatestSharedImages maxRev) + byName + ) + toDelete = + fold + ( Map.map + (dropAllButNLatestSharedImages maxRev) + byName + ) + infoL "ALL CACHED IMAGES:" + forM_ allCached (infoL . show) + infoL ("CACHED " ++ maybe "" (("(" ++) . (++ ") ") . show) maxRevConfig ++ "IMAGES TO KEEP:") + forM_ toKeep (infoL . show) + infoL "CACHED IMAGES TO DELETE:" + forM_ toDelete (infoL . show) + removeCachedSharedImages toDelete + return () + +-- | Publish the latest version of a shared image identified by name to the +-- selected repository from the cache. +pushSharedImageLatestVersion :: + (Lifted IO e, CommandIO e, '[SelectedRemoteRepoReader, RepoCacheReader, ExcB9] <:: e) => + SharedImageName -> + Eff e () +pushSharedImageLatestVersion name@(SharedImageName imgName) = + lookupCachedImages name <$> getSharedImages + >>= maybe + (errorExitL (printf "Nothing found for %s." (show imgName))) + ( \sharedImage -> do + dbgL (printf "PUSHING '%s'" (ppShow sharedImage)) + pushToSelectedRepo sharedImage + infoL (printf "PUSHED '%s'" imgName) + ) + . Set.lookupMax + +-- | Upload a shared image from the cache to a selected remote repository +pushToSelectedRepo :: + (Member ExcB9 e, Lifted IO e, CommandIO e, '[RepoCacheReader, SelectedRemoteRepoReader] <:: e) => + SharedImage -> + Eff e () +pushToSelectedRepo i = do + c <- getSharedImagesCacheDir + MkSelectedRemoteRepo r <- getSelectedRemoteRepo + when (isJust r) $ do + let (Image imgFile' _imgType _imgFS) = sharedImageImage i + cachedImgFile = c imgFile' + cachedInfoFile = c sharedImageFileName i + repoImgFile = sharedImagesRootDirectory imgFile' + repoInfoFile = sharedImagesRootDirectory sharedImageFileName i + pushToRepo (fromJust r) cachedImgFile repoImgFile + pushToRepo (fromJust r) cachedInfoFile repoInfoFile + +-- | Return either all remote repos or just the single selected repo. +getSelectedRepos :: '[B9ConfigReader, SelectedRemoteRepoReader] <:: e => Eff e [RemoteRepo] +getSelectedRepos = do + allRepos <- getRemoteRepos + MkSelectedRemoteRepo selectedRepo <- getSelectedRemoteRepo + let repos = maybe allRepos return selectedRepo -- 'Maybe' a repo + return repos + +-- | Return the path to the sub directory in the cache that contains files of +-- shared images. +getSharedImagesCacheDir :: '[RepoCacheReader] <:: e => Eff e FilePath +getSharedImagesCacheDir = do + cacheDir <- localRepoDir <$> getRepoCache + return (cacheDir sharedImagesRootDirectory) + +removeCachedSharedImages :: (CommandIO e, Member (Reader RepoCache) e) => Set SharedImage -> Eff e () +removeCachedSharedImages toDelete = + do + imgDir <- getSharedImagesCacheDir + let filesToDelete = Set.map (imgDir ) (infoFiles <> imgFiles) + infoFiles = Set.map sharedImageFileName toDelete + imgFiles = Set.map (imageFileName . sharedImageImage) toDelete + if Set.null filesToDelete + then infoL "NO IMAGES TO DELETE" + else do + infoL "DELETING FILES:" + forM_ filesToDelete (infoL . show) + liftIO (mapM_ removeIfExists filesToDelete) diff --git a/src/lib/B9/SystemdNspawn.hs b/src/lib/B9/SystemdNspawn.hs --- a/src/lib/B9/SystemdNspawn.hs +++ b/src/lib/B9/SystemdNspawn.hs @@ -106,7 +106,12 @@ printHash (imgPath, containerMountPoint) liftIO $ createDirectoryIfMissing True hostMountPoint hostCmd (sudo (printf "mount -o loop '%s' '%s'" imgPath hostMountPoint)) timeoutFastCmd - return (LoopbackMount {loopbackHost = hostMountPoint, loopbackContainer = containerMountPoint}) + return + ( LoopbackMount + { loopbackHost = hostMountPoint, + loopbackContainer = containerMountPoint + } + ) newtype ContainerRootImage = ContainerRootImage FilePath @@ -207,7 +212,7 @@ sharedDirMountsRo = [(h, c) | SharedDirectoryRO h (MountPoint c) <- sharedDirs] extraArgs = maybe [] (: []) (_systemdNspawnExtraArgs dCfg) execOptions = ["/bin/sh", bootScriptContainerCommand bootScript] - timeout = (CommandTimeout . (* 1000000)) <$> _systemdNspawnMaxLifetimeSeconds dCfg + timeout = (TimeoutMicros . (* 1000000)) <$> _systemdNspawnMaxLifetimeSeconds dCfg traceL ("executing systemd-nspawn container build") case _systemdNspawnConsole dCfg of SystemdNspawnInteractive -> @@ -215,7 +220,12 @@ _ -> hostCmd (sudo systemdCmd) timeout -umountLoopbackImages :: forall e. (Member ExcB9 e, CommandIO e) => SudoPrepender -> ContainerMounts -> Eff e () +umountLoopbackImages :: + forall e. + (Member ExcB9 e, CommandIO e) => + SudoPrepender -> + ContainerMounts -> + Eff e () umountLoopbackImages sudo c = do case containerRootImage c of Left _ -> return () @@ -228,12 +238,17 @@ res <- hostCmd (sudo (printf "umount '%s'" (loopbackHost l))) timeoutFastCmd when (not res) (errorL ("failed to unmount: " ++ show l)) -removeContainerBuildRootDir :: forall e. (Member ExcB9 e, CommandIO e) => SudoPrepender -> ContainerBuildDirectories -> Eff e () +removeContainerBuildRootDir :: + forall e. + (Member ExcB9 e, CommandIO e) => + SudoPrepender -> + ContainerBuildDirectories -> + Eff e () removeContainerBuildRootDir sudo containerBuildDirs = do let target = containerBuildRoot containerBuildDirs traceL $ "removing: " ++ target res <- hostCmd (sudo (printf "rm -rf '%s'" target)) timeoutFastCmd when (not res) (errorL ("failed to remove: " ++ target)) -timeoutFastCmd :: Maybe CommandTimeout -timeoutFastCmd = Just (CommandTimeout 10000000) +timeoutFastCmd :: Maybe Timeout +timeoutFastCmd = Just (TimeoutMicros 10000000) diff --git a/src/lib/System/IO/B9Extras.hs b/src/lib/System/IO/B9Extras.hs --- a/src/lib/System/IO/B9Extras.hs +++ b/src/lib/System/IO/B9Extras.hs @@ -3,6 +3,7 @@ ( SystemPath (..), overSystemPath, resolve, + ensureSystemPath, ensureDir, getDirectoryFiles, prettyPrintToFile, @@ -10,6 +11,7 @@ ConsultException (..), randomUUID, UUID (), + removeIfExists, ) where @@ -22,6 +24,7 @@ ) import System.Directory import System.FilePath +import System.IO.Error import System.Random (randomIO) import Text.Printf import Text.Read (readEither) @@ -77,6 +80,13 @@ return (snd <$> filter fst (fileEntries `zip` entries)) -- | Create all missing parent directories of a file path. +-- +-- @since 1.1.0 +ensureSystemPath :: MonadIO m => SystemPath -> m () +ensureSystemPath = + resolve >=> liftIO . createDirectoryIfMissing True + +-- | Create all missing parent directories of a file path. -- Note that the file path is assumed to be of a regular file, and -- 'takeDirectory' is applied before creating the directory. ensureDir :: MonadIO m => FilePath -> m () @@ -136,3 +146,10 @@ <*> randomIO ) ) + +removeIfExists :: FilePath -> IO () +removeIfExists fileName = removeFile fileName `catch` handleExists + where + handleExists e + | isDoesNotExistError e = return () + | otherwise = throwIO e diff --git a/src/tests/B9/B9ExecSpec.hs b/src/tests/B9/B9ExecSpec.hs new file mode 100644 --- /dev/null +++ b/src/tests/B9/B9ExecSpec.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE NumericUnderscores #-} + +module B9.B9ExecSpec + ( spec, + ) +where + +import B9.B9Config +import B9.B9Error +import B9.B9Exec +import B9.B9Monad +import Control.Exception +import Control.Monad +import System.Directory +import System.Environment +import System.Exit +import System.FilePath +import System.IO.B9Extras +import Test.Hspec +import Text.Printf + +spec :: HasCallStack => Spec +spec = do + context + "timeout_factor is Nothing" + ( do + let tf = Nothing + context + "default_timeout_seconds is Nothing " + ( do + let t = Nothing + context + "commands finish in time" + ( do + context + "cmd" + (it "returns" (cmdWrapper t tf "sleep 1" `shouldReturn` ())) + context + "hostCmd without timeout" + ( it + "returns Right True" + ( b9Wrapper t tf (hostCmdEither HostCommandNoStdin "sleep 1" Nothing) + `shouldReturn` Right ExitSuccess + ) + ) + context + "hostCmd with timeout" + ( it + "returns Right True" + ( b9Wrapper t tf (hostCmdEither HostCommandNoStdin "sleep 1" (Just (TimeoutMicros 2_000_000))) + `shouldReturn` Right ExitSuccess + ) + ) + ) + context + "commands take too long" + ( context + "hostCmd with timeout" + ( it + "it returns an error" + ( b9Wrapper t tf (hostCmdEither HostCommandNoStdin "sleep 1" (Just (TimeoutMicros 100_000))) + `shouldReturn` Left (TimeoutMicros 100_000) + ) + ) + ) + ) + context + "default_timeout_seconds is Just 1.5 second " + ( do + let t = Just (TimeoutMicros 1_500_000) + context + "commands finish in time" + ( do + context + "cmd" + (it "returns" (cmdWrapper t tf "sleep 1" `shouldReturn` ())) + context + "hostCmd without timeout" + ( it + "returns Right True" + ( b9Wrapper t tf (hostCmdEither HostCommandNoStdin "sleep 1" Nothing) + `shouldReturn` Right ExitSuccess + ) + ) + context + "hostCmd with timeout" + ( it + "returns Right True" + ( b9Wrapper t tf (hostCmdEither HostCommandNoStdin "sleep 2" (Just (TimeoutMicros 3_000_000))) + `shouldReturn` Right ExitSuccess + ) + ) + ) + context + "commands take too long" + ( do + context + "cmd" + (it "throws in error" (cmdWrapper t tf "sleep 2" `shouldThrow` (const True :: Selector B9Error))) + context + "hostCmd without timeout" + ( it + "returns Left" + ( b9Wrapper t tf (hostCmdEither HostCommandNoStdin "sleep 2" Nothing) + `shouldReturn` Left (TimeoutMicros 1_500_000) + ) + ) + context + "hostCmd with timeout" + ( it + "returns Left" + ( b9Wrapper t tf (hostCmdEither HostCommandNoStdin "sleep 1" (Just (TimeoutMicros 100_000))) + `shouldReturn` Left (TimeoutMicros 100_000) + ) + ) + ) + ) + ) + context + "timeout_factor is Just 2" + ( do + let tf = Just 2 + context + "default_timeout_seconds is Just .75 seconds " + ( do + let t = Just (TimeoutMicros 750_000) + context + "commands finish in time" + ( do + context + "cmd" + (it "returns" (cmdWrapper t tf "sleep 1" `shouldReturn` ())) + context + "hostCmd without timeout" + ( it + "returns Right True" + ( b9Wrapper t tf (hostCmdEither HostCommandNoStdin "sleep 1" Nothing) + `shouldReturn` Right ExitSuccess + ) + ) + context + "hostCmd with timeout" + ( it + "returns Right True" + ( b9Wrapper t tf (hostCmdEither HostCommandNoStdin "sleep 2" (Just (TimeoutMicros 1_500_000))) + `shouldReturn` Right ExitSuccess + ) + ) + ) + context + "commands take too long" + ( do + context + "cmd" + (it "throws in error" (cmdWrapper t tf "sleep 2" `shouldThrow` (const True :: Selector B9Error))) + context + "hostCmd without timeout" + ( it + "returns Left" + ( b9Wrapper t tf (hostCmdEither HostCommandNoStdin "sleep 2" Nothing) + `shouldReturn` Left (TimeoutMicros 1_500_000) + ) + ) + context + "hostCmd with timeout" + ( it + "returns Left" + ( b9Wrapper t tf (hostCmdEither HostCommandNoStdin "sleep 1" (Just (TimeoutMicros 100_000))) + `shouldReturn` Left (TimeoutMicros 200_000) + ) + ) + ) + ) + ) + +cmdWrapper :: HasCallStack => Maybe Timeout -> Maybe Int -> String -> IO () +cmdWrapper t tf = b9Wrapper t tf . cmd + +b9Wrapper :: HasCallStack => Maybe Timeout -> Maybe Int -> B9 a -> IO a +b9Wrapper t tf effect = + withTempBuildDirs $ \cfgOverride -> + let cfg = overrideTimeoutFactor tf (overrideDefaultTimeout t cfgOverride) + in runB9ConfigActionWithOverrides (runB9 effect) cfg + +withTempBuildDirs :: HasCallStack => (B9ConfigOverride -> IO a) -> IO a +withTempBuildDirs k = + bracket acquire release use + where + acquire = do + nixOutDirEnv <- lookupEnv "NIX_BUILD_TOP" + let rootDir = maybe InTempDir (((.) . (.)) Path ()) nixOutDirEnv + repoRelPath <- printf "testsRepositoryIOSpec-test-repo-%U" <$> randomUUID + buildRelPath <- printf "RepositoryIOSpec-root-%U" <$> randomUUID + cfgRelPath <- printf "RepositoryIOSpec-b9cfg-%U" <$> randomUUID + let tmpRepoPath = rootDir ("tests" repoRelPath) + tmpBuildPath = rootDir ("tests" buildRelPath) + tmpCfgPath = rootDir ("tests" cfgRelPath) + ensureSystemPath tmpRepoPath + ensureSystemPath tmpBuildPath + tmpBuildPathFileName <- resolve tmpBuildPath + return (tmpRepoPath, tmpBuildPathFileName, tmpCfgPath) + release (tmpRepoPath, tmpBuildPathFileName, tmpCfgPath) = do + let cleanupTmpPath = removePathForcibly <=< resolve + cleanupTmpPath tmpRepoPath + cleanupTmpPath tmpCfgPath + removePathForcibly tmpBuildPathFileName + use (tmpRepoPath, tmpBuildPathFileName, tmpCfgPath) = + let mkCfg cfgIn = + cfgIn + { _repositoryCache = Just tmpRepoPath, + _projectRoot = Just tmpBuildPathFileName + } + oCfg = + overrideB9Config + mkCfg + ( overrideWorkingDirectory + tmpBuildPathFileName + ( overrideDefaultB9ConfigPath + tmpCfgPath + noB9ConfigOverride + ) + ) + in k oCfg diff --git a/src/tests/B9/RepositoryIOSpec.hs b/src/tests/B9/RepositoryIOSpec.hs new file mode 100644 --- /dev/null +++ b/src/tests/B9/RepositoryIOSpec.hs @@ -0,0 +1,202 @@ +module B9.RepositoryIOSpec + ( spec, + ) +where + +import B9 (ppShow) +import B9.Artifact.Readable +import B9.Artifact.Readable.Interpreter (assemble) +import B9.B9Config +import B9.B9Error +import B9.B9Logging +import B9.B9Monad +import B9.BuildInfo +import B9.DiskImages +import B9.Repository +import B9.RepositoryIO +import B9.Vm +import Control.Concurrent (threadDelay) +import Control.Exception +import Control.Monad +import Data.Foldable +import qualified Data.Map as Map +import qualified Data.Set as Set +import System.Directory +import System.Environment +import System.FilePath +import System.IO.B9Extras +import Test.Hspec +import Text.Printf + +spec :: HasCallStack => Spec +spec = do + let cleanCacheAndLookupImages mkCfg buildAction = + withTempBuildDirs $ \cfgWithRepo -> do + let cfg = overrideB9Config mkCfg cfgWithRepo + buildCfg = overrideB9Config noCleanupCfg cfgWithRepo + x <- buildAction buildCfg + y <- + allCachedSharedImages + <$> b9Build + cfg + ( cleanLocalRepoCache + *> infoL "SEARCHING FOR SHARED IMAGES" + *> getSharedImages + ) + return (x, y) + shareAndLookupTestImages mkCfg = + withTempBuildDirs $ \cfgWithRepo -> do + let cfg = overrideB9Config mkCfg cfgWithRepo + putStrLn (ppShow cfg) + sharedImagesExpected <- shareTestImages cfg + sharedImagesActual <- + allCachedSharedImages + <$> b9Build cfg getSharedImages + return (sharedImagesExpected, sharedImagesActual) + testBuilds3X2 = + replicate + 3 + [ ( t, + ImageTarget + (Share t Raw KeepSize) + (EmptyImage t Ext4 Raw (ImageSize 10 MB)) + NotMounted + ) + | t <- ["testImg0", "testImg1"] + ] + shareTestImages cfg = fmap concat + <$> forM testBuilds3X2 + $ \testTargets -> + do + threadDelay 1200000 + forM testTargets $ \(t, dest) -> + b9Build + cfg + ( assemble + (Artifact (IID t) (VmImages [dest] NoVmScript)) + *> ( SharedImage (SharedImageName t) + <$> (SharedImageDate <$> getBuildDate) + <*> (SharedImageBuildId <$> getBuildId) + <*> pure Raw + <*> pure Ext4 + ) + ) + describe "shared_image_cache_cleanup" $ do + context "_maxLocalSharedImageRevisions == Nothing" $ do + context "no images in cache" $ do + it "does nothing and returns no error" $ + cleanCacheAndLookupImages noCleanupCfg (const (return ())) + >>= (`shouldBe` mempty) . snd + context "two images names with each three versions" $ do + it "removes ALL images" $ + cleanCacheAndLookupImages noCleanupCfg shareTestImages + >>= (`shouldBe` mempty) . snd + context "_maxLocalSharedImageRevisions == Just 1" $ do + context "no images in cache" $ do + it "does nothing and returns no error" $ + cleanCacheAndLookupImages + (cleanupAfterBuildCfg 1) + (const (return ())) + >>= (`shouldBe` mempty) . snd + context "two images names with each three versions" $ do + it "retains the latest image of each subset with the same name (somehow they must procreate, right? ;)" $ do + (generatedImages, actual) <- + cleanCacheAndLookupImages + (cleanupAfterBuildCfg 1) + ( \c -> + shareTestImages c + *> (b9Build c (allCachedSharedImages <$> getSharedImages)) + ) + let expected = + fold + ( Map.map + (Set.drop 2) + (groupBySharedImageName generatedImages) + ) + actual `shouldBe` expected + -- TODO describe "pull shared images" $ do + describe "create & share images" $ do + describe "Without autmatic cleanup" + $ it "returns all shared images that were built" + $ do + (sharedImagesExpected, sharedImagesActual) <- + shareAndLookupTestImages noCleanupCfg + sharedImagesActual `shouldBe` Set.fromList sharedImagesExpected + describe "with automatic cleanup after build enabled in _maxLocalSharedImageRevisions" $ do + describe "with an invalid parameter _maxLocalSharedImageRevisions == Just 0" $ do + it "does nothing and exits with error" $ + shareAndLookupTestImages (cleanupAfterBuildCfg (-1)) + `shouldThrow` (const True :: Selector SomeException) + describe "with an invalid parameter _maxLocalSharedImageRevisions == Just -1" $ do + it "does nothing and exits with error" $ + shareAndLookupTestImages (cleanupAfterBuildCfg 0) + `shouldThrow` (const True :: Selector B9Error) + describe "with a valid parameter _maxLocalSharedImageRevisions == Just 1" $ do + it "returns the latest of all shared images that were built" $ do + (sharedImagesExpected, sharedImagesActual) <- + shareAndLookupTestImages (cleanupAfterBuildCfg 1) + sharedImagesActual `shouldBe` keepNLatestSharedImages 1 (Set.fromList sharedImagesExpected) + describe "with a valid parameter _maxLocalSharedImageRevisions == Just 2" $ do + it "returns the latest two of all shared images that were built" $ do + (sharedImagesExpected, sharedImagesActual) <- + shareAndLookupTestImages (cleanupAfterBuildCfg 2) + sharedImagesActual `shouldBe` keepNLatestSharedImages 2 (Set.fromList sharedImagesExpected) + describe "with a valid parameter _maxLocalSharedImageRevisions == Just 3000" $ do + it "returns the latest 3000 of all shared images that were built" $ do + (sharedImagesExpected, sharedImagesActual) <- + shareAndLookupTestImages (cleanupAfterBuildCfg 3000) + sharedImagesActual `shouldBe` Set.fromList sharedImagesExpected + +noCleanupCfg :: B9Config -> B9Config +noCleanupCfg c = + c {_maxLocalSharedImageRevisions = Nothing} + +cleanupAfterBuildCfg :: Int -> B9Config -> B9Config +cleanupAfterBuildCfg n c = + c {_maxLocalSharedImageRevisions = Just n} + +b9Build :: HasCallStack => B9ConfigOverride -> B9 a -> IO a +b9Build cfg effect = + runB9ConfigActionWithOverrides + (runB9 effect) + cfg + +withTempBuildDirs :: HasCallStack => (B9ConfigOverride -> IO a) -> IO a +withTempBuildDirs k = + bracket acquire release use + where + acquire = do + nixOutDirEnv <- lookupEnv "NIX_BUILD_TOP" + let rootDir = maybe InTempDir (((.) . (.)) Path ()) nixOutDirEnv + repoRelPath <- printf "testsRepositoryIOSpec-test-repo-%U" <$> randomUUID + buildRelPath <- printf "RepositoryIOSpec-root-%U" <$> randomUUID + cfgRelPath <- printf "RepositoryIOSpec-b9cfg-%U" <$> randomUUID + let tmpRepoPath = rootDir ("tests" repoRelPath) + tmpBuildPath = rootDir ("tests" buildRelPath) + tmpCfgPath = rootDir ("tests" cfgRelPath) + ensureSystemPath tmpRepoPath + ensureSystemPath tmpBuildPath + tmpBuildPathFileName <- resolve tmpBuildPath + return (tmpRepoPath, tmpBuildPathFileName, tmpCfgPath) + release (tmpRepoPath, tmpBuildPathFileName, tmpCfgPath) = do + let cleanupTmpPath = removePathForcibly <=< resolve + cleanupTmpPath tmpRepoPath + cleanupTmpPath tmpCfgPath + removePathForcibly tmpBuildPathFileName + use (tmpRepoPath, tmpBuildPathFileName, tmpCfgPath) = + let mkCfg cfgIn = + cfgIn + { _repositoryCache = Just tmpRepoPath, + _projectRoot = Just tmpBuildPathFileName + } + oCfg = + overrideB9Config + mkCfg + ( overrideWorkingDirectory + tmpBuildPathFileName + ( overrideDefaultB9ConfigPath + tmpCfgPath + noB9ConfigOverride + ) + ) + in k oCfg diff --git a/src/tests/B9/RepositorySpec.hs b/src/tests/B9/RepositorySpec.hs new file mode 100644 --- /dev/null +++ b/src/tests/B9/RepositorySpec.hs @@ -0,0 +1,262 @@ +module B9.RepositorySpec + ( spec, + filterRepoImagesMapReturnsAllAndOnlyImagesSatisfieingTheFilterPredicate, + filterRepoImagesMapReturnsAllAndOnlyReposSatisfieingTheFilterPredicate, + allSharedImagesWithRepoReturnsAllNonEmptyRepos, + allSharedImagesWithRepoReturnsOnlyReposContainedInTheParameter, + allSharedImagesWithRepoReturnsAllImages, + allSharedImagesWithRepoReturnsOnlyPairsSuchThatTheImageIsContainedInTheRepository, + maxSharedImageOfAllReposReturnsNonNothingIfInputHasImages, + maxSharedImageOfAllReposReturnsTheMaximumImage, + maxSharedImageOfAllReposReturnsAValidRepoImagePair, + ) +where + +import B9.DiskImages +import B9.Repository +import Data.Foldable (any) +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Set as Set +import Test.Hspec +import Test.QuickCheck + +spec :: HasCallStack => Spec +spec = + describe + "Repository" + ( do + describe + "dropAllButNLatestSharedImages" + ( do + it + "returns a set that is disjunct with the result of keepNLatestSharedImages" + ( property + ( \(Positive n) sharedImages -> + let dropped = dropAllButNLatestSharedImages n sharedImages + kept = keepNLatestSharedImages n sharedImages + in dropped `Set.disjoint` kept + ) + ) + it + "returns a set with at most n * number of unique names entries, for all n >= 0" + ( property + ( \(Positive n) sharedImages -> + let actual = keepNLatestSharedImages n sharedImages + noUniqueNames = + Set.size (Set.map sharedImageName sharedImages) + in Set.size actual <= n * noUniqueNames + ) + ) + ) + describe + "keepNLatestSharedImages" + ( do + it + "returns a set with a plausible number of elements" + ( property + ( \n sharedImages -> + let actual = keepNLatestSharedImages n sharedImages + noUniqueNames = + Set.size (Set.map sharedImageName sharedImages) + in label + "number of output elements < (max 0 n) * number of unqiue image names" + (Set.size actual <= max 0 n * noUniqueNames) + .&&. classify + (n > 0) + "n > 0" + ( n > 0 + ==> label + "the output contains as many sharedImageNames as the input" + (Set.size (Set.map sharedImageName actual) === noUniqueNames) + .&&. label + "keepNLatestSharedImages with n == 1 returns exactly as many elements as there are unique names" + (Set.size (keepNLatestSharedImages 1 sharedImages) === noUniqueNames) + .&&. label + "the newest entry in the output is the newest entry in the input" + (Set.lookupMax actual === Set.lookupMax sharedImages) + ) + ) + ) + it + "returns the input unaltered if n >= number of input images" + ( property + ( \(Positive n) sharedImages -> + let actual = keepNLatestSharedImages n sharedImages + in n >= Set.size sharedImages ==> sharedImages === actual + ) + ) + it + "returns a set with at most n * number of unique names entries, for all n >= 0" + ( property + ( \(Positive n) sharedImages -> + let actual = keepNLatestSharedImages n sharedImages + noUniqueNames = + Set.size (Set.map sharedImageName sharedImages) + in Set.size actual <= n * noUniqueNames + ) + ) + ) + describe + "filterRepoImagesMap" + ( do + it + "returns all- and only repos matching the repo predicate" + (property (withMaxSuccess 20 filterRepoImagesMapReturnsAllAndOnlyReposSatisfieingTheFilterPredicate)) + it + "returns all- and only images matching the image predicate" + (property (withMaxSuccess 20 filterRepoImagesMapReturnsAllAndOnlyImagesSatisfieingTheFilterPredicate)) + it "is idempotent" $ + property + ( withMaxSuccess + 20 + ( \(Fun _ repoPred) (Fun _ p) repoImgMap -> + let expected = filterRepoImagesMap repoPred p repoImgMap + actual = filterRepoImagesMap repoPred p expected + in expected === actual + ) + ) + ) + describe + "lookupCachedImages" + ( it + "returns only shared images that are cached" + (property lookupCachedImagesReturnsOnlyImagesFromCache) + ) + describe + "allSharedImagesWithRepo" + ( do + it + "returns all repositories that are not empty" + (property allSharedImagesWithRepoReturnsAllNonEmptyRepos) + it + "returns only repositories that are in the input" + (property allSharedImagesWithRepoReturnsOnlyReposContainedInTheParameter) + it + "returns all images" + (property allSharedImagesWithRepoReturnsAllImages) + it + "returns only pairs where the image is in the repository" + (property allSharedImagesWithRepoReturnsOnlyPairsSuchThatTheImageIsContainedInTheRepository) + ) + describe + "maxSharedImageOfAllRepos" + ( do + it + "returns a non-Nothing value of the input has any images and Nothing otherwise" + (property maxSharedImageOfAllReposReturnsNonNothingIfInputHasImages) + it + "returns the maximum of all images" + (property maxSharedImageOfAllReposReturnsTheMaximumImage) + it + "returns a pair where the image is in the repository" + (property maxSharedImageOfAllReposReturnsAValidRepoImagePair) + ) + ) + +matchesSomeButNotAll :: Foldable t => (a -> Bool) -> t a -> Bool +matchesSomeButNotAll p xs = any p xs && any (not . p) xs + +filterRepoImagesMapReturnsAllAndOnlyImagesSatisfieingTheFilterPredicate :: + Fun SharedImage Bool -> RepoImagesMap -> Property +filterRepoImagesMapReturnsAllAndOnlyImagesSatisfieingTheFilterPredicate (Fun _ p) t = + let i' = runCodeUnderTest p + i'Complement = runCodeUnderTest (not . p) + i = allSharedImages t + runCodeUnderTest = allSharedImages . flip (filterRepoImagesMap (const True)) t + in classify + (not (p `any` i)) + "predicate matches no image" + (null i' && i'Complement == i) + .||. classify + (p `matchesSomeButNotAll` i) + "predicate matches some images" + ( p `all` i' + && not (p `any` i'Complement) + && Set.union i' i'Complement == i + && null (Set.intersection i' i'Complement) + ) + .||. classify + (p `all` i) + "predicate matches all images" + (null i'Complement && i' == i) + +filterRepoImagesMapReturnsAllAndOnlyReposSatisfieingTheFilterPredicate :: + Fun Repository Bool -> RepoImagesMap -> Property +filterRepoImagesMapReturnsAllAndOnlyReposSatisfieingTheFilterPredicate (Fun _ p) t = + let i' = runCodeUnderTest p + i'Complement = runCodeUnderTest (not . p) + i = allRepositories t + runCodeUnderTest = allRepositories . flip (flip filterRepoImagesMap (const True)) t + in classify + (not (p `any` i)) + "predicate matches no repo" + (null i' && i'Complement == i) + .||. classify + (p `matchesSomeButNotAll` i) + "predicate matches some repos" + ( p `all` i' + && not (p `any` i'Complement) + && Set.union i' i'Complement == i + && null (Set.intersection i' i'Complement) + ) + .||. classify + (p `all` i) + "predicate matches all repos" + (null i'Complement && i' == i) + +lookupCachedImagesReturnsOnlyImagesFromCache :: SharedImageName -> RepoImagesMap -> Property +lookupCachedImagesReturnsOnlyImagesFromCache sn table = + let result = lookupCachedImages sn table + in Set.intersection + result + (fromMaybe (Set.empty) (Map.lookup Cache table)) + === result + +allSharedImagesWithRepoReturnsAllNonEmptyRepos :: RepoImagesMap -> Property +allSharedImagesWithRepoReturnsAllNonEmptyRepos t = + let nonEmptyRepos = + Map.foldrWithKey + (\repo imgs acc -> if null imgs then acc else Set.insert repo acc) + Set.empty + t + reposReturned = + Set.map snd (allSharedImagesWithRepo t) + in reposReturned === nonEmptyRepos + +allSharedImagesWithRepoReturnsOnlyReposContainedInTheParameter :: + RepoImagesMap -> Bool +allSharedImagesWithRepoReturnsOnlyReposContainedInTheParameter t = + let allReposReturned = Set.map snd (allSharedImagesWithRepo t) + in allReposReturned `Set.isSubsetOf` allRepositories t + +allSharedImagesWithRepoReturnsAllImages :: RepoImagesMap -> Property +allSharedImagesWithRepoReturnsAllImages t = + let allImagesReturned = Set.map fst (allSharedImagesWithRepo t) + in allImagesReturned === allSharedImages t + +allSharedImagesWithRepoReturnsOnlyPairsSuchThatTheImageIsContainedInTheRepository :: + RepoImagesMap -> Bool +allSharedImagesWithRepoReturnsOnlyPairsSuchThatTheImageIsContainedInTheRepository t = + let validPair (i, r) = + maybe False (Set.member i) (Map.lookup r t) + in all validPair (allSharedImagesWithRepo t) + +maxSharedImageOfAllReposReturnsNonNothingIfInputHasImages :: RepoImagesMap -> Property +maxSharedImageOfAllReposReturnsNonNothingIfInputHasImages t = + isJust (maxSharedImageOfAllRepos t) =/= null (allSharedImages t) + +maxSharedImageOfAllReposReturnsTheMaximumImage :: RepoImagesMap -> Property +maxSharedImageOfAllReposReturnsTheMaximumImage t = + not (null (allSharedImages t)) + ==> fmap fst (maxSharedImageOfAllRepos t) === Just (maximum (allSharedImages t)) + +maxSharedImageOfAllReposReturnsAValidRepoImagePair :: RepoImagesMap -> Property +maxSharedImageOfAllReposReturnsAValidRepoImagePair t = + case maxSharedImageOfAllRepos t of + Just (i, r) -> + label + "got result" + (Just i === (Map.lookup r t >>= Set.lookupMax)) + Nothing -> + label "got no result" True diff --git a/src/tests/B9/Shake/SharedImageRulesSpec.hs b/src/tests/B9/Shake/SharedImageRulesSpec.hs new file mode 100644 --- /dev/null +++ b/src/tests/B9/Shake/SharedImageRulesSpec.hs @@ -0,0 +1,104 @@ +module B9.Shake.SharedImageRulesSpec + ( spec, + ) +where + +import B9.Artifact.Readable +import B9.Artifact.Readable.Interpreter (assemble) +import B9.B9Config +import B9.B9Monad +import B9.DiskImages +import B9.Repository +import B9.RepositoryIO +import B9.Shake.SharedImageRules +import B9.Vm +import Control.Exception +import Control.Monad +import qualified Data.Set as Set +import Development.Shake as Shake +import System.Directory +import System.Environment +import System.FilePath +import System.IO.B9Extras +import Test.Hspec +import Text.Printf + +testShakeBuild :: B9ConfigOverride -> IO () +testShakeBuild cfg = shake shakeOptions $ do + enableSharedImageRules cfg + customSharedImageAction (SharedImageName "test") $ + liftIO + ( b9Build + cfg + ( void + ( assemble + ( Artifact + (IID "test-image") + ( VmImages + [ ImageTarget + (Share "test" Raw KeepSize) + (EmptyImage "test" Ext4 Raw (ImageSize 10 MB)) + NotMounted + ] + NoVmScript + ) + ) + ) + ) + ) + action (needSharedImage (SharedImageName "test")) + +spec :: HasCallStack => Spec +spec = do + context "missing shared image" $ do + it "builds a missing image" $ do + withTempBuildDirs $ \cfg -> do + testShakeBuild cfg + actualImages <- b9Build cfg (allCachedSharedImages <$> getSharedImages) + Set.size actualImages `shouldBe` 1 + +b9Build :: HasCallStack => B9ConfigOverride -> B9 a -> IO a +b9Build cfg effect = + runB9ConfigActionWithOverrides + (runB9 effect) + cfg + +withTempBuildDirs :: HasCallStack => (B9ConfigOverride -> IO a) -> IO a +withTempBuildDirs k = + bracket acquire release use + where + acquire = do + nixOutDirEnv <- lookupEnv "NIX_BUILD_TOP" + let rootDir = maybe InTempDir (((.) . (.)) Path ()) nixOutDirEnv + repoRelPath <- printf "testsRepositoryIOSpec-test-repo-%U" <$> randomUUID + buildRelPath <- printf "RepositoryIOSpec-root-%U" <$> randomUUID + cfgRelPath <- printf "RepositoryIOSpec-b9cfg-%U" <$> randomUUID + let tmpRepoPath = rootDir ("tests" repoRelPath) + tmpBuildPath = rootDir ("tests" buildRelPath) + tmpCfgPath = rootDir ("tests" cfgRelPath) + ensureSystemPath tmpRepoPath + ensureSystemPath tmpBuildPath + tmpBuildPathFileName <- resolve tmpBuildPath + return (tmpRepoPath, tmpBuildPathFileName, tmpCfgPath) + release (tmpRepoPath, tmpBuildPathFileName, tmpCfgPath) = do + let cleanupTmpPath = removePathForcibly <=< resolve + cleanupTmpPath tmpRepoPath + cleanupTmpPath tmpCfgPath + removePathForcibly tmpBuildPathFileName + use (tmpRepoPath, tmpBuildPathFileName, tmpCfgPath) = + let mkCfg cfgIn = + cfgIn + { _repositoryCache = Just tmpRepoPath, + _projectRoot = Just tmpBuildPathFileName + } + oCfg = + overrideB9Config + mkCfg + ( overrideWorkingDirectory + tmpBuildPathFileName + ( overrideDefaultB9ConfigPath + tmpCfgPath + noB9ConfigOverride + ) + ) + in k oCfg