Compare repos dir and repos in DB when launching Vervis

src/Vervis/Application.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -36,6 +36,10 @@ import Control.Monad
 import Control.Monad.Logger                 (liftLoc, runLoggingT, logInfo, logError)
 import Control.Monad.Trans.Reader
 import Data.Default.Class
+import Data.Foldable
+import Data.List.NonEmpty (nonEmpty)
+import Data.Maybe
+import Data.Traversable
 import Database.Persist.Postgresql
 import Graphics.SVGFonts.Fonts (lin2)
 import Graphics.SVGFonts.ReadFont (loadFont)
@@ -51,6 +55,8 @@ import Network.Wai.Middleware.RequestLogger (Destination (Logger),
                                              IPAddrSource (..),
                                              OutputFormat (..), destination,
                                              mkRequestLogger, outputFormat)
+import System.Directory
+import System.FilePath
 import System.Log.FastLogger
 import Yesod.Auth
 import Yesod.Core
@@ -60,7 +66,9 @@ import Yesod.Default.Config2
 import Yesod.Persist.Core
 import Yesod.Static
 
+import qualified Data.CaseInsensitive as CI
 import qualified Data.Text as T (unpack)
+import qualified Database.Esqueleto as E
 
 import Database.Persist.Schema.PostgreSQL (schemaBackend)
 import Yesod.Mail.Send (runMailer)
@@ -71,6 +79,7 @@ import Network.FedURI
 import Yesod.MonadSite
 
 import Control.Concurrent.Local
+import Data.List.NonEmpty.Local
 import Web.Hashids.Local
 
 import Vervis.ActorKey (generateActorKey, actorKeyRotator)
@@ -101,6 +110,9 @@ import Vervis.Handler.Wiki
 import Vervis.Handler.Workflow
 
 import Vervis.Migration (migrateDB)
+import Vervis.Model
+import Vervis.Model.Ident
+import Vervis.Path
 import Vervis.Settings
 import Vervis.Ssh (runSsh)
 
@@ -197,6 +209,7 @@ makeFoundation appSettings = do
                 error $ T.unpack msg
             Right (_from, _to) -> do
                 $logInfo "DB migration success"
+                verifyRepoDir
                 fixRunningDeliveries
                 deleteUnusedURAs
                 writePostReceiveHooks
@@ -211,6 +224,44 @@ makeFoundation appSettings = do
 
     -- Return the foundation
     return app
+    where
+    verifyRepoDir = do
+        repos <- lift repoTreeFromDir
+        repos' <- repoTreeFromDB
+        unless (repos == repos') $
+            error "Repo dir check failed!"
+        liftIO $
+            for_ repos $ \ (shr, rps) ->
+                for_ rps $ \ rp ->
+                    putStrLn $ "Found repo " ++ shr ++ " / " ++ rp
+    repoTreeFromDir = do
+        dir <- askRepoRootDir
+        outers <- liftIO $ listDirectory dir
+        repos <- for outers $ \ outer -> do
+            let path = dir </> outer
+            checkDir path
+            inners <- liftIO $ listDirectory path
+            traverse_ (checkDir . (path </>)) inners
+            return $ (outer,) <$> nonEmpty inners
+        return $ catMaybes repos
+        where
+        checkDir path = liftIO $ do
+            isdir <- doesDirectoryExist path
+            islink <- pathIsSymbolicLink path
+            unless (isdir && not islink) $
+                error $ "Non-dir file: " ++ path
+    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)
+        where
+        adapt =
+            groupWithExtract
+                (lower . unShrIdent . E.unValue . fst)
+                (lower . unRpIdent . E.unValue . snd)
+            where
+            lower = T.unpack . CI.foldedCase
 
 -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
 -- applying some additional middlewares.