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
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import Data.Maybe
import Text.Printf
import System.FilePath
import System.Directory
import B9.B9Config.Repository as X
import System.IO.B9Extras
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)
type RepoCacheReader = Reader RepoCache
getRepoCache :: Member RepoCacheReader e => Eff e RepoCache
getRepoCache = ask
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
newtype SelectedRemoteRepo = MkSelectedRemoteRepo { fromSelectedRemoteRepo :: Maybe RemoteRepo }
type SelectedRemoteRepoReader = Reader SelectedRemoteRepo
getSelectedRemoteRepo :: Member SelectedRemoteRepoReader e => Eff e SelectedRemoteRepo
getSelectedRemoteRepo = ask
initRepoCache :: MonadIO m => SystemPath -> m RepoCache
initRepoCache repoDirSystemPath = do
repoDir <- resolve repoDirSystemPath
ensureDir (repoDir ++ "/")
return (RepoCache repoDir)
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)
initRemoteRepo :: MonadIO m
=> RepoCache
-> RemoteRepo
-> m RemoteRepo
initRemoteRepo cache repo = do
repo' <- remoteRepoCheckSshPrivKey repo
let (RemoteRepo repoId _ _ _ _) = repo'
ensureDir (remoteRepoCacheDir cache repoId ++ "/")
return repo'
cleanRemoteRepo :: MonadIO m
=> RepoCache
-> RemoteRepo
-> m ()
cleanRemoteRepo cache repo = do
let repoId = remoteRepoRepoId repo
repoDir = remoteRepoCacheDir cache repoId ++ "/"
ensureDir repoDir
liftIO $ removeDirectoryRecursive repoDir
ensureDir repoDir
remoteRepoCacheDir :: RepoCache
-> String
-> FilePath
remoteRepoCacheDir (RepoCache cacheDir) repoId =
cacheDir </> "remote-repos" </> repoId
localRepoDir :: RepoCache
-> FilePath
localRepoDir (RepoCache cacheDir) =
cacheDir </> "local-repo"
lookupRemoteRepo :: [RemoteRepo] -> String -> Maybe RemoteRepo
lookupRemoteRepo repos repoId = lookup repoId repoIdRepoPairs
where repoIdRepoPairs = map (\r@(RemoteRepo rid _ _ _ _) -> (rid,r)) repos