Startup: If repo dir check fails, print both versions of repo tree

This commit is contained in:
fr33domlover 2020-05-14 12:11:31 +00:00
parent cac4edc8eb
commit 2063c7313b

View file

@ -32,6 +32,7 @@ where
import Control.Concurrent.Chan import Control.Concurrent.Chan
import Control.Concurrent.STM.TVar import Control.Concurrent.STM.TVar
import Control.Exception hiding (Handler)
import Control.Monad import Control.Monad
import Control.Monad.Logger (liftLoc, runLoggingT, logInfo, logError) import Control.Monad.Logger (liftLoc, runLoggingT, logInfo, logError)
import Control.Monad.Trans.Reader import Control.Monad.Trans.Reader
@ -229,14 +230,19 @@ makeFoundation appSettings = do
verifyRepoDir = do verifyRepoDir = do
repos <- lift repoTreeFromDir repos <- lift repoTreeFromDir
repos' <- repoTreeFromDB repos' <- repoTreeFromDB
unless (repos == repos') $ unless (repos == repos') $ liftIO $ do
error "Repo dir check failed!" putStrLn "Repo tree based on filesystem:"
liftIO $ printRepos repos
for_ repos $ \ (shr, rps) -> putStrLn "Repo tree based on database:"
for_ rps $ \ (rp, vcs) -> printRepos repos'
putStrLn $ throwIO $ userError "Repo dir check failed!"
"Found repo " ++ liftIO $ printRepos repos
shr ++ " / " ++ rp ++ " [" ++ show vcs ++ "]" where
printRepos = traverse_ $ \ (shr, rps) ->
for_ rps $ \ (rp, vcs) ->
putStrLn $
"Found repo " ++
shr ++ " / " ++ rp ++ " [" ++ show vcs ++ "]"
repoTreeFromDir = do repoTreeFromDir = do
dir <- askRepoRootDir dir <- askRepoRootDir
outers <- liftIO $ listDirectory dir outers <- liftIO $ listDirectory dir