diff options
Diffstat (limited to 'server')
| -rw-r--r-- | server/Server.hs | 22 | ||||
| -rw-r--r-- | server/Worker.hs | 22 |
2 files changed, 25 insertions, 19 deletions
diff --git a/server/Server.hs b/server/Server.hs index 779509d..da2e73d 100644 --- a/server/Server.hs +++ b/server/Server.hs @@ -47,7 +47,8 @@ import Data.Either.Extra (mapLeft) import Data.Functor.Contravariant (contramap) import qualified Data.Map.Strict as M import Lens.Micro.Platform (at, ix, makeLenses, traverseOf) -import LintConfig (LintConfig') +import LintConfig (ConfigKind (..), LintConfig, + feedConfig) import Servant (FromHttpApiData) import Servant.Client (BaseUrl, parseBaseUrl) import qualified Text.Show as TS @@ -89,7 +90,7 @@ toSha ref = Sha1 data Org (loaded :: Bool) = Org { orgSlug :: Text - , orgLintconfig :: ConfigRes loaded LintConfig' + , orgLintconfig :: ConfigRes loaded (LintConfig Skeleton) , orgEntrypoint :: FilePath , orgGeneration :: Int , orgRepos :: [RemoteRef] @@ -97,7 +98,8 @@ data Org (loaded :: Bool) = Org , orgWebdir :: Text } deriving (Generic) -instance NFData LintConfig' => NFData (Org True) +instance NFData (LintConfig Skeleton) => NFData (Org True) +deriving instance Show (LintConfig Skeleton) => Show (Org True) -- | Orgs are compared via their slugs only -- TODO: the server should probably refuse to start if two orgs have the @@ -176,11 +178,15 @@ loadConfig path = do Left err -> error $ prettyTomlDecodeErrors err where loadOrg :: Org False -> IO (Org True) - loadOrg org = do - lintconfig <- eitherDecodeFileStrict' (orgLintconfig org) >>= \case - Right c -> pure c - Left err -> error $ show err - pure $ org { orgLintconfig = lintconfig } + loadOrg org@Org{..} = do + lintconfig <- + eitherDecodeFileStrict' orgLintconfig >>= \case + Right (c :: LintConfig Basic) -> pure c + Left err -> error $ show err + let config = org { orgLintconfig = + feedConfig lintconfig (map reponame orgRepos) orgSlug } + print config + pure config data RealtimeMsg = RelintPending | Reload deriving (Generic, ToJSON) diff --git a/server/Worker.hs b/server/Worker.hs index 8b3903c..a5fab58 100644 --- a/server/Worker.hs +++ b/server/Worker.hs @@ -22,12 +22,12 @@ import qualified Data.Text as T import qualified Data.UUID as UUID import qualified Data.UUID.V4 as UUID import Fmt ((+|), (|+)) +import LintConfig (stuffConfig) import Server (Config, JobStatus (..), Org (..), RealtimeMsg (RelintPending, Reload), - RemoteRef (reporef, repourl), - ServerState, adjustedPath, - getJobStatus, + RemoteRef (..), ServerState, + adjustedPath, getJobStatus, newRealtimeChannel, setJobStatus, tmpdir, toSha) import System.Directory (doesDirectoryExist) @@ -63,6 +63,7 @@ runJob config Job {..} done = do handle whoops $ finally (lint workdir) (cleanup workdir) where + lintConfig = stuffConfig (orgLintconfig jobOrg) (reponame jobRef) lint workdir = do maybeRealtime <- getJobStatus done (orgSlug jobOrg) (toSha jobRef) >>= \case Nothing -> pure Nothing @@ -80,9 +81,9 @@ runJob config Job {..} done = do -- TODO: these calls fail for dumb http, add some fallback! (callgit gitdir [ "fetch", "origin", toString ref, "--depth", "1" ]) - (callgit gitdir - [ "clone", toString ref, "--bare" - , "--depth", "1", "-b", toString ref]) + (callProcess "git" + [ "clone", toString url, "--bare" + , "--depth", "1", "-b", toString ref, gitdir]) rev <- map T.strip -- git returns a newline here $ readgit' gitdir ["rev-parse", toString ref] @@ -90,10 +91,10 @@ runJob config Job {..} done = do callgit gitdir [ "worktree", "add", "--force", workdir, toString ref ] - res <- recursiveCheckDir (orgLintconfig jobOrg) workdir (orgEntrypoint jobOrg) + res <- recursiveCheckDir lintConfig workdir (orgEntrypoint jobOrg) >>= evaluateNF - writeAdjustedRepository (orgLintconfig jobOrg) workdir (toString outPath) res + writeAdjustedRepository lintConfig workdir (toString outPath) res >>= runStdoutLoggingT . \case ExitSuccess -> logInfoN $ "linted map "+| (show jobRef :: Text) |+"." @@ -126,7 +127,6 @@ runJob config Job {..} done = do url = repourl jobRef ref = reporef jobRef - callgit = callgit' gitdir = view tmpdir config </> toString hashedname hashedname = T.map escapeSlash url where escapeSlash = \case { '/' -> '-'; a -> a } @@ -137,8 +137,8 @@ readgit' dir args = map toText $ print args readProcess "git" ([ "-C", toString dir ] <> args) "" -callgit' :: MonadIO m => FilePath -> [String] -> m () -callgit' dir args = +callgit :: MonadIO m => FilePath -> [String] -> m () +callgit dir args = liftIO $ do print args callProcess "git" ([ "-C", toString dir ] <> args) |