gathering output fully working

Handler/Shared.hs

@@ -122,20 +122,11 @@ getViewProgressR jobId = do
 
 runProgram :: FilePath -> [String] -> Channel -> Handler ()
 runProgram programPath args chan = do
-  (exitCode, out, err) <- liftIO $ readProcessWithExitCode programPath args ""
+  (_, Just hout, Just herr, pid) <-
-  raw chan $ T.pack err
+       liftIO $ createProcess (proc programPath args){ std_out = CreatePipe, std_err = CreatePipe }
-  raw chan $ T.pack out
+  (code, out) <- gatherOutput pid hout herr chan
-
+  _ <- liftIO $ waitForProcess pid
---  (_, Just hout, Just herr, pid) <-
+  return ()
---       liftIO $ createProcess (proc programPath args){ std_out = CreatePipe, std_err = CreatePipe }
-
---  outErr <- liftIO $ hGetContents herr
---  let outErrLines = lines outErr
---  mapM_ (raw chan) outErrLines
---  (code, out) <- liftIO $ gatherOutput pid herr
---  raw chan $ decodeUtf8 out
---  _ <- liftIO $ waitForProcess pid
---  return ()
 
 
 processOutput :: Text -> ([Text], Text)
@@ -149,20 +140,33 @@ processOutput = processOutput' . lines
                       last (_:xs) = last xs
 
 
-gatherOutput :: ProcessHandle -> Handle -> IO (ExitCode, ByteString)
+gatherOutput :: ProcessHandle -> Handle -> Handle -> Channel -> Handler (ExitCode, Text)
-gatherOutput ph h = work mempty
+gatherOutput ph hout herr chan = work mempty mempty
   where
-    work acc = do
+    work accout accerr = do
         -- Read any outstanding input.
-        bs <- BS.hGetNonBlocking h (64 * 1024)
+        resterr <- takeABit herr accerr
-        let acc' = acc <> bs
+        restout <- takeABit hout accout
+        threadDelay 1000000
         -- Check on the process.
-        s <- getProcessExitCode ph
+        s <- liftIO $ getProcessExitCode ph
         -- Exit or loop.
         case s of
-            Nothing -> work acc'
+            Nothing -> work restout resterr
             Just ec -> do
                 -- Get any last bit written between the read and the status
                 -- check.
-                last <- BS.hGetContents h
+                _ <- takeFinalBit herr resterr
-                return (ec, acc' <> last)
+                all <- takeFinalBit hout restout
+                return (ec, all)
+    takeABit h acc = do
+      bs <- liftIO $ BS.hGetNonBlocking hout (64 * 1024)
+      let acc' = acc <> (decodeUtf8 bs)
+      let (fullLines, rest) = processOutput acc'
+      mapM_ (msg chan) fullLines
+      return rest
+    takeFinalBit h rest = do
+      last <- liftIO $ BS.hGetContents h
+      let all = rest <> (decodeUtf8 last)
+      mapM_ (msg chan) $ lines all
+      return all