Read job recipes from config file

4 files changed, 210 insertions, 86 deletions

diff --git a/minici.cabal b/minici.cabal
index 8858889..692dafe 100644
--- a/minici.cabal
+++ b/minici.cabal
@@ -24,7 +24,8 @@ executable minici
     ghc-options:      -Wall
 
     -- Modules included in this executable, other than Main.
-    -- other-modules:
+    other-modules:      Config
+                        Job
 
     -- LANGUAGE extensions used by modules in this package.
     default-extensions:  ExistentialQuantification
@@ -35,15 +36,20 @@ executable minici
                          ImportQualifiedPost
                          LambdaCase
                          MultiParamTypeClasses
+                         MultiWayIf
                          OverloadedStrings
                          ScopedTypeVariables
                          TupleSections
                          TypeApplications
     -- other-extensions:
     build-depends:    base ^>=4.15.1.0
+                    , bytestring        >=0.10 && <0.11
+                    , containers        >=0.6 && <0.7
                     , directory >=1.3 && <1.4
                     , filepath >=1.4 && <1.5
+                    , HsYAML    >=0.2 && <0.3
                     , mtl >=2.2 && <2.3
+                    , parser-combinators >=1.3 && <1.4
                     , process >=1.6 && <1.7
                     , text >=1.2 && <1.3
     hs-source-dirs:   src
