hunk ./client/builder-client.cabal 25 - filepath >= 1.1 && < 1.3, + filepath >= 1.1 && < 1.4, hunk ./client/builder-client.cabal 30 - process >= 1.0 && < 1.1, - time >= 1.1 && < 1.3 + process >= 1.0 && < 1.2, + time >= 1.1 && < 1.5 hunk ./client/builder-client.cabal 33 - Build-Depends: unix >= 2.3 && < 2.5 + Build-Depends: unix >= 2.3 && < 2.6 hunk ./common/builder-lib.cabal 27 - filepath >= 1.1 && < 1.3, + filepath >= 1.1 && < 1.4, hunk ./common/builder-lib.cabal 31 - process >= 1.0 && < 1.1, - time >= 1.1 && < 1.3 + process >= 1.0 && < 1.2, + time >= 1.1 && < 1.5 hunk ./server/ConfigHandler.hs 71 - loadedModSummaries <- filterM (isLoaded . ms_mod_name) modGraph - let loadedMods = [ (ms_mod m, Nothing) - | m <- loadedModSummaries ] - setContext [] loadedMods + let modNames = map ms_mod_name modGraph + loadedModNames <- filterM isLoaded modNames + let imps = map (IIDecl . simpleImportDecl) loadedModNames + setContext imps hunk ./server/builder-server.cabal 26 - filepath >= 1.1 && < 1.3, - ghc, + filepath >= 1.1 && < 1.4, + ghc >= 7.4, hunk ./server/builder-server.cabal 34 - process >= 1.0 && < 1.1, - time >= 1.1 && < 1.3, - unix >= 2.3 && < 2.5, + process >= 1.0 && < 1.2, + time >= 1.1 && < 1.5, + unix >= 2.3 && < 2.6, hunk ./server/server.hs 79 -runServer mfp v = withSocketsDo $ withOpenSSL $ - do messagerVar <- newEmptyMVar - notifierVar <- newEmptyMVar - configHandlerVar <- newEmptyMVar - timeMasterVar <- newEmptyMVar - let directory = Directory { - dir_messagerVar = messagerVar, - dir_notifierVar = notifierVar, - dir_configHandlerVar = configHandlerVar, - dir_timeMasterVar = timeMasterVar - } - mfph = case mfp of - Nothing -> Nothing - Just fp -> Just (fp, Nothing) - persistentThread "Messager" (messager directory mfph v) - persistentThread "Notification" (notifier directory) - persistentThread "Config handler" (configHandler configHandlerVar) - persistentThread "Time" (timeMaster timeMasterVar) - _ <- installHandler sigHUP - (Catch (gotSigHUP directory)) - Nothing - addrinfos <- getAddrInfo Nothing (Just "0.0.0.0") (Just (show port)) - let serveraddr = head addrinfos - bracket (socket (addrFamily serveraddr) Stream defaultProtocol) - sClose - (listenForClients directory serveraddr) +runServer mfp v = withSocketsDo $ withOpenSSL $ do + tid <- myThreadId + messagerVar <- newEmptyMVar + notifierVar <- newEmptyMVar + configHandlerVar <- newEmptyMVar + timeMasterVar <- newEmptyMVar + let directory = Directory { + dir_messagerVar = messagerVar, + dir_notifierVar = notifierVar, + dir_configHandlerVar = configHandlerVar, + dir_timeMasterVar = timeMasterVar + } + mfph = case mfp of + Nothing -> Nothing + Just fp -> Just (fp, Nothing) + runThread tid Persistent "Messager" (messager directory mfph v) + runThread tid Persistent "Notification" (notifier directory) + runThread tid Persistent "Config handler" (configHandler configHandlerVar) + runThread tid Persistent "Time" (timeMaster timeMasterVar) + _ <- installHandler sigHUP + (Catch (gotSigHUP directory)) + Nothing + addrinfos <- getAddrInfo Nothing (Just "0.0.0.0") (Just (show port)) + let serveraddr = head addrinfos + bracket (socket (addrFamily serveraddr) Stream defaultProtocol) + sClose + (listenForClients tid directory serveraddr) hunk ./server/server.hs 113 -persistentThread :: String -> IO () -> IO () -persistentThread title f - = do let thread = f `catch` \e -> - do warn (exceptionMsg e) - thread +data ThreadType = Persistent | ClientThread + +runThread :: ThreadId -> ThreadType -> String -> IO () -> IO () +runThread mainThread threadType title f + = do let thread = f + `catches` + [Handler $ \e -> + do warn ("Got an asynchronous exception: " ++ + show (e :: AsyncException)) + killThread mainThread, + Handler $ \e -> + case threadType of + Persistent -> + do warn (exceptionMsg e ["Restarting..."]) + thread + ClientThread -> + warn (exceptionMsg e []) + ] hunk ./server/server.hs 133 - where exceptionMsg e = unlines [title ++ " thread got an exception:", - show (e :: SomeException), - "Restarting..."] + where exceptionMsg e ms = unlines ([title ++ " thread got an exception:", + show (e :: SomeException)] ++ ms) hunk ./server/server.hs 136 -listenForClients :: Directory -> AddrInfo -> Socket -> IO () -listenForClients directory serveraddr sock +listenForClients :: ThreadId -> Directory -> AddrInfo -> Socket -> IO () +listenForClients tid directory serveraddr sock hunk ./server/server.hs 144 - _ <- forkIO $ startSsl defaultProtocolVersion directory who conn + _ <- runThread tid ClientThread (show addr) $ + startSsl defaultProtocolVersion directory who conn hunk ./common/Builder/Utils.hs 36 +import OpenSSL.Session (SomeSSLException) hunk ./common/Builder/Utils.hs 317 - = io `catch` \e -> - if isEOFError e || - (isUserError e && ("SSL" `isPrefixOf` ioeGetErrorString e)) - then io' - else throwIO e + = io `catches` + [Handler $ \e -> if isEOFError e + then io' + else throwIO e, + Handler $ \(_ :: SomeSSLException) -> io'] hunk ./common/builder-lib.cabal 22 - Extensions: DeriveDataTypeable, GeneralizedNewtypeDeriving + Extensions: ScopedTypeVariables, + DeriveDataTypeable, + GeneralizedNewtypeDeriving hunk ./TODO 5 -* Add SSL instructions to docs hunk ./TODO 8 -* More exception handling (e.g. catch the exception when we fail to - clean tempbuild, and put it somewhere visible) hunk ./common/Builder/Files.hs 5 + getBuildNumbers, + -- hunk ./common/Builder/Files.hs 71 +-- + +getBuildNumbers :: Root -> IO [BuildNum] +getBuildNumbers root = getSortedNumericDirectoryContents (mkPath root "builds") + hunk ./common/Builder/Utils.hs 134 -maybeReadBinaryFile :: MonadIO m => FilePath -> m (Maybe String) -maybeReadBinaryFile fp +maybeReadBinaryFileHandle :: MonadIO m + => FilePath -> m (Maybe (String, Handle)) +maybeReadBinaryFileHandle fp hunk ./common/Builder/Utils.hs 140 - Just h -> liftIO $ liftM Just $ hGetContents h + Just h -> liftIO $ do str <- hGetContents h + return (Just (str, h)) hunk ./common/Builder/Utils.hs 144 +maybeReadBinaryFile :: MonadIO m => FilePath -> m (Maybe String) +maybeReadBinaryFile fp = liftM (fmap fst) $ maybeReadBinaryFileHandle fp + hunk ./common/Builder/Utils.hs 234 - = do mxs <- maybeReadBinaryFile fp - case mxs of - Just xs -> + = do mxsh <- maybeReadBinaryFileHandle fp + case mxsh of + Just (xs, h) -> hunk ./common/Builder/Utils.hs 239 - return Nothing + do liftIO $ hClose h + return Nothing hunk ./server/WebpageCreation.hs 22 + root = Server (baseDir "clients") u hunk ./server/WebpageCreation.hs 26 - webBuildDir = baseDir "web/builders" u show bn + webRootDir = baseDir "web/builders" + webBuilderDir = webRootDir u + webBuildDir = webBuilderDir show bn hunk ./server/WebpageCreation.hs 33 - mapM_ (mkStepPage u bn) steps - relPage <- mkBuildPage config u bn steps - mkIndex u + mapM_ (mkStepPage root u bn) steps + (relPage, result) <- mkBuildPage root config u bn steps + mkBuilderIndex root webBuilderDir u bn result hunk ./server/WebpageCreation.hs 38 -mkStepPage :: User -> BuildNum -> BuildStepNum -> IO () -mkStepPage u bn bsn - = do let root = Server (baseDir "clients") u - page = baseDir "web/builders" u show bn show bsn <.> "html" +mkStepPage :: Root -> User -> BuildNum -> BuildStepNum -> IO () +mkStepPage root u bn bsn + = do let page = baseDir "web/builders" u show bn show bsn <.> "html" hunk ./server/WebpageCreation.hs 56 - outputHtml <- getOutputHtml root bn bsn + outputHtml <- getOutputHtml root bn bsn hunk ./server/WebpageCreation.hs 82 -mkBuildPage :: Config -> User -> BuildNum -> [BuildStepNum] -> IO String -mkBuildPage config u bn bsns - = do let root = Server (baseDir "clients") u - relPage = "builders" u show bn <.> "html" +mkBuildPage :: Root -> Config -> User -> BuildNum -> [BuildStepNum] + -> IO (String, Result) +mkBuildPage root config u bn bsns + = do let relPage = "builders" u show bn <.> "html" hunk ./server/WebpageCreation.hs 90 - let linkClass = case result of - Success -> "success" - Failure -> "failure" - Incomplete -> "incomplete" - builderDescription = case lookup u (config_clients config) of + let builderDescription = case lookup u (config_clients config) of hunk ./server/WebpageCreation.hs 99 - +++ (paragraph ! [theclass linkClass]) + +++ (paragraph ! [theclass (resultToLinkClass result)]) hunk ./server/WebpageCreation.hs 109 - return relPage + return (relPage, result) hunk ./server/WebpageCreation.hs 157 --- XXX This should do something: -mkIndex :: User -> IO () -mkIndex _ = return () +data IndexData = IndexData { + idNext :: BuildNum, + idBuildResults :: [(BuildNum, Result)] + } + deriving (Show, Read) + +mkBuilderIndex :: Root -> FilePath -> User -> BuildNum -> Result -> IO () +mkBuilderIndex root webBuilderDir u bn result + = do let indexPage = webBuilderDir "index.html" + indexDataFile = webBuilderDir "index.dat" + mIndexData <- maybeReadFromFile indexDataFile + buildResults <- case mIndexData of + Just i + | idNext i == bn -> return $ idBuildResults i + _ -> + do warn ("Failed to read " ++ show indexDataFile ++ + ". Recreating it.") + bns <- getBuildNumbers root + mapM (\bn' -> do res <- readBuildResult root bn' + return (bn', res)) + (reverse bns) + let buildResults' = (bn, result) : buildResults + indexData' = IndexData { + idNext = bn + 1, + idBuildResults = buildResults' + } + html = mkBuilderIndexHtml u buildResults' + writeToFile indexDataFile indexData' + writeBinaryFile indexPage $ renderHtml html + +mkBuilderIndexHtml :: User -> [(BuildNum, Result)] -> Html +mkBuilderIndexHtml u xs = header headerHtml + +++ body bodyHtml + where headerHtml = thetitle descriptionHtml + +++ (thelink ! [rel "Stylesheet", + thetype "text/css", + href "../../css/builder.css"]) + noHtml + bodyHtml = h1 descriptionHtml + +++ ulist (concatHtml (map li links)) + descriptionHtml = stringToHtml u + links = [ (anchor ! [href url, theclass (resultToLinkClass res)]) + (stringToHtml (show bn ++ ": " ++ show res)) + | (bn, res) <- xs + , let url = show bn <.> "html" + ] + +resultToLinkClass :: Result -> String +resultToLinkClass Success = "success" +resultToLinkClass Failure = "failure" +resultToLinkClass Incomplete = "incomplete" hunk ./server/WebpageCreation.hs 157 -data IndexData = IndexData { - idNext :: BuildNum, - idBuildResults :: [(BuildNum, Result)] - } +data BuilderIndexData = BuilderIndexData { + bidNext :: BuildNum, + bidBuildResults :: [(BuildNum, Result)] + } hunk ./server/WebpageCreation.hs 165 - = do let indexPage = webBuilderDir "index.html" - indexDataFile = webBuilderDir "index.dat" - mIndexData <- maybeReadFromFile indexDataFile - buildResults <- case mIndexData of + = do let builderIndexPage = webBuilderDir "index.html" + builderIndexDataFile = webBuilderDir "index.dat" + mBuilderIndexData <- maybeReadFromFile builderIndexDataFile + buildResults <- case mBuilderIndexData of hunk ./server/WebpageCreation.hs 170 - | idNext i == bn -> return $ idBuildResults i + | bidNext i == bn -> return $ bidBuildResults i hunk ./server/WebpageCreation.hs 172 - do warn ("Failed to read " ++ show indexDataFile ++ - ". Recreating it.") + do warn ("Failed to read " ++ show builderIndexDataFile + ++ ". Recreating it.") hunk ./server/WebpageCreation.hs 179 - indexData' = IndexData { - idNext = bn + 1, - idBuildResults = buildResults' - } + builderIndexData' = BuilderIndexData { + bidNext = bn + 1, + bidBuildResults = buildResults' + } hunk ./server/WebpageCreation.hs 184 - writeToFile indexDataFile indexData' - writeBinaryFile indexPage $ renderHtml html + writeToFile builderIndexDataFile builderIndexData' + writeBinaryFile builderIndexPage $ renderHtml html hunk ./common/Builder/Utils.hs 17 + getInterestingDirectoryContents, hunk ./common/Builder/Utils.hs 256 + = do xs <- getInterestingDirectoryContents fp + f xs + where f [] = return [] + f (x : xs) = case maybeRead x of + Nothing -> + die ("Bad directory entry: " ++ show x) + Just n -> + liftM (n :) (f xs) + +getInterestingDirectoryContents :: FilePath -> IO [FilePath] +getInterestingDirectoryContents fp hunk ./common/Builder/Utils.hs 273 - do warn "Got an InvalidArgument exception in getNumericDirectoryContents" - warn ("Requested numeric directory contents for " ++ show fp) + do warn "Got an InvalidArgument exception in getInterestingDirectoryContents" + warn ("Requested directory contents for " ++ show fp) hunk ./common/Builder/Utils.hs 286 - f xs - where f [] = return [] - f ("." : xs) = f xs - f (".." : xs) = f xs - f (x : xs) = case maybeRead x of - Nothing -> - die ("Bad directory entry: " ++ show x) - Just n -> - liftM (n :) (f xs) + return $ filter (`notElem` [".", ".."]) xs hunk ./server/WebpageCreation.hs 22 - root = Server (baseDir "clients") u - buildsDir = baseDir "clients" u "builds" + usersDir = baseDir "clients" + root = Server usersDir u + buildsDir = usersDir u "builds" hunk ./server/WebpageCreation.hs 37 + mkIndex usersDir webRootDir u bn result hunk ./server/WebpageCreation.hs 206 +data IndexData = IndexData { + idRecentResults :: [(User, [(BuildNum, Result)])] + } + deriving (Show, Read) + +-- The indexWidth is how many previous builds we show the result of in +-- the main index +indexWidth :: Int +indexWidth = 10 + +mkIndex :: FilePath -> FilePath -> User -> BuildNum -> Result -> IO () +mkIndex usersDir webDir u bn result + = do let indexPage = webDir "index.html" + indexDataFile = webDir "index.dat" + mIndexData <- maybeReadFromFile indexDataFile + indexData <- case mIndexData of + Just i -> return $ idRecentResults i + _ -> + do warn ("Failed to read " ++ show indexDataFile + ++ ". Recreating it.") + regenerateIndexData usersDir + let (myIndexData, othersIndexData) = partition ((u ==) . fst) indexData + myIndexDatum = case myIndexData of + [] -> [] + ((_, x) : _) -> x + -- If the list has > 1 element then something's + -- gone wrong, but let's not worry about that + indexData' = (u, take indexWidth ((bn, result) : myIndexDatum)) + : othersIndexData + html = mkIndexHtml indexData' + writeToFile indexDataFile indexData' + writeBinaryFile indexPage $ renderHtml html + +regenerateIndexData :: FilePath -> IO [(User, [(BuildNum, Result)])] +regenerateIndexData usersDir + = do let doUser user = do let root = Server usersDir user + bns <- getBuildNumbers root + let bns' = take indexWidth (reverse bns) + xs <- mapM (doBuild root) bns' + return (user, xs) + doBuild root bn = do res <- readBuildResult root bn + return (bn, res) + users <- getInterestingDirectoryContents usersDir + mapM doUser users + +mkIndexHtml :: [(User, [(BuildNum, Result)])] -> Html +mkIndexHtml xs = header headerHtml + +++ body bodyHtml + where headerHtml = thetitle descriptionHtml + +++ (thelink ! [rel "Stylesheet", + thetype "text/css", + href "../css/builder.css"]) + noHtml + bodyHtml = h1 descriptionHtml + +++ (table ! [border 1]) + (concatHtml builderTable) + descriptionHtml = stringToHtml "Builder summary" + builderTable = [ tr (td uLink +++ mkCells u bnresults) + | (u, bnresults) <- xs + , let uLink = (anchor ! [href (u "index.html")]) + (stringToHtml u) + ] + mkCells u bnresults = [ td (mkCell u bn result) + | (bn, result) <- bnresults ] + mkCell u bn res = (anchor ! [href (u show bn <.> "html"), + theclass (resultToLinkClass res)]) + (stringToHtml (show bn ++ ": " ++ show res)) + hunk ./server/WebpageCreation.hs 268 - mkCells u bnresults = [ td (mkCell u bn result) + mkCells u bnresults = [ mkCell u bn result hunk ./server/WebpageCreation.hs 270 - mkCell u bn res = (anchor ! [href (u show bn <.> "html"), - theclass (resultToLinkClass res)]) - (stringToHtml (show bn ++ ": " ++ show res)) + mkCell u bn res = (td ! [theclass (resultToLinkClass res)]) + $ (anchor ! [href (u show bn <.> "html")]) + $ stringToHtml (show bn ++ ": " ++ show res) hunk ./server/WebpageCreation.hs 263 - builderTable = [ tr (td uLink +++ mkCells u bnresults) + builderTable = [ tr ((td ! [theclass lastResultClass]) uLink +++ + mkCells u bnresults) hunk ./server/WebpageCreation.hs 268 + lastResult = case bnresults of + [] -> Incomplete + (_, res) : _ -> res + lastResultClass = resultToLinkClass lastResult hunk ./server/WebpageCreation.hs 222 - Just i -> return $ idRecentResults i + Just (IndexData i) -> + do let (mine, others) = partition ((u ==) . fst) i + myOne = case mine of + [] -> [] + ((_, x) : _) -> x + -- If the list has > 1 element + -- then something's gone wrong, + -- but let's not worry about that + myOne' = take indexWidth ((bn, result) : myOne) + return ((u, myOne') : others) hunk ./server/WebpageCreation.hs 236 - let (myIndexData, othersIndexData) = partition ((u ==) . fst) indexData - myIndexDatum = case myIndexData of - [] -> [] - ((_, x) : _) -> x - -- If the list has > 1 element then something's - -- gone wrong, but let's not worry about that - indexData' = (u, take indexWidth ((bn, result) : myIndexDatum)) - : othersIndexData - html = mkIndexHtml indexData' - writeToFile indexDataFile indexData' + let html = mkIndexHtml indexData + writeToFile indexDataFile (IndexData indexData) hunk ./server/WebpageCreation.hs 172 - | bidNext i == bn -> return $ bidBuildResults i + | bidNext i == bn -> + return ((bn, result) : bidBuildResults i) hunk ./server/WebpageCreation.hs 181 - let buildResults' = (bn, result) : buildResults - builderIndexData' = BuilderIndexData { + let builderIndexData' = BuilderIndexData { hunk ./server/WebpageCreation.hs 183 - bidBuildResults = buildResults' + bidBuildResults = buildResults hunk ./server/WebpageCreation.hs 185 - html = mkBuilderIndexHtml u buildResults' + html = mkBuilderIndexHtml u buildResults hunk ./builder.css 48 +.nonwrapped { + white-space: nowrap; +} + + hunk ./common/Builder/Files.hs 5 - getBuildNumbers, + getBuildNumbers, getBuildStepNumbers, hunk ./common/Builder/Files.hs 76 +getBuildStepNumbers :: Root -> BuildNum -> IO [BuildStepNum] +getBuildStepNumbers root bn = getSortedNumericDirectoryContents (mkPath root ("builds" show bn "steps")) + hunk ./server/WebpageCreation.hs 24 - buildsDir = usersDir u "builds" - buildDir = buildsDir show bn - stepsDir = buildDir "steps" hunk ./server/WebpageCreation.hs 27 - steps <- getSortedNumericDirectoryContents stepsDir + steps <- getBuildStepNumbers root bn hunk ./server/WebpageCreation.hs 33 - mkBuilderIndex root webBuilderDir u bn result - mkIndex usersDir webRootDir u bn result + mEndTime <- getEndTime' root bn steps + mkBuilderIndex root webBuilderDir u bn mEndTime result + mkIndex usersDir webRootDir u bn mEndTime result hunk ./server/WebpageCreation.hs 47 - maybeToTimeHtml = maybeToHtmlWith - (show . posixSecondsToUTCTime . fromInteger) + maybeToTimeHtml = maybeToHtmlWith endTimeToString hunk ./server/WebpageCreation.hs 156 -data BuilderIndexData = BuilderIndexData { - bidNext :: BuildNum, - bidBuildResults :: [(BuildNum, Result)] - } +data BuilderIndexData + = BuilderIndexData { + bidNext :: BuildNum, + bidBuildResults :: [(BuildNum, Maybe EndTime, Result)] + } hunk ./server/WebpageCreation.hs 163 -mkBuilderIndex :: Root -> FilePath -> User -> BuildNum -> Result -> IO () -mkBuilderIndex root webBuilderDir u bn result +mkBuilderIndex :: Root -> FilePath -> User -> BuildNum + -> Maybe EndTime -> Result + -> IO () +mkBuilderIndex root webBuilderDir u bn mEndTime result hunk ./server/WebpageCreation.hs 173 - return ((bn, result) : bidBuildResults i) + return ((bn, mEndTime, result) : bidBuildResults i) hunk ./server/WebpageCreation.hs 179 - return (bn', res)) + met <- getEndTime root bn' + return (bn', met, res)) hunk ./server/WebpageCreation.hs 190 -mkBuilderIndexHtml :: User -> [(BuildNum, Result)] -> Html +mkBuilderIndexHtml :: User -> [(BuildNum, Maybe EndTime, Result)] -> Html hunk ./server/WebpageCreation.hs 201 - links = [ (anchor ! [href url, theclass (resultToLinkClass res)]) - (stringToHtml (show bn ++ ": " ++ show res)) - | (bn, res) <- xs + links = [ (anchor ! [href url, theclass ("nonwrapped " ++ resultToLinkClass res)]) + text + | (bn, met, res) <- xs hunk ./server/WebpageCreation.hs 205 + text = stringToHtml (show bn ++ ": " ++ show res) + +++ br + +++ mEndTimeToString met hunk ./server/WebpageCreation.hs 211 - idRecentResults :: [(User, [(BuildNum, Result)])] + idRecentResults :: [(User, [(BuildNum, Maybe EndTime, Result)])] hunk ./server/WebpageCreation.hs 220 -mkIndex :: FilePath -> FilePath -> User -> BuildNum -> Result -> IO () -mkIndex usersDir webDir u bn result +mkIndex :: FilePath -> FilePath -> User -> BuildNum -> Maybe EndTime -> Result + -> IO () +mkIndex usersDir webDir u bn mEndTime result hunk ./server/WebpageCreation.hs 235 - myOne' = take indexWidth ((bn, result) : myOne) + myOne' = take indexWidth ((bn, mEndTime, result) : myOne) hunk ./server/WebpageCreation.hs 245 -regenerateIndexData :: FilePath -> IO [(User, [(BuildNum, Result)])] +regenerateIndexData :: FilePath + -> IO [(User, [(BuildNum, Maybe EndTime, Result)])] hunk ./server/WebpageCreation.hs 254 - return (bn, res) + met <- getEndTime root bn + return (bn, met, res) hunk ./server/WebpageCreation.hs 259 -mkIndexHtml :: [(User, [(BuildNum, Result)])] -> Html +mkIndexHtml :: [(User, [(BuildNum, Maybe EndTime, Result)])] -> Html hunk ./server/WebpageCreation.hs 272 - mkCells u bnresults) - | (u, bnresults) <- xs + mkCells u ys) + | (u, ys) <- xs hunk ./server/WebpageCreation.hs 276 - lastResult = case bnresults of + lastResult = case ys of hunk ./server/WebpageCreation.hs 278 - (_, res) : _ -> res + (_, _, res) : _ -> res hunk ./server/WebpageCreation.hs 281 - mkCells u bnresults = [ mkCell u bn result - | (bn, result) <- bnresults ] - mkCell u bn res = (td ! [theclass (resultToLinkClass res)]) - $ (anchor ! [href (u show bn <.> "html")]) - $ stringToHtml (show bn ++ ": " ++ show res) + mkCells u bnresults = [ mkCell u bn met result + | (bn, met, result) <- bnresults ] + mkCell u bn met res + = (td ! [theclass ("nonwrapped " ++ resultToLinkClass res)]) + $ (anchor ! [href (u show bn <.> "html")]) + (stringToHtml (show bn ++ ": " ++ show res) + +++ br + +++ stringToHtml (mEndTimeToString met)) + +getEndTime :: Root -> BuildNum -> IO (Maybe EndTime) +getEndTime root bn = do steps <- getBuildStepNumbers root bn + `onDoesNotExist` + return [] + getEndTime' root bn steps + +getEndTime' :: Root -> BuildNum -> [BuildStepNum] -> IO (Maybe EndTime) +getEndTime' root bn steps = f (reverse steps) + where f [] = return Nothing + f (s : ss) = do met <- readMaybeBuildStepEndTime root bn s + case met of + Just et -> return (Just et) + Nothing -> f ss hunk ./server/WebpageCreation.hs 309 +mEndTimeToString :: Maybe EndTime -> String +mEndTimeToString Nothing = "" +mEndTimeToString (Just et) = endTimeToString et + +endTimeToString :: EndTime -> String +endTimeToString = show . posixSecondsToUTCTime . fromInteger + hunk ./client/client.hs 302 - let buildsDir = baseDir "builds" - bns <- liftIO $ getSortedNumericDirectoryContents buildsDir + let root = Client baseDir + bns <- liftIO $ getBuildNumbers root hunk ./client/client.hs 356 - bsns <- liftIO $ getSortedNumericDirectoryContents stepsDir + bsns <- liftIO $ getBuildStepNumbers root bn hunk ./server/Email.hs 23 - buildsDir = baseDir "clients" u "builds" - buildDir = buildsDir show bn - stepsDir = buildDir "steps" hunk ./server/Email.hs 24 - bsns <- getSortedNumericDirectoryContents stepsDir + bsns <- getBuildStepNumbers root bn hunk ./common/Builder/Files.hs 54 +import Control.Monad hunk ./common/Builder/Files.hs 56 +import Data.Maybe hunk ./common/Builder/Files.hs 386 +readMaybeBuildResult :: MonadIO m => Root -> BuildNum -> m (Maybe Result) +readMaybeBuildResult root bn = maybeReadFromFile $ fpBuildResult root bn + hunk ./common/Builder/Files.hs 390 -readBuildResult root bn = readFromFile $ fpBuildResult root bn +readBuildResult root bn + = liftM (fromMaybe Incomplete) $ readMaybeBuildResult root bn