summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Config.hs94
-rw-r--r--src/Job.hs79
-rw-r--r--src/Main.hs115
3 files changed, 203 insertions, 85 deletions
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 ""
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-17 04:13:58 +0000