s464900/gonito
1
0
Fork 0
forked from filipg/gonito
Code Issues Pull Requests Projects Releases Wiki Activity

Challenges can be updated

Browse Source
This commit is contained in:
Filip Gralinski 2019-08-29 08:56:22 +02:00
parent ca42fcbf84
commit 32c77b3c74
7 changed files with 155 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

127
Handler/CreateChallenge.hs
View File

@ -11,6 +11,8 @@ import Handler.Extract
import GEval.Core
import GEval.OptionsParser
import Gonito.ExtractMetadata (getLastCommitMessage)
import System.Directory (doesFileExist)
import System.FilePath.Find as SFF
import System.FilePath
@ -105,7 +107,7 @@ getChallengeUpdateR challengeId = do
$(widgetFile "update-challenge")
postChallengeUpdateR :: ChallengeId -> Handler TypedContent
postChallengeUpdateR _ = do
postChallengeUpdateR challengeId = do
((result, _), _) <- runFormPost updateChallengeForm
let challengeData = case result of
FormSuccess res -> Just res
@ -118,9 +120,81 @@ postChallengeUpdateR _ = do
if userIsAdmin user
then
do
runViewProgress $ (flip err) "TO BE IMPLEMENTED"
runViewProgress $ doChallengeUpdate challengeId updateType publicUrl publicBranch publicGitAnnexRemote privateUrl privateBranch privateGitAnnexRemote
else
runViewProgress $ (flip err) "MUST BE AN ADMIN TO CREATE A CHALLENGE"
runViewProgress $ (flip err) "MUST BE AN ADMIN TO UPDATE A CHALLENGE"
doChallengeUpdate :: ChallengeId -> ChallengeUpdateType -> Text -> Text -> Maybe Text -> Text -> Text -> Maybe Text -> Channel -> Handler ()
doChallengeUpdate challengeId updateType publicUrl publicBranch publicGitAnnexRemote privateUrl privateBranch privateGitAnnexRemote chan = do
challenge <- runDB $ get404 challengeId
(Entity _ version) <- runDB $ getBy404 $ UniqueVersionByCommit $ challengeVersion challenge
let (newMajor, newMinor, newPatch) = incrementVersion updateType (versionMajor version,
versionMinor version,
versionPatch version)
msg chan ("UPDATING TO VERSION: " ++ (pack $ show newMajor) ++ "." ++ (pack $ show newMinor) ++ "." ++ (pack $ show newPatch))
userId <- requireAuthId
(Just publicRepoId) <- getPossiblyExistingRepo (\_ _ _ -> return True)
userId
challengeId
RepoSpec {
repoSpecUrl = publicUrl,
repoSpecBranch = publicBranch,
repoSpecGitAnnexRemote = publicGitAnnexRemote}
chan
(Just privateRepoId) <- getPossiblyExistingRepo (\_ _ _ -> return True)
userId
challengeId
RepoSpec {
repoSpecUrl = privateUrl,
repoSpecBranch = privateBranch,
repoSpecGitAnnexRemote = privateGitAnnexRemote}
chan
privateRepo <- runDB $ get404 $ privateRepoId
repoDir <- getRepoDir privateRepoId
(Just versionDescription) <- liftIO $ getLastCommitMessage repoDir
theNow <- liftIO getCurrentTime
let commit = (repoCurrentCommit privateRepo)
mAlreadyExistingVersion <- runDB $ getBy $ UniqueVersionByCommit commit
case mAlreadyExistingVersion of
Just (Entity versionId _) -> do
runDB $ update versionId [VersionMajor =. newMajor,
VersionMinor =. newMinor,
VersionPatch =. newPatch,
VersionDescription =. versionDescription,
VersionStamp =. theNow]
Nothing -> do
_ <- runDB $ insert $ Version commit
newMajor
newMinor
newPatch
versionDescription
theNow
return ()
(title, description, mImage) <- extractChallengeMetadata publicRepoId chan
runDB $ update challengeId [ChallengePublicRepo =. publicRepoId,
ChallengePrivateRepo =. privateRepoId,
ChallengeVersion =. commit,
ChallengeTitle =. title,
ChallengeDescription =. description,
ChallengeImage =. mImage]
updateTests challengeId chan
return ()
incrementVersion :: ChallengeUpdateType -> (Int, Int, Int) -> (Int, Int, Int)
incrementVersion MajorChange (major, minor, patch) = (major + 1, minor, patch)
incrementVersion MinorChange (major, minor, patch) = (major, minor + 1, patch)
incrementVersion ChallengePatch (major, minor, patch) = (major, minor, patch + 1)
defaultMajorVersion :: Int
@ -135,9 +209,8 @@ defaultPatchVersion = 0
defaultInitialDescription :: Text
defaultInitialDescription = "initial version"
addChallenge :: Text -> (Key Repo) -> (Key Repo) -> Channel -> Handler ()
addChallenge name publicRepoId privateRepoId chan = do
msg chan "adding challenge..."
extractChallengeMetadata :: Key Repo -> Channel -> Handler (Text, Text, Maybe ByteString)
extractChallengeMetadata publicRepoId chan = do
publicRepoDir <- getRepoDir publicRepoId
let readmeFilePath = publicRepoDir </> readmeFile
doesReadmeExist <- liftIO $ doesFileExist readmeFilePath
@ -157,6 +230,14 @@ addChallenge name publicRepoId privateRepoId chan = do
else do
return Nothing
return (T.pack $ title, T.pack $ description, mImage)
addChallenge :: Text -> (Key Repo) -> (Key Repo) -> Channel -> Handler ()
addChallenge name publicRepoId privateRepoId chan = do
msg chan "adding challenge..."
(title, description, mImage) <- extractChallengeMetadata publicRepoId chan
privateRepo <- runDB $ get404 privateRepoId
time <- liftIO getCurrentTime
@ -174,8 +255,8 @@ addChallenge name publicRepoId privateRepoId chan = do
challengePublicRepo=publicRepoId,
challengePrivateRepo=privateRepoId,
challengeName=name,
challengeTitle=(T.pack $ title),
challengeDescription=(T.pack $ description),
challengeTitle=title,
challengeDescription=description,
challengeStamp=time,
challengeImage=mImage,
challengeStarred=False,
@ -222,20 +303,30 @@ checkTestDir chan challengeId challenge commit testDir = do
err chan "Cannot read metric"
return ()
Right opts -> do
_ <- runDB $ mapM (\(priority, metric) -> insert $ Test {
testChallenge=challengeId,
testMetric=metric,
testName=T.pack $ takeFileName testDir,
testChecksum=(SHA1 checksum),
testCommit=commit,
testActive=True,
testPrecision=gesPrecision $ geoSpec opts,
testPriority=Just priority}) $ zip [1..] (gesMetrics $ geoSpec opts)
_ <- runDB $ mapM (insertOrUpdateTest testDir challengeId (SHA1 checksum) commit opts) $ zip [1..] (gesMetrics $ geoSpec opts)
return ()
else
msg chan $ concat ["Test dir ", (T.pack testDir), " does not have expected results."]
return ()
insertOrUpdateTest testDir challengeId checksum commit opts (priority, metric) = do
let name=T.pack $ takeFileName testDir
mAlreadyExistingTest <- getBy $ UniqueChallengeNameMetricChecksum challengeId name metric checksum
case mAlreadyExistingTest of
Just (Entity testId _) -> update testId [TestCommit=.commit,
TestPrecision=.(gesPrecision $ geoSpec opts),
TestPriority=.Just priority]
Nothing -> do
_ <- insert $ Test {
testChallenge=challengeId,
testMetric=metric,
testName=name,
testChecksum=checksum,
testCommit=commit,
testActive=True,
testPrecision=gesPrecision $ geoSpec opts,
testPriority=Just priority}
return ()
gatherSHA1 :: FilePath -> IO ByteString
gatherSHA1 testDir = do
@ -267,7 +358,7 @@ createChallengeForm = renderBootstrap3 BootstrapBasicForm $ (,,,,,,)
updateChallengeForm :: Form (ChallengeUpdateType, Text, Text, Maybe Text, Text, Text, Maybe Text)
updateChallengeForm = renderBootstrap3 BootstrapBasicForm $ (,,,,,,)
<$> areq (radioField optionsEnum) (bfs MsgChangeType) Nothing
<$> areq (radioField optionsEnum) "change type" (Just ChallengePatch)
<*> areq textField (bfs MsgPublicUrl) Nothing
<*> areq textField (bfs MsgBranch) (Just "master")
<*> aopt textField (bfs MsgGitAnnexRemote) Nothing

