diff options
Diffstat (limited to 'server')
| -rw-r--r-- | server/HtmlOrphans.hs | 3 | ||||
| -rw-r--r-- | server/Server.hs | 17 | ||||
| -rw-r--r-- | server/Worker.hs | 1 |
3 files changed, 14 insertions, 7 deletions
diff --git a/server/HtmlOrphans.hs b/server/HtmlOrphans.hs index c9fa852..ebe65aa 100644 --- a/server/HtmlOrphans.hs +++ b/server/HtmlOrphans.hs @@ -29,7 +29,6 @@ import Lucid.Html5 (a_, body_, class_, code_, div_, em_, h1_, h2_, import Server (JobStatus (..), Org (orgSlug), RemoteRef (reporef, repourl), prettySha, unState) -import Text.Dot (showDot) import Types (Hint (Hint), Level (..)) @@ -139,7 +138,7 @@ instance ToHtml DirResult where "\ \d3.select(\"#exitGraph\")\n\ \ .graphviz()\n\ - \ .dot(\"" <> toText (escapeJSON $ showDot dirresultGraph) <> "\")\n\ + \ .dot(\"" <> toText (escapeJSON $ toString dirresultGraph) <> "\")\n\ \ .render()\n\ \" diff --git a/server/Server.hs b/server/Server.hs index f89dc7b..f2b286b 100644 --- a/server/Server.hs +++ b/server/Server.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} @@ -15,6 +16,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module Server ( loadConfig , Org(..) @@ -57,7 +59,7 @@ data RemoteRef = RemoteRef , reporef :: Text , reponame :: Text -- ^ the "world name" for the hub / world:// links - } deriving (Generic, FromJSON, ToJSON, Eq, Ord, Show) + } deriving (Generic, FromJSON, ToJSON, Eq, Ord, Show, NFData) type family ConfigRes (b :: Bool) a where ConfigRes True a = a @@ -65,7 +67,7 @@ type family ConfigRes (b :: Bool) a where -- | the internal text is actually already base64-encoded newtype Sha1 = Sha1 Text - deriving newtype (Eq, Show, Ord, FromHttpApiData, ToJSON) + deriving newtype (Eq, Show, Ord, FromHttpApiData, ToJSON, NFData) -- | base64-encoded sha1 prettySha :: Sha1 -> Text @@ -88,7 +90,9 @@ data Org (loaded :: Bool) = Org , orgRepos :: [RemoteRef] , orgUrl :: Text , orgWebdir :: Text - } deriving Generic + } deriving (Generic) + +instance NFData LintConfig' => NFData (Org True) -- | Orgs are compared via their slugs only -- TODO: the server should probably refuse to start if two orgs have the @@ -159,7 +163,7 @@ configCodec = Config -- | a job status (of a specific uuid) data JobStatus = Pending | Linted !DirResult Text | Failed Text - deriving (Generic, ToJSON) + deriving (Generic, ToJSON, NFData) instance TS.Show JobStatus where show = \case @@ -171,6 +175,9 @@ instance TS.Show JobStatus where -- stuff in here, hence the newtype newtype ServerState = ServerState { _unState :: Map (Org True) (Map Sha1 (RemoteRef, JobStatus)) } + deriving Generic + +instance NFData LintConfig' => NFData ServerState makeLenses ''ServerState @@ -204,7 +211,7 @@ setJobStatus mvar !org !ref !status = do -- will otherwise cause a thunk leak, since Data.Map is annoyingly un-strict -- even in its strict variety. for some reason it also doesn't work when -- moved inside the `over` though … - _ <- evaluateWHNF (view (unState . ix org) state) + _ <- evaluateNF (view (unState . ix org) state) pure $ over (unState . ix org . at (toSha ref)) (const $ Just (ref, status)) state diff --git a/server/Worker.hs b/server/Worker.hs index b5d71fc..91fa8e2 100644 --- a/server/Worker.hs +++ b/server/Worker.hs @@ -66,6 +66,7 @@ runJob config Job {..} done = do callgit gitdir [ "worktree", "add", "--force", workdir, toString ref ] res <- recursiveCheckDir (orgLintconfig jobOrg) workdir (orgEntrypoint jobOrg) + >>= evaluateNF setJobStatus done jobOrg jobRef $ Linted res rev |