naskya/vervis
1
0
Fork 0
mirror of https://code.naskya.net/repos/ndqEd synced 2025-01-10 21:16:46 +09:00
Code 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
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
import Data.Bifunctor
import Data.Default.Class import Data.Default.Class
import Data.Foldable import Data.Foldable
import Data.Git.Repository (isRepo)
import Data.List.NonEmpty (nonEmpty) import Data.List.NonEmpty (nonEmpty)
import Data.Maybe import Data.Maybe
import Data.String
import Data.Traversable import Data.Traversable
import Database.Persist.Postgresql import Database.Persist.Postgresql
import Graphics.SVGFonts.Fonts (lin2) import Graphics.SVGFonts.Fonts (lin2)
@ -112,6 +115,7 @@ import Vervis.Handler.Workflow
import Vervis.Migration (migrateDB) import Vervis.Migration (migrateDB)
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident import Vervis.Model.Ident
import Vervis.Model.Repo
import Vervis.Path import Vervis.Path
import Vervis.Settings import Vervis.Settings
import Vervis.Ssh (runSsh) import Vervis.Ssh (runSsh)
@ -232,8 +236,10 @@ makeFoundation appSettings = do
error "Repo dir check failed!" error "Repo dir check failed!"
liftIO $ liftIO $
for_ repos $ \ (shr, rps) -> for_ repos $ \ (shr, rps) ->
for_ rps $ \ rp -> for_ rps $ \ (rp, vcs) ->
putStrLn $ "Found repo " ++ shr ++ " / " ++ rp putStrLn $
"Found repo " ++
shr ++ " / " ++ rp ++ " [" ++ show vcs ++ "]"
repoTreeFromDir = do repoTreeFromDir = do
dir <- askRepoRootDir dir <- askRepoRootDir
outers <- liftIO $ listDirectory dir outers <- liftIO $ listDirectory dir
@ -241,8 +247,17 @@ makeFoundation appSettings = do
let path = dir </> outer let path = dir </> outer
checkDir path checkDir path
inners <- liftIO $ listDirectory path inners <- liftIO $ listDirectory path
traverse_ (checkDir . (path </>)) inners inners' <- for inners $ \ inner -> do
return $ (outer,) <$> nonEmpty inners 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 return $ catMaybes repos
where where
checkDir path = liftIO $ do checkDir path = liftIO $ do
@ -250,16 +265,25 @@ makeFoundation appSettings = do
islink <- pathIsSymbolicLink path islink <- pathIsSymbolicLink path
unless (isdir && not islink) $ unless (isdir && not islink) $
error $ "Non-dir file: " ++ path 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 = repoTreeFromDB =
fmap adapt $ E.select $ E.from $ \ (s `E.InnerJoin` r) -> do fmap adapt $ E.select $ E.from $ \ (s `E.InnerJoin` r) -> do
E.on $ s E.^. SharerId E.==. r E.^. RepoSharer E.on $ s E.^. SharerId E.==. r E.^. RepoSharer
E.orderBy [E.asc $ s E.^. SharerIdent, E.asc $ r E.^. RepoIdent] 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 where
adapt = adapt =
groupWithExtract groupWithExtract
(lower . unShrIdent . E.unValue . fst) (lower . unShrIdent . E.unValue . fst)
(lower . unRpIdent . E.unValue . snd) (first (lower . unRpIdent) . bimap E.unValue E.unValue . snd)
where where
lower = T.unpack . CI.foldedCase lower = T.unpack . CI.foldedCase