Improved how Wasp prints output of underlying processes. (#794)

waspc/cli/src/Wasp/Cli/Command.hs

@@ -17,8 +17,7 @@ newtype Command a = Command {_runCommand :: ExceptT CommandError IO a}
 
 runCommand :: Command a -> IO ()
 runCommand cmd = do
-  errorOrResult <- runExceptT $ _runCommand cmd
-  case errorOrResult of
+  runExceptT (_runCommand cmd) >>= \case
     Left cmdError -> cliSendMessage $ Msg.Failure (_errorTitle cmdError) (_errorMsg cmdError)
     Right _ -> return ()
 

waspc/src/Wasp/Generator/Job.hs

@@ -28,4 +28,4 @@ data JobMessageData
 
 data JobOutputType = Stdout | Stderr deriving (Show, Eq)
 
-data JobType = WebApp | Server | Db deriving (Show, Eq)
+data JobType = WebApp | Server | Db deriving (Show, Eq, Ord, Bounded, Enum)

waspc/src/Wasp/Generator/Job/Common.hs

@@ -0,0 +1,24 @@
+module Wasp.Generator.Job.Common
+  ( getJobMessageOutHandle,
+    getJobMessageContent,
+  )
+where
+
+import qualified Data.Text as T
+import System.Exit (ExitCode (..))
+import System.IO (Handle, stderr, stdout)
+import qualified Wasp.Generator.Job as J
+
+getJobMessageOutHandle :: J.JobMessage -> Handle
+getJobMessageOutHandle jobMsg = case J._data jobMsg of
+  J.JobOutput _ outputType ->
+    case outputType of
+      J.Stdout -> stdout
+      J.Stderr -> stderr
+  J.JobExit _ -> stdout
+
+getJobMessageContent :: J.JobMessage -> T.Text
+getJobMessageContent jobMsg = case J._data jobMsg of
+  J.JobOutput output _ -> output
+  J.JobExit ExitSuccess -> "Job exited successfully."
+  J.JobExit (ExitFailure exitCode) -> T.pack $ "Job failed with exit code " <> show exitCode

waspc/src/Wasp/Generator/Job/IO.hs

@@ -1,40 +1,25 @@
 module Wasp.Generator.Job.IO
   ( readJobMessagesAndPrintThemPrefixed,
-    printPrefixedJobMessage,
     printJobMessage,
   )
 where
 
 import Control.Concurrent (Chan, readChan)
-import qualified Data.Text as T
+import Control.Monad.IO.Class (liftIO)
 import qualified Data.Text.IO as T.IO
-import System.Exit (ExitCode (..))
-import System.IO (Handle, hFlush, stderr, stdout)
+import System.IO (hFlush)
 import qualified Wasp.Generator.Job as J
-import qualified Wasp.Util.Terminal as Term
+import Wasp.Generator.Job.Common (getJobMessageContent, getJobMessageOutHandle)
+import Wasp.Generator.Job.IO.PrefixedWriter (printJobMessagePrefixed, runPrefixedWriter)
 
 readJobMessagesAndPrintThemPrefixed :: Chan J.JobMessage -> IO ()
-readJobMessagesAndPrintThemPrefixed =
-  let go prevJobMsg chan = do
-        jobMsg <- readChan chan
-        case J._data jobMsg of
-          J.JobOutput {} -> printPrefixedJobMessage prevJobMsg jobMsg >> go (Just jobMsg) chan
-          J.JobExit {} -> return ()
-   in go Nothing
-
-printPrefixedJobMessage :: Maybe J.JobMessage -> J.JobMessage -> IO ()
-printPrefixedJobMessage maybePrevJobMessage jobMessage = do
-  let outHandle = getJobMessageOutHandle jobMessage
-      prefix = makeJobMessagePrefix jobMessage
-      content = getJobMessageContent jobMessage
-
-  let maybeAddPrefixAtStart =
-        ((if (J._jobType <$> maybePrevJobMessage) /= Just (J._jobType jobMessage) then "\n" <> prefix else "") <>)
-      addPrefixAfterSubstr substr = T.intercalate (substr <> prefix) . T.splitOn substr
-      addPrefix = maybeAddPrefixAtStart . addPrefixAfterSubstr "\n" . addPrefixAfterSubstr "\r"
-
-  T.IO.hPutStr outHandle $ addPrefix content
-  hFlush outHandle
+readJobMessagesAndPrintThemPrefixed chan = runPrefixedWriter go
+  where
+    go = do
+      jobMsg <- liftIO $ readChan chan
+      case J._data jobMsg of
+        J.JobOutput {} -> printJobMessagePrefixed jobMsg >> go
+        J.JobExit {} -> return ()
 
 printJobMessage :: J.JobMessage -> IO ()
 printJobMessage jobMsg = do
@@ -42,26 +27,3 @@ printJobMessage jobMsg = do
   let message = getJobMessageContent jobMsg
   T.IO.hPutStr outHandle message
   hFlush outHandle
-
-makeJobMessagePrefix :: J.JobMessage -> T.Text
-makeJobMessagePrefix jobMsg =
-  case J._jobType jobMsg of
-    J.Server -> T.pack $ Term.applyStyles [Term.Magenta] "Server"
-    J.WebApp -> T.pack $ Term.applyStyles [Term.Cyan] "Web app"
-    J.Db -> T.pack $ Term.applyStyles [Term.White] "Db"
-    <> (if getJobMessageOutHandle jobMsg == stderr then " (stderr)" else "")
-    <> ": "
-
-getJobMessageOutHandle :: J.JobMessage -> Handle
-getJobMessageOutHandle jobMsg = case J._data jobMsg of
-  J.JobOutput _ outputType ->
-    case outputType of
-      J.Stdout -> stdout
-      J.Stderr -> stderr
-  J.JobExit _ -> stdout
-
-getJobMessageContent :: J.JobMessage -> T.Text
-getJobMessageContent jobMsg = case J._data jobMsg of
-  J.JobOutput output _ -> output
-  J.JobExit ExitSuccess -> "Job exited successfully."
-  J.JobExit (ExitFailure exitCode) -> T.pack $ "Job failed with exit code " <> show exitCode

waspc/src/Wasp/Generator/Job/IO/PrefixedWriter.hs

@@ -0,0 +1,180 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Wasp.Generator.Job.IO.PrefixedWriter
+  ( printJobMessagePrefixed,
+    runPrefixedWriter,
+    PrefixedWriter,
+  )
+where
+
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.State (get, put)
+import Control.Monad.State.Strict (MonadState, StateT, runStateT)
+import qualified Data.Set as S
+import qualified Data.Text as T
+import qualified Data.Text.IO as T.IO
+import System.IO (hFlush, stderr)
+import qualified Wasp.Generator.Job as J
+import Wasp.Generator.Job.Common (getJobMessageContent, getJobMessageOutHandle)
+import qualified Wasp.Util.Terminal as Term
+
+-- |
+-- Imagine you have a job sending following two messages:
+--  1. "First"
+--  2. " line\n"
+--  3. "Second line"
+--
+-- What we want is to prefix new lines with a corresponding job prefix before we print them,
+-- e.g. "Server: ". So we want to output this as:
+--   Server: First line
+--   Server: Second line
+--
+-- This is what this function does, it properly prefixes the given message and then prints it.
+-- Prefixes include job type name, and optional indication that output is stderr, e.g.:
+-- "Server:", "Web app:", "Db(stderr):"
+--
+-- * Implementation details:
+--
+-- Simplest (and naive) way to go about this is to add prefix after any newline.
+-- However, what can happen is that third message from above comes quite later than the second
+-- message, and in the meantime some other output (e.g. from another job) is printed.
+-- In such case, we get following:
+--   Server: First line
+--   Server:
+--   Some other output!
+--   Second line
+--
+-- This is not an easy problem to solve, as we can't know what kind of message is coming next,
+-- and there are always situations where some other output might interrupt us.
+-- But, what we can at least do is avoid having this situation described above, where newline is
+-- "kidnapped", and we do that by postponing the newline (make it pending) for later,
+-- until the next message from the same output (job + output stream) arrives.
+--
+-- Specifically, what we do is postpone printing of a newline if it is the last character in a message.
+-- We make it pending instead, and once the new message comes from the same output, we apply it at the
+-- start of that message.
+--
+-- This way we get proper output in the situation as described above:
+--   Server: First line
+--   Some other output!
+--   Server: Second line
+--
+-- We additionaly check if the last message (before the current message) was from the same output.
+-- If not, or there was no previous message, then we ensure there is prefix at the start of
+-- the message. This helps with situations where output from one job was interrupted by the
+-- output from another job, or when message is the very first message.
+printJobMessagePrefixed :: J.JobMessage -> PrefixedWriter ()
+printJobMessagePrefixed jobMessage = do
+  (PrefixedWriterState outputsWithPendingNewline lastJobMessage) <- get
+
+  let (outputsWithPendingNewline', messageContent) =
+        applyPendingNewline outputsWithPendingNewline jobMessage
+  let prefixedMessageContent = addPrefixWhereNeeded lastJobMessage messageContent
+
+  put $ PrefixedWriterState outputsWithPendingNewline' (Just jobMessage)
+
+  liftIO $ printPrefixedMessageContent prefixedMessageContent
+  where
+    printPrefixedMessageContent :: T.Text -> IO ()
+    printPrefixedMessageContent content = T.IO.hPutStr outHandle content >> hFlush outHandle
+      where
+        outHandle = getJobMessageOutHandle jobMessage
+
+    -- TODO: We haven't considered Windows much here, so in the future we might
+    --   want to check that this works ok on Windows and tweak it a bit if not.
+    addPrefixWhereNeeded :: Maybe J.JobMessage -> T.Text -> T.Text
+    addPrefixWhereNeeded lastJobMessage =
+      ensureNewlineAtStartIfInterruptingAnotherOutput
+        . ensurePrefixAtStartIfNotContinuingOnSameOutput
+        . addPrefixAfterSubstr "\r"
+        . addPrefixAfterSubstr "\n"
+      where
+        addPrefixAfterSubstr :: T.Text -> T.Text -> T.Text
+        addPrefixAfterSubstr substr = T.intercalate (substr <> prefix) . T.splitOn substr
+
+        ensurePrefixAtStartIfNotContinuingOnSameOutput :: T.Text -> T.Text
+        ensurePrefixAtStartIfNotContinuingOnSameOutput text =
+          let continuingOnSameOutput =
+                (getJobMessageOutput <$> lastJobMessage) == Just (getJobMessageOutput jobMessage)
+              prefixAtStart =
+                or [(delimiter <> prefix) `T.isPrefixOf` text | delimiter <- ["\r", "\n", ""]]
+           in if not continuingOnSameOutput && not prefixAtStart then prefix <> text else text
+
+        ensureNewlineAtStartIfInterruptingAnotherOutput :: T.Text -> T.Text
+        ensureNewlineAtStartIfInterruptingAnotherOutput text =
+          let interruptingAnotherOutput =
+                (getJobMessageOutput <$> lastJobMessage) /= Just (getJobMessageOutput jobMessage)
+              newlineAtStart = "\n" `T.isPrefixOf` text
+           in if interruptingAnotherOutput && not newlineAtStart then "\n" <> text else text
+
+        prefix :: T.Text
+        prefix = makeJobMessagePrefix jobMessage
+
+newtype PrefixedWriter a = PrefixedWriter {_runPrefixedWriter :: StateT PrefixedWriterState IO a}
+  deriving (Functor, Applicative, Monad, MonadIO, MonadState PrefixedWriterState)
+
+data PrefixedWriterState = PrefixedWriterState
+  { _outputsWithPendingNewline :: !OutputsWithPendingNewline,
+    _lastJobMessage :: !(Maybe J.JobMessage)
+  }
+
+runPrefixedWriter :: PrefixedWriter a -> IO a
+runPrefixedWriter pw = fst <$> runStateT (_runPrefixedWriter pw) initState
+  where
+    initState =
+      PrefixedWriterState
+        { _outputsWithPendingNewline = S.empty,
+          _lastJobMessage = Nothing
+        }
+
+-- Job message output type.
+data Output = Output
+  { _outputJobType :: !J.JobType,
+    _outputIsStderr :: !Bool
+  }
+  deriving (Eq, Ord)
+
+type OutputsWithPendingNewline = S.Set Output
+
+-- | Given a set of job message outputs with pending newline and a job message,
+-- it applies any pending newline (newline from the previous messages from the same output)
+-- to the job message content while also detecting if content ends with a newline
+-- and in that case adds it to the set of pending newlines (while removing used pending newline).
+-- It returns this updated content and updated set of pending newlines.
+applyPendingNewline ::
+  OutputsWithPendingNewline -> J.JobMessage -> (OutputsWithPendingNewline, T.Text)
+applyPendingNewline outputsWithPendingNewline jobMessage = (outputsWithPendingNewline', content')
+  where
+    content' = addPendingNewlineToStartIfAny $ removeTrailingNewlineIfAny content
+      where
+        removeTrailingNewlineIfAny = if contentEndsWithNewline then T.init else id
+        addPendingNewlineToStartIfAny =
+          if getJobMessageOutput jobMessage `S.member` outputsWithPendingNewline then ("\n" <>) else id
+
+    outputsWithPendingNewline' = updateOp output outputsWithPendingNewline
+      where
+        updateOp = if contentEndsWithNewline then S.insert else S.delete
+
+    contentEndsWithNewline = "\n" `T.isSuffixOf` content
+
+    output = getJobMessageOutput jobMessage
+    content = getJobMessageContent jobMessage
+
+getJobMessageOutput :: J.JobMessage -> Output
+getJobMessageOutput jm =
+  Output
+    { _outputJobType = J._jobType jm,
+      _outputIsStderr = getJobMessageOutHandle jm == stderr
+    }
+
+makeJobMessagePrefix :: J.JobMessage -> T.Text
+makeJobMessagePrefix jobMsg =
+  case J._jobType jobMsg of
+    J.Server -> T.pack $ Term.applyStyles [Term.Magenta] "Server"
+    J.WebApp -> T.pack $ Term.applyStyles [Term.Cyan] "Web app"
+    J.Db -> T.pack $ Term.applyStyles [Term.Blue] "Db"
+    <> ( if getJobMessageOutHandle jobMsg == stderr
+           then T.pack $ Term.applyStyles [Term.Yellow] "(stderr)"
+           else ""
+       )
+    <> ": "

waspc/src/Wasp/Generator/NpmInstall.hs

@@ -6,6 +6,7 @@ where
 import Control.Concurrent (Chan, newChan, readChan)
 import Control.Concurrent.Async (concurrently)
 import Control.Monad (when)
+import Control.Monad.IO.Class (liftIO)
 import qualified Data.Aeson as Aeson
 import qualified Data.ByteString.Lazy as B
 import StrongPath (Abs, Dir, File', Path', Rel, relfile, (</>))
@@ -15,7 +16,7 @@ import System.Exit (ExitCode (..))
 import Wasp.AppSpec (AppSpec)
 import Wasp.Generator.Common (ProjectRootDir)
 import qualified Wasp.Generator.Job as J
-import Wasp.Generator.Job.IO (printPrefixedJobMessage)
+import Wasp.Generator.Job.IO.PrefixedWriter (PrefixedWriter, printJobMessagePrefixed, runPrefixedWriter)
 import Wasp.Generator.Monad (GeneratorError (..), GeneratorWarning (..))
 import qualified Wasp.Generator.NpmDependencies as N
 import Wasp.Generator.ServerGenerator as SG
@@ -101,25 +102,27 @@ loadInstalledFullStackNpmDependencies dstDir = do
 installNpmDependencies :: Path' Abs (Dir ProjectRootDir) -> IO (Either String ())
 installNpmDependencies projectDir = do
   chan <- newChan
-  let runSetupJobs = concurrently (ServerSetup.installNpmDependencies projectDir chan) (WebAppSetup.installNpmDependencies projectDir chan)
+  let runSetupJobs =
+        ServerSetup.installNpmDependencies projectDir chan
+          `concurrently` WebAppSetup.installNpmDependencies projectDir chan
   (_, result) <- concurrently (handleJobMessages chan) runSetupJobs
   case result of
     (ExitSuccess, ExitSuccess) -> return $ Right ()
     exitCodes -> return $ Left $ setupFailedMessage exitCodes
   where
-    handleJobMessages = go Nothing (False, False)
+    handleJobMessages = runPrefixedWriter . go (False, False)
       where
-        go :: Maybe J.JobMessage -> (Bool, Bool) -> Chan J.JobMessage -> IO ()
-        go _ (True, True) _ = return ()
-        go prevJobMsg (isWebAppDone, isServerDone) chan = do
-          jobMsg <- readChan chan
+        go :: (Bool, Bool) -> Chan J.JobMessage -> PrefixedWriter ()
+        go (True, True) _ = return ()
+        go (isWebAppDone, isServerDone) chan = do
+          jobMsg <- liftIO $ readChan chan
           case J._data jobMsg of
             J.JobOutput {} ->
-              printPrefixedJobMessage prevJobMsg jobMsg
-                >> go (Just jobMsg) (isWebAppDone, isServerDone) chan
+              printJobMessagePrefixed jobMsg
+                >> go (isWebAppDone, isServerDone) chan
             J.JobExit {} -> case J._jobType jobMsg of
-              J.WebApp -> go (Just jobMsg) (True, isServerDone) chan
-              J.Server -> go (Just jobMsg) (isWebAppDone, True) chan
+              J.WebApp -> go (True, isServerDone) chan
+              J.Server -> go (isWebAppDone, True) chan
               J.Db -> error "This should never happen. No db job should be active."
 
     setupFailedMessage (serverExitCode, webAppExitCode) =

waspc/waspc.cabal

@@ -221,7 +221,9 @@ library
     Wasp.Generator.FileDraft.Writeable
     Wasp.Generator.FileDraft.WriteableMonad
     Wasp.Generator.Job
+    Wasp.Generator.Job.Common
     Wasp.Generator.Job.IO
+    Wasp.Generator.Job.IO.PrefixedWriter
     Wasp.Generator.Job.Process
     Wasp.Generator.JsImport
     Wasp.Generator.Monad