From 487e06bf875ba8a835399b26095c756899b1209f Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Thu, 17 Feb 2022 00:06:22 +0100
Subject: server: remove a thunk leak

(really a lot of these data structures should be eagerly evaluated into
normal form, i suspect there's still a lot to be gained)
---
 server/Server.hs | 21 +++++++++++++++++----
 1 file changed, 17 insertions(+), 4 deletions(-)

(limited to 'server/Server.hs')

diff --git a/server/Server.hs b/server/Server.hs
index 8f09ac7..f89dc7b 100644
--- a/server/Server.hs
+++ b/server/Server.hs
@@ -39,11 +39,12 @@ import qualified Data.ByteString.Base64.URL as Base64
 import           Data.Coerce                (coerce)
 import           Data.Either.Extra          (mapLeft)
 import           Data.Functor.Contravariant (contramap)
-import qualified Data.Map                   as M
+import qualified Data.Map.Strict            as M
 import           Lens.Micro.Platform        (at, ix, makeLenses, traverseOf)
 import           LintConfig                 (LintConfig')
 import           Servant                    (FromHttpApiData)
 import           Servant.Client             (BaseUrl, parseBaseUrl)
+import qualified Text.Show                  as TS
 import           Toml                       (BiMap (BiMap), TomlBiMap,
                                              TomlBiMapError (ArbitraryError),
                                              TomlCodec, prettyTomlDecodeErrors,
@@ -157,9 +158,15 @@ configCodec = Config
 
 -- | a job status (of a specific uuid)
 data JobStatus =
-  Pending | Linted DirResult Text | Failed Text
+  Pending | Linted !DirResult Text | Failed Text
   deriving (Generic, ToJSON)
 
+instance TS.Show JobStatus where
+  show = \case
+    Pending        -> "Pending"
+    Linted res rev -> "Linted result"
+    Failed err     -> "Failed with: " <> show err
+
 -- | the server's global state; might eventually end up with more
 -- stuff in here, hence the newtype
 newtype ServerState = ServerState
@@ -192,8 +199,14 @@ loadConfig path = do
 
 -- | NOTE: this does not create the org if it does not yet exist!
 setJobStatus :: MVar ServerState -> Org True -> RemoteRef -> JobStatus -> IO ()
-setJobStatus mvar !org !ref !status = modifyMVar_ mvar
-  $ pure . over (unState . ix org . at (toSha ref)) (const $ Just (ref, status))
+setJobStatus mvar !org !ref !status = do
+  modifyMVar_ mvar $ \state -> 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)
+    pure $ over (unState . ix org . at (toSha ref))
+                (const $ Just (ref, status)) state
 
 getJobStatus :: MVar ServerState -> Text -> Sha1 -> IO (Maybe (RemoteRef, JobStatus))
 getJobStatus mvar orgslug sha = withMVar mvar $ \state ->
-- 
cgit v1.2.3