gonito/Handler/CreateChallenge.hs

196 lines
7.9 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,
withSmallInput)
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
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
2018-06-05 07:46:42 +02:00
Just (name, publicUrl, publicBranch, publicGitAnnexRemote,
privateUrl, privateBranch, privateGitAnnexRemote) = 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-06-05 07:46:42 +02:00
runViewProgress $ doCreateChallenge name publicUrl publicBranch publicGitAnnexRemote privateUrl privateBranch privateGitAnnexRemote
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
2018-06-05 07:46:42 +02:00
doCreateChallenge :: Text -> Text -> Text -> Maybe Text -> Text -> Text -> Maybe Text -> Channel -> Handler ()
doCreateChallenge name publicUrl publicBranch publicGitAnnexRemote privateUrl privateBranch privateGitAnnexRemote 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-06-05 07:46:42 +02:00
repoSpecBranch = publicBranch,
repoSpecGitAnnexRemote = publicGitAnnexRemote},
2018-06-04 22:14:39 +02:00
cloningSpecReferenceRepo = RepoSpec {
repoSpecUrl = publicUrl,
2018-06-05 07:46:42 +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
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
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
ef <- findFilePossiblyCompressed (fp </> expectedFileName)
return $ isJust ef
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
_ <- runDB $ mapM (\(priority, metric) -> insert $ Test {
testChallenge=challengeId,
testMetric=metric,
testName=T.pack $ takeFileName testDir,
testChecksum=(SHA1 checksum),
testCommit=commit,
2016-02-17 09:34:34 +01:00
testActive=True,
testPrecision=gesPrecision $ geoSpec opts,
testPriority=Just priority}) $ 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 ()
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-*")
2018-06-05 07:46:42 +02:00
sampleForm :: Form (Text, Text, Text, Maybe Text, Text, Text, Maybe Text)
sampleForm = renderBootstrap3 BootstrapBasicForm $ (,,,,,,)
2015-08-29 14:58:47 +02:00
<$> areq textField (fieldSettingsLabel MsgName) Nothing
<*> areq textField (fieldSettingsLabel MsgPublicUrl) Nothing
<*> areq textField (fieldSettingsLabel MsgBranch) Nothing
2018-06-05 07:46:42 +02:00
<*> aopt textField (fieldSettingsLabel MsgGitAnnexRemote) Nothing
2015-08-29 14:58:47 +02:00
<*> areq textField (fieldSettingsLabel MsgPrivateUrl) Nothing
<*> areq textField (fieldSettingsLabel MsgBranch) Nothing
2018-06-05 07:46:42 +02:00
<*> aopt textField (fieldSettingsLabel MsgGitAnnexRemote) Nothing