diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index 904b22f..a67dfa2 100644 --- a/src/Vervis/Application.hs +++ b/src/Vervis/Application.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018, 2019 by fr33domlover . + - Written in 2016, 2018, 2019, 2020 by fr33domlover . - - ♡ 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.