sprinkle some NFData everywhere

(also some evaluateNF, leading to slightly less memory usage)

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