diff options
| -rw-r--r-- | minici.cabal | 8 | ||||
| -rw-r--r-- | src/Config.hs | 94 | ||||
| -rw-r--r-- | src/Job.hs | 79 | ||||
| -rw-r--r-- | src/Main.hs | 115 |
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 "" |