summaryrefslogtreecommitdiff
path: root/server
diff options
context:
space:
mode:
authorstuebinm2022-02-17 00:41:36 +0100
committerstuebinm2022-02-17 00:41:36 +0100
commitfaa244e1a7e760be88054a5f15b3e115ad8e32e5 (patch)
tree34cec7b74b49284f446aaf3073a551306d8ca5be /server
parent487e06bf875ba8a835399b26095c756899b1209f (diff)
sprinkle some NFData everywhere
(also some evaluateNF, leading to slightly less memory usage)
Diffstat (limited to '')
-rw-r--r--server/HtmlOrphans.hs3
-rw-r--r--server/Server.hs17
-rw-r--r--server/Worker.hs1
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