gonito/Handler/CreateChallenge.hs

172 lines
6.2 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
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
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
maybePublicRepoId <- cloneRepo publicUrl publicBranch publicUrl publicBranch 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
maybePrivateRepoId <- cloneRepo privateUrl privateBranch (T.pack $ publicRepoDir) (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
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)
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 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}
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