diff --git a/src/Config.hs b/src/Config.hs
new file mode 100644
index 0000000..7e9ad85
--- /dev/null
+++ b/src/Config.hs
@@ -0,0 +1,94 @@
+module Config (
+    Config(..),
+    findConfig,
+    parseConfig,
+) where
+
+import Control.Monad
+import Control.Monad.Combinators
+
+import Data.ByteString.Lazy qualified as BS
+import Data.List
+import Data.Map qualified as M
+import Data.Maybe
+import Data.Ord
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.YAML
+
+import System.Directory
+import System.Exit
+import System.FilePath
+import System.Process
+
+import Job
+
+data Config = Config
+    { configJobs :: [Job]
+    }
+
+instance Semigroup Config where
+    a <> b = Config
+        { configJobs = configJobs a ++ configJobs b
+        }
+
+instance Monoid Config where
+    mempty = Config
+        { configJobs = []
+        }
+
+instance FromYAML Config where
+    parseYAML = withMap "Config" $ \m -> do
+        let getpos = \case (Scalar pos _, _) -> pos
+                           (Mapping pos _ _, _) -> pos
+                           (Sequence pos _ _, _) -> pos
+                           (Anchor pos _ _, _) -> pos
+        jobs <- fmap catMaybes $ forM (sortBy (comparing $ posLine . getpos) $ M.assocs m) $ \case
+            (Scalar _ (SStr tag), node) | ["job", name] <- T.words tag -> do
+                flip (withMap "Job") node $ \j -> Just <$> choice
+                    [ cabalJob name =<< j .: "cabal"
+                    , shellJob name =<< j .: "shell"
+                    ]
+            _ -> return Nothing
+        return $ Config jobs
+
+cabalJob :: Text -> Node Pos -> Parser Job
+cabalJob name = withMap "cabal job" $ \m -> do
+    ghcOptions <- m .:? "ghc-options" >>= \case
+        Nothing -> return []
+        Just s -> withSeq "GHC option list" (mapM (withStr "GHC option" return)) s
+
+    return Job
+        { jobName = JobName name
+        , jobRecipe = [ proc "cabal" $ concat [ ["build"], ("--ghc-option="++) . T.unpack <$> ghcOptions ] ]
+        , jobArtifacts = map (\(ArtifactName aname) -> (ArtifactName "bin", proc "cabal" ["list-bin", T.unpack aname])) []
+        }
+
+shellJob :: Text -> Node Pos -> Parser Job
+shellJob name = withSeq "shell commands" $ \xs -> do
+    recipe <- forM xs $ withStr "shell command" $ return . T.unpack
+    return Job
+        { jobName = JobName name
+        , jobRecipe = map shell recipe
+        , jobArtifacts = []
+        }
+
+findConfig :: IO (Maybe FilePath)
+findConfig = go "."
+  where
+    name = "minici.yaml"
+    go path = do
+        doesFileExist (path </> name) >>= \case
+            True -> return $ Just $ path </> name
+            False -> doesDirectoryExist (path </> "..") >>= \case
+                True -> go (path </> "..")
+                False -> return Nothing
+
+parseConfig :: FilePath -> IO Config
+parseConfig path = do
+    contents <- BS.readFile path
+    case decode1 contents of
+        Left (pos, err) -> do
+            putStr $ prettyPosWithSource pos contents err
+            exitFailure
+        Right conf -> return conf
diff --git a/src/Job.hs b/src/Job.hs
new file mode 100644
index 0000000..db3f4d0
--- /dev/null
+++ b/src/Job.hs
@@ -0,0 +1,79 @@
+module Job (
+    Job(..),
+    JobOutput(..),
+    JobName(..), stringJobName,
+    ArtifactName(..),
+    runJob,
+) where
+
+import Control.Monad
+import Control.Monad.Except
+
+import Data.Text (Text)
+import Data.Text qualified as T
+
+import System.Directory
+import System.Exit
+import System.FilePath
+import System.IO
+import System.Process
+
+data Job = Job
+    { jobName :: JobName
+    , jobRecipe :: [CreateProcess]
+    , jobArtifacts :: [(ArtifactName, CreateProcess)]
+    }
+
+data JobOutput = JobOutput
+    { outName :: JobName
+    , outStatus :: Bool
+    , outArtifacts :: [(ArtifactName, FilePath)]
+    }
+    deriving (Show)
+
+data JobName = JobName Text
+    deriving (Eq, Ord, Show)
+
+stringJobName :: JobName -> String
+stringJobName (JobName name) = T.unpack name
+
+data ArtifactName = ArtifactName Text
+    deriving (Eq, Ord, Show)
+
+
+runJob :: FilePath -> String -> Job -> IO JobOutput
+runJob dir cid job = do
+    [path] <- lines <$> readProcess "mktemp" ["-d", "-t", "minici.XXXXXXXXXX"] ""
+
+    "" <- readProcess "git" ["--work-tree=" <> path, "restore", "--source=" <> cid, "--", "."] ""
+    ["tree", tid]:_  <- map words . lines <$> readProcess "git" ["cat-file", "-p", cid] ""
+
+    let jdir = dir </> "jobs" </> tid </> stringJobName (jobName job)
+    createDirectoryIfMissing True jdir
+    logs <- openFile (jdir </> "log") WriteMode
+
+    res <- runExceptT $ do
+        forM_ (jobRecipe job) $ \p -> do
+            (Just hin, _, _, hp) <- liftIO $ createProcess_ "" p
+                { cwd = Just path
+                , std_in = CreatePipe
+                , std_out = UseHandle logs
+                , std_err = UseHandle logs
+                }
+            liftIO $ hClose hin
+            exit <- liftIO $ waitForProcess hp
+
+            when (exit /= ExitSuccess) $
+                throwError ()
+
+    hClose logs
+    removeDirectoryRecursive $ path
+
+    writeFile (jdir </> "status") $
+        if res == Right () then "success\n" else "failure\n"
+
+    return JobOutput
+        { outName = jobName job
+        , outStatus = res == Right ()
+        , outArtifacts = []
+        }
diff --git a/src/Main.hs b/src/Main.hs
index e2d458f..da3c0d8 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,101 +1,46 @@
 module Main (main) where
 
 import Control.Monad
-import Control.Monad.Except
 
-import Data.Text (Text)
-import Data.Text qualified as T
-
-import System.Directory
-import System.Exit
-import System.FilePath
 import System.IO
 import System.Process
 
