b9 1.0.1 → 1.1.0

raw patch · 24 files changed

+1674/−480 lines, 24 filesdep +containersdep ~filepathPVP ok

version bump matches the API change (PVP)

Dependencies added: containers

Dependency ranges changed: filepath

API changes (from Hackage documentation)

Files

• .gitignore +1/−0
• CHANGELOG.md +15/−0
• README.md +12/−0
• b9.cabal +11/−4
• src/cli/Main.hs +2/−1
• src/lib/B9.hs +15/−51
• src/lib/B9/B9Config.hs +69/−10
• src/lib/B9/B9Error.hs +3/−3
• src/lib/B9/B9Exec.hs +39/−67
• src/lib/B9/B9Monad.hs +1/−0
• src/lib/B9/BuildInfo.hs +2/−2
• src/lib/B9/DiskImageBuilder.hs +42/−198
• src/lib/B9/DiskImages.hs +99/−10
• src/lib/B9/Docker.hs +2/−18
• src/lib/B9/LibVirtLXC.hs +2/−1
• src/lib/B9/Podman.hs +2/−18
• src/lib/B9/Repository.hs +208/−71
• src/lib/B9/RepositoryIO.hs +320/−20
• src/lib/B9/SystemdNspawn.hs +21/−6
• src/lib/System/IO/B9Extras.hs +17/−0
• src/tests/B9/B9ExecSpec.hs +223/−0
• src/tests/B9/RepositoryIOSpec.hs +202/−0
• src/tests/B9/RepositorySpec.hs +262/−0
• src/tests/B9/Shake/SharedImageRulesSpec.hs +104/−0

@@ -1,3 +1,4 @@+.shake *.hi *.ho TAGS

@@ -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

@@ -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 

@@ -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

@@ -128,7 +128,8 @@        in B9ConfigOverride             { _customB9ConfigPath = Path <$> cfg,               _customB9Config = b9cfg,-              _customEnvironment = mempty+              _customEnvironment = mempty,+              _customDefaulB9ConfigPath = Nothing             }  cmds :: Parser (B9ConfigAction ())

@@ -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'

@@ -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)

@@ -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 --

@@ -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

@@ -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

@@ -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

@@ -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+--

@@ -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 =

@@ -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"

@@ -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

@@ -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"

@@ -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

@@ -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)

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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