-- | Effectful functions executing shared image respository operations.
--    See "B9.Repository"
module B9.RepositoryIO
  ( repoSearch, -- internal
    pushToRepo, -- internal
    pullFromRepo, -- internal
    withRemoteRepos,
    pullGlob,
    FilePathGlob (..),
    getSharedImages,
    getSharedImagesCacheDir,
    getSelectedRepos,
    pullRemoteRepos,
    pullLatestImage,
    cleanOldSharedImageRevisionsFromCache,
    cleanLocalRepoCache,
    pushToSelectedRepo,
    pushSharedImageLatestVersion,
    getLatestImageByName,
    -- initRemoteRepo,
    cleanRemoteRepo,
    remoteRepoCheckSshPrivKey,
  )
where

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
import System.IO.B9Extras (SystemPath, consult, ensureDir, resolve)
import Text.Printf (printf)
import Text.Show.Pretty (ppShow)

-- | 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 :: Eff (RepoCacheReader : e) a -> Eff e a
withRemoteRepos Eff (RepoCacheReader : e) a
f = do
  B9Config
cfg <- Eff e B9Config
forall (e :: [* -> *]). Member B9ConfigReader e => Eff e B9Config
getB9Config
  RepoCache
repoCache <-
    IO RepoCache -> Eff e RepoCache
forall (m :: * -> *) (r :: [* -> *]) a.
Lifted m r =>
m a -> Eff r a
lift
      (SystemPath -> IO RepoCache
forall (m :: * -> *). MonadIO m => SystemPath -> m RepoCache
initRepoCache (SystemPath -> Maybe SystemPath -> SystemPath
forall a. a -> Maybe a -> a
fromMaybe SystemPath
defaultRepositoryCache (B9Config -> Maybe SystemPath
_repositoryCache B9Config
cfg)))
  Set RemoteRepo
remoteRepos' <- [RemoteRepo] -> Set RemoteRepo
forall a. Ord a => [a] -> Set a
Set.fromList ([RemoteRepo] -> Set RemoteRepo)
-> Eff e [RemoteRepo] -> Eff e (Set RemoteRepo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RemoteRepo -> Eff e RemoteRepo)
-> [RemoteRepo] -> Eff e [RemoteRepo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (RepoCache -> RemoteRepo -> Eff e RemoteRepo
forall (m :: * -> *).
MonadIO m =>
RepoCache -> RemoteRepo -> m RemoteRepo
initRemoteRepo RepoCache
repoCache) (Set RemoteRepo -> [RemoteRepo]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (B9Config -> Set RemoteRepo
_remoteRepos B9Config
cfg))
  let setRemoteRepos :: B9Config -> B9Config
setRemoteRepos = (Set RemoteRepo -> Identity (Set RemoteRepo))
-> B9Config -> Identity B9Config
Lens' B9Config (Set RemoteRepo)
remoteRepos ((Set RemoteRepo -> Identity (Set RemoteRepo))
 -> B9Config -> Identity B9Config)
-> Set RemoteRepo -> B9Config -> B9Config
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set RemoteRepo
remoteRepos'
  (B9Config -> B9Config) -> Eff e a -> Eff e a
forall (e :: [* -> *]) a.
Member B9ConfigReader e =>
(B9Config -> B9Config) -> Eff e a -> Eff e a
localB9Config B9Config -> B9Config
setRemoteRepos (RepoCache -> Eff (RepoCacheReader : e) a -> Eff e a
forall e (r :: [* -> *]) w. e -> Eff (Reader e : r) w -> Eff r w
runReader RepoCache
repoCache Eff (RepoCacheReader : e) a
f)

-- | Initialize the local repository cache directory.
initRepoCache :: MonadIO m => SystemPath -> m RepoCache
initRepoCache :: SystemPath -> m RepoCache
initRepoCache SystemPath
repoDirSystemPath = do
  FilePath
repoDir <- SystemPath -> m FilePath
forall (m :: * -> *). MonadIO m => SystemPath -> m FilePath
resolve SystemPath
repoDirSystemPath
  FilePath -> m ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
ensureDir (FilePath
repoDir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/")
  RepoCache -> m RepoCache
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> RepoCache
RepoCache FilePath
repoDir)

-- | Check for existance of priv-key and make it an absolute path.
remoteRepoCheckSshPrivKey :: MonadIO m => RemoteRepo -> m RemoteRepo
remoteRepoCheckSshPrivKey :: RemoteRepo -> m RemoteRepo
remoteRepoCheckSshPrivKey (RemoteRepo FilePath
rId FilePath
rp (SshPrivKey FilePath
keyFile) SshRemoteHost
h SshRemoteUser
u) = do
  Bool
exists <- IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Bool
doesFileExist FilePath
keyFile)
  FilePath
keyFile' <- IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO FilePath
canonicalizePath FilePath
keyFile)
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
    Bool
