gonito/Handler/CreateChallenge.hs

505 lines
22 KiB
Haskell
Raw Normal View History

2015-08-29 14:58:47 +02:00
module Handler.CreateChallenge where
import Import
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3,
2018-09-01 12:01:35 +02:00
bfs)
2015-08-29 14:58:47 +02:00
2015-08-29 18:24:01 +02:00
import Handler.Shared
2018-06-05 08:22:51 +02:00
import Handler.Runner
2015-09-04 15:10:47 +02:00
import Handler.Extract
import GEval.Core
import GEval.OptionsParser
2019-09-24 22:52:25 +02:00
import GEval.EvaluationScheme
2019-12-13 22:14:00 +01:00
import GEval.Validation
2020-08-08 21:52:44 +02:00
import GEval.Common (FormattingOptions(..))
2019-08-29 08:56:22 +02:00
import Gonito.ExtractMetadata (getLastCommitMessage)
2015-09-04 15:10:47 +02:00
import System.Directory (doesFileExist)
2015-09-04 22:21:51 +02:00
import System.FilePath.Find as SFF
2015-09-29 18:23:11 +02:00
import System.FilePath
2015-09-04 15:10:47 +02:00
import qualified Data.Text as T
2015-08-29 18:24:01 +02:00
2019-09-24 22:52:25 +02:00
import Data.Time.Clock (secondsToDiffTime)
import Data.Time.LocalTime (timeOfDayToTime, TimeOfDay, timeToTimeOfDay)
2015-09-04 22:21:51 +02:00
import PersistSHA1
2018-01-18 08:21:06 +01:00
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.Conduit.Binary (sinkLbs, sourceFile)
2020-03-26 18:55:01 +01:00
data ChallengeCreationData = ChallengeCreationData {
challengeCreationDataName :: Text,
challengeCreationMetadata :: ChallengeMetadata }
2020-03-26 18:55:01 +01:00
data ChallengeMetadata = ChallengeMetadata {
challengeMetadataPublicUrl :: Text,
challengeMetadataPublicBranch :: Text,
challengeMetadataPublicGitAnnexRemote :: Maybe Text,
2020-03-26 18:55:01 +01:00
challengeMetadataPrivateUrl :: Text,
challengeMetadataPrivateBranch :: Text,
challengeMetadataPrivateGitAnnexRemote :: Maybe Text,
2020-03-26 18:55:01 +01:00
2020-03-26 21:01:04 +01:00
challengeMetadataDeadline :: Maybe UTCTime,
2021-09-25 18:37:08 +02:00
challengeMetadataValidate :: Bool,
challengeMetadataPhase :: Maybe Text }
2020-03-26 18:55:01 +01:00
2015-08-29 14:58:47 +02:00
getCreateChallengeR :: Handler Html
getCreateChallengeR = do
2018-09-01 12:01:35 +02:00
(formWidget, formEnctype) <- generateFormPost createChallengeForm
2015-08-29 14:58:47 +02:00
defaultLayout $ do
setTitle "Welcome To Yesod!"
$(widgetFile "create-challenge")
2015-08-29 18:24:01 +02:00
postCreateChallengeR :: Handler TypedContent
2015-08-29 14:58:47 +02:00
postCreateChallengeR = do
2018-09-01 12:01:35 +02:00
((result, _), _) <- runFormPost createChallengeForm
2020-03-26 18:55:01 +01:00
let challengeData' = case result of
2015-08-29 14:58:47 +02:00
FormSuccess res -> Just res
_ -> Nothing
2020-03-26 18:55:01 +01:00
Just challengeData = challengeData'
2015-08-29 14:58:47 +02:00
2015-10-06 22:56:57 +02:00
userId <- requireAuthId
user <- runDB $ get404 userId
if userIsAdmin user
then
2018-09-01 12:01:35 +02:00
do
2020-03-26 18:55:01 +01:00
let name = challengeCreationDataName challengeData
2018-09-01 12:01:35 +02:00
2020-03-26 18:55:01 +01:00
if isLocalIdAcceptable name
2018-09-01 12:01:35 +02:00
then
2020-03-26 18:55:01 +01:00
runViewProgress $ doCreateChallenge challengeData
2018-09-01 12:01:35 +02:00
else
2021-05-12 07:03:38 +02:00
runViewProgress $ (flip err) "unexpected challenge ID (use only lower-case letters, digits and hyphens, start with a letter or a digit)"
2015-10-06 22:56:57 +02:00
else
runViewProgress $ (flip err) "MUST BE AN ADMIN TO CREATE A CHALLENGE"
2015-09-04 06:47:49 +02:00
2020-03-26 18:55:01 +01:00
doCreateChallenge :: ChallengeCreationData -> Channel -> Handler ()
doCreateChallenge creationData chan = do
let name = challengeCreationDataName creationData
let challengeMetadata = challengeCreationMetadata creationData
let publicUrl = challengeMetadataPublicUrl challengeMetadata
let publicBranch = challengeMetadataPublicBranch challengeMetadata
let publicGitAnnexRemote = challengeMetadataPublicGitAnnexRemote challengeMetadata
2020-03-26 18:55:01 +01:00
let privateUrl = challengeMetadataPrivateUrl challengeMetadata
let privateBranch = challengeMetadataPrivateBranch challengeMetadata
let privateGitAnnexRemote = challengeMetadataPrivateGitAnnexRemote challengeMetadata
2020-03-26 18:55:01 +01:00
let mDeadline = challengeMetadataDeadline challengeMetadata
2020-03-26 21:01:04 +01:00
let shouldBeValidated = challengeMetadataValidate challengeMetadata
2020-03-26 18:55:01 +01:00
2021-09-25 18:37:08 +02:00
mPhaseTagId <- fetchPhaseTagId (challengeMetadataPhase challengeMetadata)
2018-06-04 21:58:05 +02:00
maybePublicRepoId <- cloneRepo (RepoCloningSpec {
2018-06-04 22:14:39 +02:00
cloningSpecRepo = RepoSpec {
repoSpecUrl = publicUrl,
2018-09-01 12:01:35 +02:00
repoSpecBranch = publicBranch,
repoSpecGitAnnexRemote = publicGitAnnexRemote},
cloningSpecReferenceRepo = RepoSpec {
2018-06-04 22:14:39 +02:00
repoSpecUrl = publicUrl,
2018-09-01 12:01:35 +02:00
repoSpecBranch = publicBranch,
repoSpecGitAnnexRemote = publicGitAnnexRemote}}) chan
2015-09-04 06:47:49 +02:00
case maybePublicRepoId of
Just publicRepoId -> do
publicRepo <- runDB $ get404 publicRepoId
publicRepoDir <- getRepoDirOrClone publicRepoId chan
2018-06-04 21:58:05 +02:00
maybePrivateRepoId <- cloneRepo (RepoCloningSpec {
2018-06-04 22:14:39 +02:00
cloningSpecRepo = RepoSpec {
repoSpecUrl = privateUrl,
2018-06-05 07:46:42 +02:00
repoSpecBranch = privateBranch,
repoSpecGitAnnexRemote = privateGitAnnexRemote},
2018-06-04 22:14:39 +02:00
cloningSpecReferenceRepo = RepoSpec {
repoSpecUrl =(T.pack $ publicRepoDir),
2018-06-05 07:46:42 +02:00
repoSpecBranch = (repoBranch publicRepo),
repoSpecGitAnnexRemote = (repoGitAnnexRemote publicRepo)}}) chan
2015-09-04 10:16:12 +02:00
case maybePrivateRepoId of
2019-12-13 22:14:00 +01:00
Just privateRepoId -> do
2020-03-26 21:01:04 +01:00
isValidated <- validateChallenge shouldBeValidated privateRepoId chan
2021-09-25 18:37:08 +02:00
when isValidated $ addChallenge name publicRepoId privateRepoId mDeadline mPhaseTagId chan
2018-09-01 12:01:35 +02:00
Nothing -> return ()
2015-09-04 06:47:49 +02:00
Nothing -> return ()
2015-08-29 14:58:47 +02:00
2019-08-28 08:49:43 +02:00
data ChallengeUpdateType = MajorChange | MinorChange | ChallengePatch
deriving (Eq, Enum, Bounded)
data ChallengeUpdateData = ChallengeUpdateData {
challengeUpdateDataType :: ChallengeUpdateType,
challengeUpdateDataMetadata :: ChallengeMetadata }
2019-08-28 08:49:43 +02:00
instance Show ChallengeUpdateType where
show MajorChange = "major change"
show MinorChange = "minor change"
show ChallengePatch = "patch"
2021-09-25 18:37:08 +02:00
fetchChallengeData :: (MonadIO m, PersistUniqueRead backend, BaseBackend backend ~ SqlBackend) => Key Challenge -> ReaderT backend m (Repo, Repo, Maybe UTCTime, Maybe Tag)
2019-09-24 22:52:25 +02:00
fetchChallengeData challengeId = do
challenge <- get404 challengeId
publicRepo <- get404 $ challengePublicRepo challenge
privateRepo <- get404 $ challengePrivateRepo challenge
version <- getBy404 $ UniqueVersionByCommit $ challengeVersion challenge
2021-09-25 18:37:08 +02:00
mTag <- case versionPhase $ entityVal version of
Just phaseTagId -> get phaseTagId
Nothing -> return Nothing
return (publicRepo, privateRepo, versionDeadline $ entityVal $ version, mTag)
2019-09-24 22:52:25 +02:00
2019-08-28 08:49:43 +02:00
getChallengeUpdateR :: ChallengeId -> Handler Html
getChallengeUpdateR challengeId = do
2021-09-25 18:37:08 +02:00
(publicRepo, privateRepo, mDeadline, mTag) <- runDB $ fetchChallengeData challengeId
(formWidget, formEnctype) <- generateFormPost $ updateChallengeForm publicRepo privateRepo mDeadline mTag
2019-09-24 22:52:25 +02:00
defaultLayout $ do
setTitle "Welcome To Yesod!"
$(widgetFile "update-challenge")
2019-08-28 08:49:43 +02:00
postChallengeUpdateR :: ChallengeId -> Handler TypedContent
2019-08-29 08:56:22 +02:00
postChallengeUpdateR challengeId = do
2021-09-25 18:37:08 +02:00
(publicRepo, privateRepo, mDeadline, mTag) <- runDB $ fetchChallengeData challengeId
((result, _), _) <- runFormPost $ updateChallengeForm publicRepo privateRepo mDeadline mTag
let challengeData' = case result of
2019-08-28 08:49:43 +02:00
FormSuccess res -> Just res
_ -> Nothing
Just challengeData = challengeData'
2019-08-28 08:49:43 +02:00
userId <- requireAuthId
user <- runDB $ get404 userId
if userIsAdmin user
then
do
runViewProgress $ doChallengeUpdate challengeId challengeData
2019-08-28 08:49:43 +02:00
else
2019-08-29 08:56:22 +02:00
runViewProgress $ (flip err) "MUST BE AN ADMIN TO UPDATE A CHALLENGE"
2019-09-24 22:52:25 +02:00
combineMaybeDayAndTime :: Maybe Day -> Maybe TimeOfDay -> Maybe UTCTime
combineMaybeDayAndTime mDeadlineDay mDeadlineTime =
case mDeadlineDay of
Just deadlineDay -> Just $ UTCTime {
utctDay = deadlineDay,
utctDayTime = fromMaybe (secondsToDiffTime 24 * 60 * 60 - 1) $ timeOfDayToTime <$> mDeadlineTime }
Nothing -> Nothing
2021-09-25 18:37:08 +02:00
fetchPhaseTagId mPhase = do
mPhaseTagEnt <- case mPhase of
Just phase -> runDB $ getBy $ UniqueTagName phase
Nothing -> return Nothing
return (entityKey <$> mPhaseTagEnt)
doChallengeUpdate :: ChallengeId -> ChallengeUpdateData -> Channel -> Handler ()
doChallengeUpdate challengeId challengeData chan = do
let updateType = challengeUpdateDataType challengeData
let metadata = challengeUpdateDataMetadata challengeData
let publicUrl = challengeMetadataPublicUrl metadata
let publicBranch = challengeMetadataPublicBranch metadata
let publicGitAnnexRemote = challengeMetadataPublicGitAnnexRemote metadata
let privateUrl = challengeMetadataPrivateUrl metadata
let privateBranch = challengeMetadataPrivateBranch metadata
let privateGitAnnexRemote = challengeMetadataPrivateGitAnnexRemote metadata
let newDeadline = challengeMetadataDeadline metadata
2020-03-26 21:01:04 +01:00
let shouldBeValidated = challengeMetadataValidate metadata
2019-09-24 22:52:25 +02:00
2021-09-25 18:37:08 +02:00
mPhaseTagId <- fetchPhaseTagId (challengeMetadataPhase metadata)
2019-08-29 08:56:22 +02:00
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
2020-03-26 21:01:04 +01:00
isValidated <- validateChallenge shouldBeValidated privateRepoId chan
2019-12-13 22:14:00 +01:00
when isValidated $
do
privateRepo <- runDB $ get404 $ privateRepoId
repoDir <- getRepoDirOrClone privateRepoId chan
2019-12-13 22:14:00 +01:00
(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 [VersionDeadline =. newDeadline,
VersionMajor =. newMajor,
VersionMinor =. newMinor,
VersionPatch =. newPatch,
VersionDescription =. versionDescription,
2021-09-25 18:37:08 +02:00
VersionStamp =. theNow,
VersionPhase =. mPhaseTagId]
2019-12-13 22:14:00 +01:00
Nothing -> do
_ <- runDB $ insert $ Version (Just challengeId)
commit
newDeadline
newMajor
newMinor
newPatch
versionDescription
theNow
2021-09-25 18:37:08 +02:00
mPhaseTagId
2019-12-13 22:14:00 +01:00
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 ()
2019-08-29 08:56:22 +02:00
return ()
incrementVersion :: ChallengeUpdateType -> (Int, Int, Int) -> (Int, Int, Int)
2019-09-23 17:35:39 +02:00
incrementVersion MajorChange (major, _, _) = (major + 1, 0, 0)
incrementVersion MinorChange (major, minor, _) = (major, minor + 1, 0)
2019-08-29 08:56:22 +02:00
incrementVersion ChallengePatch (major, minor, patch) = (major, minor, patch + 1)
2019-08-28 08:49:43 +02:00
2019-08-27 22:36:51 +02:00
defaultMajorVersion :: Int
defaultMajorVersion = 1
defaultMinorVersion :: Int
defaultMinorVersion = 0
defaultPatchVersion :: Int
defaultPatchVersion = 0
defaultInitialDescription :: Text
defaultInitialDescription = "initial version"
2019-08-29 08:56:22 +02:00
extractChallengeMetadata :: Key Repo -> Channel -> Handler (Text, Text, Maybe ByteString)
extractChallengeMetadata publicRepoId chan = do
publicRepoDir <- getRepoDirOrClone publicRepoId chan
2015-09-04 15:10:47 +02:00
let readmeFilePath = publicRepoDir </> readmeFile
doesReadmeExist <- liftIO $ doesFileExist readmeFilePath
(title, description) <- if doesReadmeExist
then
liftIO $ extractTitleAndDescription readmeFilePath
else do
err chan "README was not found"
return (defaultTitle, defaultDescription)
2018-01-18 08:21:06 +01:00
let imageFilePath = publicRepoDir </> imageFile
doesImageFileExists <- liftIO $ doesFileExist imageFilePath
mImage <- if doesImageFileExists
then do
fileBytes <- liftIO $ runResourceT $ sourceFile imageFilePath $$ sinkLbs
return $ Just (S.pack . L.unpack $ fileBytes)
else do
return Nothing
2019-08-29 08:56:22 +02:00
return (T.pack $ title, T.pack $ description, mImage)
2021-09-25 18:37:08 +02:00
addChallenge :: Text -> (Key Repo) -> (Key Repo) -> Maybe UTCTime -> Maybe TagId -> Channel -> Handler ()
addChallenge name publicRepoId privateRepoId deadline mPhaseTagId chan = do
2019-08-29 08:56:22 +02:00
msg chan "adding challenge..."
(title, description, mImage) <- extractChallengeMetadata publicRepoId chan
2019-08-27 22:36:51 +02:00
privateRepo <- runDB $ get404 privateRepoId
2015-09-04 10:16:12 +02:00
time <- liftIO getCurrentTime
2019-08-27 22:36:51 +02:00
let commit=repoCurrentCommit $ privateRepo
2015-09-04 10:16:12 +02:00
challengeId <- runDB $ insert $ Challenge {
challengePublicRepo=publicRepoId,
challengePrivateRepo=privateRepoId,
challengeName=name,
2019-08-29 08:56:22 +02:00
challengeTitle=title,
challengeDescription=description,
2018-01-18 08:21:06 +01:00
challengeStamp=time,
2018-01-18 09:21:21 +01:00
challengeImage=mImage,
2019-03-20 16:31:08 +01:00
challengeStarred=False,
2019-08-27 22:36:51 +02:00
challengeArchived=Just False,
2019-12-14 18:21:47 +01:00
challengeVersion=commit,
2021-03-22 08:19:47 +01:00
challengeSensitive=Just False,
challengeIsCompetition=Just False}
2019-08-27 22:36:51 +02:00
2019-09-24 22:52:25 +02:00
_ <- runDB $ insert $ Version {
versionChallenge=Just challengeId,
versionCommit=commit,
versionDeadline=deadline,
versionMajor=defaultMajorVersion,
versionMinor=defaultMinorVersion,
versionPatch=defaultPatchVersion,
versionDescription=defaultInitialDescription,
2021-09-25 18:37:08 +02:00
versionStamp=time,
versionPhase=mPhaseTagId }
2019-09-24 22:52:25 +02:00
2015-09-04 22:21:51 +02:00
updateTests challengeId chan
2019-08-27 22:36:51 +02:00
2015-09-04 22:21:51 +02:00
return ()
updateTests :: (Key Challenge) -> Channel -> Handler ()
updateTests challengeId chan = do
challenge <- runDB $ get404 challengeId
let repoId = challengePrivateRepo challenge
repoDir <- getRepoDirOrClone repoId chan
2015-09-04 22:21:51 +02:00
repo <- runDB $ get404 repoId
let commit = repoCurrentCommit repo
testDirs <- liftIO $ findTestDirs repoDir
mapM_ (checkTestDir chan challengeId challenge commit) testDirs
2015-09-04 22:21:51 +02:00
msg chan (T.pack $ show testDirs)
return ()
2018-06-09 15:35:31 +02:00
expectedFileName :: FilePath
2015-09-04 22:21:51 +02:00
expectedFileName = "expected.tsv"
doesExpectedExist :: FilePath -> IO Bool
2018-06-09 15:35:31 +02:00
doesExpectedExist fp = do
2019-02-14 22:57:29 +01:00
efs <- mapM (\ext -> findFilePossiblyCompressed (fp </> expectedFileName -<.> ext)) extensionsHandled
return $ not $ null $ catMaybes efs
2015-09-04 22:21:51 +02:00
checkTestDir :: Channel -> (Key Challenge) -> Challenge -> SHA1 -> FilePath -> Handler ()
checkTestDir chan challengeId challenge commit testDir = do
2015-09-04 22:21:51 +02:00
expectedExists <- liftIO $ doesExpectedExist testDir
if expectedExists
then do
msg chan $ concat ["Test dir ", (T.pack testDir), " found."]
checksum <- liftIO $ gatherSHA1 testDir
challengeRepoDir <- getRepoDirOrClone (challengePrivateRepo challenge) chan
optionsParsingResult <- liftIO $ getOptions [
2016-01-08 21:57:29 +01:00
"--expected-directory", challengeRepoDir,
"--test-name", takeFileName testDir]
case optionsParsingResult of
Left _ -> do
err chan "Cannot read metric"
return ()
Right opts -> do
2019-08-29 08:56:22 +02:00
_ <- runDB $ mapM (insertOrUpdateTest testDir challengeId (SHA1 checksum) commit opts) $ zip [1..] (gesMetrics $ geoSpec opts)
return ()
2015-09-04 22:21:51 +02:00
else
msg chan $ concat ["Test dir ", (T.pack testDir), " does not have expected results."]
2015-09-04 10:16:12 +02:00
return ()
2019-09-24 22:52:25 +02:00
insertOrUpdateTest :: (MonadIO m, PersistUniqueRead backend, PersistStoreWrite backend, BaseBackend backend ~ SqlBackend) => FilePath -> Key Challenge -> SHA1 -> SHA1 -> GEvalOptions -> (Int, EvaluationScheme) -> ReaderT backend m ()
2019-08-29 08:56:22 +02:00
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,
2020-09-05 16:45:09 +02:00
TestPrecision=.(decimalPlaces $ gesFormatting $ geoSpec opts),
TestAsPercentage=.(Just $ asPercentage $ gesFormatting $ geoSpec opts),
2019-08-29 08:56:22 +02:00
TestPriority=.Just priority]
Nothing -> do
_ <- insert $ Test {
testChallenge=challengeId,
testMetric=metric,
testName=name,
testChecksum=checksum,
testCommit=commit,
testActive=True,
2020-08-08 21:52:44 +02:00
testPrecision=decimalPlaces $ gesFormatting $ geoSpec opts,
2020-09-05 16:45:09 +02:00
testAsPercentage=Just $ asPercentage $ gesFormatting $ geoSpec opts,
2019-08-29 08:56:22 +02:00
testPriority=Just priority}
return ()
2015-09-04 10:16:12 +02:00
2015-09-04 22:21:51 +02:00
gatherSHA1 :: FilePath -> IO ByteString
gatherSHA1 testDir = do
files <- SFF.find always isTestDirHashedFile testDir
2015-09-29 14:15:49 +02:00
gatherSHA1ForCollectionOfFiles files
2015-09-04 22:21:51 +02:00
isTestDirHashedFile :: FindClause Bool
isTestDirHashedFile = fileType ==? RegularFile
findTestDirs :: FilePath -> IO [FilePath]
findTestDirs = SFF.find never testDirFilter
never :: FindClause Bool
never = depth ==? 0
testDirFilter :: FindClause Bool
testDirFilter = (fileType ==? Directory) &&? (SFF.fileName ~~? "dev-*" ||? SFF.fileName ~~? "test-*")
2020-03-26 18:55:01 +01:00
createChallengeForm :: Form ChallengeCreationData
createChallengeForm = renderBootstrap3 BootstrapBasicForm $ ChallengeCreationData
<$> (T.strip <$> areq textField (fieldWithTooltip MsgChallengeName MsgChallengeNameTooltip) Nothing)
2021-09-25 18:37:08 +02:00
<*> challengeMetadataInputs Nothing Nothing Nothing Nothing
challengeMetadataInputs :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage, RenderMessage (HandlerSite m) AppMessage)
2021-09-25 18:37:08 +02:00
=> Maybe Repo -> Maybe Repo -> Maybe UTCTime -> Maybe Tag -> AForm m ChallengeMetadata
challengeMetadataInputs mPublicRepo mPrivateRepo mDeadline mPhase =
ChallengeMetadata <$> (T.strip <$> areq textField (bfs MsgPublicUrl) (repoUrl <$> mPublicRepo))
<*> (T.strip <$> areq textField (bfs MsgBranch) (Just $ maybe "master" repoBranch mPublicRepo))
<*> (fmap T.strip <$> aopt textField (bfs MsgGitAnnexRemote) (repoGitAnnexRemote <$> mPublicRepo))
<*> (T.strip <$> areq textField (bfs MsgPrivateUrl) (repoUrl <$> mPrivateRepo))
<*> (T.strip <$> areq textField (bfs MsgBranch) (Just $ maybe "dont-peek" repoBranch mPrivateRepo))
<*> (fmap T.strip <$> aopt textField (bfs MsgGitAnnexRemote) (repoGitAnnexRemote <$> mPrivateRepo))
<*> (combineMaybeDayAndTime <$> aopt dayField (bfs MsgChallengeDeadlineDay) (Just $ utctDay <$> mDeadline)
<*> aopt timeFieldTypeTime (fieldWithTooltip MsgChallengeDeadlineTime MsgChallengeDeadlineTooltip) (Just $ timeToTimeOfDay <$> utctDayTime <$> mDeadline))
2020-03-26 21:01:04 +01:00
<*> areq checkBoxField (bfs MsgShouldChallengeBeValidated) (Just True)
2021-09-25 18:37:08 +02:00
<*> aopt textField (bfs MsgPhase) (Just (tagName <$> mPhase))
2021-09-25 18:37:08 +02:00
updateChallengeForm :: Repo -> Repo -> Maybe UTCTime -> Maybe Tag -> Form ChallengeUpdateData
updateChallengeForm publicRepo privateRepo mDeadline mPhase = renderBootstrap3 BootstrapBasicForm $ ChallengeUpdateData
2019-08-29 08:56:22 +02:00
<$> areq (radioField optionsEnum) "change type" (Just ChallengePatch)
2021-09-25 18:37:08 +02:00
<*> challengeMetadataInputs (Just publicRepo) (Just privateRepo) mDeadline mPhase
2019-12-13 22:14:00 +01:00
-- Validate whether a challenge is correct.
-- Contrary to `GEval.Validate.validationChallenge` do not
-- throw an exception (just return `False`)
2020-03-26 21:01:04 +01:00
validateChallenge :: Bool -- switch whether really validate
-> RepoId -- ID of the private repository
2019-12-13 22:14:00 +01:00
-> Channel
-> Handler Bool -- returns false if not validated
2020-03-26 21:01:04 +01:00
validateChallenge False _ chan = do
msg chan "SKIPPING CHALLENGE VALIDATION"
return True
validateChallenge True repoId chan = do
2019-12-13 22:14:00 +01:00
msg chan "Validating the challenge..."
repoDir <- getRepoDirOrClone repoId chan
2019-12-13 22:14:00 +01:00
optionsParsingResult <- liftIO $ getOptions [
"--expected-directory", repoDir]
case optionsParsingResult of
Left _ -> do
err chan "Cannot read metric"
return False
Right opts -> do
result <- liftIO (try $ validationChallenge repoDir (geoSpec opts) :: IO (Either SomeException ()))
case result of
Left ex -> do
err chan (T.pack $ "Invalid challenge!!! " ++ (show ex))
return False
Right _ -> return True