gonito/Handler/Shared.hs

769 lines
28 KiB
Haskell
Raw Normal View History

2015-08-29 18:24:01 +02:00
{-# LANGUAGE RecordWildCards #-}
2018-11-14 17:41:01 +01:00
{-# LANGUAGE ScopedTypeVariables #-}
2021-07-30 12:19:27 +02:00
{-# LANGUAGE QuasiQuotes #-}
2015-08-29 18:24:01 +02:00
module Handler.Shared where
import Import
import qualified Data.IntMap as IntMap
import Yesod.WebSockets
2018-06-05 08:22:51 +02:00
import Handler.Runner
import System.Exit
2021-07-30 12:19:27 +02:00
2015-08-29 22:19:44 +02:00
import qualified Data.Text as T
import Database.Persist.Sql (fromSqlKey)
2015-08-29 22:19:44 +02:00
import Control.Concurrent.Lifted (threadDelay)
2018-05-20 16:58:48 +02:00
import Control.Concurrent (forkIO)
2015-08-30 12:33:47 +02:00
2015-09-29 14:15:49 +02:00
import qualified Crypto.Hash.SHA1 as CHS
2018-01-25 16:34:05 +01:00
import qualified Data.List as DL
2015-09-04 06:47:49 +02:00
import System.Random
import System.Directory (doesFileExist, renameDirectory, doesDirectoryExist)
2015-09-04 10:51:53 +02:00
2015-09-04 06:47:49 +02:00
import PersistSHA1
2015-08-30 12:33:47 +02:00
import Text.Printf
import Yesod.Form.Bootstrap3 (bfs)
import qualified Test.RandomStrings as RS
2017-09-28 11:29:48 +02:00
import qualified Crypto.Nonce as Nonce
import System.IO.Unsafe (unsafePerformIO)
2018-09-01 12:01:35 +02:00
import Text.Regex.TDFA
import Web.Announcements (formatLink, AnnouncementHook)
2021-08-21 09:45:37 +02:00
import GEval.Core
2020-08-08 21:52:44 +02:00
import GEval.Common
import GEval.EvaluationScheme
2020-01-28 23:14:46 +01:00
import GEval.Formatting (formatTheResultWithErrorBounds)
import qualified Data.Vector as DV
2016-01-08 21:57:29 +01:00
arena :: Handler FilePath
arena = do
app <- getYesod
return $ (appVarDir $ appSettings app) </> "arena"
2015-09-04 06:47:49 +02:00
gitPath :: FilePath
gitPath = "/usr/bin/git"
browsableGitSite :: Text
2017-09-23 10:33:39 +02:00
browsableGitSite = "https://gonito.net/gitlist/"
serverAddress :: Text
serverAddress = "gonito.net"
2016-02-15 11:43:47 +01:00
gitServer :: Text
gitServer = "ssh://gitolite@" ++ serverAddress ++ "/"
gitReadOnlyServer :: Text
gitReadOnlyServer = "git://" ++ serverAddress ++ "/"
getPublicSubmissionBranch :: SubmissionId -> Text
getPublicSubmissionBranch = T.pack . (printf "submission-%05d") . fromSqlKey
2019-12-07 22:48:58 +01:00
getPublicSubmissionUrl :: RepoScheme -> Text -> Maybe Repo -> Text -> Text
getPublicSubmissionUrl SelfHosted repoHost _ bareRepoName = repoHost ++ bareRepoName
getPublicSubmissionUrl Branches _ (Just repo) _ = repoUrl repo
getPublicSubmissionUrl NoInternalGitServer repoHost _ bareRepoName = repoHost ++ bareRepoName
getReadOnlySubmissionUrl :: RepoScheme -> Repo -> Text -> Text
getReadOnlySubmissionUrl SelfHosted _ bareRepoName = gitReadOnlyServer ++ bareRepoName
getReadOnlySubmissionUrl Branches repo _ = repoUrl repo
getReadOnlySubmissionUrl NoInternalGitServer repo _ = repoUrl repo
browsableGitRepoBranch :: RepoScheme -> Repo -> Text -> Text -> Text
browsableGitRepoBranch SelfHosted _ bareRepoName branch = (browsableGitRepo bareRepoName) ++ "/" ++ branch ++ "/"
browsableGitRepoBranch Branches repo _ branch = sshToHttps (repoUrl repo) branch
browsableGitRepoBranch NoInternalGitServer repo _ branch = sshToHttps (repoUrl repo) branch
sshToHttps :: Text -> Text -> Text
2018-06-06 14:18:27 +02:00
sshToHttps url branch = "https://" ++ (T.replace ".git" "" $ T.replace ":" "/" $ T.replace "ssh://" "" $ T.replace "git@" "" url) ++ "/tree/" ++ branch
2016-02-15 11:43:47 +01:00
browsableGitRepo :: Text -> Text
browsableGitRepo bareRepoName
| ".git" `isSuffixOf` bareRepoName = browsableGitSite ++ bareRepoName
| otherwise = browsableGitSite ++ bareRepoName ++ ".git"
2017-09-28 11:29:48 +02:00
2015-08-30 12:33:47 +02:00
runViewProgress :: (Channel -> Handler ()) -> Handler TypedContent
runViewProgress action = do
app <- getYesod
let viewingProgressStyle = appViewingProgressStyle $ appSettings app
runViewProgress' (case viewingProgressStyle of
WithWebSockets -> ViewProgressWithWebSocketsR
WithPlainText -> ViewProgressR)
action
2017-09-28 11:29:48 +02:00
runOpenViewProgress :: (Channel -> Handler ()) -> Handler TypedContent
runOpenViewProgress = runViewProgress' OpenViewProgressR
runViewProgressWithWebSockets :: (Channel -> Handler ()) -> Handler TypedContent
runViewProgressWithWebSockets = runViewProgress' ViewProgressWithWebSocketsR
consoleApp :: Int -> WebSocketsT Handler ()
consoleApp jobId = do
App {..} <- getYesod
mchan <- liftIO $ atom $ do
m <- readTVar jobs
case IntMap.lookup jobId m of
Nothing -> return Nothing
2021-07-30 12:19:27 +02:00
Just chan -> fmap Just $ cloneTChan chan
case mchan of
Nothing -> do
sendTextData ("CANNOT FIND THE OUTPUT (ALREADY SHOWN??)" :: Text)
_ <- sendCloseE ("" :: Text)
return ()
Just chan -> do
let loop = do
mtext <- liftIO $ atom $ readTChan chan
case mtext of
Nothing -> sendCloseE ("" :: Text)
Just text -> do
sendTextData text
loop
_ <- loop
return ()
2021-07-30 12:19:27 +02:00
getViewProgressWithWebSocketsJsonR :: Int -> Handler Value
getViewProgressWithWebSocketsJsonR jobId = do
webSockets $ consoleApp jobId
return $ String $ pack $ show jobId
getViewProgressLogR :: Int -> Handler Html
getViewProgressLogR jobId = do
webSockets $ consoleApp jobId
2021-08-09 22:07:44 +02:00
p <- widgetToPageContent logSelfContainedWidget
2021-07-30 12:19:27 +02:00
hamletToRepHtml [hamlet|
<html>
<head>
<title>
#{pageTitle p}
2021-08-09 22:07:44 +02:00
<style>
#outwindow {
border: 1px solid black;
margin-bottom: 1em;
color: white;
background-color: black;
padding: 10pt;
}
#outwindow pre {
color: white;
background-color: black;
}
#wait {
animation: blink 1s linear infinite;
}
@keyframes blink {
0% {
opacity: 0;
}
50% {
opacity: .5;
}
100% {
opacity: 1;
}
}
2021-07-30 12:19:27 +02:00
^{pageHead p}
<body>
^{pageBody p}
|]
2021-08-09 22:07:44 +02:00
logHtmlContent :: WidgetFor site ()
logHtmlContent = [whamlet|
<div #outwindow>
<div #output>
<div #wait>
... PLEASE WAIT ...
|]
2021-08-09 22:07:44 +02:00
logCssContent = [lucius|
#outwindow {
border: 1px solid black;
margin-bottom: 1em;
color: white;
background-color: black;
padding: 10pt;
}
#outwindow pre {
color: white;
background-color: black;
}
#wait {
animation: blink 1s linear infinite;
}
@keyframes blink {
0% {
opacity: 0;
}
50% {
opacity: .5;
}
100% {
opacity: 1;
}
}
|]
2021-08-09 22:07:44 +02:00
logJsContent :: JavascriptUrl url
logJsContent = [julius|
var url = document.URL,
output = document.getElementById("output"),
wait = document.getElementById("wait"),
conn;
2021-04-24 17:43:53 +02:00
var anchor_name_regex = /\#.*$/;
url = url.replace("http:", "ws:").replace("https:", "wss:").replace(anchor_name_regex, "")
conn = new WebSocket(url);
conn.onmessage = function(e) {
var p = document.createElement("pre");
p.appendChild(document.createTextNode(e.data));
output.appendChild(p);
};
conn.onclose = function(e) {
wait.parentNode.removeChild(wait);
};
|]
2021-08-09 22:07:44 +02:00
logWidget :: WidgetFor site ()
logWidget = do
logHtmlContent
toWidget logCssContent
toWidget logJsContent
logSelfContainedWidget :: WidgetFor site ()
logSelfContainedWidget = do
logHtmlContent
-- for some reason, CSS content be put directly in the HTML
-- so it was copied & pasted
-- toWidgetHead logCssContent
toWidgetBody logJsContent
2021-07-30 12:19:27 +02:00
getViewProgressWithWebSocketsR :: Int -> Handler Html
getViewProgressWithWebSocketsR jobId = do
webSockets $ consoleApp jobId
defaultLayout logWidget
2021-01-17 20:37:25 +01:00
runViewProgressAsynchronously :: (Channel -> Handler ()) -> Handler Value
runViewProgressAsynchronously action = runViewProgressGeneralized getJobIdAsJson action
-- where getJobIdAsJson jobId = return $ Number (scientific (toInteger jobId) 0)
where getJobIdAsJson jobId = return $ String $ pack $ show jobId
2017-09-28 11:29:48 +02:00
runViewProgress' :: (Int -> Route App) -> (Channel -> Handler ()) -> Handler TypedContent
2021-01-17 20:37:25 +01:00
runViewProgress' route action = runViewProgressGeneralized doRedirection action
where doRedirection jobId = redirect $ route jobId
runViewProgressGeneralized :: (Int -> Handler v) -> (Channel -> Handler ()) -> Handler v
runViewProgressGeneralized handler action = do
2015-08-29 18:24:01 +02:00
App {..} <- getYesod
2021-07-30 12:19:27 +02:00
jobId' <- randomInt
-- we don't want negative numbers (so that nobody would be confused)
let jobId = abs jobId'
2015-09-04 06:47:49 +02:00
chan <- liftIO $ atom $ do
2021-07-30 12:19:27 +02:00
chan <- newTChan
2015-08-29 18:24:01 +02:00
m <- readTVar jobs
writeTVar jobs $ IntMap.insert jobId chan m
2015-09-04 06:47:49 +02:00
return chan
2018-05-20 16:58:48 +02:00
runInnerHandler <- handlerToIO
_ <- liftIO $ forkIO $ runInnerHandler $ do
2015-08-30 12:33:47 +02:00
liftIO $ threadDelay 1000000
2015-08-29 18:24:01 +02:00
action chan
2015-08-30 12:33:47 +02:00
liftIO $ atom $ do
2015-08-29 18:24:01 +02:00
writeTChan chan $ Just "All done\n"
writeTChan chan Nothing
2021-07-30 12:19:27 +02:00
-- TODO we don't remove logs, they could clog up the memory
-- m <- readTVar jobs
-- writeTVar jobs $ IntMap.delete jobId m
2021-01-17 20:37:25 +01:00
handler jobId
2018-06-04 21:58:05 +02:00
data RepoCloningSpec = RepoCloningSpec {
2018-06-04 22:14:39 +02:00
cloningSpecRepo :: RepoSpec,
cloningSpecReferenceRepo :: RepoSpec
}
2018-06-01 22:52:49 +02:00
2018-06-04 22:14:39 +02:00
data RepoSpec = RepoSpec {
repoSpecUrl :: Text,
2018-06-05 07:46:42 +02:00
repoSpecBranch :: Text,
repoSpecGitAnnexRemote :: Maybe Text
2018-06-01 22:52:49 +02:00
}
2018-06-04 21:58:05 +02:00
cloneRepo :: RepoCloningSpec -> Channel -> Handler (Maybe (Key Repo))
2018-06-04 22:14:39 +02:00
cloneRepo repoCloningSpec chan = do
let url = repoSpecUrl $ cloningSpecRepo repoCloningSpec
let branch = repoSpecBranch $ cloningSpecRepo repoCloningSpec
2015-08-30 12:33:47 +02:00
maybeRepo <- runDB $ getBy $ UniqueUrlBranch url branch
userId <- requireAuthId
2015-08-29 22:19:44 +02:00
case maybeRepo of
Just _ -> do
err chan "Repo already there"
return Nothing
Nothing -> cloneRepo' userId repoCloningSpec chan
2015-09-28 23:43:55 +02:00
updateRepo :: Key Repo -> Channel -> Handler Bool
updateRepo repoId chan = do
repo <- runDB $ get404 repoId
repoDir <- getRepoDirOrClone repoId chan
2016-02-11 22:25:07 +01:00
let branch = repoBranch repo
exitCode <- runWithChannel chan $ do
runProg (Just repoDir) gitPath ["fetch",
"origin",
T.unpack branch,
"--progress"]
runProg (Just repoDir) gitPath ["reset",
"--hard",
"FETCH_HEAD"]
getStuffUsingGitAnnex repoDir (repoGitAnnexRemote repo)
2015-09-28 23:43:55 +02:00
case exitCode of
ExitSuccess -> do
maybeHeadCommit <- getHeadCommit repoDir chan
case maybeHeadCommit of
Just headCommit -> do
runDB $ update repoId [RepoCurrentCommit =. headCommit]
return True
Nothing -> return False
_ -> return False
2015-09-28 23:43:55 +02:00
-- | Get a directionary with a submission.
-- It may reset a git repository which might be risky if a repository
-- is shared among a number of submissions.
getSubmissionRepoDir :: SubmissionId -> Channel -> Handler (Maybe FilePath)
getSubmissionRepoDir submissionId chan = do
submission <- runDB $ get404 submissionId
repoDir <- getRepoDirOrClone (submissionRepo submission) chan
let sha1Code = submissionCommit submission
-- this is not right... it should be fixed in the future
-- 1. All kinds of mayhem may ensue in case of concurrency
-- 2. ... especially if the repository is shared among a number of submissions
-- 3. The commit might not be actually there (it might have been garbage collected).
(exitCode, _) <- runProgram (Just repoDir) gitPath ["reset", "--hard", T.unpack $ fromSHA1ToText sha1Code] chan
case exitCode of
ExitSuccess -> return (Just repoDir)
ExitFailure _ -> return Nothing
2019-12-14 18:21:47 +01:00
justGetSubmissionRepoDir :: SubmissionId -> Handler (Maybe FilePath)
justGetSubmissionRepoDir submissionId = do
devNullChan <- liftIO newTChanIO
getSubmissionRepoDir submissionId devNullChan
2015-09-28 23:43:55 +02:00
getHeadCommit :: FilePath -> Channel -> Handler (Maybe SHA1)
getHeadCommit repoDir chan = do
(exitCode, out) <- runProgram (Just repoDir) gitPath ["rev-parse", "HEAD"] chan
case exitCode of
ExitSuccess -> do
msg chan $ concat ["HEAD commit is ", commitId]
return $ Just commitRaw
where commitId = T.replace "\n" "" out
commitRaw = fromTextToSHA1 commitId
ExitFailure _ -> do
err chan "cannot determine HEAD commit"
return Nothing
2019-08-29 08:56:22 +02:00
getPossiblyExistingRepo :: (Key Challenge -> Key Repo -> Channel -> Handler Bool)
-> UserId -> Key Challenge -> RepoSpec -> Channel -> Handler (Maybe (Key Repo))
getPossiblyExistingRepo checkRepo userId challengeId repoSpec chan = do
let url = repoSpecUrl repoSpec
let branch = repoSpecBranch repoSpec
let gitAnnexRemote = repoSpecGitAnnexRemote repoSpec
maybeRepo <- runDB $ getBy $ UniqueUrlBranch url branch
case maybeRepo of
Just (Entity repoId _) -> do
msg chan "Repo already there"
available <- checkRepo challengeId repoId chan
if available
then
do
-- this is not completely right... some other thread
-- might update this to a different value
runDB $ update repoId [RepoGitAnnexRemote =. gitAnnexRemote]
updateStatus <- updateRepo repoId chan
if updateStatus
then
return $ Just repoId
else
return Nothing
else
return Nothing
Nothing -> do
challenge <- runDB $ get404 challengeId
let repoId = challengePublicRepo challenge
repo <- runDB $ get404 repoId
repoDir <- getRepoDirOrClone repoId chan
2019-08-29 08:56:22 +02:00
let repoCloningSpec = RepoCloningSpec {
cloningSpecRepo = repoSpec,
cloningSpecReferenceRepo = RepoSpec {
repoSpecUrl = (T.pack repoDir),
repoSpecBranch = (repoBranch repo),
repoSpecGitAnnexRemote = Nothing
}
}
cloneRepo' userId repoCloningSpec chan
2020-09-05 11:52:33 +02:00
cloneRepoToTempDir :: RepoCloningSpec -> Channel -> Handler (ExitCode, FilePath)
cloneRepoToTempDir repoCloningSpec chan = do
let url = repoSpecUrl $ cloningSpecRepo repoCloningSpec
msg chan $ concat ["Preparing to clone repo ", url]
msg chan "Cloning..."
r <- randomInt
arenaDir <- arena
let tmpRepoDir = arenaDir </> ("t" ++ show r)
exitCode <- rawClone tmpRepoDir repoCloningSpec chan
return (exitCode, tmpRepoDir)
2019-08-29 08:56:22 +02:00
cloneRepo' :: UserId -> RepoCloningSpec -> Channel -> Handler (Maybe (Key Repo))
cloneRepo' userId repoCloningSpec chan = do
2020-09-05 11:52:33 +02:00
let url = repoSpecUrl $ cloningSpecRepo repoCloningSpec
(exitCode, tmpRepoDir) <- cloneRepoToTempDir repoCloningSpec chan
case exitCode of
2015-09-04 06:47:49 +02:00
ExitSuccess -> do
2015-09-28 23:43:55 +02:00
maybeHeadCommit <- getHeadCommit tmpRepoDir chan
case maybeHeadCommit of
Just commitRaw -> do
2015-09-04 06:47:49 +02:00
time <- liftIO getCurrentTime
repoId <- runDB $ insert $ Repo {
repoUrl=url,
2018-06-04 22:14:39 +02:00
repoBranch=repoSpecBranch $ cloningSpecRepo repoCloningSpec,
2018-06-05 07:46:42 +02:00
repoGitAnnexRemote=repoSpecGitAnnexRemote $ cloningSpecRepo repoCloningSpec,
2015-09-04 10:02:33 +02:00
repoCurrentCommit=commitRaw,
2015-09-04 06:47:49 +02:00
repoOwner=userId,
repoReady=True,
repoStamp=time }
2016-01-08 21:57:29 +01:00
repoDir <- getRepoDir repoId
2015-09-04 10:51:53 +02:00
liftIO $ renameDirectory tmpRepoDir repoDir
msg chan $ concat ["Repo is in ", (T.pack repoDir)]
2015-09-04 06:47:49 +02:00
return $ Just repoId
2015-09-28 23:43:55 +02:00
Nothing -> do
2015-09-04 06:47:49 +02:00
return Nothing
ExitFailure _ -> do
err chan "git failed"
return Nothing
2015-08-29 22:19:44 +02:00
2019-12-07 21:26:50 +01:00
-- An auxilliary function for fixing git URLs.
-- By default, this does nothing, but can be changed
-- in Gonito forks.
-- Should be used just before a raw git command is executed
-- (i.e. its changes will not be reflected in the database).
fixGitRepoUrl :: Text -> Text
fixGitRepoUrl = id
2018-06-05 09:36:48 +02:00
rawClone :: FilePath -> RepoCloningSpec -> Channel -> Handler ExitCode
rawClone tmpRepoDir repoCloningSpec chan = runWithChannel chan $ do
2018-06-04 22:14:39 +02:00
let url = repoSpecUrl $ cloningSpecRepo repoCloningSpec
let branch = repoSpecBranch $ cloningSpecRepo repoCloningSpec
let referenceUrl = repoSpecUrl $ cloningSpecReferenceRepo repoCloningSpec
let referenceBranch = repoSpecBranch $ cloningSpecReferenceRepo repoCloningSpec
2018-06-05 09:36:48 +02:00
runProg Nothing gitPath ["clone",
"--progress",
2018-10-15 14:19:20 +02:00
"--single-branch",
2018-06-05 09:36:48 +02:00
"--branch",
T.unpack referenceBranch,
2019-12-07 21:26:50 +01:00
T.unpack (fixGitRepoUrl referenceUrl),
2018-06-05 09:36:48 +02:00
tmpRepoDir]
2015-11-11 09:50:32 +01:00
if url /= referenceUrl || branch /= referenceBranch
then
do
2018-06-05 09:36:48 +02:00
runProg (Just tmpRepoDir) gitPath ["remote",
"set-url",
"origin",
2019-12-07 21:26:50 +01:00
T.unpack (fixGitRepoUrl url)]
2018-06-05 09:36:48 +02:00
runProg (Just tmpRepoDir) gitPath ["fetch",
"origin",
T.unpack branch]
runProg (Just tmpRepoDir) gitPath ["reset",
"--hard",
"FETCH_HEAD"]
2018-06-05 16:23:16 +02:00
getStuffUsingGitAnnex tmpRepoDir (repoSpecGitAnnexRemote $ cloningSpecRepo repoCloningSpec)
2015-11-11 09:50:32 +01:00
else
2018-06-05 09:36:48 +02:00
return ()
2015-09-28 23:43:55 +02:00
2018-06-05 16:23:16 +02:00
getStuffUsingGitAnnex :: FilePath -> Maybe Text -> Runner ()
getStuffUsingGitAnnex _ Nothing = return ()
getStuffUsingGitAnnex tmpRepoDir (Just gitAnnexRemote) = do
let randomRemoteNameLen = 10
remoteName <- liftIO $ RS.randomString (RS.onlyAlpha RS.randomASCII) randomRemoteNameLen
2018-06-05 16:23:16 +02:00
runGitAnnex tmpRepoDir ["init"]
2018-06-05 16:57:44 +02:00
runGitAnnex tmpRepoDir (["initremote", remoteName] ++ (words $ T.unpack gitAnnexRemote))
2018-06-05 16:23:16 +02:00
runGitAnnex tmpRepoDir ["get", "--from", remoteName]
runGitAnnex :: FilePath -> [String] -> Runner ()
runGitAnnex tmpRepoDir args = runProg (Just tmpRepoDir) gitPath ("annex":args)
2021-02-17 09:31:23 +01:00
doesRepoExistsOnTheDisk :: RepoId -> Handler Bool
doesRepoExistsOnTheDisk repoId = do
repoDir <- getRepoDir repoId
repoDirExists <- liftIO $ doesDirectoryExist repoDir
return repoDirExists
-- Gets a directory for an already cloned repo (e.g. arena/r1234). If,
-- for some reason, the directory does not exist (e.g. the database
-- was recovered on a new computer), it will re-clone the repository.
getRepoDirOrClone :: RepoId -> Channel -> Handler FilePath
getRepoDirOrClone repoId chan = do
2021-02-17 09:31:23 +01:00
repoDirExists <- doesRepoExistsOnTheDisk repoId
repoDir <- getRepoDir repoId
if repoDirExists
then
return ()
else
do
repo <- runDB $ get404 repoId
let repoSpec = RepoSpec {
repoSpecUrl = repoUrl repo,
repoSpecBranch = repoBranch repo,
repoSpecGitAnnexRemote = repoGitAnnexRemote repo }
let repoCloningSpec = RepoCloningSpec {
cloningSpecRepo = repoSpec,
cloningSpecReferenceRepo = repoSpec }
(exitCode, tmpRepoDir) <- cloneRepoToTempDir repoCloningSpec chan
case exitCode of
ExitSuccess -> do
let commitHash = fromSHA1ToText $ repoCurrentCommit repo
(exitCode', _) <- runProgram (Just tmpRepoDir) gitPath ["reset",
"--hard",
T.unpack commitHash] chan
case exitCode' of
ExitSuccess -> do
liftIO $ renameDirectory tmpRepoDir repoDir
return ()
ExitFailure _ -> do
err chan $ "cannot reset to commit" ++ commitHash
return ()
ExitFailure _ -> do
err chan "git failed"
return ()
return repoDir
2016-01-08 21:57:29 +01:00
getRepoDir :: Key Repo -> Handler FilePath
getRepoDir repoId = do
arenaDir <- arena
return $ arenaDir </> ("r" ++ repoIdAsString)
where repoIdAsString = show $ fromSqlKey repoId
2015-09-04 10:51:53 +02:00
2017-09-28 11:29:48 +02:00
getOpenViewProgressR :: Int -> Handler TypedContent
getOpenViewProgressR = getViewProgressR
2015-08-29 18:24:01 +02:00
getViewProgressR :: Int -> Handler TypedContent
getViewProgressR jobId = do
App {..} <- getYesod
mchan <- liftIO $ atom $ do
m <- readTVar jobs
case IntMap.lookup jobId m of
Nothing -> return Nothing
2021-07-30 12:19:27 +02:00
Just chan -> fmap Just $ cloneTChan chan
2015-08-29 18:24:01 +02:00
case mchan of
Nothing -> notFound
Just chan -> respondSource typePlain $ do
let loop = do
mtext <- liftIO $ atom $ readTChan chan
case mtext of
Nothing -> return ()
Just text -> do
sendChunkText text
sendFlush
loop
loop
2015-08-30 12:33:47 +02:00
2015-09-04 06:47:49 +02:00
randomInt :: Handler Int
randomInt = liftIO $ randomIO
2015-09-29 14:15:49 +02:00
gatherSHA1ForCollectionOfFiles :: [FilePath] -> IO ByteString
gatherSHA1ForCollectionOfFiles files = do
contentss <- mapM readFile $ sort files
return $ CHS.finalize $ foldl' CHS.update CHS.init contentss
2016-05-03 08:46:10 +02:00
anonymizedLabel :: Text
anonymizedLabel = "[anonymized]"
nameNotGivenLabel :: Text
nameNotGivenLabel = "[name not given]"
2016-05-03 08:46:10 +02:00
formatSubmitter :: User -> Text
formatSubmitter user = if userIsAnonymous user
then
anonymizedLabel
2016-05-03 08:46:10 +02:00
else
case userName user of
Just name -> name
Nothing -> nameNotGivenLabel
fieldWithTooltip :: forall master msg msg1. (RenderMessage master msg, RenderMessage master msg1) => msg -> msg1 -> FieldSettings master
fieldWithTooltip name tooltip = (bfs name) { fsTooltip = Just $ SomeMessage tooltip }
2017-09-28 11:29:48 +02:00
nonceGen :: Nonce.Generator
nonceGen = unsafePerformIO Nonce.new
{-# NOINLINE nonceGen #-}
-- | Randomly create a new verification key.
newToken :: MonadIO m => m Text
newToken = Nonce.nonce128urlT nonceGen
2017-09-28 16:51:10 +02:00
enableTriggerToken :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, YesodPersist site, PersistStoreWrite (YesodPersistBackend site)) => Key User -> Maybe a -> HandlerFor site ()
2017-09-28 16:51:10 +02:00
enableTriggerToken _ (Just _) = return ()
enableTriggerToken userId Nothing = do
token <- newToken
runDB $ update userId [UserTriggerToken =. Just token]
2018-01-25 16:34:05 +01:00
thenCmp :: Ordering -> Ordering -> Ordering
thenCmp EQ o2 = o2
thenCmp o1 _ = o1
fetchMainTest :: (MonadIO m, PersistQueryRead backend, BaseBackend backend ~ SqlBackend) => Key Challenge -> ReaderT backend m (Maybe (Entity Test))
2019-09-10 08:59:30 +02:00
fetchMainTest challengeId = do
challenge <- get404 challengeId
activeTests <- selectList [TestChallenge ==. challengeId,
TestActive ==. True,
TestCommit ==. challengeVersion challenge] []
2019-09-10 08:59:30 +02:00
return $ getMainTest activeTests
fetchTestByName :: (MonadIO m, PersistQueryRead backend, BaseBackend backend ~ SqlBackend) => Maybe Text -> Key Challenge -> ReaderT backend m (Maybe (Entity Test))
fetchTestByName Nothing challengeId = fetchMainTest challengeId
fetchTestByName (Just tName) challengeId = do
challenge <- get404 challengeId
tests' <- selectList [TestChallenge ==. challengeId,
TestCommit ==. challengeVersion challenge] []
let tests = sortBy (flip testComparator) tests'
return $ find (\t -> formatTestEvaluationScheme (entityVal t) == tName) tests
-- get the test with the highest priority
getMainTest :: [Entity Test] -> Maybe (Entity Test)
getMainTest [] = Nothing
getMainTest tests = Just $ DL.maximumBy testComparator tests
2018-07-28 19:59:29 +02:00
-- get all the non-dev tests starting with the one with the highest priorty
-- (or all the tests if there are no non-dev tests)
getMainTests :: [Entity Test] -> [Entity Test]
getMainTests tests = sortBy testComparator tests'
where tests' = if null tests''
then tests
else tests''
tests'' = filter (not . ("dev-" `isPrefixOf`) . testName . entityVal) tests
2018-07-28 19:59:29 +02:00
testComparator :: Entity Test -> Entity Test -> Ordering
testComparator (Entity _ a) (Entity _ b) =
((testName a) `compare` (testName b))
`thenCmp`
((fromMaybe unknownPriority $ testPriority b) `compare` (fromMaybe unknownPriority $ testPriority a))
where unknownPriority = 9999
2018-01-25 16:34:05 +01:00
formatNonScientifically :: Double -> Text
formatNonScientifically = T.pack . (printf "%f")
2018-01-25 16:34:05 +01:00
formatFullScore :: Maybe Evaluation -> Text
formatFullScore (Just evaluation) = fromMaybe "???" (formatNonScientifically <$> evaluationScore evaluation)
2018-01-25 16:34:05 +01:00
formatFullScore Nothing = "N/A"
2020-09-05 16:45:09 +02:00
formatTruncatedScore :: FormattingOptions -> Maybe Evaluation -> Text
2018-01-25 16:34:05 +01:00
formatTruncatedScore _ Nothing = formatFullScore Nothing
2020-09-05 16:45:09 +02:00
formatTruncatedScore formattingOpts (Just evaluation) = case evaluationScore evaluation of
2020-08-08 21:52:44 +02:00
Just score -> T.pack $ formatTheResultWithErrorBounds formattingOpts score (evaluationErrorBound evaluation)
2018-01-25 16:34:05 +01:00
Nothing -> formatFullScore Nothing
2020-08-08 21:52:44 +02:00
2018-06-09 15:35:31 +02:00
2020-09-05 16:45:09 +02:00
getTestFormattingOpts :: Test -> FormattingOptions
getTestFormattingOpts test =
FormattingOptions {
decimalPlaces = testPrecision test,
asPercentage = fromMaybe False $ testAsPercentage test
}
formatScore :: Maybe Int -> Double -> Text
formatScore Nothing = T.pack . show
formatScore (Just precision) = T.pack . (printf "%0.*f" precision)
2018-07-28 17:04:27 +02:00
formatParameter :: Parameter -> Text
formatParameter param = parameterName param ++ "=" ++ parameterValue param
formatTestEvaluationScheme :: Test -> Text
formatTestEvaluationScheme = T.pack . evaluationSchemeName . testMetric
2018-07-28 17:04:27 +02:00
formatTest :: Test -> Text
formatTest test = (testName test) ++ "/" ++ (formatTestEvaluationScheme test)
2018-07-28 17:04:27 +02:00
formatTestForHtml :: Test -> Text
formatTestForHtml test = (testName test) ++ " " ++ (formatTestEvaluationScheme test)
2018-06-09 15:35:31 +02:00
findFilePossiblyCompressed :: FilePath -> IO (Maybe FilePath)
findFilePossiblyCompressed baseFilePath = do
let possibleFiles = [baseFilePath] ++ (map (baseFilePath <.>) ["gz", "bz2", "xz"])
foundFiles <- filterM doesFileExist possibleFiles
return $ case foundFiles of
[] -> Nothing
(h:_) -> Just h
2018-09-01 12:01:35 +02:00
localIdRegexp :: Regex
2021-05-12 07:03:38 +02:00
localIdRegexp = makeRegexOpts defaultCompOpt{newSyntax=True} defaultExecOpt ("\\`[a-z0-9][-a-z0-9]{0,63}\\'" ::String)
2018-09-01 12:01:35 +02:00
unwantedLocalIds :: [Text]
unwantedLocalIds = ["git",
"gitolite",
"admin",
"root",
"filipg"]
isLocalIdAcceptable :: Text -> Bool
isLocalIdAcceptable localId =
match localIdRegexp (unpack localId) && not (localId `elem` unwantedLocalIds)
-- need to transfer the information into a JS script
getIsHigherTheBetterArray :: [Test] -> Value
getIsHigherTheBetterArray = Array
. DV.fromList
. map (convertIsHigherTheBetter
. getMetricOrdering
. evaluationSchemeMetric
. testMetric)
where convertIsHigherTheBetter TheHigherTheBetter = Bool True
convertIsHigherTheBetter _ = Bool False
2018-09-21 17:55:00 +02:00
compareFun :: MetricOrdering -> Double -> Double -> Ordering
compareFun TheLowerTheBetter = flip compare
compareFun TheHigherTheBetter = compare
2018-11-14 17:41:01 +01:00
linkInAnnouncement :: Maybe AnnouncementHook -> App -> Text -> Text -> Text
linkInAnnouncement hook app title addr = formatLink hook slink title
where slink = (appRoot $ appSettings app) ++ "/" ++ addr
2019-12-13 22:29:41 +01:00
formatVersion :: (Int, Int, Int) -> Text
formatVersion (major, minor, patch) = (T.pack $ show major)
<> "." <> (T.pack $ show minor)
<> "." <> (T.pack $ show patch)
checkWhetherGivenUserRepo :: (PersistStoreRead backend, MonadIO m, BaseBackend backend ~ SqlBackend)
=> Key User -> Key Submission -> ReaderT backend m Bool
checkWhetherGivenUserRepo userId submissionId = do
submission <- get404 submissionId
return $ userId == submissionSubmitter submission
fetchTheEvaluation :: (MonadIO m, PersistUniqueRead backend, BaseBackend backend ~ SqlBackend)
=> Out -> SHA1 -> ReaderT backend m (Maybe (Entity Evaluation))
fetchTheEvaluation out version =
getBy $ UniqueEvaluationTestChecksumVersion (outTest out) (outChecksum out) version