module Development.Bake.Server.Start(
startServer
) where
import Development.Bake.Type
import Development.Bake.Web
import Development.Bake.Message
import Development.Bake.Util
import Development.Bake.Server.Type
import Development.Bake.Server.Web
import Development.Bake.Server.Brains
import Development.Shake.Command
import Control.Concurrent
import Control.DeepSeq
import Control.Exception.Extra
import Data.List.Extra
import Data.Maybe
import Data.Time.Clock
import System.Environment.Extra
import Control.Monad.Extra
import Data.Tuple.Extra
import System.Directory.Extra
import System.Console.CmdArgs.Verbosity
import System.FilePath
startServer :: Port -> FilePath -> Author -> String -> Double -> Oven state patch test -> IO ()
startServer port datadir author name timeout (validate . concrete -> oven) = do
exe <- getExecutablePath
curdirLock <- newMVar ()
ignore $ removeDirectoryRecursive "bake-server"
createDirectoryIfMissing True "bake-server"
s <- withServerDir curdirLock $ ovenUpdateState oven Nothing
putStrLn $ "Initial state of: " ++ show s
var <- newMVar $ (defaultServer s){authors = [(Nothing,author)]}
server port $ \i@Input{..} -> do
whenLoud $ print i
handle_ (fmap OutputError . showException) $ do
res <-
if null inputURL then
web oven inputArgs =<< readMVar var
else if ["html"] `isPrefixOf` inputURL then
return $ OutputFile $ datadir </> "html" </> last inputURL
else if ["api"] `isPrefixOf` inputURL then
(case messageFromInput i{inputURL = drop 1 inputURL} of
Left e -> return $ OutputError e
Right v -> do
fmap questionToOutput $ modifyMVar var $ \s -> do
(s,q) <- operate curdirLock timeout oven v s
case v of
AddPatch _ p | p `notElem` map fst (extra s) -> do
forkIO $ do
dir <- createDir "bake-extra" [fromState $ fst $ active s, fromPatch p]
res <- try_ $ do
unit $ cmd (Cwd dir) exe "runextra"
"--output=extra.txt"
["--state=" ++ fromState (fst $ active s)]
["--patch=" ++ fromPatch p]
fmap read $ readFile $ dir </> "extra.txt"
res <- either (fmap dupe . showException) return res
modifyMVar_ var $ \s -> return s{extra = (p,res) : extra s}
return (s{extra=(p,dupe "Calculating..."):extra s}, q)
_ -> return (s,q)
)
else
return OutputMissing
evaluate $ force res
operate :: MVar () -> Double -> Oven State Patch Test -> Message -> Server -> IO (Server, Maybe Question)
operate curdirLock timeout oven message server = case message of
AddPatch author p | (s, ps) <- active server -> do
whenLoud $ print ("Add patch to",s,snoc ps p)
now <- getTimestamp
dull server{active = (s, snoc ps p), authors = (Just p, author) : authors server, submitted = (now,p) : submitted server}
DelPatch author p | (s, ps) <- active server -> dull server{active = (s, delete p ps)}
Pause author -> dull server{paused = Just $ fromMaybe [] $ paused server}
Unpause author | (s, ps) <- active server ->
dull server{paused=Nothing, active = (s, ps ++ maybe [] (map snd) (paused server))}
Finished q a -> do
when (not $ aSuccess a) $ do
putStrLn $ replicate 70 '#'
print (active server, q, a{aStdout=""})
putStrLn $ aStdout a
putStrLn $ replicate 70 '#'
server <- return server{history = [(t,qq,if q == qq then Just a else aa) | (t,qq,aa) <- history server]}
consistent server
dull server
Pinged ping -> do
limit <- getCurrentTime
now <- getTimestamp
server <- return $ prune (addUTCTime (fromRational $ toRational $ negate timeout) limit) $ server
{pings = (now,ping) : filter ((/= pClient ping) . pClient . snd) (pings server)}
flip loopM server $ \server ->
case brains (ovenTestInfo oven) server ping of
Sleep ->
return $ Right (server, Nothing)
Task q -> do
when (qClient q /= pClient ping) $ error "client doesn't match the ping"
server <- return $ server{history = (now,q,Nothing) : history server}
return $ Right (server, Just q)
Update -> do
dir <- createDir "bake-test" $ fromState (fst $ active server) : map fromPatch (snd $ active server)
s <- withServerDir curdirLock $ withCurrentDirectory (".." </> dir) $
ovenUpdateState oven $ Just $ active server
ovenNotify oven [a | (p,a) <- authors server, maybe False (`elem` snd (active server)) p] $ unlines
["Your patch just made it in"]
return $ Left server{active=(s, []), updates=(now,s,active server):updates server}
Reject p t -> do
ovenNotify oven [a | (pp,a) <- authors server, Just p == pp] $ unlines
["Your patch " ++ show p ++ " got rejected","Failure in test " ++ show t]
return $ Left server{active=second (delete p) $ active server}
Broken t -> do
ovenNotify oven [a | (p,a) <- authors server, maybe True (`elem` snd (active server)) p] $ unlines
["Eek, it's all gone horribly wrong","Failure with no patches in test " ++ show t]
return $ Left server{active=(fst $ active server, [])}
where
dull s = return (s,Nothing)
prune :: UTCTime -> Server -> Server
prune cutoff s = s{history = filter (flip elem clients . qClient . snd3) $ history s}
where clients = [pClient | (Timestamp t _,Ping{..}) <- pings s, t >= cutoff]
consistent :: Server -> IO ()
consistent Server{..} = do
let xs = groupSort $ map (qCandidate . snd3 &&& id) $ filter (isNothing . qTest . snd3) history
forM_ xs $ \(c,vs) -> do
case nub $ map (sort . uncurry (++) . aTests) $ filter aSuccess $ mapMaybe thd3 vs of
a:b:_ -> error $ "Tests don't match for candidate: " ++ show (c,a,b,vs)
_ -> return ()
withServerDir :: MVar () -> IO a -> IO a
withServerDir curdirLock act = withMVar curdirLock $ const $ withCurrentDirectory "bake-server" act