From 25d384c07bfd47e661d21883cfb3a6fe21cfef37 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sat, 1 Jun 2024 15:25:41 +0200
Subject: Explicit run command in separate module

Changelog: Explicit run command
---
 src/Command/Run.hs | 86 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 86 insertions(+)
 create mode 100644 src/Command/Run.hs

(limited to 'src/Command/Run.hs')

diff --git a/src/Command/Run.hs b/src/Command/Run.hs
new file mode 100644
index 0000000..3b997b5
--- /dev/null
+++ b/src/Command/Run.hs
@@ -0,0 +1,86 @@
+module Command.Run (
+    RunCommand,
+) where
+
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Monad
+import Control.Monad.Reader
+
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Text.IO qualified as T
+
+import System.IO
+import System.Process
+
+import Command
+import Config
+import Job
+
+data RunCommand = RunCommand
+
+instance Command RunCommand where
+    commandName _ = "run"
+
+    commandInit _ = RunCommand
+    commandExec _ = cmdRun
+
+cmdRun :: CommandExec ()
+cmdRun = do
+    config <- getConfig
+    liftIO $ do
+        commits <- map (fmap (drop 1) . (span (/=' '))) . lines <$>
+            readProcess "git" ["log", "--pretty=oneline", "--first-parent", "--reverse", "origin/master..HEAD"] ""
+
+        putStr $ replicate (8 + 50) ' '
+        forM_ (configJobs config) $ \job -> do
+            T.putStr $ (" "<>) $ fitToLength 7 $ textJobName $ jobName job
+        putStrLn ""
+
+        forM_ commits $ \(cid, desc) -> do
+            let shortCid = T.pack $ take 7 cid
+            outs <- runJobs "./.minici" cid $ configJobs config
+            displayStatusLine shortCid (" " <> fitToLength 50 (T.pack desc)) outs
+
+
+fitToLength :: Int -> Text -> Text
+fitToLength maxlen str | len <= maxlen = str <> T.replicate (maxlen - len) " "
+                       | otherwise     = T.take (maxlen - 1) str <> "…"
+    where len = T.length str
+
+showStatus :: Bool -> JobStatus a -> Text
+showStatus blink = \case
+    JobQueued       -> "\ESC[94m…\ESC[0m      "
+    JobWaiting uses -> "\ESC[94m~" <> fitToLength 6 (T.intercalate "," (map textJobName uses)) <> "\ESC[0m"
+    JobSkipped      ->  "\ESC[0m-\ESC[0m      "
+    JobRunning      -> "\ESC[96m" <> (if blink then "*" else "•") <> "\ESC[0m      "
+    JobError _      -> "\ESC[91m!!\ESC[0m     "
+    JobFailed       -> "\ESC[91m✗\ESC[0m      "
+    JobDone _       -> "\ESC[92m✓\ESC[0m      "
+
+displayStatusLine :: Text -> Text -> [TVar (JobStatus JobOutput)] -> IO ()
+displayStatusLine prefix1 prefix2 statuses = do
+    blinkVar <- newTVarIO False
+    t <- forkIO $ forever $ do
+        threadDelay 500000
+        atomically $ writeTVar blinkVar . not =<< readTVar blinkVar
+    go blinkVar ""
+    killThread t
+  where
+    go blinkVar prev = do
+        (ss, cur) <- atomically $ do
+            ss <- mapM readTVar statuses
+            blink <- readTVar blinkVar
+            let cur = T.concat $ map ((" " <>) . showStatus blink) ss
+            when (cur == prev) retry
+            return (ss, cur)
+        when (not $ T.null prev) $ putStr "\r"
+        let prefix1' = if any jobStatusFailed ss then "\ESC[91m" <> prefix1 <> "\ESC[0m"
+                                                 else prefix1
+        T.putStr $ prefix1' <> prefix2 <> cur
+        hFlush stdout
+
+        if all jobStatusFinished ss
+           then T.putStrLn ""
+           else go blinkVar cur
-- 
cgit v1.2.3