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)

3 files changed, 33 insertions, 21 deletions

diff --git a/server/Main.hs b/server/Main.hs
index 1a18c6a..d9c548b 100644
--- a/server/Main.hs
+++ b/server/Main.hs
@@ -31,9 +31,9 @@ import           Network.Wai.Middleware.RequestLogger (OutputFormat (..),
                                                        RequestLoggerSettings (..),
                                                        mkRequestLogger)
 import           Servant                              (Application, Capture,
-                                                       EmptyAPI, Get, JSON,
-                                                       PlainText, Post, Raw,
-                                                       ReqBody, Server, serve,
+                                                       Get, JSON, PlainText,
+                                                       Post, Raw, ReqBody,
+                                                       Server, serve,
                                                        type (:<|>) (..),
                                                        type (:>))
 import           Servant.HTML.Lucid                   (HTML)
@@ -47,10 +47,8 @@ import           Server                               (JobStatus, Org (..),
 import           Worker                               (Job (Job), linterThread)
 
 import           Servant.API                          (Header)
-import           Servant.Client                       (BaseUrl (BaseUrl),
-                                                       ClientM, Scheme (Http),
-                                                       client, mkClientEnv,
-                                                       runClientM)
+import           Servant.Client                       (ClientM, client,
+                                                       mkClientEnv, runClientM)
 
 type family PolyEndpoint method format payload where
   PolyEndpoint Get format payload = Get format payload
@@ -114,19 +112,19 @@ main = do
 
   -- TODO: what about tls / https?
   manager' <- newManager defaultManagerSettings
-  updater <- async $ forever $ do
-    done <- readMVar state
-    res <- runClientM
-           (postNewMaps (view token config) (MapService done))
-           (mkClientEnv manager' (view exneuland config))
-    print res
-    threadDelay (view interval config * 1000000)
+  -- updater <- async $ forever $ do
+  --   done <- readMVar state
+  --   res <- runClientM
+  --          (postNewMaps (view token config) (MapService done))
+  --          (mkClientEnv manager' (view exneuland config))
+  --   print res
+  --   threadDelay (view interval config * 1000000)
 
   -- spawns threads for each job in the queue
   linter <- async $ void $ linterThread config queue state
   link linter
   link poker
-  link updater
+  -- link updater
 
   let warpsettings =
        setPort (view port config)
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 ->
diff --git a/server/Worker.hs b/server/Worker.hs
index 24a774b..b5d71fc 100644
--- a/server/Worker.hs
+++ b/server/Worker.hs
@@ -47,7 +47,7 @@ linterThread config queue done = forever $ do
 -- TODO: re-add proper fancy (colourful?) logging
 runJob :: Config True -> Job -> MVar ServerState -> IO ()
 runJob config Job {..} done = do
-  rand <- liftIO UUID.nextRandom
+  rand <- UUID.nextRandom
   let workdir = "/tmp" </> ("worktree-" <> UUID.toString rand)
 
   handle whoops
@@ -64,7 +64,8 @@ runJob config Job {..} done = do
       rev <- map T.strip -- git returns a newline here
         $ readgit' gitdir ["rev-parse", toString ref]
       callgit gitdir [ "worktree", "add", "--force", workdir, toString ref ]
-      res <- liftIO $ recursiveCheckDir (orgLintconfig jobOrg) workdir (orgEntrypoint jobOrg)
+
+      res <- recursiveCheckDir (orgLintconfig jobOrg) workdir (orgEntrypoint jobOrg)
       setJobStatus done jobOrg jobRef $
         Linted res rev