From dbf2253dc4256809b255767cbf4ae9c236f18542 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Sat, 19 Mar 2022 19:12:04 +0100
Subject: remove leftover rc3 things & some new stuff

this removes:
 - the bbb properties
 - all explicit mentions of rc3
 - the weird script domain hacks (done via a substitution now)
 - some (few) of the weirder code choices

it also adds some more type level witchery to deal with configs, which
for some reason seems to be the hardest problem of this entire program …

also the server now does inter-assembly dependency checking!
---
 server/Server.hs | 22 ++++++++++++++--------
 server/Worker.hs | 22 +++++++++++-----------
 2 files changed, 25 insertions(+), 19 deletions(-)

(limited to 'server')

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)
-- 
cgit v1.2.3