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
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"
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
anyEither :: Either a a -> a
anyEither (Left x) = x
anyEither (Right x) = x