-data Job = Job
-    { jobName :: JobName
-    , jobRecipe :: [CreateProcess]
-    , jobArtifacts :: [(ArtifactName, CreateProcess)]
-    }
-
-data JobOutput = JobOutput
-    { outName :: JobName
-    , outStatus :: Bool
-    , outArtifacts :: [(ArtifactName, FilePath)]
-    }
-    deriving (Show)
-
-data JobName = JobName Text
-    deriving (Eq, Ord, Show)
-
-data ArtifactName = ArtifactName Text
-    deriving (Eq, Ord, Show)
-
-stringJobName :: JobName -> String
-stringJobName (JobName name) = T.unpack name
-
-
-runJob :: FilePath -> String -> Job -> IO JobOutput
-runJob dir cid job = do
-    [path] <- lines <$> readProcess "mktemp" ["-d", "-t", "minici.XXXXXXXXXX"] ""
-
-    "" <- readProcess "git" ["--work-tree=" <> path, "restore", "--source=" <> cid, "--", "."] ""
-    ["tree", tid]:_  <- map words . lines <$> readProcess "git" ["cat-file", "-p", cid] ""
-
-    let jdir = dir </> "jobs" </> tid </> stringJobName (jobName job)
-    createDirectoryIfMissing True jdir
-    logs <- openFile (jdir </> "log") WriteMode
-
-    res <- runExceptT $ do
-        forM_ (jobRecipe job) $ \p -> do
-            (Just hin, _, _, hp) <- liftIO $ createProcess_ "" p
-                { cwd = Just path
-                , std_in = CreatePipe
-                , std_out = UseHandle logs
-                , std_err = UseHandle logs
-                }
-            liftIO $ hClose hin
-            exit <- liftIO $ waitForProcess hp
+import Config
+import Job
 
-            when (exit /= ExitSuccess) $
-                throwError ()
-
-    hClose logs
-    removeDirectoryRecursive $ path
-
-    writeFile (jdir </> "status") $
-        if res == Right () then "success\n" else "failure\n"
-
-    return JobOutput
-        { outName = jobName job
-        , outStatus = res == Right ()
-        , outArtifacts = []
-        }
-
-
-cabalJob :: JobName -> [ArtifactName] -> Job
-cabalJob name artifacts = Job
-    { jobName = name
-    , jobRecipe = [ proc "cabal" ["build", "--ghc-option=-Werror"] ]
-    , jobArtifacts = map (\(ArtifactName aname) -> (ArtifactName "bin", proc "cabal" ["list-bin", T.unpack aname])) artifacts
-    }
+fitToLength :: Int -> String -> String
+fitToLength maxlen str | len <= maxlen = str <> replicate (maxlen - len) ' '
+                       | otherwise     = take (maxlen - 1) str <> "…"
+    where len = length str
 
 main :: IO ()
 main = do
+    Just configPath <- findConfig
+    config <- parseConfig configPath
+
     commits <- map (fmap (drop 1) . (span (/=' '))) . lines <$>
         readProcess "git" ["log", "--pretty=oneline", "--first-parent", "--reverse", "origin/master..HEAD"] ""
-    forM_ commits $ \(cid, desc) -> do
-        let descLen = length desc
-            desc' = if descLen <= 50 then desc <> replicate (50 - descLen) ' '
-                                     else take 49 desc <> "…"
-            shortCid = take 7 cid
 
-        putStr $ shortCid <> " " <> desc' <> " "
+    putStr $ replicate (8 + 50) ' '
+    forM_ (configJobs config) $ \job -> do
+        putStr $ (' ':) $ fitToLength 7 $ stringJobName $ jobName job
+    putStrLn ""
+
+    forM_ commits $ \(cid, desc) -> do
+        let shortCid = take 7 cid
+        putStr $ shortCid <> " " <> fitToLength 50 desc
         hFlush stdout
-        runJob "./.minici" cid (cabalJob (JobName "build") $ map (ArtifactName . T.pack) []) >>= \case
-            out | outStatus out -> do
-                putStr "\ESC[92m✓\ESC[0m"
-            _ -> do
-                putStr "\ESC[91m✗\ESC[0m"
-                putStr $ "\r\ESC[91m" <> shortCid <> "\ESC[0m"
+        results <- forM (configJobs config) $ \job -> do
+            putStr " "
+            hFlush stdout
+            out <- runJob "./.minici" cid job
+            if | outStatus out -> do
+                    putStr "\ESC[92m✓\ESC[0m      "
+               | otherwise -> do
+                    putStr "\ESC[91m✗\ESC[0m      "
+            hFlush stdout
+            return $ outStatus out
+
+        when (not $ and results) $ do
+            putStr $ "\r\ESC[91m" <> shortCid <> "\ESC[0m"
         putStrLn ""