forge/Vervis
1
0
Fork 0
Code Pull requests Activity

When comparing repo dir to DB, compare the VCS type of each repo as well

Browse source
This commit is contained in:
fr33domlover 2020-01-18 11:49:07 +00:00
parent 54ea66878f
commit fc0f694289
1 changed files with 30 additions and 6 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

36
src/Vervis/Application.hs
View file

@ -35,10 +35,13 @@ import Control.Concurrent.STM.TVar
import Control.Monad
import Control.Monad.Logger (liftLoc, runLoggingT, logInfo, logError)
import Control.Monad.Trans.Reader
import Data.Bifunctor
import Data.Default.Class
import Data.Foldable
import Data.Git.Repository (isRepo)
import Data.List.NonEmpty (nonEmpty)
import Data.Maybe
import Data.String
import Data.Traversable
import Database.Persist.Postgresql
import Graphics.SVGFonts.Fonts (lin2)
@ -112,6 +115,7 @@ import Vervis.Handler.Workflow
import Vervis.Migration (migrateDB)
import Vervis.Model
import Vervis.Model.Ident
import Vervis.Model.Repo
import Vervis.Path
import Vervis.Settings
import Vervis.Ssh (runSsh)
@ -232,8 +236,10 @@ makeFoundation appSettings = do
error "Repo dir check failed!"
liftIO $
for_ repos $ \ (shr, rps) ->
for_ rps $ \ rp ->
putStrLn $ "Found repo " ++ shr ++ " / " ++ rp
for_ rps $ \ (rp, vcs) ->
putStrLn $
"Found repo " ++
shr ++ " / " ++ rp ++ " [" ++ show vcs ++ "]"
repoTreeFromDir = do
dir <- askRepoRootDir
outers <- liftIO $ listDirectory dir
@ -241,8 +247,17 @@ makeFoundation appSettings = do
let path = dir </> outer
checkDir path
inners <- liftIO $ listDirectory path
traverse_ (checkDir . (path </>)) inners
return $ (outer,) <$> nonEmpty inners
inners' <- for inners $ \ inner -> do
checkDir $ path </> inner
vcs <- do
mvcs <- detectVcs $ path </> inner
let ref = outer ++ "/" ++ inner
case mvcs of
Left False -> error $ "Failed to detect VCS: " ++ ref
Left True -> error $ "Detected both VCSs: " ++ ref
Right v -> return v
return (inner, vcs)
return $ (outer,) <$> nonEmpty inners'
return $ catMaybes repos
where
checkDir path = liftIO $ do
@ -250,16 +265,25 @@ makeFoundation appSettings = do
islink <- pathIsSymbolicLink path
unless (isdir && not islink) $
error $ "Non-dir file: " ++ path
detectVcs path = liftIO $ do
darcs <- doesDirectoryExist $ path </> "_darcs"
git <- isRepo $ fromString path
return $
case (darcs, git) of
(True, False) -> Right VCSDarcs
(False, True) -> Right VCSGit
(False, False) -> Left False
(True, True) -> Left True
repoTreeFromDB =
fmap adapt $ E.select $ E.from $ \ (s `E.InnerJoin` r) -> do
E.on $ s E.^. SharerId E.==. r E.^. RepoSharer
E.orderBy [E.asc $ s E.^. SharerIdent, E.asc $ r E.^. RepoIdent]
return (s E.^. SharerIdent, r E.^. RepoIdent)
return (s E.^. SharerIdent, (r E.^. RepoIdent, r E.^. RepoVcs))
where
adapt =
groupWithExtract
(lower . unShrIdent . E.unValue . fst)
(lower . unRpIdent . E.unValue . snd)
(first (lower . unRpIdent) . bimap E.unValue E.unValue . snd)
where
lower = T.unpack . CI.foldedCase