2015-08-29 14:58:47 +02:00
|
|
|
module Handler.CreateChallenge where
|
|
|
|
|
|
|
|
import Import
|
|
|
|
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3,
|
|
|
|
withSmallInput)
|
|
|
|
|
2015-08-29 18:24:01 +02:00
|
|
|
import Handler.Shared
|
2015-09-04 15:10:47 +02:00
|
|
|
import Handler.Extract
|
|
|
|
|
2015-12-20 21:00:00 +01:00
|
|
|
import GEval.Core
|
|
|
|
import GEval.OptionsParser
|
|
|
|
|
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
|
|
|
|
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
|
|
|
|
(formWidget, formEnctype) <- generateFormPost sampleForm
|
2015-09-04 22:21:51 +02:00
|
|
|
let submission = Nothing :: Maybe (Import.FileInfo, Text)
|
2015-08-29 14:58:47 +02:00
|
|
|
handlerName = "getCreateChallengeR" :: Text
|
|
|
|
defaultLayout $ do
|
|
|
|
aDomId <- newIdent
|
|
|
|
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
|
|
|
|
((result, formWidget), formEnctype) <- runFormPost sampleForm
|
|
|
|
let handlerName = "postCreateChallengeR" :: Text
|
|
|
|
challengeData = case result of
|
|
|
|
FormSuccess res -> Just res
|
|
|
|
_ -> Nothing
|
2015-08-29 22:19:44 +02:00
|
|
|
Just (name, publicUrl, publicBranch, privateUrl, privateBranch) = 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
|
|
|
|
runViewProgress $ doCreateChallenge name publicUrl publicBranch privateUrl privateBranch
|
|
|
|
else
|
|
|
|
runViewProgress $ (flip err) "MUST BE AN ADMIN TO CREATE A CHALLENGE"
|
2015-09-04 06:47:49 +02:00
|
|
|
|
|
|
|
doCreateChallenge :: Text -> Text -> Text -> Text -> Text -> Channel -> Handler ()
|
|
|
|
doCreateChallenge name publicUrl publicBranch privateUrl privateBranch 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,
|
|
|
|
repoSpecBranch = publicBranch },
|
|
|
|
cloningSpecReferenceRepo = RepoSpec {
|
|
|
|
repoSpecUrl = publicUrl,
|
|
|
|
repoSpecBranch = publicBranch}}) chan
|
2015-09-04 06:47:49 +02:00
|
|
|
case maybePublicRepoId of
|
|
|
|
Just publicRepoId -> do
|
2015-11-11 10:24:03 +01:00
|
|
|
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,
|
|
|
|
repoSpecBranch = privateBranch },
|
|
|
|
cloningSpecReferenceRepo = RepoSpec {
|
|
|
|
repoSpecUrl =(T.pack $ publicRepoDir),
|
|
|
|
repoSpecBranch = (repoBranch publicRepo)}}) chan
|
2015-09-04 10:16:12 +02:00
|
|
|
case maybePrivateRepoId of
|
|
|
|
Just privateRepoId -> addChallenge name publicRepoId privateRepoId chan
|
|
|
|
Nothing -> return ()
|
2015-09-04 06:47:49 +02:00
|
|
|
Nothing -> return ()
|
2015-08-29 14:58:47 +02:00
|
|
|
|
2015-09-04 10:16:12 +02:00
|
|
|
addChallenge :: Text -> (Key Repo) -> (Key Repo) -> Channel -> Handler ()
|
|
|
|
addChallenge name publicRepoId privateRepoId chan = do
|
|
|
|
msg chan "adding challenge..."
|
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
|
|
|
|
|
2015-09-04 10:16:12 +02:00
|
|
|
time <- liftIO getCurrentTime
|
|
|
|
challengeId <- runDB $ insert $ Challenge {
|
|
|
|
challengePublicRepo=publicRepoId,
|
|
|
|
challengePrivateRepo=privateRepoId,
|
|
|
|
challengeName=name,
|
2015-09-04 15:10:47 +02:00
|
|
|
challengeTitle=(T.pack $ title),
|
|
|
|
challengeDescription=(T.pack $ description),
|
2018-01-18 08:21:06 +01:00
|
|
|
challengeStamp=time,
|
2018-01-18 09:21:21 +01:00
|
|
|
challengeImage=mImage,
|
2018-01-25 16:43:50 +01:00
|
|
|
challengeStarred=False}
|
2015-09-04 22:21:51 +02:00
|
|
|
updateTests challengeId chan
|
|
|
|
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
|
2015-12-20 21:00:00 +01:00
|
|
|
mapM_ (checkTestDir chan challengeId challenge commit) testDirs
|
2015-09-04 22:21:51 +02:00
|
|
|
msg chan (T.pack $ show testDirs)
|
|
|
|
return ()
|
|
|
|
|
|
|
|
expectedFileName = "expected.tsv"
|
|
|
|
|
|
|
|
doesExpectedExist :: FilePath -> IO Bool
|
|
|
|
doesExpectedExist fp = doesFileExist (fp </> expectedFileName)
|
|
|
|
|
2015-12-20 21:00:00 +01: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
|
2015-12-20 21:00:00 +01:00
|
|
|
optionsParsingResult <- liftIO $ getOptions [
|
2016-01-08 21:57:29 +01:00
|
|
|
"--expected-directory", challengeRepoDir,
|
2015-12-20 21:00:00 +01:00
|
|
|
"--test-name", takeFileName testDir]
|
|
|
|
case optionsParsingResult of
|
|
|
|
Left evalException -> do
|
|
|
|
err chan "Cannot read metric"
|
|
|
|
return ()
|
|
|
|
Right opts -> do
|
|
|
|
_ <- runDB $ insert $ Test {
|
|
|
|
testChallenge=challengeId,
|
|
|
|
testMetric=gesMetric $ geoSpec opts,
|
|
|
|
testName=T.pack $ takeFileName testDir,
|
|
|
|
testChecksum=(SHA1 checksum),
|
|
|
|
testCommit=commit,
|
2016-02-17 09:34:34 +01:00
|
|
|
testActive=True,
|
2018-01-25 09:13:06 +01:00
|
|
|
testPrecision=gesPrecision $ geoSpec opts}
|
2015-12-20 21:00:00 +01:00
|
|
|
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 ()
|
|
|
|
|
|
|
|
|
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-*")
|
|
|
|
|
2015-08-29 14:58:47 +02:00
|
|
|
sampleForm :: Form (Text, Text, Text, Text, Text)
|
|
|
|
sampleForm = renderBootstrap3 BootstrapBasicForm $ (,,,,)
|
|
|
|
<$> areq textField (fieldSettingsLabel MsgName) Nothing
|
|
|
|
<*> areq textField (fieldSettingsLabel MsgPublicUrl) Nothing
|
|
|
|
<*> areq textField (fieldSettingsLabel MsgBranch) Nothing
|
|
|
|
<*> areq textField (fieldSettingsLabel MsgPrivateUrl) Nothing
|
|
|
|
<*> areq textField (fieldSettingsLabel MsgBranch) Nothing
|