court (empty) → 0.1.0.0
raw patch · 17 files changed
+728/−0 lines, 17 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, directory, filepath, old-locale, optparse-applicative, process, stm, text, time, unix
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- court.cabal +63/−0
- plugins/Darcs.hs +38/−0
- share/court/build +3/−0
- share/index.html +63/−0
- share/main.js +74/−0
- share/plugin-map +13/−0
- src/Court/Builder.hs +107/−0
- src/Court/Job.hs +8/−0
- src/Court/Options.hs +43/−0
- src/Court/Plugin.hs +28/−0
- src/Court/PluginManager.hs +92/−0
- src/Court/Queue.hs +42/−0
- src/Court/Result.hs +72/−0
- src/Court/Utils.hs +13/−0
- src/Main.hs +37/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ court.cabal view
@@ -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
+ plugins/Darcs.hs view
@@ -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
@@ -0,0 +1,3 @@+#!/bin/sh++echo Build successful in `pwd`
@@ -0,0 +1,63 @@+<!DOCTYPE html>+<html lang="en">+ <head>+ <title>Court</title>++ <meta charset="utf-8">+ <meta name="description" content="Simple and flexible CI tool">++ <link rel="stylesheet" href="http://netdna.bootstrapcdn.com/bootstrap/3.1.1/css/bootstrap.min.css" media="screen">++ <script src="http://ajax.googleapis.com/ajax/libs/angularjs/1.2.15/angular.min.js"></script>+ <script src="http://cdnjs.cloudflare.com/ajax/libs/angular.js/1.2.16/angular-route.min.js"></script>+ </head>++ <body>+ <div class="navbar navbar-static-top navbar-inverse">+ <div class="container">+ <div class="navbar-header">+ <a href="/" class="navbar-brand">Court</a>+ </div>+ </div>+ </div>++ <div class="container" ng-view>+ <p class="lead">Court is loading...</p>+ </div>++ <div style="display:none">+ <div id="listOfBuildsTemplate">+ <h1>+ Builds+ <a ng-click="reloadBuilds()" style="cursor: pointer;">+ <small>Refresh</small>+ </a>+ </h1>++ <show-build ng-repeat="result in results" build="result"></show-build>+ </div>++ <div id="buildTemplate">+ <ul class="list-group">+ <li class="list-group-item" ng-class="{'list-group-item-success': build.succeed, 'list-group-item-danger': !build.succeed}">+ <a ng-href="#/{{build.project_path}}">{{build.project_path}}</a>+ (<a ng-href="{{build.project_path}}">see folder</a>)+ </li>++ <li class="list-group-item" ng-class="{'list-group-item-success': build.succeed, 'list-group-item-danger': !build.succeed}">+ <span ng-show="showShortOutput">+ <pre>{{shortOutput}}</pre>+ <a style="cursor: pointer;" ng-click="toggleView()">Show more</a>+ </span>+ <span ng-hide="showShortOutput">+ <pre>{{build.output}}</pre>+ <a style="cursor: pointer;" ng-click="toggleView()">Show less</a>+ </span>+ </li>+ </ul>+ </div>+ </div>++ <script src="main.js"></script>+ </body>+</html>
@@ -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"]);+};
@@ -0,0 +1,13 @@+PluginMap+ [+ ( "court"+ , [ Plugin+ { pluginExecutable = "sh"+ , pluginArguments =+ [ "-c"+ , "while true; do echo \"passed\\tto\\tbuilder\"; sleep 10; done"+ ]+ }+ ]+ )+ ]
+ src/Court/Builder.hs view
@@ -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
+ src/Court/Job.hs view
@@ -0,0 +1,8 @@+module Court.Job+ ( Job(..)+ ) where++data Job = Job+ { jobProjectPath :: FilePath+ , jobArguments :: [String]+ } deriving (Show, Eq)
+ src/Court/Options.hs view
@@ -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)
+ src/Court/Plugin.hs view
@@ -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
+ src/Court/PluginManager.hs view
@@ -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)
+ src/Court/Queue.hs view
@@ -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
+ src/Court/Result.hs view
@@ -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
+ src/Court/Utils.hs view
@@ -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')
+ src/Main.hs view
@@ -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