Permalink
Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
169 lines (138 sloc) 5.93 KB
{-# LANGUAGE TypeFamilies, DeriveDataTypeable, TemplateHaskell,
MultiParamTypeClasses, FlexibleContexts,
FlexibleInstances, TypeSynonymInstances #-}
module Main where
import Happstack.State
import Happstack.Server hiding (Host)
import Data.Typeable
import Control.Arrow
import Control.Concurrent
import Control.Monad.State (put, get, modify)
import Control.Monad.Reader
import Data.Monoid
import Data.Maybe
import Data.Generics
import System.Environment
import qualified Data.Map as Map
import Text.JSON
import Data.List
type Host = String
type TestName = String
type Revision = String
type Duration = Float
type Measurement = (Host, TestName, Revision, Duration)
type Margin = Float
defaultMargin = 0.125
duration :: Measurement -> Duration
duration (_,_,_,d) = d
instance FromData Measurement where
fromData = do
test <- look "test"
duration <- lookRead "duration"
host <- look "host"
revision <- look "revision"
return (host, test, revision, duration)
type Measurements0 = Map.Map (Host, TestName) (Duration, [(Revision, Duration, Bool)])
type Measurements = Map.Map (Host, TestName) (Duration, Margin, [(Revision, Duration, Bool)])
data State0 = State0 Measurements0 deriving (Typeable)
data State = State {measurements :: Measurements} deriving (Typeable)
instance Version State0
$(deriveSerialize ''State0)
instance Version State where
mode = extension 1 (Proxy :: Proxy State0)
$(deriveSerialize ''State)
instance Migrate State0 State where
migrate (State0 ms) = State (Map.map (\(x, y) -> (x, defaultMargin, y)) ms)
instance Component State where
type Dependencies State = End
initialValue = State $ Map.fromList []
addMeasurement :: Measurement -> Float -> Update State (Bool, Float)
addMeasurement (host, tname, rev, duration) margin = do
State measurements <- get
let newmap = upd measurements
put . State $ newmap
let (best, _, (_, _, res):_) = newmap Map.! (host, tname)
return (res, best)
where upd = Map.insertWith upd' (host, tname) (duration, margin, [(rev, duration, True)])
upd' _ (mdur, _, ms) = (min mdur duration, margin, (rev, duration, duration <= mdur * (1.0+margin)):ms)
deleteResult :: Measurement -> Update State ()
deleteResult (host, test, revision, dur) = do
State measurements <- get
put $ State $ Map.adjust g (host, test) measurements
where g (best, margin, ms) = let newMs = filter (not.toDelete) ms in (bestResult newMs, margin, newMs)
toDelete (r, d, _) = r == revision && d == dur
bestResult = foldl' min 99999999.0 . map duration
duration (_, d, _) = d
getMeasurements :: Query State Measurements
getMeasurements = fmap measurements ask
$(mkMethods ''State ['addMeasurement, 'getMeasurements, 'deleteResult])
reportMeasurement :: TestName -> Host -> ServerPart Response
reportMeasurement test host = do
Just revision <- getDataFn $ look "revision"
Just duration <- getDataFn $ lookRead "duration"
maybeMargin <- getDataFn $ lookRead "margin"
let margin = fromMaybe defaultMargin maybeMargin
(res, best) <- update (AddMeasurement (host, test, revision, duration) margin)
return . toResponse $ if res
then "PASS"
else "FAIL\n" ++ show best
listMeasurements :: ServerPart Response
listMeasurements = do
measurements <- query (GetMeasurements)
return . toResponse . foldr g "" $ Map.toList measurements
where g ((host, test), val) = ss host . ss " " . ss test . ss "\n" . shows val . ss "\n\n"
ss = showString
tests :: ServerPart Response
tests = fmap (toResponse . encode . Map.keys) (query GetMeasurements)
displayDetails :: Host -> TestName -> ServerPart Response
displayDetails hostName testName = do
allMeasurements <- query GetMeasurements
if (hostName, testName) `Map.member` allMeasurements
then fileServeStrict [] "static/test-details.html"
else fail $ "no such test or host" ++ show (testName, hostName)
testInfo :: Host -> TestName -> ServerPart Response
testInfo hostName testName = do
allMeasurements <- query GetMeasurements
let measurements = allMeasurements Map.! (hostName, testName)
return . toResponse . encode $ measurements
justTestInfo :: TestName -> ServerPart Response
justTestInfo testName = do
allMeasurements <- query GetMeasurements
return . toResponse . encode . map (first fst) . filter ((==testName).snd.fst) . Map.toList $ allMeasurements
justTest :: TestName -> ServerPart Response
justTest testName = (nullDir >> fileServeStrict [] "static/test.html")
`mappend` (dir "json" $ methodSP GET $ justTestInfo testName)
handleRemoveResult :: Host -> TestName -> ServerPart Response
handleRemoveResult host test = do
Just revision <- getDataFn $ look "revision"
Just dur <- getDataFn $ lookRead "duration"
update (DeleteResult (host, test, revision, dur))
return $ toResponse $ "ok" ++ show (revision, dur)
testHostPart test host = msum [
methodSP GET $ displayDetails host test
, methodSP POST $ reportMeasurement test host
, dir "json" $ testInfo host test
, dir "remove" $ methodSP POST $ handleRemoveResult host test
]
controller = msum [
nullDir >> fileServeStrict [] "static/index.html"
, dir "static" $ fileServeStrict [] "static"
, dir "tests" tests -- json
, dir "list" listMeasurements -- raw page
, path (\testName -> justTest testName `mappend` path (\hostName -> testHostPart testName hostName))
]
main = do
args <- getArgs
let stateName = case args of
[name] -> name
[] -> "apprazor"
withProgName stateName $ do
control <- startSystemState entryPoint
tid <- forkIO $ simpleHTTP (Conf 5003 Nothing) $ controller
putStrLn "listening on port 5003"
waitForTermination
killThread tid
createCheckpoint control
shutdownSystem control
where entryPoint :: Proxy State
entryPoint = Proxy