41
Handler/Shared.hs
View File

@ -177,6 +177,47 @@ getHeadCommit repoDir chan = do
err chan "cannot determine HEAD commit"
return Nothing
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 <- getRepoDir repoId
let repoCloningSpec = RepoCloningSpec {
cloningSpecRepo = repoSpec,
cloningSpecReferenceRepo = RepoSpec {
repoSpecUrl = (T.pack repoDir),
repoSpecBranch = (repoBranch repo),
repoSpecGitAnnexRemote = Nothing
}
}
cloneRepo' userId repoCloningSpec chan
cloneRepo' :: UserId -> RepoCloningSpec -> Channel -> Handler (Maybe (Key Repo))
cloneRepo' userId repoCloningSpec chan = do
let url = repoSpecUrl $ cloningSpecRepo repoCloningSpec

38
Handler/ShowChallenge.hs
View File

@ -587,43 +587,7 @@ rawEval challengeDir metric repoDir name outF = Import.try (runGEvalGetOptions [
"--test-name", (T.unpack name)])
getSubmissionRepo :: UserId -> Key Challenge -> RepoSpec -> Channel -> Handler (Maybe (Key Repo))
getSubmissionRepo 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 <- checkRepoAvailibility 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 <- getRepoDir repoId
let repoCloningSpec = RepoCloningSpec {
cloningSpecRepo = repoSpec,
cloningSpecReferenceRepo = RepoSpec {
repoSpecUrl = (T.pack repoDir),
repoSpecBranch = (repoBranch repo),
repoSpecGitAnnexRemote = Nothing
}
}
cloneRepo' userId repoCloningSpec chan
getSubmissionRepo userId challengeId repoSpec chan = getPossiblyExistingRepo checkRepoAvailibility userId challengeId repoSpec chan
checkRepoAvailibility :: Key Challenge -> Key Repo -> Channel -> Handler Bool
checkRepoAvailibility challengeId repoId chan = do

