Saturnin (empty) → 0.1.0
raw patch · 15 files changed
+1070/−0 lines, 15 filesdep +Saturnindep +basedep +bytestringsetup-changed
Dependencies added: Saturnin, base, bytestring, data-default, directory, either, exceptions, filepath, formatting, hlint, hspec, ini, mtl, network, old-locale, process, regex-compat, spawn, stm, temporary, text, time, unordered-containers, yaml
Files
- LICENSE +26/−0
- Saturnin.cabal +114/−0
- Setup.hs +2/−0
- executable/main.hs +5/−0
- library/Saturnin/Git.hs +102/−0
- library/Saturnin/Jobs.hs +202/−0
- library/Saturnin/Logging.hs +33/−0
- library/Saturnin/Server.hs +121/−0
- library/Saturnin/Server/Config.hs +88/−0
- library/Saturnin/Server/Connection.hs +210/−0
- library/Saturnin/Types.hs +111/−0
- tests/HLint.hs +16/−0
- tests/Haddock.hs +30/−0
- tests/unit/Saturnin/ServerSpec.hs +9/−0
- tests/unit/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2015, Jan Matejka <yac@blesmrt.net>+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the cbugzilla nor the names of its+ 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.
+ Saturnin.cabal view
@@ -0,0 +1,114 @@+author: Jan Matějka+build-type: Simple+cabal-version: >= 1.16+copyright: 2015 Jan Matějka <yac@blesmrt.net>+license: BSD3+maintainer: <yac@blesmrt.net>+name: Saturnin+synopsis: Saturnin CI / Job System+version: 0.1.0+category: Application Server+description: Saturnin CI / Job System+license-file: LICENSE+++source-repository head+ type: git+ location: https://github.com/yaccz/saturnin.git++library+ build-depends:+ base < 5+ , network+ , ini+ , data-default+ , text+ , filepath+ , process >= 1.2+ , temporary+ , directory+ , unordered-containers >= 0.2.4.0+ , spawn+ , yaml+ , time+ , old-locale+ , formatting+ , bytestring+ , stm+ , mtl+ , either+ , exceptions+ default-language: Haskell2010+ exposed-modules:+ Saturnin.Git+ , Saturnin.Jobs+ , Saturnin.Server+ , Saturnin.Server.Config+ , Saturnin.Server.Connection+ , Saturnin.Logging+ , Saturnin.Types+ ghc-options:+ -Wall+ ghc-prof-options:+ -auto-all+ -prof+ hs-source-dirs: library++executable saturnin+ main-is: main.hs+ hs-source-dirs:+ executable+ default-language: Haskell2010+ ghc-options:+ -Wall+ build-depends:+ base < 5+ , Saturnin++test-suite tests+ build-depends:+ base < 5+ , Saturnin+ , mtl+ , either+ , data-default+ , hspec+ default-language:+ Haskell2010+ ghc-options:+ -Wall+ hs-source-dirs:+ tests/unit+ main-is:+ Spec.hs+ other-modules:+ Saturnin.ServerSpec+ type:+ exitcode-stdio-1.0++test-suite documentation+ build-depends:+ base < 5+ , process == 1.*+ , regex-compat == 0.*+ default-language:+ Haskell2010+ hs-source-dirs:+ tests+ main-is:+ Haddock.hs+ type:+ exitcode-stdio-1.0++test-suite style+ build-depends:+ base < 5+ , hlint == 1.*+ default-language:+ Haskell2010+ hs-source-dirs:+ tests+ main-is:+ HLint.hs+ type:+ exitcode-stdio-1.0
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ executable/main.hs view
@@ -0,0 +1,5 @@+module Main (main) where++import Saturnin.Server+main :: IO ()+main = runYBServer
+ library/Saturnin/Git.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE OverloadedStrings #-}+module Saturnin.Git+ ( readFile+ , runCmd+ , GitSource (..)+ , GitURI (..)+ , GitRevOrRef (..)+ )+where++import qualified Data.ByteString as B+import Data.Text.Lazy (Text, unpack, pack)+import Formatting+import Prelude hiding (readFile)+import System.Exit+import System.FilePath.Posix+import System.IO hiding (readFile)+import System.Process++newtype GitURI = GitURI { uri :: Text }+ deriving (Show, Read)++newtype GitRevOrRef = GitRevOrRef { revOrRef :: Text }+ deriving (Show, Read)++data GitSource = GitSource+ { gsUri :: GitURI+ , gsRevOrRef :: GitRevOrRef+ }+ deriving (Show, Read)++-- | readFile reads FilePath from repository at GitSource+--+-- Implemented by clone uri; checkout ref/rev and then just readFile+--+-- Other approach could be:+-- git archive --remote=<uri> <tree-ish> <filepath>+-- But it's not currently possible as the <tree-ish> is too+-- restricted:+--+-- 3. Clients may not use other sha1 expressions, even if the end+-- result is reachable. E.g., neither a relative commit like+-- master^ nor a literal sha1 like abcd1234 is allowed, even if+-- the result is reachable from the refs. [1]_+--+-- .. [1]: man git-upload-archive++readFile+ :: GitSource+ -> FilePath -- The file to read+ -> FilePath -- Working directory+ -> IO B.ByteString+readFile (GitSource u r) p wd = do+ _ <- clone u wd (Just "repo")+ _ <- checkout (wd </> "repo") r+ B.readFile (wd </> "repo" </> p)++clone+ :: GitURI+ -> FilePath -- Directory to clone into+ -> Maybe FilePath -- Directory name for the repository+ -> IO (String, String)+clone (GitURI u) wd (Just n) = runGit wd ["clone", u, pack n]+clone (GitURI u) wd (Nothing) = runGit wd ["clone", u]++checkout :: FilePath -> GitRevOrRef -> IO (String, String)+checkout wd (GitRevOrRef r) = runGit wd ["checkout", r]++runGit+ :: FilePath -- working directory+ -> [Text] -- argv+ -> IO (String, String)+runGit wd argv = runCmd (Just wd) "git" $ fmap unpack argv++runCmd+ :: Maybe FilePath -- cwd+ -> FilePath -- exe+ -> [String] -- argv+ -> IO (String, String) -- out, err+runCmd cwd' exe argv = do+ let cp = (proc exe argv)+ { cwd = cwd'+ , std_out = CreatePipe+ , std_err = CreatePipe+ }+ (_, Just hout, Just herr, ph) <- createProcess cp+ ec <- waitForProcess ph+ out <- hGetContents hout+ err <- hGetContents herr++ ret ec out err+ where+ ret (f @ (ExitFailure _)) out err = error . unpack $ format+ ( shown+ % ": " % shown+ % " " % shown+ % " out: " % shown+ % " err: " % shown+ % "\n"+ )+ f exe argv out err+ ret ExitSuccess out err = return (out, err)
+ library/Saturnin/Jobs.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE OverloadedStrings #-}+module Saturnin.Jobs+ ( JobRequest (..)+ , CmdResult (..)+ , JobResult (..)+ , Job (..)+ , RemoteJob (..)+ , mkRemoteJob+ , runRemoteJob+ , RemoteJobRunnerState (..)+ )+where++import Control.Applicative+import Control.Monad+import Control.Monad.State+import Formatting+import Data.Either.Combinators+import Data.Text.Lazy hiding (dropWhileEnd)+import Prelude hiding (readFile)+import System.Exit+import System.IO+import System.Process++import Saturnin.Git+import Saturnin.Logging+import Saturnin.Types++-- | Job fully describes a job to be run. This is what JobRequest is+-- translated into for internal representation. This holds data that are+-- needed to actually run the job - that is data derived from the+-- JobRequest, eg.: [Hostname] instead of [MachineDescription]+data Job = Job+ { remoteJobs :: [RemoteJob]+ , request :: JobRequest+ , jobID :: JobID+ } deriving (Show)++-- | RemoteJob describes a job to be run on one machine. RemoteJob+-- is always part of Job.+data RemoteJob = TestJob+ { rJobTestType :: TestType+ , rJobDataSource :: GitSource+ , jobMachine :: MachineDescription+ , jobHost :: Hostname+ } deriving (Show)++mkRemoteJob+ :: JobRequest+ -> MachineDescription+ -> Hostname+ -> RemoteJob+mkRemoteJob x = TestJob (testType x) (dataSource x)++getJob :: RemoteJobRunner RemoteJob+getJob = rJob <$> get++data RemoteJobRunnerState = RemoteJobRunnerState+ { rJob :: RemoteJob+ , rJobLogger :: Logger+ , cLogger :: Logger+ }+type RemoteJobRunner a = StateT RemoteJobRunnerState IO a++runRemoteJob+ :: RemoteJobRunnerState+ -> IO JobResult+runRemoteJob x = evalStateT run x+ where+ run :: RemoteJobRunner JobResult+ run = mkWorkDir+ >>= checkoutDataSource+ >>= prepareEnvironment+ >>= endTestSetup+ >>= runTest+ >>= mkJobResult++mkJobResult+ :: Either TestResult a+ -> RemoteJobRunner JobResult+mkJobResult x = do+ j <- getJob+ return $ JobResult (jobMachine j) (getResult x)+ where+ getResult (Left y) = y+ getResult (Right _) = Passed++rJobLogToConnection :: Text -> RemoteJobRunner ()+rJobLogToConnection x = do+ c <- cLogger <$> get+ liftIO $ c x++logRemoteJob :: Text -> RemoteJobRunner ()+logRemoteJob x = do+ rJobLogToConnection x+ rl <- rJobLogger <$> get+ liftIO $ rl x++-- | Run a command on the remote machine.+-- Log the CmdResult to the job's log file and client connection.+-- And return Right CmdResult on success or Left Failed on error.+exe :: Text -> RemoteJobRunner (Either TestResult CmdResult)+exe x = do+ j <- getJob+ r <- liftIO . remoteCmd x $ jobHost j+ logRemoteJob . pack . show $ anyEither r+ return $ mapLeft (const Failed) r++-- | Returns `Left FailedSetup` iff `Left _`+-- otherwise `Right _`+endTestSetup+ :: Either TestResult WorkDir+ -> RemoteJobRunner (Either TestResult WorkDir)+endTestSetup = return . mapLeft (const FailedSetup)++type WorkDir = Text++-- | Returns `Right WorkDir` or `Left Failed`+mkWorkDir :: RemoteJobRunner (Either TestResult WorkDir)+mkWorkDir = (<$>) (strip . cmdResultOut) <$> (exe "mktemp -dt 'ybs.XXXXXX'")++-- | Returns `Right WorkDir` of the data source or `Left Failed`+checkoutDataSource+ :: Either TestResult WorkDir+ -> RemoteJobRunner (Either TestResult WorkDir)+checkoutDataSource (Right p) = do+ j <- getJob+ (<$>) (const repo) <$> (exe . cmd $ rJobDataSource j)+ where+ cmd s = format (+ " git clone " % text % " " % text %+ " && cd " % text %+ " && git checkout " % text+ )+ (uri $ gsUri s) repo+ repo+ (revOrRef $ gsRevOrRef s)++ repo = intercalate "/" [p, "repo"]+checkoutDataSource (Left x) = return $ Left x++prepareEnvironment+ :: Either TestResult WorkDir+ -> RemoteJobRunner (Either TestResult WorkDir)+prepareEnvironment (Right p) = do+ j <- getJob+ (<$>) (const p) <$> (exe' $ rJobTestType j)+ where+ exe' CabalTest = exe $ format (+ "cd " % text %+ " && cabal sandbox init && cabal update" %+ " && PATH=\"/root/.cabal/bin:$PATH\" cabal install" %+ " --only-dependencies -j --enable-tests"+ ) p+ exe' MakeCheckTest = return $ Right undefined+prepareEnvironment (Left x) = return $ Left x++runTest+ :: Either TestResult WorkDir+ -> RemoteJobRunner (Either TestResult CmdResult)+runTest (Right p) = do+ j <- getJob+ exe . cmd $ rJobTestType j+ where+ cmd CabalTest = format ("cd " % text % " && cabal test") p+ cmd MakeCheckTest = format ("cd " % text % " && make check") p+runTest (Left x) = return $ Left x++data CmdResult = CmdResult+ { cmdResultOut :: Text+ , cmdResultErr :: Text+ , cmdResultCmd :: Text+ , cmdResultCode :: ExitCode+ } deriving (Show)++data JobResult = JobResult+ { machine :: MachineDescription+ , result :: TestResult+ } deriving (Show)++-- | run command Text on remote Hostname and return `Left CmdResult` on+-- error and `Right CmdResult` on success.+remoteCmd+ :: Text+ -> Hostname+ -> IO (Either CmdResult CmdResult)+remoteCmd cmd h = do+ (_, Just hout, Just herr, ph) <- createProcess cp+ ec <- waitForProcess ph+ out <- pack <$> hGetContents hout+ err <- pack <$> hGetContents herr++ return . either' ec $ CmdResult out err cmd ec+ where+ cp = (proc "ssh" [h, unpack cmd])+ { cwd = Just "/"+ , std_out = CreatePipe+ , std_err = CreatePipe+ }++ either' ExitSuccess x = Right x+ either' (ExitFailure _) x = Left x
+ library/Saturnin/Logging.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE OverloadedStrings #-}+module Saturnin.Logging+ ( getJobLogger+ , Logger+ , DistributedJobLogger+ )+where++import Data.Monoid+import Data.Text.Lazy+import System.Directory+import System.FilePath.Posix++import Saturnin.Server.Config++jobLogs :: FilePath+jobLogs = "/var/lib/ybs/job-logs"++jobLog+ :: FilePath -- job's base logging path+ -> MachineDescription+ -> Text+ -> IO ()+jobLog p m msg = appendFile (p </> (m <> ".txt")) $ unpack msg++getJobLogger :: JobID -> IO DistributedJobLogger+getJobLogger (JobID x) = do+ let p = jobLogs </> (show x)+ _ <- createDirectoryIfMissing True p+ return $ jobLog p++type Logger = Text -> IO ()+type DistributedJobLogger = FilePath -> Text -> IO ()
+ library/Saturnin/Server.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE OverloadedStrings #-}+module Saturnin.Server+ ( runYBServer+ )+where++import Prelude hiding (lookup, log, readFile)++import Control.Applicative+import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad.Catch+import Control.Monad.State+import Data.Default+import Data.Either.Combinators+import Data.Maybe+import Formatting (format, shown, text, (%))+import Network.Socket+import System.Directory+import System.IO hiding (readFile)++import Saturnin.Server.Config+import Saturnin.Server.Connection+import Saturnin.Types++runYBServer :: IO ()+runYBServer = atomically (newTVar def) >>= evalStateT serve+ where+ serve :: YBServer ()+ serve =+ ybsCloseStdin+ >> openLogFile+ >> ybsReadConfig+ >>= ybsReadState+ >>= registerMachines+ >>= ybsCreateWorkdir+ >>= ybsListen+ >>= ybsAccept++ybsCloseStdin :: YBServer ()+ybsCloseStdin = liftIO $ hClose stdin++openLogFile :: YBServer ()+openLogFile = do+ ts <- get+ h <- liftIO $ openFile "/var/log/ybs.log" AppendMode+ liftIO . atomically $ do+ s <- readTVar ts+ writeTVar ts $ s { logHandle = h }++ybsReadConfig :: YBServer (Maybe ConfigServer)+ybsReadConfig = do+ x <- liftIO readConfig+ whenLeft x $ logError . format shown+ whenRight x $ \z -> get >>= \ts ->+ liftIO . atomically $ do+ s <- readTVar ts+ writeTVar ts $ s { ybssConfig = z }+ return $ rightToMaybe x++ybsReadState+ :: Maybe ConfigServer+ -> YBServer (Maybe ConfigServer)+ybsReadState Nothing = return Nothing+ybsReadState (Just cg) = do+ eps <- liftIO readPState+ whenLeft eps $ logError . format shown+ ts <- get+ whenRight eps $ \ps -> liftIO . atomically $ do+ s <- readTVar ts+ writeTVar ts $ s { pState = ps }+ return $ const cg <$> rightToMaybe eps++registerMachines+ :: Maybe ConfigServer+ -> YBServer (Maybe ConfigServer)+registerMachines (Just cg) = do+ ts <- get+ liftIO . atomically $ do+ s <- readTVar ts+ writeTVar ts $ s { freeMachines = machines cg }+ return (Just cg)+registerMachines Nothing = return Nothing++ybsCreateWorkdir :: Maybe ConfigServer -> YBServer (Maybe ConfigServer)+ybsCreateWorkdir (Just cg) = do+ catch+ (liftIO . createDirectoryIfMissing True . fromJust $ work_dir cg)+ (logError . format (text % shown) p :: SomeException -> YBServer ())+ return $ Just cg+ where+ p = "Failed to create working directory"+ybsCreateWorkdir Nothing = return Nothing++ybsListen+ :: (Maybe ConfigServer)+ -> YBServer (Maybe Socket)+ybsListen (Just cg) = do+ addrinfos <- liftIO $ getAddrInfo+ (Just defaultHints {addrFamily = AF_INET})+ (listen_addr cg)+ (listen_port cg)++ let addr = head addrinfos++ sock <- liftIO $ socket (addrFamily addr) Stream defaultProtocol+ _ <- liftIO . bind sock $ addrAddress addr++ logInfo $ format ("Listening on " % shown) addr+ _ <- liftIO $ listen sock 5++ return $ Just sock+ybsListen Nothing = return Nothing++ybsAccept :: Maybe Socket -> YBServer ()+ybsAccept (Just x) = do+ ts <- get+ forever $ do+ c <- liftIO $ accept x+ void . liftIO . forkIO $ evalStateT (handleConnection c) ts+ybsAccept Nothing = return ()
+ library/Saturnin/Server/Config.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE DeriveGeneric #-}+module Saturnin.Server.Config+ ( ConfigServer (..)+ , readConfig+ , MachineDescription+ , Hostname+ , YBServerPersistentState (..)+ , readPState+ , writePState+ , JobID (..)+ , bumpJobID+ )+where++import Data.Default+import Data.HashMap.Strict+import Data.Yaml+import GHC.Generics+import System.Directory+import System.FilePath.Posix++type MachineDescription = String+type Hostname = String++data ConfigServer = ConfigServer+ { listen_addr :: Maybe String+ , listen_port :: Maybe String+ , machines :: HashMap MachineDescription Hostname+ , work_dir :: Maybe FilePath+ } deriving (Show, Generic)++instance FromJSON ConfigServer++instance Default ConfigServer where+ def = ConfigServer+ { listen_addr = Nothing+ , listen_port = Nothing+ , machines = empty+ , work_dir = Nothing+ }++readConfig :: IO (Either ParseException ConfigServer)+readConfig = do+ tmp <- getTemporaryDirectory+ cg <- decodeFileEither "/etc/ybs.yml"++ return $ fmap (defWorkDir tmp) cg+ where+ defWorkDir t (cg @ ConfigServer { work_dir = Nothing }) =+ cg { work_dir = Just $ t </> "ybs" }+ defWorkDir _ cg = cg+++data JobID = JobID Int+ deriving (Show, Read, Generic)++instance Enum JobID where+ toEnum x = JobID x+ fromEnum (JobID x) = x++instance FromJSON JobID+instance ToJSON JobID++data YBServerPersistentState = YBServerPersistentState+ { lastJobID :: JobID }+ deriving (Show, Read, Generic)++instance FromJSON YBServerPersistentState+instance ToJSON YBServerPersistentState++instance Default YBServerPersistentState where+ def = YBServerPersistentState $ JobID 0++bumpJobID :: YBServerPersistentState -> YBServerPersistentState+bumpJobID x = x { lastJobID = succ $ lastJobID x }++readPState :: IO (Either ParseException YBServerPersistentState)+readPState = do+ x <- doesFileExist pstatePath+ if x+ then decodeFileEither pstatePath+ else return $ Right def++writePState :: YBServerPersistentState -> IO ()+writePState = encodeFile pstatePath++pstatePath :: FilePath+pstatePath = "/var/lib/ybs/state"
+ library/Saturnin/Server/Connection.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE OverloadedStrings #-}+module Saturnin.Server.Connection+ ( handleConnection+ )+where++import Prelude hiding (lookup, log, readFile)++import Control.Applicative+import Control.Arrow+import Control.Concurrent.Spawn+import Control.Concurrent.STM+import Control.Monad.State+import Data.HashMap.Strict+import Data.Text.Lazy hiding (head, all, length)+import Data.Time.Clock+import Formatting+import Network.Socket+import System.IO hiding (readFile)+import Text.Read hiding (get, lift)++import Saturnin.Jobs+import Saturnin.Logging+import Saturnin.Server.Config+import Saturnin.Types++-- getServerState :: JobRequestListenerConnectionHandler YBServerState+-- getServerState = lift get++--getConfig :: JobRequestListenerConnectionHandler ConfigServer+--getConfig = ybssConfig <$> getServerState++readBytes :: JobRequestListenerConnectionHandler String+readBytes = (\x -> liftIO $ fst3 <$> recvFrom x 1024) =<< (fst <$> get)++-- | Log to both log file and the client connection+logBoth :: Job -> Text -> JobRequestListenerConnectionHandler ()+logBoth j x = logToConnection x >> (logJob j x)++logJob :: Job -> Text -> JobRequestListenerConnectionHandler ()+logJob j x = do+ l <- liftIO . getJobLogger $ jobID j+ liftIO $ l "master" x++-- | Log to both server stderr and client connection+logToServerAndConn :: Text -> JobRequestListenerConnectionHandler ()+logToServerAndConn x = logToConnection x >> (lift $ logInfo x)++handleConnection :: (Socket, SockAddr) -> YBServer ()+handleConnection = evalStateT handle'+ where+ handle' = logClientConnected+ >> readJobRequest+ >>= mkJob+ >>= logJobStart+ >>= distributeJob+ >>= returnMachines+ >>= reportJobResult+ >> reportFreeMachines+ >> closeConnection+ >> logClientDisconnected++logClientConnected :: JobRequestListenerConnectionHandler ()+logClientConnected = do+ addr <- snd <$> get+ t <- liftIO getCurrentTime+ lift . logInfo $ format (shown % " connected: " % shown) t addr++logClientDisconnected :: JobRequestListenerConnectionHandler ()+logClientDisconnected = do+ addr <- snd <$> get+ t <- liftIO getCurrentTime+ lift . logInfo $ format (shown % " disconnected: " % shown) t addr++readJobRequest :: JobRequestListenerConnectionHandler (Maybe JobRequest)+readJobRequest = do+ bytes <- readBytes+ let mjr = readMaybe bytes+ whenNothing mjr . logToServerAndConn+ $ format ("failed to read JobRequest: " % shown) bytes+ return mjr++mkJob+ :: Maybe JobRequest+ -> JobRequestListenerConnectionHandler (Maybe Job)+mkJob (Just x) = do+ ms <- selectMachines x+ whenNothing ms $+ logToServerAndConn "Unable to select all requested machines"++ mk ms+ where+ mk :: Maybe [(MachineDescription, Hostname)] -> JobRequestListenerConnectionHandler (Maybe Job)+ mk (Just ms) = do+ jid <- getJobID+ return . Just $ Job+ { remoteJobs = uncurry (mkRemoteJob x) <$> ms+ , request = x+ , jobID = jid+ }+ mk Nothing = return Nothing+mkJob Nothing = return Nothing++logJobStart+ :: Maybe Job+ -> JobRequestListenerConnectionHandler (Maybe Job)+logJobStart (Just j) = do+ t <- liftIO getCurrentTime+ logBoth j $ format (shown% " starting job " %shown) t j+ return $ Just j+logJobStart x = return x++distributeJob+ :: Maybe Job+ -> JobRequestListenerConnectionHandler (Maybe (Job, [JobResult]))+distributeJob (Just x) = do+ baseLogger <- liftIO . getJobLogger $ jobID x+ c <- fst <$> get+ rs <- liftIO $ parMapIO runRemoteJob (rJobs x baseLogger $ logToConnection' c)+ return $ Just (x, rs)+ where+ rJobs :: Job -> DistributedJobLogger -> Logger -> [RemoteJobRunnerState]+ rJobs j l cL =+ (\y -> RemoteJobRunnerState y (l $ jobMachine y) cL) <$> (remoteJobs j)++distributeJob Nothing = return Nothing++returnMachines+ :: Maybe (Job, [JobResult])+ -> JobRequestListenerConnectionHandler (Maybe (Job, [JobResult]))+returnMachines (x @ (Just (j, _))) = do+ ts <- lift get+ let returning = fromList $ (jobMachine &&& jobHost) <$> remoteJobs j+ liftIO . atomically $ do+ s <- readTVar ts+ let old = freeMachines s+ writeTVar ts $ s { freeMachines = old `union` returning }+ return x+returnMachines Nothing = return Nothing++reportJobResult+ :: Maybe (Job, [JobResult])+ -> JobRequestListenerConnectionHandler ()+reportJobResult (Just (j, xs)) = do+ logBoth j $ format (+ "\n\n\nJob finished: " %shown% "\n" %+ "Job results: " %shown% "\n" %+ "Overal result: " %shown% "\n"+ ) (request j) xs overall+ where+ overall = if all isPassed $ result <$> xs+ then Passed+ else Failed++reportJobResult Nothing = return ()++closeConnection :: JobRequestListenerConnectionHandler ()+closeConnection = do+ c <- fst <$> get+ h <- liftIO $ socketToHandle c ReadWriteMode+ _ <- liftIO $ hFlush h+ _ <- liftIO $ hClose h+ return ()++getJobID :: JobRequestListenerConnectionHandler JobID+getJobID = do+ ts <- lift get+ ps <- liftIO . atomically $ do+ s <- readTVar ts+ let new = s { pState = bumpJobID $ pState s }+ writeTVar ts new+ return $ pState new++ liftIO $ writePState ps+ return $ lastJobID ps++reportFreeMachines :: JobRequestListenerConnectionHandler ()+reportFreeMachines = lift get+ >>= (freeMachines <$>) . liftIO . atomically . readTVar+ >>= lift . logInfo . format ("free machines: "%shown)++-- | Returns Nothing if all the request machines were not found+-- otherwise removes the taken machines the freeMachines in+-- YBServerState and returns Just the taken machines+selectMachines+ :: JobRequest+ -> JobRequestListenerConnectionHandler (Maybe [(MachineDescription, Hostname)])+selectMachines r = do+ ts <- lift get+ liftIO . atomically $ do+ s <- readTVar ts+ let requested = testMachines r+ free = freeMachines s+ found = filterMachines requested free++ if length found /= length requested+ then return Nothing+ else writeTVar ts+ (s { freeMachines = difference free $ fromList found})+ >> (return $ Just found)++filterMachines+ :: [MachineDescription]+ -> HashMap MachineDescription Hostname+ -> [(MachineDescription, Hostname)]+filterMachines ss xs = toList $ filterWithKey (\k _ -> elem k ss) xs++whenNothing :: Applicative m => Maybe a -> m () -> m ()+whenNothing (Just _) _ = pure ()+whenNothing Nothing f = f
+ library/Saturnin/Types.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE RankNTypes, OverloadedStrings #-}+module Saturnin.Types+ ( MachineDescription+ , Hostname+ , BuildRequest (..)+ , JobRequest (..)+ , TestType (..)+ , GitSource (..)+ , YBServer+ , YBServerState (..)+ , YBSSharedState+ , fst3+ , TestResult (..)+ , anyEither+ , isPassed+ , JobID (..)+ , JobRequestListenerConnectionHandler+ , logError+ , logInfo+ , logToConnection+ , logToConnection'+ )+where++import Control.Applicative hiding (empty)+import Control.Concurrent.STM+import Control.Monad.State+import Data.Text.Lazy hiding (empty)+import Data.Default+import Data.HashMap.Strict+import Data.Monoid+import Formatting+import Network.Socket+import System.IO++import Saturnin.Git+import Saturnin.Server.Config++data BuildRequest = GitBuildRequest+ { brUri :: String+ , brHead :: String+ }++type MachinesRegister = HashMap MachineDescription Hostname++-- | JobRequest specifies job to be run. This is what client send to the+-- job server.+data JobRequest = TestRequest+ { testType :: TestType+ , dataSource :: GitSource+ , testMachines :: [MachineDescription]+ }+ deriving (Show, Read)++data TestType = CabalTest | MakeCheckTest+ deriving (Show, Read)++data YBServerState = YBServerState+ { ybssConfig :: ConfigServer+ , pState :: YBServerPersistentState+ , freeMachines :: MachinesRegister+ , logHandle :: Handle+ }+ deriving (Show)++instance Default YBServerState where+ def = YBServerState def def empty stderr++type YBSSharedState = TVar YBServerState+type YBServer a = StateT YBSSharedState IO a++logServer :: Text -> YBServer ()+logServer x = do+ liftIO . hPutStr stderr $ unpack x+ ts <- get+ lh <- liftIO . atomically $ logHandle <$> readTVar ts+ liftIO . hPutStr lh $ unpack x++logError :: Text -> YBServer ()+logError = logServer . format ("error: " % text % "\n")++logInfo :: Text -> YBServer ()+logInfo = logServer . format ("info: " % text % "\n")++type JobRequestListenerConnectionHandler a =+ StateT (Socket, SockAddr) (StateT YBSSharedState IO) a++logToConnection :: Text -> JobRequestListenerConnectionHandler ()+logToConnection x = do+ c <- (fst <$> get)+ liftIO $ logToConnection' c x++logToConnection' :: Socket -> Text -> IO ()+logToConnection' c x =+ void . send c $ unpack x <> "\n"++-- | fst for three-tuple+fst3 :: forall t t1 t2. (t, t1, t2) -> t+fst3 (x, _, _) = x++data TestResult = Passed | Failed | FailedSetup+ deriving (Show, Read)++isPassed :: TestResult -> Bool+isPassed Passed = True+isPassed _ = False++-- | Returns any thing in Either. Be it Left or Right.+anyEither :: Either a a -> a+anyEither (Left x) = x+anyEither (Right x) = x
+ tests/HLint.hs view
@@ -0,0 +1,16 @@+module Main (main) where++import Language.Haskell.HLint (hlint)+import System.Exit (exitFailure, exitSuccess)++arguments :: [String]+arguments =+ [+ "library"+ , "tests"+ ]++main :: IO ()+main = do+ hints <- hlint arguments+ if null hints then exitSuccess else exitFailure
+ tests/Haddock.hs view
@@ -0,0 +1,30 @@+module Main (main) where++import Data.List (genericLength)+import Data.Maybe (catMaybes)+import System.Exit (exitFailure, exitSuccess)+import System.Process (readProcess)+import Text.Regex (matchRegex, mkRegex)++arguments :: [String]+arguments =+ [ "haddock"+ ]++average :: (Fractional a, Real b) => [b] -> a+average xs = realToFrac (sum xs) / genericLength xs++expected :: Fractional a => a+expected = 0++main :: IO ()+main = do+ output <- readProcess "cabal" arguments ""+ if average (match output) >= expected+ then exitSuccess+ else putStr output >> exitFailure++match :: String -> [Int]+match = fmap read . concat . catMaybes . fmap (matchRegex pattern) . lines+ where+ pattern = mkRegex "^ *([0-9]*)% "
+ tests/unit/Saturnin/ServerSpec.hs view
@@ -0,0 +1,9 @@+module Saturnin.ServerSpec (spec) where++import Test.Hspec++spec :: Spec+spec = do+ describe "tests skeleton" $ do+ it "works" $ do+ True `shouldBe` True
+ tests/unit/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}