diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2015, Jan Matejka +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. diff --git a/Saturnin.cabal b/Saturnin.cabal new file mode 100644 --- /dev/null +++ b/Saturnin.cabal @@ -0,0 +1,114 @@ +author: Jan Matějka +build-type: Simple +cabal-version: >= 1.16 +copyright: 2015 Jan Matějka +license: BSD3 +maintainer: +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 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/executable/main.hs b/executable/main.hs new file mode 100644 --- /dev/null +++ b/executable/main.hs @@ -0,0 +1,5 @@ +module Main (main) where + +import Saturnin.Server +main :: IO () +main = runYBServer diff --git a/library/Saturnin/Git.hs b/library/Saturnin/Git.hs new file mode 100644 --- /dev/null +++ b/library/Saturnin/Git.hs @@ -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= +-- But it's not currently possible as the 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) diff --git a/library/Saturnin/Jobs.hs b/library/Saturnin/Jobs.hs new file mode 100644 --- /dev/null +++ b/library/Saturnin/Jobs.hs @@ -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 diff --git a/library/Saturnin/Logging.hs b/library/Saturnin/Logging.hs new file mode 100644 --- /dev/null +++ b/library/Saturnin/Logging.hs @@ -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 () diff --git a/library/Saturnin/Server.hs b/library/Saturnin/Server.hs new file mode 100644 --- /dev/null +++ b/library/Saturnin/Server.hs @@ -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 () diff --git a/library/Saturnin/Server/Config.hs b/library/Saturnin/Server/Config.hs new file mode 100644 --- /dev/null +++ b/library/Saturnin/Server/Config.hs @@ -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" diff --git a/library/Saturnin/Server/Connection.hs b/library/Saturnin/Server/Connection.hs new file mode 100644 --- /dev/null +++ b/library/Saturnin/Server/Connection.hs @@ -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 diff --git a/library/Saturnin/Types.hs b/library/Saturnin/Types.hs new file mode 100644 --- /dev/null +++ b/library/Saturnin/Types.hs @@ -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 diff --git a/tests/HLint.hs b/tests/HLint.hs new file mode 100644 --- /dev/null +++ b/tests/HLint.hs @@ -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 diff --git a/tests/Haddock.hs b/tests/Haddock.hs new file mode 100644 --- /dev/null +++ b/tests/Haddock.hs @@ -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]*)% " diff --git a/tests/unit/Saturnin/ServerSpec.hs b/tests/unit/Saturnin/ServerSpec.hs new file mode 100644 --- /dev/null +++ b/tests/unit/Saturnin/ServerSpec.hs @@ -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 diff --git a/tests/unit/Spec.hs b/tests/unit/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/unit/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}