1
config/models
View File

@ -47,6 +47,7 @@ Version
major Int
minor Int
patch Int
UniqueVersionByCommit commit
UniqueVersion commit major minor patch
description Text
stamp UTCTime default=now()

1
messages/en.msg
View File

@ -82,3 +82,4 @@ MajorChange: major change
MinorChange: minor change
Patch: patch
ChangeType: change type
Update: Update

2
templates/show-challenge.hamlet
View File

@ -10,7 +10,7 @@ $if (checkIfAdmin mUserEnt)
$if (challengeArchived challenge /= Just True)
<form method=post action=@{ArchiveR challengeId}#form enctype="text/plain">
<button>Archive
<form method=post action=@{ChallengeUpdateR challengeId}#form enctype="text/plain">
<form method=get action=@{ChallengeUpdateR challengeId}#form enctype="text/plain">
<button>Update
$if (challengeArchived challenge == Just True)

2
templates/update-challenge.hamlet
View File

@ -4,4 +4,4 @@
<form method=post action=@{ChallengeUpdateR challengeId}#form enctype=#{formEnctype}>
^{formWidget}
<button .btn .btn-primary type="submit">
_{MsgAdd} <span class="glyphicon glyphicon-upload"></span>
_{MsgUpdate} <span class="glyphicon glyphicon-upload"></span>