diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Thomas Feron + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Thomas Feron nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/court.cabal b/court.cabal new file mode 100644 --- /dev/null +++ b/court.cabal @@ -0,0 +1,63 @@ +-- Initial court.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ + +name: court +version: 0.1.0.0 +synopsis: Simple and flexible CI system +description: Simple and flexible CI system. +license: BSD3 +license-file: LICENSE +author: Thomas Feron +maintainer: tho.feron@gmail.com +copyright: Copyright (c) 2014, Thomas Feron +category: Development +build-type: Simple +cabal-version: >=1.10 +bug-reports: http://hub.darcs.net/thoferon/court/issues +homepage: http://hub.darcs.net/thoferon/court + +data-files: share/index.html + , share/main.js + , share/plugin-map + , share/court/build + +executable court + main-is: Main.hs + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -threaded -Wall + other-modules: Court.Builder + , Court.Job + , Court.Options + , Court.Plugin + , Court.PluginManager + , Court.Queue + , Court.Result + , Court.Utils + build-depends: base >=4.6 && <4.7 + , optparse-applicative ==0.9.* + , stm ==2.4.* + , process ==1.2.* + , filepath ==1.3.* + , directory ==1.2.* + , time ==1.4.* + , old-locale ==1.* + , bytestring ==0.10.* + , text ==1.1.* + , aeson ==0.7.* + , unix ==2.7.* + +executable court-darcs-plugin + main-is: Darcs.hs + hs-source-dirs: plugins + default-language: Haskell2010 + ghc-options: -Wall + build-depends: base >=4.6 && <4.7 + , filepath ==1.3.* + , directory ==1.2.* + , process ==1.2.* + +source-repository head + type: darcs + location: http://hub.darcs.net/thoferon/court + tag: 0.1.0.0 diff --git a/plugins/Darcs.hs b/plugins/Darcs.hs new file mode 100644 --- /dev/null +++ b/plugins/Darcs.hs @@ -0,0 +1,38 @@ +import Control.Applicative +import Control.Concurrent +import Control.Monad + +import Data.List + +import System.Directory +import System.Environment +import System.Exit +import System.FilePath +import System.IO +import System.Process + +main :: IO () +main = do + hSetBuffering stdout LineBuffering + hSetBuffering stderr LineBuffering + + args <- getArgs + repo <- case args of + [] -> hPutStrLn stderr "Please pass the repository as argument" >> exitFailure + r : _ -> return r + + testRepoPath <- ( "test-repo") <$> getCurrentDirectory + checkExistence <- doesDirectoryExist testRepoPath + + unless checkExistence $ do + hPutStrLn stderr $ "Getting " ++ repo ++ " ..." + exitCode <- rawSystem "darcs" ["get", repo, testRepoPath, "--lazy"] + unless (exitCode == ExitSuccess) $ exitWith exitCode + + setCurrentDirectory testRepoPath + + forever $ do + hPutStrLn stderr "Checking ..." + output <- readProcess "darcs" ["pull", "--all"] "" + unless ("No remote changes to pull in" `isInfixOf` output) $ putStrLn testRepoPath + threadDelay $ 30 * 1000 * 1000 diff --git a/share/court/build b/share/court/build new file mode 100644 --- /dev/null +++ b/share/court/build @@ -0,0 +1,3 @@ +#!/bin/sh + +echo Build successful in `pwd` diff --git a/share/index.html b/share/index.html new file mode 100644 --- /dev/null +++ b/share/index.html @@ -0,0 +1,63 @@ + + + + Court + + + + + + + + + + + +
+
+
+ Court +
+
+
+ +
+

Court is loading...

+
+ +
+
+

+ Builds + + Refresh + +

