gonito/Handler/CreateChallenge.hs

468 lines
20 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
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)
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
let challengeData = case result of
2015-08-29 14:58:47 +02:00
FormSuccess res -> Just res
_ -> Nothing
2018-06-05 07:46:42 +02:00
Just (name, publicUrl, publicBranch, publicGitAnnexRemote,
2019-09-24 22:52:25 +02:00
privateUrl, privateBranch, privateGitAnnexRemote,
mDeadlineDay, mDeadlineTime) = challengeData
let mDeadline = combineMaybeDayAndTime mDeadlineDay mDeadlineTime
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
let name' = T.strip name
if isLocalIdAcceptable name'
then
runViewProgress $ doCreateChallenge name'
(T.strip publicUrl)
(T.strip publicBranch)
(T.strip <$> publicGitAnnexRemote)
(T.strip privateUrl)
(T.strip privateBranch)
(T.strip <$> privateGitAnnexRemote)
2019-09-24 22:52:25 +02:00
mDeadline
2018-09-01 12:01:35 +02:00
else
runViewProgress $ (flip err) "unexpected challenge ID (use only lower-case letters, digits and hyphens, start with a letter)"
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
2019-09-24 22:52:25 +02:00
doCreateChallenge :: Text -> Text -> Text -> Maybe Text -> Text -> Text -> Maybe Text -> Maybe UTCTime -> Channel -> Handler ()
doCreateChallenge name publicUrl publicBranch publicGitAnnexRemote privateUrl privateBranch privateGitAnnexRemote mDeadline chan = do
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
2016-01-08 21:57:29 +01:00
publicRepoDir <- getRepoDir publicRepoId
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
isValidated <- validateChallenge privateRepoId chan
when isValidated $ addChallenge name publicRepoId privateRepoId mDeadline 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)
instance Show ChallengeUpdateType where
show MajorChange = "major change"
show MinorChange = "minor change"
show ChallengePatch = "patch"
2019-09-24 22:52:25 +02:00
fetchChallengeData :: (MonadIO m, PersistUniqueRead backend, BaseBackend backend ~ SqlBackend) => Key Challenge -> ReaderT backend m (Repo, Repo, Maybe UTCTime)
fetchChallengeData challengeId = do
challenge <- get404 challengeId
publicRepo <- get404 $ challengePublicRepo challenge
privateRepo <- get404 $ challengePrivateRepo challenge
version <- getBy404 $ UniqueVersionByCommit $ challengeVersion challenge
return (publicRepo, privateRepo, versionDeadline $ entityVal $ version)
2019-08-28 08:49:43 +02:00
getChallengeUpdateR :: ChallengeId -> Handler Html
getChallengeUpdateR challengeId = do
2019-09-24 22:52:25 +02:00
(publicRepo, privateRepo, mDeadline) <- runDB $ fetchChallengeData challengeId
(formWidget, formEnctype) <- generateFormPost $ updateChallengeForm publicRepo privateRepo mDeadline
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
2019-09-24 22:52:25 +02:00
(publicRepo, privateRepo, mDeadline) <- runDB $ fetchChallengeData challengeId
((result, _), _) <- runFormPost $ updateChallengeForm publicRepo privateRepo mDeadline
2019-08-28 08:49:43 +02:00
let challengeData = case result of
FormSuccess res -> Just res
_ -> Nothing
Just (updateType, publicUrl, publicBranch, publicGitAnnexRemote,
2019-09-24 22:52:25 +02:00
privateUrl, privateBranch, privateGitAnnexRemote,
mDeadlineDay, mDeadlineTime) = challengeData
let mNewDeadline = combineMaybeDayAndTime mDeadlineDay mDeadlineTime
2019-08-28 08:49:43 +02:00
userId <- requireAuthId
user <- runDB $ get404 userId
if userIsAdmin user
then
do
2019-09-24 22:52:25 +02:00
runViewProgress $ doChallengeUpdate challengeId
updateType
mNewDeadline
publicUrl
publicBranch
publicGitAnnexRemote
privateUrl
privateBranch
privateGitAnnexRemote
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
doChallengeUpdate :: ChallengeId -> ChallengeUpdateType -> Maybe UTCTime
-> Text -> Text -> Maybe Text
-> Text -> Text -> Maybe Text
-> Channel -> Handler ()
doChallengeUpdate challengeId
updateType
newDeadline
publicUrl
publicBranch
publicGitAnnexRemote
privateUrl
privateBranch
privateGitAnnexRemote
chan = do
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
2019-12-13 22:14:00 +01:00
isValidated <- validateChallenge privateRepoId chan
when isValidated $
do
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 [VersionDeadline =. newDeadline,
VersionMajor =. newMajor,
VersionMinor =. newMinor,
VersionPatch =. newPatch,
VersionDescription =. versionDescription,
VersionStamp =. theNow]
Nothing -> do
_ <- runDB $ insert $ Version (Just challengeId)
commit
newDeadline
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 ()
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
2016-01-08 21:57:29 +01:00
publicRepoDir <- getRepoDir publicRepoId
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)
2019-09-24 22:52:25 +02:00
addChallenge :: Text -> (Key Repo) -> (Key Repo) -> Maybe UTCTime -> Channel -> Handler ()
addChallenge name publicRepoId privateRepoId deadline 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,
challengeSensitive=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,
versionStamp=time}
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
2016-01-08 21:57:29 +01:00
repoDir <- getRepoDir repoId
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
2016-01-08 21:57:29 +01:00
challengeRepoDir <- getRepoDir $ challengePrivateRepo challenge
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,
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 ()
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-*")
2019-09-24 22:52:25 +02:00
createChallengeForm :: Form (Text, Text, Text, Maybe Text, Text, Text, Maybe Text, Maybe Day, Maybe TimeOfDay)
createChallengeForm = renderBootstrap3 BootstrapBasicForm $ (,,,,,,,,)
2018-09-01 12:01:35 +02:00
<$> areq textField (fieldWithTooltip MsgChallengeName MsgChallengeNameTooltip) Nothing
<*> areq textField (bfs MsgPublicUrl) Nothing
<*> areq textField (bfs MsgBranch) (Just "master")
<*> aopt textField (bfs MsgGitAnnexRemote) Nothing
<*> areq textField (bfs MsgPrivateUrl) Nothing
<*> areq textField (bfs MsgBranch) (Just "dont-peek")
<*> aopt textField (bfs MsgGitAnnexRemote) Nothing
2019-09-24 22:52:25 +02:00
<*> aopt dayField (bfs MsgChallengeDeadlineDay) Nothing
<*> aopt timeFieldTypeTime (fieldWithTooltip MsgChallengeDeadlineTime MsgChallengeDeadlineTooltip) Nothing
2019-08-28 08:49:43 +02:00
2019-09-24 22:52:25 +02:00
updateChallengeForm :: Repo -> Repo -> Maybe UTCTime -> Form (ChallengeUpdateType,
Text, Text, Maybe Text,
Text, Text, Maybe Text,
Maybe Day, Maybe TimeOfDay)
updateChallengeForm publicRepo privateRepo mDeadline = renderBootstrap3 BootstrapBasicForm $ (,,,,,,,,)
2019-08-29 08:56:22 +02:00
<$> areq (radioField optionsEnum) "change type" (Just ChallengePatch)
2019-09-24 22:52:25 +02:00
<*> areq textField (bfs MsgPublicUrl) (Just $ repoUrl publicRepo)
<*> areq textField (bfs MsgBranch) (Just $ repoBranch publicRepo)
<*> aopt textField (bfs MsgGitAnnexRemote) (Just $ repoGitAnnexRemote publicRepo)
<*> areq textField (bfs MsgPrivateUrl) (Just $ repoUrl privateRepo)
<*> areq textField (bfs MsgBranch) (Just $ repoBranch privateRepo)
<*> aopt textField (bfs MsgGitAnnexRemote) (Just $ repoGitAnnexRemote privateRepo)
<*> aopt dayField (bfs MsgChallengeDeadlineDay) (Just $ utctDay <$> mDeadline)
<*> aopt timeFieldTypeTime (fieldWithTooltip MsgChallengeDeadlineTime MsgChallengeDeadlineTooltip)
(Just $ timeToTimeOfDay <$> utctDayTime <$> mDeadline)
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`)
validateChallenge :: RepoId -- ID of the private repository
-> Channel
-> Handler Bool -- returns false if not validated
validateChallenge repoId chan = do
msg chan "Validating the challenge..."
repoDir <- getRepoDir repoId
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