gonito/Handler/CreateChallenge.hs

206 lines
8.3 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
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
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,
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-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)
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
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-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
2018-09-01 12:01:35 +02:00
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,
2019-03-20 16:31:08 +01:00
challengeStarred=False,
challengeArchived=Just 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
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
_ <- 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-09-01 12:01:35 +02:00
createChallengeForm :: Form (Text, Text, Text, Maybe Text, Text, Text, Maybe Text)
createChallengeForm = renderBootstrap3 BootstrapBasicForm $ (,,,,,,)
<$> 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