+ + +
+ +
+ +
+
+ + + + diff --git a/share/main.js b/share/main.js new file mode 100644 --- /dev/null +++ b/share/main.js @@ -0,0 +1,74 @@ +window.onload = function() { + var listOfBuildsTemplate = document.getElementById("listOfBuildsTemplate").innerHTML; + var buildTemplate = document.getElementById("buildTemplate").innerHTML; + + var app = angular.module("app", ["ngRoute"]); + + app.config(function($routeProvider) { + $routeProvider.when("/", { + controller: "IndexCtrl", + template: listOfBuildsTemplate + }); + + $routeProvider.when("/:projectName", { + controller: "IndexCtrl", + template: listOfBuildsTemplate + }); + + $routeProvider.otherwise({ + redirectTo: "/" + }); + }); + + app.controller("IndexCtrl", function($scope, $interval, $routeParams, ResultService) { + var projectName = $routeParams.projectName; + $scope.results = []; + + $scope.reloadBuilds = function() { + ResultService.getResults(projectName) + .then(function(data) { + $scope.results = data.results; + }); + }; + + $scope.reloadBuilds(); + }); + + app.service("ResultService", function($http, $q) { + this.getResults = function(projectName) { + var deferred = $q.defer(); + var url = document.location.href.split("#")[0] + + (projectName ? projectName + "/" : "") + + "results.json"; + + $http({method: "GET", url: url}) + .success(function(data) { + deferred.resolve(data); + }).error(function(data) { + console.log(data); + deferred.reject(); + }); + + return deferred.promise; + }; + }); + + app.directive("showBuild", function() { + return { + restrict: "E", + template: buildTemplate, + scope: { build: "=" }, + replace: true, + link: function(scope, element, attrs) { + scope.showShortOutput = true; + scope.shortOutput = scope.build.output.substr(0, 200) + " ..." + + scope.toggleView = function () { + scope.showShortOutput = !scope.showShortOutput; + }; + } + }; + }); + + angular.bootstrap(document, ["app"]); +}; diff --git a/share/plugin-map b/share/plugin-map new file mode 100644 --- /dev/null +++ b/share/plugin-map @@ -0,0 +1,13 @@ +PluginMap + [ + ( "court" + , [ Plugin + { pluginExecutable = "sh" + , pluginArguments = + [ "-c" + , "while true; do echo \"passed\\tto\\tbuilder\"; sleep 10; done" + ] + } + ] + ) + ] diff --git a/src/Court/Builder.hs b/src/Court/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Court/Builder.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Court.Builder + ( builder + , buildNext + ) where + +import Control.Concurrent +import Control.Exception +import Control.Monad + +import Data.List +import Data.Maybe +import Data.Time + +import System.Directory +import System.FilePath +import System.IO +import System.Locale +import System.Process + +import Court.Job +import Court.Options +import Court.Queue +import Court.Result +import Court.Utils + +builder :: Options -> TVar Queue -> IO () +builder opts queueTVar = builder' [] + where + builder' :: [MVar ()] -> IO () + builder' mvars = do + mJob <- takeNextJob queueTVar + mvars' <- case mJob of + Nothing -> do + threadDelay $ 1000 * 1000 + return mvars + Just job -> builder'' job mvars + builder' mvars' + + builder'' :: Job -> [MVar ()] -> IO [MVar ()] + builder'' job mvars = do + mvars' <- cleanMVars mvars + if length mvars' >= optThreads opts + then do + threadDelay $ 5 * 1000 * 1000 + builder'' job mvars' + else do + mvar' <- newEmptyMVar + _ <- forkIO $ buildNext opts job mvar' + return $ mvar' : mvars' + + cleanMVars :: [MVar ()] -> IO [MVar ()] + cleanMVars mvars = do + mMVars <- forM mvars $ \mvar -> do + mres <- tryTakeMVar mvar + return $ maybe (Just mvar) (const Nothing) mres + return $ catMaybes mMVars + +buildNext :: Options -> Job -> MVar () -> IO () +buildNext opts job mvar = handle errorHandler $ do + hPutStrLn stderr $ "Building " ++ show job ++ " ..." + (buildPath, outputPath, processHandle) <- spawnBuild job + exitCode <- waitForProcess processHandle + output <- readFile outputPath + let result = Result + { resultExitCode = exitCode + , resultOutput = output + , resultPath = buildPath + } + modifyGlobalResults opts $ changeResults result + modifyLocalResults job $ changeResults result + cleanBuilds 20 $ jobProjectPath job + putMVar mvar () + where + changeResults :: Result -> Results -> Results + changeResults result (Results results) = Results $ take 20 $ result : results + + errorHandler :: SomeException -> IO () + errorHandler e = do + hPutStrLn stderr $ "ERROR: " ++ show e + putMVar mvar () + +spawnBuild :: Job -> IO (FilePath, FilePath, ProcessHandle) +spawnBuild job = do + now <- getCurrentTime + let buildDir = "build." ++ formatTime defaultTimeLocale "%Y%m%d%H%M%S" now + executablePath = jobProjectPath job "build" + buildPath = jobProjectPath job buildDir + outputPath = buildPath "build.out" + createDirectory buildPath + (inR, inW) <- createPipeHandles + hClose inW + stdout' <- openFile outputPath ReadWriteMode + processHandle <- runProcess + executablePath (jobArguments job) (Just buildPath) Nothing + (Just inR) (Just stdout') Nothing + return (buildPath, outputPath, processHandle) + +cleanBuilds :: Int -> FilePath -> IO () +cleanBuilds n path = do + items <- getDirectoryContents path + mapM_ (removeDirectoryRecursive . (path )) + . drop n + . sortBy (\a b -> b `compare` a) + . filter ("build." `isPrefixOf`) + $ items diff --git a/src/Court/Job.hs b/src/Court/Job.hs new file mode 100644 --- /dev/null +++ b/src/Court/Job.hs @@ -0,0 +1,8 @@ +module Court.Job + ( Job(..) + ) where + +data Job = Job + { jobProjectPath :: FilePath + , jobArguments :: [String] + } deriving (Show, Eq) diff --git a/src/Court/Options.hs b/src/Court/Options.hs new file mode 100644 --- /dev/null +++ b/src/Court/Options.hs @@ -0,0 +1,43 @@ +module Court.Options + ( Options(..) + , getOptions + ) where + +import Options.Applicative + +data Options = Options + { optDirectory :: FilePath + , optThreads :: Int + , optPluginMapPath :: FilePath + , optUser :: Maybe String + , optGroup :: Maybe String + , optDaemonize :: Bool + } deriving (Show, Eq) + +parseOptions :: Parser Options +parseOptions = Options + <$> strOption (short 'd' <> long "directory" + <> help "Directory in which the projects are" + <> value ".") + <*> option (short 't' <> long "num-threads" + <> help "Number of threads spawned, therefore, the number of concurrent builds" + <> value 2) + <*> strOption (short 'p' <> long "plugin-map" + <> help "Path to the plugin map file" + <> value "plugin-map") + <*> maybeOption (short 'u' <> long "user" + <> help "User to run the program with") + <*> maybeOption (short 'g' <> long "group" + <> help "Group to run the program with") + <*> flag True False (short 'f' <> long "dont-daemonize" + <> help "Do not fork and detach the process from the process group") + where + maybeOption :: Mod OptionFields String -> Parser (Maybe String) + maybeOption mods = + (\s -> if null s then Nothing else Just s) <$> strOption (mods <> value "") + +getOptions :: IO Options +getOptions = do + execParser $ info parseOptions + (header "court - Simple and flexible CI tool" + <> fullDesc) diff --git a/src/Court/Plugin.hs b/src/Court/Plugin.hs new file mode 100644 --- /dev/null +++ b/src/Court/Plugin.hs @@ -0,0 +1,28 @@ +module Court.Plugin + ( Plugin(..) + , RunningPlugin(..) + , PluginMap(..) + , pluginMapToPairs + ) where + +import System.FilePath +import System.IO +import System.Process + +data Plugin = Plugin + { pluginExecutable :: FilePath + , pluginArguments :: [String] + } deriving (Show, Read, Eq) + +data RunningPlugin = RunningPlugin + { runningPluginStdout :: Handle + , runningPluginProcess :: ProcessHandle + , runningPluginOrigin :: (FilePath, Plugin) + } + +newtype PluginMap = PluginMap [(FilePath, [Plugin])] deriving (Show, Read, Eq) + +pluginMapToPairs :: FilePath -> PluginMap -> [(FilePath, Plugin)] +pluginMapToPairs basePath (PluginMap pairs) = + let mkPair path plugin = (if isRelative path then basePath path else path, plugin) + in concat $ map (\(path, plugins) -> map (\plugin -> mkPair path plugin) plugins) pairs diff --git a/src/Court/PluginManager.hs b/src/Court/PluginManager.hs new file mode 100644 --- /dev/null +++ b/src/Court/PluginManager.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Court.PluginManager + ( pluginManager + ) where + +import Control.Concurrent +import Control.Exception +import Control.Monad + +import Data.List + +import System.Directory +import System.Exit +import System.FilePath +import System.IO +import System.Process + +import Court.Job +import Court.Options +import Court.Plugin +import Court.Queue +import Court.Utils + +pluginManager :: Options -> TVar Queue -> IO () +pluginManager opts queueTVar = do + pluginMap <- loadPluginMapOrDie $ optPluginMapPath opts + basePath <- if isAbsolute (optDirectory opts) + then return $ optDirectory opts + else do + current <- getCurrentDirectory + return $ normalise $ current optDirectory opts + let pairs = pluginMapToPairs basePath pluginMap + runningPlugins <- mapM (uncurry spawnPlugin) pairs + consumePlugins queueTVar runningPlugins + +loadPluginMapOrDie :: FilePath -> IO PluginMap +loadPluginMapOrDie path = do + contents <- readFile path + case reads contents of + (pluginMap,_):_ -> return pluginMap + _ -> hPutStrLn stderr ("Can't read plugin map at " ++ path) >> exitFailure + +spawnPlugin :: FilePath -> Plugin -> IO RunningPlugin +spawnPlugin path plugin = do + hPutStrLn stderr $ "Spawning " ++ show plugin ++ " in " ++ path ++ " ..." + let args = pluginArguments plugin + (inR, inW) <- createPipeHandles + (outR, outW) <- createPipeHandles + processHandle <- runProcess + (pluginExecutable plugin) args (Just path) Nothing + (Just inR) (Just outW) Nothing + hClose inW + return RunningPlugin + { runningPluginStdout = outR + , runningPluginProcess = processHandle + , runningPluginOrigin = (path, plugin) + } + +consumePlugins :: TVar Queue -> [RunningPlugin] -> IO () +consumePlugins queueTVar runningPlugins = do + runningPlugins' <- forM runningPlugins $ \runningPlugin -> do + let kill = terminateProcess $ runningPluginProcess runningPlugin + respawn = uncurry spawnPlugin $ runningPluginOrigin runningPlugin + + handle (\(_ :: SomeException) -> kill >> respawn) $ do + let out = runningPluginStdout runningPlugin + checkReady <- hReady out + when checkReady $ do + line <- hGetLine out + let job = Job + { jobProjectPath = fst $ runningPluginOrigin runningPlugin + , jobArguments = readTabSeparatedList line + } + hPutStrLn stderr $ "Job added in the queue: " ++ show job + addToQueue queueTVar job + return runningPlugin + + threadDelay $ 1000 * 1000 + consumePlugins queueTVar runningPlugins' + + where + readTabSeparatedList :: String -> [String] + readTabSeparatedList = unfoldr $ \str -> + let (part, tabbedRest) = break (== '\t') str + arg = case reads part of + (arg',""):_ -> arg' + _ -> part + in case (str, tabbedRest) of + ("",_) -> Nothing + (_,"") -> Just (arg, "") + (_,_:rest) -> Just (arg, rest) diff --git a/src/Court/Queue.hs b/src/Court/Queue.hs new file mode 100644 --- /dev/null +++ b/src/Court/Queue.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE BangPatterns #-} + +module Court.Queue + ( module Control.Concurrent.STM + , module Data.Monoid + , Queue(..) + , takeNextJobSTM + , takeNextJob + , addToQueueSTM + , addToQueue + ) where + +import Control.Concurrent.STM + +import Data.List +import Data.Monoid + +import Court.Job + +data Queue = Queue ![Job] deriving (Show, Eq) + +instance Monoid Queue where + mempty = Queue [] + mappend (Queue xs) (Queue ys) = Queue . nub $ xs ++ ys + +takeNextJobSTM :: TVar Queue -> STM (Maybe Job) +takeNextJobSTM queueTVar = do + Queue jobs <- readTVar queueTVar + case jobs of + job : rest -> do + writeTVar queueTVar $ Queue rest + return $ Just job + _ -> return Nothing + +takeNextJob :: TVar Queue -> IO (Maybe Job) +takeNextJob = atomically . takeNextJobSTM + +addToQueueSTM :: TVar Queue -> Job -> STM () +addToQueueSTM queueTVar job = modifyTVar queueTVar (<> Queue [job]) + +addToQueue :: TVar Queue -> Job -> IO () +addToQueue queueTVar job = atomically $ addToQueueSTM queueTVar job diff --git a/src/Court/Result.hs b/src/Court/Result.hs new file mode 100644 --- /dev/null +++ b/src/Court/Result.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Court.Result + ( Results(..) + , Result(..) + , modifyGlobalResults + , modifyLocalResults + ) where + +import Control.Applicative + +import Data.Aeson hiding (Result) +import qualified Data.ByteString.Lazy.Char8 as BSL + +import System.Directory +import System.Exit +import System.FilePath + +import Court.Job +import Court.Options + +newtype Results = Results [Result] deriving (Show, Eq) + +instance FromJSON Results where + parseJSON (Object v) = Results <$> v .: "results" + parseJSON _ = fail "object expected" + +instance ToJSON Results where + toJSON (Results results) = object [ "results" .= results ] + +data Result = Result + { resultExitCode :: ExitCode + , resultOutput :: String + , resultPath :: FilePath + } deriving (Show, Eq) + +instance FromJSON Result where + parseJSON (Object v) = Result + <$> (fmap read $ v .: "exit_code") + <*> v .: "output" + <*> v .: "path" + parseJSON _ = fail "object expected" + +instance ToJSON Result where + toJSON result = object + [ "exit_code" .= show (resultExitCode result) + , "output" .= resultOutput result + , "path" .= resultPath result + , "project_path" .= (snd . splitFileName .takeDirectory . resultPath $ result) + , "succeed" .= (resultExitCode result == ExitSuccess) + ] + +modifyGlobalResults :: Options -> (Results -> Results) -> IO () +modifyGlobalResults opts f = do + let path = optDirectory opts "results.json" + modifyResults' path f + +modifyLocalResults :: Job -> (Results -> Results) -> IO () +modifyLocalResults job f = do + let path = jobProjectPath job "results.json" + modifyResults' path f + +modifyResults' :: FilePath -> (Results -> Results) -> IO () +modifyResults' path f = do + check <- doesFileExist path + results <- if check + then do + contents <- BSL.readFile path + return $ either (const (Results [])) id $ eitherDecode contents + else + return $ Results [] + BSL.writeFile path $! encode $ f results diff --git a/src/Court/Utils.hs b/src/Court/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Court/Utils.hs @@ -0,0 +1,13 @@ +module Court.Utils + ( createPipeHandles + ) where + +import System.IO +import System.Posix.IO + +createPipeHandles :: IO (Handle, Handle) +createPipeHandles = do + (r, w) <- createPipe + r' <- fdToHandle r + w' <- fdToHandle w + return (r', w') diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,37 @@ +import Control.Concurrent + +import System.IO +import System.Posix.Process +import System.Posix.User + +import Court.Builder +import Court.Options +import Court.PluginManager +import Court.Queue + +main :: IO () +main = do + hSetBuffering stderr LineBuffering + opts <- getOptions + + case optGroup opts of + Nothing -> return () + Just name -> do + groupEntry <- getGroupEntryForName name + setGroupID $ groupID groupEntry + + case optUser opts of + Nothing -> return () + Just name -> do + userEntry <- getUserEntryForName name + setUserID $ userID userEntry + + if optDaemonize opts + then forkProcess (createSession >> main' opts) >> return () + else main' opts + +main' :: Options -> IO () +main' opts = do + queueTVar <- newTVarIO mempty + _ <- forkIO $ builder opts queueTVar + pluginManager opts queueTVar