exists
    ( FilePath -> m ()
forall a. HasCallStack => FilePath -> a
error
        (FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"SSH Key file '%s' for repository '%s' is missing." FilePath
keyFile' FilePath
rId)
    )
  RemoteRepo -> m RemoteRepo
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
-> FilePath
-> SshPrivKey
-> SshRemoteHost
-> SshRemoteUser
-> RemoteRepo
RemoteRepo FilePath
rId FilePath
rp (FilePath -> SshPrivKey
SshPrivKey FilePath
keyFile') SshRemoteHost
h SshRemoteUser
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 :: RepoCache -> RemoteRepo -> m RemoteRepo
initRemoteRepo RepoCache
cache RemoteRepo
repo = do
  -- TODO logging traceL $ printf "Initializing remote repo: %s" (remoteRepoRepoId repo)
  RemoteRepo
repo' <- RemoteRepo -> m RemoteRepo
forall (m :: * -> *). MonadIO m => RemoteRepo -> m RemoteRepo
remoteRepoCheckSshPrivKey RemoteRepo
repo
  let (RemoteRepo FilePath
repoId FilePath
_ SshPrivKey
_ SshRemoteHost
_ SshRemoteUser
_) = RemoteRepo
repo'
  FilePath -> m ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
ensureDir (RepoCache -> FilePath -> FilePath
remoteRepoCacheDir RepoCache
cache FilePath
repoId FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/")
  RemoteRepo -> m RemoteRepo
forall (m :: * -> *) a. Monad m => a -> m a
return RemoteRepo
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 :: RepoCache -> RemoteRepo -> m ()
cleanRemoteRepo RepoCache
cache RemoteRepo
repo = do
  let repoId :: FilePath
repoId = RemoteRepo -> FilePath
remoteRepoRepoId RemoteRepo
repo
      repoDir :: FilePath
repoDir = RepoCache -> FilePath -> FilePath
remoteRepoCacheDir RepoCache
cache FilePath
repoId FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/"
  -- TODO logging infoL $ printf "Cleaning remote repo: %s" repoId
  FilePath -> m ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
ensureDir FilePath
repoDir
  -- TODO logging traceL $ printf "Deleting directory: %s" repoDir
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeDirectoryRecursive FilePath
repoDir
  FilePath -> m ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
ensureDir FilePath
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.
repoSearch ::
  forall e.
  (CommandIO e, Member RepoCacheReader e) =>
  FilePath ->
  FilePathGlob ->
  Eff e [(Repository, [FilePath])]
repoSearch :: FilePath -> FilePathGlob -> Eff e [(Repository, [FilePath])]
repoSearch FilePath
subDir FilePathGlob
glob = (:) ((Repository, [FilePath])
 -> [(Repository, [FilePath])] -> [(Repository, [FilePath])])
-> Eff e (Repository, [FilePath])
-> Eff e ([(Repository, [FilePath])] -> [(Repository, [FilePath])])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff e (Repository, [FilePath])
localMatches Eff e ([(Repository, [FilePath])] -> [(Repository, [FilePath])])
-> Eff e [(Repository, [FilePath])]
-> Eff e [(Repository, [FilePath])]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Eff e [(Repository, [FilePath])]
remoteRepoMatches
  where
    remoteRepoMatches :: Eff e [(Repository, [FilePath])]
remoteRepoMatches =
      Eff e (Set RemoteRepo)
forall (e :: [* -> *]).
Member B9ConfigReader e =>
Eff e (Set RemoteRepo)
getRemoteRepos Eff e (Set RemoteRepo)
-> (Set RemoteRepo -> Eff e [(Repository, [FilePath])])
-> Eff e [(Repository, [FilePath])]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (RemoteRepo -> Eff e (Repository, [FilePath]))
-> [RemoteRepo] -> Eff e [(Repository, [FilePath])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM RemoteRepo -> Eff e (Repository, [FilePath])
remoteRepoSearch ([RemoteRepo] -> Eff e [(Repository, [FilePath])])
-> (Set RemoteRepo -> [RemoteRepo])
-> Set RemoteRepo
-> Eff e [(Repository, [FilePath])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set RemoteRepo -> [RemoteRepo]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
    localMatches :: Eff e (Repository, [FilePath])
    localMatches :: Eff e (Repository, [FilePath])
localMatches = do
      RepoCache
cache <- Eff e RepoCache
forall (e :: [* -> *]). Member RepoCacheReader e => Eff e RepoCache
getRepoCache
      let dir :: FilePath
dir = RepoCache -> FilePath
localRepoDir RepoCache
cache FilePath -> FilePath -> FilePath
</> FilePath
subDir
      [FilePath]
files <- FilePath -> Eff e [FilePath]
findGlob FilePath
dir
      (Repository, [FilePath]) -> Eff e (Repository, [FilePath])
forall (m :: * -> *) a. Monad m => a -> m a
return (Repository
Cache, [FilePath]
files)
    remoteRepoSearch :: RemoteRepo -> Eff e (Repository, [FilePath])
    remoteRepoSearch :: RemoteRepo -> Eff e (Repository, [FilePath])
remoteRepoSearch RemoteRepo
repo = do
      RepoCache
cache <- Eff e RepoCache
forall (e :: [* -> *]). Member RepoCacheReader e => Eff e RepoCache
getRepoCache
      let dir :: FilePath
dir = RepoCache -> FilePath -> FilePath
remoteRepoCacheDir RepoCache
cache FilePath
repoId FilePath -> FilePath -> FilePath
</> FilePath
subDir
          (RemoteRepo FilePath
repoId FilePath
_ SshPrivKey
_ SshRemoteHost
_ SshRemoteUser
_) = RemoteRepo
repo
      [FilePath]
files <- FilePath -> Eff e [FilePath]
findGlob FilePath
dir
      (Repository, [FilePath]) -> Eff e (Repository, [FilePath])
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Repository
Remote FilePath
repoId, [FilePath]
files)
    findGlob :: FilePath -> Eff e [FilePath]
    findGlob :: FilePath -> Eff e [FilePath]
findGlob FilePath
dir = do
      FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
traceL (FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"reading contents of directory '%s'" FilePath
dir)
      FilePath -> Eff e ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
ensureDir (FilePath
dir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/")
      [FilePath]
files <- IO [FilePath] -> Eff e [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO [FilePath]
getDirectoryContents FilePath
dir)
      [FilePath] -> Eff e [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ((FilePath
dir FilePath -> FilePath -> FilePath
</>) (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePathGlob -> FilePath -> Bool
matchGlob FilePathGlob
glob) [FilePath]
files)

-- | Push a file from the cache to a remote repository
pushToRepo :: (Member ExcB9 e, CommandIO e) => RemoteRepo -> FilePath -> FilePath -> Eff e ()
pushToRepo :: RemoteRepo -> FilePath -> FilePath -> Eff e ()
pushToRepo repo :: RemoteRepo
repo@(RemoteRepo FilePath
repoId FilePath
_ SshPrivKey
_ SshRemoteHost
_ SshRemoteUser
_) FilePath
src FilePath
dest = do
  FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
dbgL (FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"PUSHING '%s' TO REPO '%s'" (FilePath -> FilePath
takeFileName FilePath
src) FilePath
repoId)
  FilePath -> Eff e ()
forall (e :: [* -> *]).
(HasCallStack, Member ExcB9 e, CommandIO e) =>
FilePath -> Eff e ()
cmd (RemoteRepo -> FilePath -> FilePath
repoEnsureDirCmd RemoteRepo
repo FilePath
dest)
  FilePath -> Eff e ()
forall (e :: [* -> *]).
(HasCallStack, Member ExcB9 e, CommandIO e) =>
FilePath -> Eff e ()
cmd (RemoteRepo -> FilePath -> FilePath -> FilePath
pushCmd RemoteRepo
repo FilePath
src FilePath
dest)

-- | Pull a file from a remote repository to cache
pullFromRepo :: (Member ExcB9 e, CommandIO e) => RemoteRepo -> FilePath -> FilePath -> Eff e ()
pullFromRepo :: RemoteRepo -> FilePath -> FilePath -> Eff e ()
pullFromRepo repo :: RemoteRepo
repo@(RemoteRepo FilePath
repoId FilePath
rootDir SshPrivKey
_key (SshRemoteHost (FilePath
host, Int
_port)) (SshRemoteUser FilePath
user)) FilePath
src FilePath
dest =
  do
    FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
dbgL (FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"PULLING '%s' FROM REPO '%s'" (FilePath -> FilePath
takeFileName FilePath
src) FilePath
repoId)
    FilePath -> Eff e ()
forall (e :: [* -> *]).
(HasCallStack, Member ExcB9 e, CommandIO e) =>
FilePath -> Eff e ()
cmd
      ( FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
forall r. PrintfType r => FilePath -> r
printf
          FilePath
"rsync -rtv -e 'ssh %s' '%s@%s:%s' '%s'"
          (RemoteRepo -> FilePath
sshOpts RemoteRepo
repo)
          FilePath
user
          FilePath
host
          (FilePath
rootDir FilePath -> FilePath -> FilePath
</> FilePath
src)
          FilePath
dest
      )

-- | Push a file from the cache to a remote repository
pullGlob ::
  (Member ExcB9 e, CommandIO e, Member RepoCacheReader e) =>
  FilePath ->
  FilePathGlob ->
  RemoteRepo ->
  Eff e ()
pullGlob :: FilePath -> FilePathGlob -> RemoteRepo -> Eff e ()
pullGlob FilePath
subDir FilePathGlob
glob repo :: RemoteRepo
repo@(RemoteRepo FilePath
repoId FilePath
rootDir SshPrivKey
_key (SshRemoteHost (FilePath
host, Int
_port)) (SshRemoteUser FilePath
user)) =
  do
    RepoCache
cache <- Eff e RepoCache
forall (e :: [* -> *]). Member RepoCacheReader e => Eff e RepoCache
getRepoCache
    FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
infoL (FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"SYNCING REPO METADATA '%s'" FilePath
repoId)
    let c :: FilePath
c =
          FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
forall r. PrintfType r => FilePath -> r
printf
            FilePath
"rsync -rtv --include '%s' --exclude '*.*' -e 'ssh %s' '%s@%s:%s/' '%s/'"
            (FilePathGlob -> FilePath
globToPattern FilePathGlob
glob)
            (RemoteRepo -> FilePath
sshOpts RemoteRepo
repo)
            FilePath
user
            FilePath
host
            (FilePath
rootDir FilePath -> FilePath -> FilePath
</> FilePath
subDir)
            FilePath
destDir
        destDir :: FilePath
destDir = FilePath
repoCacheDir FilePath -> FilePath -> FilePath
</> FilePath
subDir
        repoCacheDir :: FilePath
repoCacheDir = RepoCache -> FilePath -> FilePath
remoteRepoCacheDir RepoCache
cache FilePath
repoId
    FilePath -> Eff e ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
ensureDir FilePath
destDir
    FilePath -> Eff e ()
forall (e :: [* -> *]).
(HasCallStack, Member ExcB9 e, CommandIO e) =>
FilePath -> Eff e ()
cmd FilePath
c

-- | Express a pattern for file paths, used when searching repositories.
newtype FilePathGlob
  = FileExtension String

-- * Internals

globToPattern :: FilePathGlob -> String
globToPattern :: FilePathGlob -> FilePath
globToPattern (FileExtension FilePath
ext) = FilePath
"*." FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
ext

-- | A predicate that is satisfied if a file path matches a glob.
matchGlob :: FilePathGlob -> FilePath -> Bool
matchGlob :: FilePathGlob -> FilePath -> Bool
matchGlob (FileExtension FilePath
ext) = FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf (FilePath
"." FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
ext)

-- | A shell command string for invoking rsync to push a path to a remote host
-- via ssh.
pushCmd :: RemoteRepo -> FilePath -> FilePath -> String
pushCmd :: RemoteRepo -> FilePath -> FilePath -> FilePath
pushCmd repo :: RemoteRepo
repo@(RemoteRepo FilePath
_repoId FilePath
rootDir SshPrivKey
_key (SshRemoteHost (FilePath
host, Int
_port)) (SshRemoteUser FilePath
user)) FilePath
src FilePath
dest =
  FilePath -> FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf
    FilePath
"rsync -rtv --inplace --ignore-existing -e 'ssh %s' '%s' '%s'"
    (RemoteRepo -> FilePath
sshOpts RemoteRepo
repo)
    FilePath
src
    FilePath
sshDest
  where
    sshDest :: FilePath
sshDest = FilePath
-> FilePath -> FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%s@%s:%s/%s" FilePath
user FilePath
host FilePath
rootDir FilePath
dest :: String

-- | A shell command string for invoking rsync to create the directories for a
-- file push.
repoEnsureDirCmd :: RemoteRepo -> FilePath -> String
repoEnsureDirCmd :: RemoteRepo -> FilePath -> FilePath
repoEnsureDirCmd repo :: RemoteRepo
repo@(RemoteRepo FilePath
_repoId FilePath
rootDir SshPrivKey
_key (SshRemoteHost (FilePath
host, Int
_port)) (SshRemoteUser FilePath
user)) FilePath
dest =
  FilePath
-> FilePath -> FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf
    FilePath
"ssh %s %s@%s mkdir -p '%s'"
    (RemoteRepo -> FilePath
sshOpts RemoteRepo
repo)
    FilePath
user
    FilePath
host
    (FilePath
rootDir FilePath -> FilePath -> FilePath
</> FilePath -> FilePath
takeDirectory FilePath
dest)

sshOpts :: RemoteRepo -> String
sshOpts :: RemoteRepo -> FilePath
sshOpts (RemoteRepo FilePath
_repoId FilePath
_rootDir (SshPrivKey FilePath
key) (SshRemoteHost (FilePath
_host, Int
port)) SshRemoteUser
_user) =
  [FilePath] -> FilePath
unwords
    [ FilePath
"-o",
      FilePath
"StrictHostKeyChecking=no",
      FilePath
"-o",
      FilePath
"UserKnownHostsFile=/dev/null",
      FilePath
"-o",
      FilePath -> Int -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"Port=%i" Int
port,
      FilePath
"-o",
      FilePath
"IdentityFile=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
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 :: Eff e (Map Repository (Set SharedImage))
getSharedImages = do
  [(Repository, [FilePath])]
reposAndFiles <-
    FilePath -> FilePathGlob -> Eff e [(Repository, [FilePath])]
forall (e :: [* -> *]).
(CommandIO e, Member RepoCacheReader e) =>
FilePath -> FilePathGlob -> Eff e [(Repository, [FilePath])]
repoSearch
      FilePath
sharedImagesRootDirectory
      (FilePath -> FilePathGlob
FileExtension FilePath
sharedImageFileExtension)
  ((Repository, [FilePath])
 -> Map Repository (Set SharedImage)
 -> Eff e (Map Repository (Set SharedImage)))
-> Map Repository (Set SharedImage)
-> [(Repository, [FilePath])]
-> Eff e (Map Repository (Set SharedImage))
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM
    ( \(Repository
repo, [FilePath]
files) Map Repository (Set SharedImage)
acc -> do
        [SharedImage]
imgs <- [Maybe SharedImage] -> [SharedImage]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe SharedImage] -> [SharedImage])
-> Eff e [Maybe SharedImage] -> Eff e [SharedImage]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> Eff e (Maybe SharedImage))
-> [FilePath] -> Eff e [Maybe SharedImage]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> Eff e (Maybe SharedImage)
forall (e :: [* -> *]) a (m :: * -> *).
(MonadBaseControl IO (Eff e), Read a, MonadIO m,
 SetMember Lift (Lift m) e, FindElem B9ConfigReader e,
 FindElem (Reader Logger) e) =>
FilePath -> Eff e (Maybe a)
consult' [FilePath]
files
        let imgSet :: Set SharedImage
imgSet = [SharedImage] -> Set SharedImage
forall a. Ord a => [a] -> Set a
Set.fromList [SharedImage]
imgs
        Map Repository (Set SharedImage)
-> Eff e (Map Repository (Set SharedImage))
forall (m :: * -> *) a. Monad m => a -> m a
return (Repository
-> Set SharedImage
-> Map Repository (Set SharedImage)
-> Map Repository (Set SharedImage)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Repository
repo Set SharedImage
imgSet Map Repository (Set SharedImage)
acc)
    )
    Map Repository (Set SharedImage)
forall k a. Map k a
Map.empty
    [(Repository, [FilePath])]
reposAndFiles
  where
    consult' :: FilePath -> Eff e (Maybe a)
consult' FilePath
f = do
      Either SomeException a
r <- IO (Either SomeException a) -> Eff e (Either SomeException a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try (FilePath -> IO a
forall (m :: * -> *) a. (MonadIO m, Read a) => FilePath -> m a
consult FilePath
f))
      case Either SomeException a
r of
        Left (SomeException
e :: SomeException) -> do
          FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
dbgL
            ( FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf
                FilePath
"Failed to load shared image meta-data from '%s': '%s'"
                (FilePath -> FilePath
takeFileName FilePath
f)
                (SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e)
            )
          FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
dbgL (FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"Removing bad meta-data file '%s'" FilePath
f)
          IO () -> Eff e ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO ()
removeFile FilePath
f)
          Maybe a -> Eff e (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
        Right a
c -> Maybe a -> Eff e (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
c)

-- | Pull metadata files from all remote repositories.
pullRemoteRepos ::
  (HasCallStack, Member ExcB9 e, Lifted IO e, CommandIO e, '[SelectedRemoteRepoReader, RepoCacheReader] <:: e) =>
  Eff e ()
pullRemoteRepos :: Eff e ()
pullRemoteRepos = do
  Set RemoteRepo
repos <- Eff e (Set RemoteRepo)
forall (e :: [* -> *]).
('[B9ConfigReader, SelectedRemoteRepoReader] <:: e) =>
Eff e (Set RemoteRepo)
getSelectedRepos
  (RemoteRepo -> Eff e ()) -> Set RemoteRepo -> Eff e ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ RemoteRepo -> Eff e ()
dl Set RemoteRepo
repos
  where
    dl :: RemoteRepo -> Eff e ()
dl =
      FilePath -> FilePathGlob -> RemoteRepo -> Eff e ()
forall (e :: [* -> *]).
(Member ExcB9 e, CommandIO e, Member RepoCacheReader e) =>
FilePath -> FilePathGlob -> RemoteRepo -> Eff e ()
pullGlob
        FilePath
sharedImagesRootDirectory
        (FilePath -> FilePathGlob
FileExtension FilePath
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 :: SharedImageName -> Eff e (Maybe SharedImageBuildId)
pullLatestImage name :: SharedImageName
name@(SharedImageName FilePath
dbgName) = do
  Set RemoteRepo
repos <- Eff e (Set RemoteRepo)
forall (e :: [* -> *]).
('[B9ConfigReader, SelectedRemoteRepoReader] <:: e) =>
Eff e (Set RemoteRepo)
getSelectedRepos
  let repoPredicate :: Repository -> Bool
repoPredicate Repository
Cache = Bool
False
      repoPredicate (Remote FilePath
repoId) = FilePath
repoId FilePath -> Set FilePath -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set FilePath
repoIds
      repoIds :: Set FilePath
repoIds = (RemoteRepo -> FilePath) -> Set RemoteRepo -> Set FilePath
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map RemoteRepo -> FilePath
remoteRepoRepoId Set RemoteRepo
repos
      hasName :: SharedImage -> Bool
hasName SharedImage
sharedImage = SharedImageName
name SharedImageName -> SharedImageName -> Bool
forall a. Eq a => a -> a -> Bool
== SharedImage -> SharedImageName
sharedImageName SharedImage
sharedImage
  Map Repository (Set SharedImage)
candidates <-
    (Repository -> Bool)
-> (SharedImage -> Bool)
-> Map Repository (Set SharedImage)
-> Map Repository (Set SharedImage)
filterRepoImagesMap Repository -> Bool
repoPredicate SharedImage -> Bool
hasName (Map Repository (Set SharedImage)
 -> Map Repository (Set SharedImage))
-> Eff e (Map Repository (Set SharedImage))
-> Eff e (Map Repository (Set SharedImage))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff e (Map Repository (Set SharedImage))
forall (e :: [* -> *]).
(HasCallStack, CommandIO e, Lifted IO e,
 Member RepoCacheReader e) =>
Eff e (Map Repository (Set SharedImage))
getSharedImages
  case Map Repository (Set SharedImage) -> Maybe (SharedImage, Repository)
maxSharedImageOfAllRepos Map Repository (Set SharedImage)
candidates of
    Maybe (SharedImage, Repository)
Nothing ->
      do
        FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
errorL
          ( FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf
              FilePath
"No shared image named '%s' on these remote repositories: '%s'"
              FilePath
dbgName
              (Set FilePath -> FilePath
forall a. Show a => a -> FilePath
ppShow Set FilePath
repoIds)
          )
        Maybe SharedImageBuildId -> Eff e (Maybe SharedImageBuildId)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SharedImageBuildId
forall a. Maybe a
Nothing
    Just (SharedImage
image, Repository
Cache) -> do
      FilePath -> Eff e (Maybe SharedImageBuildId)
forall (e :: [* -> *]) a.
(CommandIO e, Member ExcB9 e) =>
FilePath -> Eff e a
errorExitL (FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"Unreachable code reached in `pullLastestImage`: '%s'  %s" FilePath
dbgName (SharedImage -> FilePath
forall a. Show a => a -> FilePath
ppShow SharedImage
image))
    Just (SharedImage
image, Remote FilePath
repoId) -> do
      FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
dbgL (FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"PULLING SHARED IMAGE: '%s'" (SharedImage -> FilePath
forall a. Show a => a -> FilePath
ppShow SharedImage
image))
      FilePath
cacheDir <- Eff e FilePath
forall (e :: [* -> *]).
('[RepoCacheReader] <:: e) =>
Eff e FilePath
getSharedImagesCacheDir
      let (Image FilePath
imgFile' ImageType
_imgType FileSystem
_fs) = SharedImage -> Image
sharedImageImage SharedImage
image
          cachedImgFile :: FilePath
cachedImgFile = FilePath
cacheDir FilePath -> FilePath -> FilePath
</> FilePath
imgFile'
          cachedInfoFile :: FilePath
cachedInfoFile = FilePath
cacheDir FilePath -> FilePath -> FilePath
</> SharedImage -> FilePath
sharedImageFileName SharedImage
image
          repoImgFile :: FilePath
repoImgFile = FilePath
sharedImagesRootDirectory FilePath -> FilePath -> FilePath
</> FilePath
imgFile'
          repoInfoFile :: FilePath
repoInfoFile = FilePath
sharedImagesRootDirectory FilePath -> FilePath -> FilePath
</> SharedImage -> FilePath
sharedImageFileName SharedImage
image
          repo :: RemoteRepo
repo = Maybe RemoteRepo -> RemoteRepo
forall a. HasCallStack => Maybe a -> a
fromJust (Set RemoteRepo -> FilePath -> Maybe RemoteRepo
lookupRemoteRepo Set RemoteRepo
repos FilePath
repoId)
      RemoteRepo -> FilePath -> FilePath -> Eff e ()
forall (e :: [* -> *]).
(Member ExcB9 e, CommandIO e) =>
RemoteRepo -> FilePath -> FilePath -> Eff e ()
pullFromRepo RemoteRepo
repo FilePath
repoImgFile FilePath
cachedImgFile
      RemoteRepo -> FilePath -> FilePath -> Eff e ()
forall (e :: [* -> *]).
(Member ExcB9 e, CommandIO e) =>
RemoteRepo -> FilePath -> FilePath -> Eff e ()
pullFromRepo RemoteRepo
repo FilePath
repoInfoFile FilePath
cachedInfoFile
      FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
infoL (FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"PULLED '%s' FROM '%s'" FilePath
dbgName FilePath
repoId)
      SharedImageName -> Eff e ()
forall (e :: [* -> *]).
('[RepoCacheReader, ExcB9] <:: e, Lifted IO e, CommandIO e) =>
SharedImageName -> Eff e ()
cleanOldSharedImageRevisionsFromCache SharedImageName
name
      Maybe SharedImageBuildId -> Eff e (Maybe SharedImageBuildId)
forall (m :: * -> *) a. Monad m => a -> m a
return (SharedImageBuildId -> Maybe SharedImageBuildId
forall a. a -> Maybe a
Just (SharedImage -> SharedImageBuildId
sharedImageBuildId SharedImage
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 :: SharedImageName -> Eff e (Maybe Image)
getLatestImageByName SharedImageName
name = do
  Set SharedImage
sharedImageRevisions <- SharedImageName
-> Map Repository (Set SharedImage) -> Set SharedImage
lookupCachedImages SharedImageName
name (Map Repository (Set SharedImage) -> Set SharedImage)
-> Eff e (Map Repository (Set SharedImage))
-> Eff e (Set SharedImage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff e (Map Repository (Set SharedImage))
forall (e :: [* -> *]).
(HasCallStack, CommandIO e, Lifted IO e,
 Member RepoCacheReader e) =>
Eff e (Map Repository (Set SharedImage))
getSharedImages
  FilePath
cacheDir <- Eff e FilePath
forall (e :: [* -> *]).
('[RepoCacheReader] <:: e) =>
Eff e FilePath
getSharedImagesCacheDir
  let image :: Maybe Image
image =
        FilePath -> Image -> Image
changeImageDirectory FilePath
cacheDir (Image -> Image) -> (SharedImage -> Image) -> SharedImage -> Image
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SharedImage -> Image
sharedImageImage
          (SharedImage -> Image) -> Maybe SharedImage -> Maybe Image
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set SharedImage -> Maybe SharedImage
forall a. Set a -> Maybe a
Set.lookupMax Set SharedImage
sharedImageRevisions
  case Maybe Image
image of
    Just Image
i -> FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
dbgL (FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"USING SHARED SOURCE IMAGE '%s'" (Image -> FilePath
forall a. Show a => a -> FilePath
show Image
i))
    Maybe Image
Nothing -> FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
errorL (FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"SOURCE IMAGE '%s' NOT FOUND" (SharedImageName -> FilePath
forall a. Show a => a -> FilePath
show SharedImageName
name))
  Maybe Image -> Eff e (Maybe Image)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Image
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 :: SharedImageName -> Eff e ()
cleanOldSharedImageRevisionsFromCache SharedImageName
sn = do
  B9Config
b9Cfg <- Eff e B9Config
forall (e :: [* -> *]). Member B9ConfigReader e => Eff e B9Config
getConfig
  Maybe Int -> (Int -> Eff e ()) -> Eff e ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (B9Config
b9Cfg B9Config -> Getting (Maybe Int) B9Config (Maybe Int) -> Maybe Int
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Int) B9Config (Maybe Int)
Lens' B9Config (Maybe Int)
maxLocalSharedImageRevisions) ((Int -> Eff e ()) -> Eff e ()) -> (Int -> Eff e ()) -> Eff e ()
forall a b. (a -> b) -> a -> b
$ \Int
maxRevisions -> do
    Bool -> Eff e () -> Eff e ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
      (Int
maxRevisions Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1)
      ( FilePath -> Eff e ()
forall (e :: [* -> *]). Member ExcB9 e => FilePath -> Eff e ()
throwB9Error_
          ( FilePath -> Int -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf
              FilePath
"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'."
              Int
maxRevisions
              FilePath
maxLocalSharedImageRevisionsK
          )
      )
    Set SharedImage
allRevisions <- SharedImageName
-> Map Repository (Set SharedImage) -> Set SharedImage
lookupCachedImages SharedImageName
sn (Map Repository (Set SharedImage) -> Set SharedImage)
-> Eff e (Map Repository (Set SharedImage))
-> Eff e (Set SharedImage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff e (Map Repository (Set SharedImage))
forall (e :: [* -> *]).
(HasCallStack, CommandIO e, Lifted IO e,
 Member RepoCacheReader e) =>
Eff e (Map Repository (Set SharedImage))
getSharedImages
    let toDelete :: Set SharedImage
toDelete = Int -> Set SharedImage -> Set SharedImage
dropAllButNLatestSharedImages Int
maxRevisions Set SharedImage
allRevisions
    Set SharedImage -> Eff e ()
forall (e :: [* -> *]).
(CommandIO e, Member RepoCacheReader e) =>
Set SharedImage -> Eff e ()
removeCachedSharedImages Set SharedImage
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 :: Eff e ()
cleanLocalRepoCache = do
  Set SharedImage
allCached <- Map Repository (Set SharedImage) -> Set SharedImage
allCachedSharedImages (Map Repository (Set SharedImage) -> Set SharedImage)
-> Eff e (Map Repository (Set SharedImage))
-> Eff e (Set SharedImage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff e (Map Repository (Set SharedImage))
forall (e :: [* -> *]).
(HasCallStack, CommandIO e, Lifted IO e,
 Member RepoCacheReader e) =>
Eff e (Map Repository (Set SharedImage))
getSharedImages
  Maybe Int
maxRevConfig <- Getting (Maybe Int) B9Config (Maybe Int) -> B9Config -> Maybe Int
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe Int) B9Config (Maybe Int)
Lens' B9Config (Maybe Int)
maxLocalSharedImageRevisions (B9Config -> Maybe Int) -> Eff e B9Config -> Eff e (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff e B9Config
forall (e :: [* -> *]). Member B9ConfigReader e => Eff e B9Config
getConfig
  let maxRev :: Int
maxRev = Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0) Maybe Int
maxRevConfig
      byName :: Map SharedImageName (Set SharedImage)
byName = Set SharedImage -> Map SharedImageName (Set SharedImage)
groupBySharedImageName Set SharedImage
allCached
      toKeep :: Set SharedImage
toKeep =
        Map SharedImageName (Set SharedImage) -> Set SharedImage
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
          ( (Set SharedImage -> Set SharedImage)
-> Map SharedImageName (Set SharedImage)
-> Map SharedImageName (Set SharedImage)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map
              (Int -> Set SharedImage -> Set SharedImage
keepNLatestSharedImages Int
maxRev)
              Map SharedImageName (Set SharedImage)
byName
          )
      toDelete :: Set SharedImage
toDelete =
        Map SharedImageName (Set SharedImage) -> Set SharedImage
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
          ( (Set SharedImage -> Set SharedImage)
-> Map SharedImageName (Set SharedImage)
-> Map SharedImageName (Set SharedImage)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map
              (Int -> Set SharedImage -> Set SharedImage
dropAllButNLatestSharedImages Int
maxRev)
              Map SharedImageName (Set SharedImage)
byName
          )
  FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
infoL FilePath
"ALL CACHED IMAGES:"
  Set SharedImage -> (SharedImage -> Eff e ()) -> Eff e ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Set SharedImage
allCached (FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
infoL (FilePath -> Eff e ())
-> (SharedImage -> FilePath) -> SharedImage -> Eff e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SharedImage -> FilePath
forall a. Show a => a -> FilePath
show)
  FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
infoL (FilePath
"CACHED " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> (Int -> FilePath) -> Maybe Int -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"" ((FilePath
"(" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) (FilePath -> FilePath) -> (Int -> FilePath) -> Int -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
") ") (FilePath -> FilePath) -> (Int -> FilePath) -> Int -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> FilePath
forall a. Show a => a -> FilePath
show) Maybe Int
maxRevConfig FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"IMAGES TO KEEP:")
  Set SharedImage -> (SharedImage -> Eff e ()) -> Eff e ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Set SharedImage
toKeep (FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
infoL (FilePath -> Eff e ())
-> (SharedImage -> FilePath) -> SharedImage -> Eff e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SharedImage -> FilePath
forall a. Show a => a -> FilePath
show)
  FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
infoL FilePath
"CACHED IMAGES TO DELETE:"
  Set SharedImage -> (SharedImage -> Eff e ()) -> Eff e ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Set SharedImage
toDelete (FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
infoL (FilePath -> Eff e ())
-> (SharedImage -> FilePath) -> SharedImage -> Eff e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SharedImage -> FilePath
forall a. Show a => a -> FilePath
show)
  Set SharedImage -> Eff e ()
forall (e :: [* -> *]).
(CommandIO e, Member RepoCacheReader e) =>
Set SharedImage -> Eff e ()
removeCachedSharedImages Set SharedImage
toDelete
  () -> Eff e ()
forall (m :: * -> *) a. Monad m => a -> m a
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 :: SharedImageName -> Eff e ()
pushSharedImageLatestVersion name :: SharedImageName
name@(SharedImageName FilePath
imgName) =
  SharedImageName
-> Map Repository (Set SharedImage) -> Set SharedImage
lookupCachedImages SharedImageName
name (Map Repository (Set SharedImage) -> Set SharedImage)
-> Eff e (Map Repository (Set SharedImage))
-> Eff e (Set SharedImage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff e (Map Repository (Set SharedImage))
forall (e :: [* -> *]).
(HasCallStack, CommandIO e, Lifted IO e,
 Member RepoCacheReader e) =>
Eff e (Map Repository (Set SharedImage))
getSharedImages
    Eff e (Set SharedImage)
-> (Set SharedImage -> Eff e ()) -> Eff e ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Eff e ()
-> (SharedImage -> Eff e ()) -> Maybe SharedImage -> Eff e ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      (FilePath -> Eff e ()
forall (e :: [* -> *]) a.
(CommandIO e, Member ExcB9 e) =>
FilePath -> Eff e a
errorExitL (FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"Nothing found for %s." (FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
imgName)))
      ( \SharedImage
sharedImage -> do
          FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
dbgL (FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"PUSHING '%s'" (SharedImage -> FilePath
forall a. Show a => a -> FilePath
ppShow SharedImage
sharedImage))
          SharedImage -> Eff e ()
forall (e :: [* -> *]).
(Member ExcB9 e, Lifted IO e, CommandIO e,
 '[RepoCacheReader, SelectedRemoteRepoReader] <:: e) =>
SharedImage -> Eff e ()
pushToSelectedRepo SharedImage
sharedImage
          FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
infoL (FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"PUSHED '%s'" FilePath
imgName)
      )
      (Maybe SharedImage -> Eff e ())
-> (Set SharedImage -> Maybe SharedImage)
-> Set SharedImage
-> Eff e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set SharedImage -> Maybe SharedImage
forall a. Set a -> Maybe a
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 :: SharedImage -> Eff e ()
pushToSelectedRepo SharedImage
i = do
  FilePath
c <- Eff e FilePath
forall (e :: [* -> *]).
('[RepoCacheReader] <:: e) =>
Eff e FilePath
getSharedImagesCacheDir
  MkSelectedRemoteRepo Maybe RemoteRepo
r <- Eff e SelectedRemoteRepo
forall (e :: [* -> *]).
Member SelectedRemoteRepoReader e =>
Eff e SelectedRemoteRepo
getSelectedRemoteRepo
  Bool -> Eff e () -> Eff e ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe RemoteRepo -> Bool
forall a. Maybe a -> Bool
isJust Maybe RemoteRepo
r) (Eff e () -> Eff e ()) -> Eff e () -> Eff e ()
forall a b. (a -> b) -> a -> b
$ do
    let (Image FilePath
imgFile' ImageType
_imgType FileSystem
_imgFS) = SharedImage -> Image
sharedImageImage SharedImage
i
        cachedImgFile :: FilePath
cachedImgFile = FilePath
c FilePath -> FilePath -> FilePath
</> FilePath
imgFile'
        cachedInfoFile :: FilePath
cachedInfoFile = FilePath
c FilePath -> FilePath -> FilePath
</> SharedImage -> FilePath
sharedImageFileName SharedImage
i
        repoImgFile :: FilePath
repoImgFile = FilePath
sharedImagesRootDirectory FilePath -> FilePath -> FilePath
</> FilePath
imgFile'
        repoInfoFile :: FilePath
repoInfoFile = FilePath
sharedImagesRootDirectory FilePath -> FilePath -> FilePath
</> SharedImage -> FilePath
sharedImageFileName SharedImage
i
    RemoteRepo -> FilePath -> FilePath -> Eff e ()
forall (e :: [* -> *]).
(Member ExcB9 e, CommandIO e) =>
RemoteRepo -> FilePath -> FilePath -> Eff e ()
pushToRepo (Maybe RemoteRepo -> RemoteRepo
forall a. HasCallStack => Maybe a -> a
fromJust Maybe RemoteRepo
r) FilePath
cachedImgFile FilePath
repoImgFile
    RemoteRepo -> FilePath -> FilePath -> Eff e ()
forall (e :: [* -> *]).
(Member ExcB9 e, CommandIO e) =>
RemoteRepo -> FilePath -> FilePath -> Eff e ()
pushToRepo (Maybe RemoteRepo -> RemoteRepo
forall a. HasCallStack => Maybe a -> a
fromJust Maybe RemoteRepo
r) FilePath
cachedInfoFile FilePath
repoInfoFile

-- | Return either all remote repos or just the single selected repo.
getSelectedRepos :: '[B9ConfigReader, SelectedRemoteRepoReader] <:: e => Eff e (Set RemoteRepo)
getSelectedRepos :: Eff e (Set RemoteRepo)
getSelectedRepos = do
  Set RemoteRepo
allRepos <- Eff e (Set RemoteRepo)
forall (e :: [* -> *]).
Member B9ConfigReader e =>
Eff e (Set RemoteRepo)
getRemoteRepos
  MkSelectedRemoteRepo Maybe RemoteRepo
selectedRepo <- Eff e SelectedRemoteRepo
forall (e :: [* -> *]).
Member SelectedRemoteRepoReader e =>
Eff e SelectedRemoteRepo
getSelectedRemoteRepo
  let repos :: Set RemoteRepo
repos = Set RemoteRepo
-> (RemoteRepo -> Set RemoteRepo)
-> Maybe RemoteRepo
-> Set RemoteRepo
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set RemoteRepo
allRepos RemoteRepo -> Set RemoteRepo
forall a. a -> Set a
Set.singleton Maybe RemoteRepo
selectedRepo -- 'Maybe' a repo
  Set RemoteRepo -> Eff e (Set RemoteRepo)
forall (m :: * -> *) a. Monad m => a -> m a
return Set RemoteRepo
repos

-- | Return the path to the sub directory in the cache that contains files of
-- shared images.
getSharedImagesCacheDir :: '[RepoCacheReader] <:: e => Eff e FilePath
getSharedImagesCacheDir :: Eff e FilePath
getSharedImagesCacheDir = do
  FilePath
cacheDir <- RepoCache -> FilePath
localRepoDir (RepoCache -> FilePath) -> Eff e RepoCache -> Eff e FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff e RepoCache
forall (e :: [* -> *]). Member RepoCacheReader e => Eff e RepoCache
getRepoCache
  FilePath -> Eff e FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
cacheDir FilePath -> FilePath -> FilePath
</> FilePath
sharedImagesRootDirectory)

removeCachedSharedImages :: (CommandIO e, Member (Reader RepoCache) e) => Set SharedImage -> Eff e ()
removeCachedSharedImages :: Set SharedImage -> Eff e ()
removeCachedSharedImages Set SharedImage
toDelete =
  do
    FilePath
imgDir <- Eff e FilePath
forall (e :: [* -> *]).
('[RepoCacheReader] <:: e) =>
Eff e FilePath
getSharedImagesCacheDir
    let filesToDelete :: Set FilePath
filesToDelete = (FilePath -> FilePath) -> Set FilePath -> Set FilePath
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (FilePath
imgDir FilePath -> FilePath -> FilePath
</>) (Set FilePath
infoFiles Set FilePath -> Set FilePath -> Set FilePath
forall a. Semigroup a => a -> a -> a
<> Set FilePath
imgFiles)
        infoFiles :: Set FilePath
infoFiles = (SharedImage -> FilePath) -> Set SharedImage -> Set FilePath
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map SharedImage -> FilePath
sharedImageFileName Set SharedImage
toDelete
        imgFiles :: Set FilePath
imgFiles = (SharedImage -> FilePath) -> Set SharedImage -> Set FilePath
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (Image -> FilePath
imageFileName (Image -> FilePath)
-> (SharedImage -> Image) -> SharedImage -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SharedImage -> Image
sharedImageImage) Set SharedImage
toDelete
    if Set FilePath -> Bool
forall a. Set a -> Bool
Set.null Set FilePath
filesToDelete
      then FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
infoL FilePath
"NO IMAGES TO DELETE"
      else do
        FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
infoL FilePath
"DELETING FILES:"
        Set FilePath -> (FilePath -> Eff e ()) -> Eff e ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Set FilePath
filesToDelete (FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
infoL (FilePath -> Eff e ())
-> (FilePath -> FilePath) -> FilePath -> Eff e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
forall a. Show a => a -> FilePath
show)
        IO () -> Eff e ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((FilePath -> IO ()) -> Set FilePath -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> IO ()
removeIfExists Set FilePath
filesToDelete)