{-| B9 has a concept of 'B9.DiskImages.SharedImaged'. Shared images can be pulled and pushed to/from remote locations via rsync+ssh. B9 also maintains a local cache; the whole thing is supposed to be build-server-safe, that means no two builds shall interfere with each other. This is accomplished by refraining from automatic cache updates from/to remote repositories.-} module B9.Repository ( initRepoCache , RepoCacheReader , getRepoCache , withRemoteRepos , withSelectedRemoteRepo , getSelectedRemoteRepo , SelectedRemoteRepoReader , SelectedRemoteRepo(..) , initRemoteRepo , cleanRemoteRepo , remoteRepoCheckSshPrivKey , remoteRepoCacheDir , localRepoDir , lookupRemoteRepo , module X ) where import B9.B9Config import B9.B9Error import Control.Monad import Control.Eff import Control.Eff.Reader.Lazy import Control.Lens import Control.Monad.IO.Class import Data.Maybe import Text.Printf import System.FilePath import System.Directory import B9.B9Config.Repository as X import System.IO.B9Extras -- | 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) -- | Alias for a 'Reader' 'Eff'ect that reads a list of 'RemoteRepo's. -- -- @since 0.5.65 type RepoCacheReader = Reader RepoCache -- | Ask for the 'RepoCache' initialized by 'withRemoteRepos'. -- -- @since 0.5.65 getRepoCache :: Member RepoCacheReader e => Eff e RepoCache getRepoCache = ask -- | Run a 'SelectedRemoteRepoReader' with the 'SelectedRemoteRepo' selected -- in the 'B9Config'. -- -- If the selected repo does not exist, and exception is thrown. -- -- @since 0.5.65 withSelectedRemoteRepo :: (Member B9ConfigReader e, Member ExcB9 e) => Eff (SelectedRemoteRepoReader ': e) a -> Eff e a withSelectedRemoteRepo e = do remoteRepos' <- _remoteRepos <$> getB9Config mSelectedRepoName <- _repository <$> getB9Config case mSelectedRepoName of Nothing -> runReader (MkSelectedRemoteRepo Nothing) e Just selectedRepoName -> case lookupRemoteRepo remoteRepos' selectedRepoName of Nothing -> throwB9Error (printf "selected remote repo '%s' not configured, valid remote repos are: '%s'" (show selectedRepoName) (show remoteRepos') ) Just r -> runReader (MkSelectedRemoteRepo (Just r)) e -- | Contains the 'Just' the 'RemoteRepo' selected by the 'B9Config' value '_repository', -- or 'Nothing' of no 'RemoteRepo' was selected in the 'B9Config'. -- -- @since 0.5.65 newtype SelectedRemoteRepo = MkSelectedRemoteRepo { fromSelectedRemoteRepo :: Maybe RemoteRepo } -- | Alias for a 'Reader' 'Eff'ect that reads the 'RemoteRepo' -- selected by the 'B9Config' value '_repository'. See 'withSelectedRemoteRepo'. -- -- @since 0.5.65 type SelectedRemoteRepoReader = Reader SelectedRemoteRepo -- | Ask for the 'RemoteRepo' -- selected by the 'B9Config' value '_repository'. See 'withSelectedRemoteRepo'. -- -- @since 0.5.65 getSelectedRemoteRepo :: 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 :: RepoCache -- ^ The repository cache directory -> String -- ^ Id of the repository -> FilePath -- ^ The existing, absolute path to the -- cache directory remoteRepoCacheDir (RepoCache cacheDir) repoId = cacheDir "remote-repos" repoId -- | Return the local repository directory. localRepoDir :: RepoCache -- ^ The repository cache directory -> FilePath -- ^ The existing, absolute path to the -- directory localRepoDir (RepoCache cacheDir) = cacheDir "local-repo" -- | Select the first 'RemoteRepo' with a given @repoId@. lookupRemoteRepo :: [RemoteRepo] -> String -> Maybe RemoteRepo lookupRemoteRepo repos repoId = lookup repoId repoIdRepoPairs where repoIdRepoPairs = map (\r@(RemoteRepo rid _ _ _ _) -> (rid, r)) repos