gonito/Handler/ShowChallenge.hs

1884 lines
83 KiB
Haskell
Raw Normal View History

2021-02-22 14:43:09 +01:00
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DoAndIfThenElse #-}
2015-09-04 23:23:32 +02:00
module Handler.ShowChallenge where
import Import hiding (Proxy, fromList)
2018-07-05 22:17:25 +02:00
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs)
2017-09-22 14:23:03 +02:00
import qualified Data.Text.Lazy as TL
2015-09-06 14:24:49 +02:00
import Text.Markdown
2015-09-29 14:15:49 +02:00
import qualified Data.Text as T
import qualified Data.HashMap.Strict as HMS
2015-12-12 18:53:20 +01:00
import qualified Yesod.Table as Table
import Control.Concurrent.Lifted (threadDelay)
import Data.Time.LocalTime
import qualified Data.List.Utils as DLU
2015-09-06 14:24:49 +02:00
import Handler.Extract
import Handler.Shared
2018-06-05 08:22:51 +02:00
import Handler.Runner
2015-12-12 18:53:20 +01:00
import Handler.Tables
2017-09-27 19:38:42 +02:00
import Handler.TagUtils
2018-07-24 15:33:35 +02:00
import Handler.MakePublic
2019-02-22 14:41:43 +01:00
import Handler.Dashboard
2019-03-20 16:31:08 +01:00
import Handler.Common
2019-12-14 14:10:50 +01:00
import Handler.Evaluate
import Handler.JWT
2021-06-28 18:38:15 +02:00
import Handler.Team
2015-09-06 14:24:49 +02:00
2020-12-31 08:46:35 +01:00
import Database.Persist.Sql (fromSqlKey)
import qualified Data.Map as Map
2021-08-21 09:45:37 +02:00
import Web.Announcements
2020-12-09 21:55:31 +01:00
2020-05-30 23:40:03 +02:00
import Data.Maybe (fromJust)
2019-08-29 21:34:13 +02:00
import Text.Blaze
2020-05-30 23:40:03 +02:00
import Data.Aeson
import Gonito.ExtractMetadata (ExtractionOptions(..),
extractMetadataFromRepoDir,
GonitoMetadata(..),
2018-11-12 20:41:46 +01:00
parseTags,
Link(..))
2018-09-01 14:23:41 +02:00
import qualified Text.Read as TR
2015-09-29 18:23:11 +02:00
import GEval.Core
import GEval.EvaluationScheme
import GEval.Formatting
import GEval.Common (MetricResult(..))
2015-09-29 22:31:56 +02:00
2015-09-29 14:15:49 +02:00
import PersistSHA1
2017-09-22 14:23:03 +02:00
import System.IO (readFile)
2017-09-28 16:11:22 +02:00
import Data.Text (pack, unpack)
2018-07-28 17:04:27 +02:00
import Data.List (nub)
2018-11-13 16:15:02 +01:00
import qualified Database.Esqueleto as E
import Database.Esqueleto ((^.))
import Data.Swagger hiding (get)
import qualified Data.Swagger as DS
import Data.Swagger.Declare
import Control.Lens hiding ((.=), (^.))
2021-01-27 14:46:06 +01:00
import Data.Proxy as DPR
import Data.HashMap.Strict.InsOrd (fromList)
2021-09-25 18:37:08 +02:00
instance ToJSON Import.Tag where
toJSON t = object
[ "name" .= tagName t
, "description" .= tagDescription t
, "color" .= tagColor t
]
instance ToSchema Import.Tag where
declareNamedSchema _ = do
stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String)
boolSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Bool)
return $ NamedSchema (Just "Tag") $ mempty
& type_ .~ SwaggerObject
& properties .~
fromList [ ("name", stringSchema)
, ("description", stringSchema)
, ("color", stringSchema)
]
& required .~ [ "name", "color", "description" ]
2020-10-15 22:27:16 +02:00
instance ToJSON LeaderboardEntry where
toJSON entry = object
[ "submitter" .= (formatSubmitter $ leaderboardUser entry)
2021-03-03 22:02:39 +01:00
, "team" .= (teamIdent <$> entityVal <$> leaderboardTeam entry)
2020-10-15 22:27:16 +02:00
, "when" .= (submissionStamp $ leaderboardBestSubmission entry)
2021-09-25 18:37:08 +02:00
, "version" .= (fst $ leaderboardVersion entry)
, "phase" .= (snd $ leaderboardVersion entry)
2020-10-15 22:27:16 +02:00
, "description" .= descriptionToBeShown (leaderboardBestSubmission entry)
(leaderboardBestVariant entry)
(leaderboardParams entry)
, "times" .= leaderboardNumberOfSubmissions entry
2021-02-15 14:44:19 +01:00
, "hash" .= (fromSHA1ToText $ submissionCommit $ leaderboardBestSubmission entry)
, "isPublic" .= (submissionIsPublic $ leaderboardBestSubmission entry)
, "isOwner" .= (leaderboardIsOwner entry)
, "isReevaluable" .= (leaderboardIsReevaluable entry)
, "isVisible" .= (leaderboardIsVisible entry)
, "id" .= (leaderboardBestSubmissionId entry)
, "variant" .= (leaderboardBestVariantId entry)
2020-10-15 22:27:16 +02:00
]
declareLeaderboardSwagger :: Declare (Definitions Schema) Swagger
declareLeaderboardSwagger = do
-- param schemas
let challengeNameSchema = toParamSchema (Proxy :: Proxy String)
leaderboardResponse <- declareResponse (Proxy :: Proxy LeaderboardView)
return $ mempty
& paths .~
2021-01-27 14:46:06 +01:00
fromList [ ("/api/leaderboard/{challengeName}",
mempty & DS.get ?~ (mempty
& parameters .~ [ Inline $ mempty
& name .~ "challengeName"
& required ?~ True
& schema .~ ParamOther (mempty
& in_ .~ ParamPath
& paramSchema .~ challengeNameSchema) ]
& produces ?~ MimeList ["application/json"]
& description ?~ "Returns a leaderboard for a given challenge"
& at 200 ?~ Inline leaderboardResponse))
]
leaderboardApi :: Swagger
leaderboardApi = spec & definitions .~ defs
where
(defs, spec) = runDeclare declareLeaderboardSwagger mempty
data LeaderboardView = LeaderboardView {
leaderboardViewTests :: [Entity Test],
leaderboardViewEntries :: [LeaderboardEntryView]
}
instance ToJSON LeaderboardView where
toJSON v = object
[ "tests" .= (map getTestReference $ leaderboardViewTests v)
, "entries" .= leaderboardViewEntries v
]
instance ToSchema LeaderboardView where
declareNamedSchema _ = do
testsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [TestReference])
entriesSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [LeaderboardEntryView])
return $ NamedSchema (Just "Leaderboard") $ mempty
& type_ .~ SwaggerObject
& properties .~
fromList [ ("tests", testsSchema)
, ("entries", entriesSchema)
]
& required .~ [ "tests", "entries" ]
2020-10-15 22:27:16 +02:00
getLeaderboardJsonR :: Text -> Handler Value
2021-02-08 18:12:02 +01:00
getLeaderboardJsonR challengeName = do
2021-03-22 08:19:47 +01:00
Entity challengeId challenge <- runDB $ getBy404 $ UniqueName challengeName
leaderboardStyle <- determineLeaderboardStyle challenge
2020-10-15 22:27:16 +02:00
(leaderboard, (_, tests)) <- getLeaderboardEntries 1 leaderboardStyle challengeId
return $ toJSON $ LeaderboardView {
leaderboardViewTests = tests,
leaderboardViewEntries = map (toLeaderboardEntryView tests) leaderboard }
data LeaderboardEntryView = LeaderboardEntryView {
leaderboardEntryViewEntry :: LeaderboardEntry,
leaderboardEntryViewEvaluations :: [EvaluationView]
}
addJsonKey :: Text -> Value -> Value -> Value
addJsonKey key val (Object xs) = Object $ HMS.insert key val xs
addJsonKey _ _ xs = xs
-- Helper definitions for properties used in more than one place
isVisibleSchema :: Referenced Schema
isVisibleSchema = Inline $ toSchema (DPR.Proxy :: DPR.Proxy Bool)
& description .~ Just "Whether the details of the submissions are visible (i.e. either the submission is public or the user has the right permissions)"
isPublicSchema :: Referenced Schema
isPublicSchema = Inline $ toSchema (DPR.Proxy :: DPR.Proxy Bool)
& description .~ Just "Whether the submissions is public (i.e. whether its details are available to everyone)"
hashSchema :: Referenced Schema
hashSchema = Inline $ toSchema (DPR.Proxy :: DPR.Proxy String)
& description .~ Just "Git SHA1 commit hash; could be used as an argument for queries (if the submission is visible)"
& example .~ Just "ec41f0e2636bfedbd765c9871c813f7c5b896c51"
versionSchema :: Referenced Schema
versionSchema = Inline $ toSchema (DPR.Proxy :: DPR.Proxy [Int])
& description .~ Just "Challenge version under which the submission was done"
& example .~ Just (toJSON [2 :: Int, 0, 1])
submitterSchema :: Referenced Schema
submitterSchema = Inline $ toSchema (DPR.Proxy :: DPR.Proxy String)
& description .~ Just ("Name of the submitter, might be a special value in square brackets, e.g. " <> anonymizedLabel <> " or " <> nameNotGivenLabel)
& example .~ Just "John Smith"
submissionIdSchema :: Referenced Schema
submissionIdSchema = Inline $ toSchema (DPR.Proxy :: DPR.Proxy Int)
& description .~ Just "Internal database identifier of the submission"
& example .~ Just(toJSON (42 :: Int))
variantIdSchema :: Referenced Schema
variantIdSchema = Inline $ toSchema (DPR.Proxy :: DPR.Proxy Int)
& description .~ Just "Internal database identifier of the submission variant"
& example .~ Just (toJSON (53 :: Int))
instance ToJSON LeaderboardEntryView where
toJSON v = addJsonKey "evaluations"
(toJSON $ leaderboardEntryViewEvaluations v)
(toJSON $ leaderboardEntryViewEntry v)
instance ToSchema LeaderboardEntryView where
declareNamedSchema _ = do
stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String)
boolSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Bool)
evaluationsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [EvaluationView])
2021-09-25 18:37:08 +02:00
tagSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Import.Tag)
return $ NamedSchema (Just "LeaderboardEntry") $ mempty
& type_ .~ SwaggerObject
& properties .~
fromList [ ("submitter", submitterSchema)
2021-03-03 22:02:39 +01:00
, ("team", stringSchema)
, ("when", stringSchema)
, ("version", versionSchema)
2021-09-25 18:37:08 +02:00
, ("phase", tagSchema)
, ("description", stringSchema)
, ("times", Inline $ toSchema (DPR.Proxy :: DPR.Proxy Int)
& description .~ Just "How many times a submission from the same user/of the same tag was submitted"
& minProperties .~ Just 1
& example .~ Just (toJSON (2:: Int)))
, ("hash", hashSchema)
, ("evaluations", evaluationsSchema)
, ("isOwner", boolSchema)
, ("isPublic", isPublicSchema)
, ("isReevaluable", boolSchema)
, ("isVisible", isVisibleSchema)
, ("id", submissionIdSchema)
, ("variantId", variantIdSchema)
]
& required .~ [ "submitter", "when", "version", "description", "times", "hash", "evaluations" ]
toLeaderboardEntryView :: [(Entity Test)] -> LeaderboardEntry -> LeaderboardEntryView
toLeaderboardEntryView tests entry = LeaderboardEntryView {
leaderboardEntryViewEntry = entry,
leaderboardEntryViewEvaluations = catMaybes $
map (convertEvaluationToView (leaderboardEvaluationMap entry)) tests
}
2020-10-15 22:27:16 +02:00
2021-03-22 08:19:47 +01:00
determineLeaderboardStyle :: Challenge -> Handler LeaderboardStyle
determineLeaderboardStyle challenge = do
2018-09-08 21:21:21 +02:00
app <- getYesod
let leaderboardStyle = appLeaderboardStyle $ appSettings app
2021-03-22 08:19:47 +01:00
return $ case challengeIsCompetition challenge of
Just True -> BySubmitter
_ -> leaderboardStyle
2018-09-08 21:21:21 +02:00
2021-03-22 08:19:47 +01:00
getShowChallengeR :: Text -> Handler Html
getShowChallengeR challengeName = do
app <- getYesod
2021-02-08 18:12:02 +01:00
challengeEnt@(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName challengeName
2021-03-22 08:19:47 +01:00
leaderboardStyle <- determineLeaderboardStyle challenge
2021-02-17 09:31:23 +01:00
isHealthy <- isChallengeHealthy challenge
2015-09-28 17:45:10 +02:00
Just repo <- runDB $ get $ challengePublicRepo challenge
(leaderboard, (entries, tests)) <- getLeaderboardEntries 1 leaderboardStyle challengeId
showAltLeaderboard <- runDB $ hasMetricsOfSecondPriority challengeId
(altLeaderboard, altTests) <- if showAltLeaderboard
then
do
(leaderboard', (_, tests')) <- getLeaderboardEntries 3 ByTag challengeId
return $ (Just leaderboard', Just tests')
else
return (Nothing, Nothing)
2016-02-16 21:10:10 +01:00
mauth <- maybeAuth
2018-09-01 14:23:41 +02:00
let params = getNumericalParams entries
let scheme = appRepoScheme $ appSettings app
challengeRepo <- runDB $ get404 $ challengePublicRepo challenge
2019-03-20 16:31:08 +01:00
challengeLayout True challenge (showChallengeWidget mauth
challengeEnt
scheme
2018-07-28 21:36:45 +02:00
challengeRepo
repo
leaderboard
altLeaderboard
params
tests
2021-02-17 09:31:23 +01:00
altTests
isHealthy)
2020-02-22 19:12:07 +01:00
hasMetricsOfSecondPriority :: (PersistQueryRead backend, MonadIO m, BaseBackend backend ~ SqlBackend) => Key Challenge -> ReaderT backend m Bool
hasMetricsOfSecondPriority challengeId = do
tests' <- selectList [TestChallenge ==. challengeId, TestActive ==. True] []
let tests = filter (\t -> (evaluationSchemePriority $ testMetric $ entityVal t) == 2) tests'
return $ not (null tests)
2015-09-06 14:24:49 +02:00
getChallengeReadmeR :: Text -> Handler Html
2021-02-08 12:27:44 +01:00
getChallengeReadmeR challengeName = do
(Entity _ challenge) <- runDB $ getBy404 $ UniqueName challengeName
readme <- challengeReadme challengeName
2016-05-16 23:44:28 +02:00
challengeLayout False challenge $ toWidget readme
2021-02-08 12:27:44 +01:00
challengeReadmeInMarkdownApi :: Swagger
challengeReadmeInMarkdownApi = spec & definitions .~ defs
where
(defs, spec) = runDeclare declareChallengeReadmeInMarkdownSwagger mempty
declareChallengeReadmeInMarkdownSwagger :: Declare (Definitions Schema) Swagger
declareChallengeReadmeInMarkdownSwagger = do
-- param schemas
let challengeNameSchema = toParamSchema (Proxy :: Proxy String)
return $ mempty
& paths .~
fromList [ ("/api/challenge-readme/{challengeName}/markdown",
mempty & DS.get ?~ (mempty
& parameters .~ [ Inline $ mempty
& name .~ "challengeName"
& required ?~ True
& schema .~ ParamOther (mempty
& in_ .~ ParamPath
& paramSchema .~ challengeNameSchema) ]
& produces ?~ MimeList ["application/text"]
& description ?~ "Returns the challenge README in Markdown"))
]
getChallengeReadmeInMarkdownR :: Text -> Handler TL.Text
getChallengeReadmeInMarkdownR challengeName = doChallengeReadmeContents challengeName
challengeReadme :: Text -> Handler Html
challengeReadme challengeName = do
theContents <- doChallengeReadmeContents challengeName
return $ markdown def theContents
2021-02-17 09:31:23 +01:00
-- Checks whether the directories with repos are available
isChallengeHealthy :: Challenge -> Handler Bool
isChallengeHealthy challenge = do
publicRepoDirExists <- doesRepoExistsOnTheDisk $ challengePublicRepo challenge
privateRepoDirExists <- doesRepoExistsOnTheDisk $ challengePrivateRepo challenge
return $ publicRepoDirExists && privateRepoDirExists
2021-02-08 12:27:44 +01:00
doChallengeReadmeContents :: Text -> Handler TL.Text
doChallengeReadmeContents challengeName = do
(Entity _ challenge) <- runDB $ getBy404 $ UniqueName challengeName
2015-09-06 14:24:49 +02:00
let repoId = challengePublicRepo challenge
2016-01-08 21:57:29 +01:00
repoDir <- getRepoDir repoId
2015-09-06 14:24:49 +02:00
let readmeFilePath = repoDir </> readmeFile
2019-08-29 21:34:13 +02:00
theContents <- liftIO $ System.IO.readFile readmeFilePath
2021-02-08 12:27:44 +01:00
return $ TL.pack theContents
2015-09-06 14:24:49 +02:00
2019-03-20 16:31:08 +01:00
showChallengeWidget :: Maybe (Entity User)
-> Entity Challenge
2018-07-28 21:36:45 +02:00
-> RepoScheme
-> Repo
-> Repo
-> [LeaderboardEntry]
-> (Maybe [LeaderboardEntry])
-> [Text]
-> [Entity Test]
-> (Maybe [Entity Test])
2021-02-17 09:31:23 +01:00
-> Bool
2018-07-28 21:36:45 +02:00
-> WidgetFor App ()
2019-03-20 16:31:08 +01:00
showChallengeWidget mUserEnt
(Entity challengeId challenge)
scheme
challengeRepo
repo
leaderboard
mAltLeaderboard
params
tests
mAltTests
2021-02-17 09:31:23 +01:00
isHealthy
= $(widgetFile "show-challenge")
2015-12-12 18:53:20 +01:00
where leaderboardWithRanks = zip [1..] leaderboard
mAltLeaderboardWithRanks = zip [1..] <$> mAltLeaderboard
maybeRepoLink = getRepoLink repo
delta = Number 4
higherTheBetterArray = getIsHigherTheBetterArray $ map entityVal tests
2019-03-20 16:31:08 +01:00
mUserId = entityKey <$> mUserEnt
2021-06-16 08:06:28 +02:00
data GitServer = Gogs | GitLab | GitHub | Gonito
deriving (Eq, Show)
guessGitServer :: Text -> Maybe GitServer
guessGitServer bareUrl
| "git.wmi.amu.edu.pl" `isPrefixOf` bareUrl = Just Gogs
| "gitlab." `isPrefixOf` bareUrl = Just GitLab
| "git." `isPrefixOf` bareUrl = Just GitLab
| "github." `isPrefixOf` bareUrl = Just GitHub
| "gonito.net" `isPrefixOf` bareUrl = Just Gonito
| otherwise = Nothing
2021-06-16 08:06:28 +02:00
getHttpLink :: Repo -> Maybe (Text, Text)
getHttpLink repo = case guessGitServer bareUrl of
Just Gogs -> Just (convertToHttpLink bareUrl, "/src/" <> branch)
Just GitLab -> Just (convertToHttpLink bareUrl, "/-/tree/" <> branch)
Just GitHub -> Just (convertToHttpLink bareUrl, "/tree/" <> branch)
Just Gonito -> Just (fixGonito $ convertToHttpLink bareUrl, "/" <> branch)
Nothing -> Nothing
where bareUrl = removeProtocol $ removeLogin rurl
removeLogin t = r
where (_, r) = T.breakOnEnd "@" t
rurl = repoUrl repo
branch = repoBranch repo
convertToHttpLink = ("https://" <>) . (T.replace ":" "/") . (T.replace ".git" "")
removeProtocol = stripPrefixes ["https://", "http://", "git://", "ssh://",
"ssh." -- when a domain with ssh. prefix is used
]
stripPrefixes prefixes t = foldr stripPrefixFrom t prefixes
stripPrefixFrom pref t = if pref `isPrefixOf` t
then drop (length pref) t
else t
2021-06-16 08:52:21 +02:00
fixGonito t = (T.replace "https://gonito.net" "https://gonito.net/gitlist" t) <> ".git"
2021-06-16 08:06:28 +02:00
getRepoLink :: Repo -> Maybe Text
getRepoLink repo = case getHttpLink repo of
Just (hostname, linkRest) -> Just $ hostname <> linkRest
Nothing -> if sitePrefix `isPrefixOf` theUrl
then Just $ (browsableGitRepo bareRepoName) ++ "/" ++ (repoBranch repo)
else Nothing
where sitePrefix = "git://gonito.net/" :: Text
sitePrefixLen = length sitePrefix
2021-02-08 18:12:02 +01:00
theUrl = repoUrl repo
bareRepoName = drop sitePrefixLen theUrl
2015-09-06 14:24:49 +02:00
2021-06-16 08:49:50 +02:00
instance ToJSON (Repo) where
toJSON repo = object
[ "url" .= repoUrl repo
, "branch" .= repoBranch repo
, "browsableUrl" .= getRepoLink repo
]
instance ToSchema (Repo) where
declareNamedSchema _ = do
stringSchema <- declareSchemaRef (Proxy :: Proxy String)
return $ NamedSchema (Just "DataRepository") $ mempty
& type_ .~ SwaggerObject
& properties .~
fromList [ ("url", Inline $ toSchema (DPR.Proxy :: DPR.Proxy String)
& description .~ Just "Git URL to be cloned (https://, git:// or ssh:// protocol)"
& example .~ Just (toJSON ("git://gonito.net/fiszki-ocr" :: String)))
, ("branch", stringSchema)
, ("browsableUrl", Inline $ toSchema (DPR.Proxy :: DPR.Proxy String)
& description .~ Just "An URL address that your browser can open; usually, but not always available"
& example .~ Just (toJSON ("https://github.com/applicaai/kleister-charity/tree/master" :: String)))
]
& required .~ [ "url", "branch" ]
getChallengeRepoJsonR :: Text -> Handler Value
getChallengeRepoJsonR chName = do
(Entity _ challenge) <- runDB $ getBy404 $ UniqueName chName
repo <- runDB $ get404 $ challengePublicRepo challenge
return $ toJSON repo
declareChallengeRepoSwagger :: Declare (Definitions Schema) Swagger
declareChallengeRepoSwagger = do
-- param schemas
let challengeNameSchema = toParamSchema (Proxy :: Proxy String)
return $ mempty
& paths .~
fromList [ ("/api/challenge-repo/{challengeName}",
mempty & DS.get ?~ (mempty
& parameters .~ [ Inline $ mempty
& name .~ "challengeName"
& required ?~ True
& schema .~ ParamOther (mempty
& in_ .~ ParamPath
& paramSchema .~ challengeNameSchema) ]
& produces ?~ MimeList ["application/json"]
& description ?~ "Return metadata for the challenge repository"))
]
challengeRepoApi :: Swagger
challengeRepoApi = spec & definitions .~ defs
where
(defs, spec) = runDeclare declareChallengeRepoSwagger mempty
2015-11-11 22:10:41 +01:00
getChallengeHowToR :: Text -> Handler Html
2021-02-08 18:12:02 +01:00
getChallengeHowToR challengeName = do
(Entity _ challenge) <- runDB $ getBy404 $ UniqueName challengeName
2015-11-11 22:10:41 +01:00
maybeUser <- maybeAuth
2017-09-28 16:51:10 +02:00
2018-06-05 23:04:58 +02:00
app <- getYesod
let settings = appSettings app
let publicRepoId = challengePublicRepo challenge
repo <- runDB $ get404 publicRepoId
2018-06-05 23:04:58 +02:00
2017-09-28 16:51:10 +02:00
case maybeUser of
Just (Entity userId user) -> do
enableTriggerToken userId (userTriggerToken user)
Nothing -> return ()
let mToken = case maybeUser of
Just (Entity _ user) -> userTriggerToken user
Nothing -> Nothing
2017-09-25 12:47:01 +02:00
let isIDSet = case maybeUser of
Just (Entity _ user) -> isJust $ userLocalId user
Nothing -> False
isSSHUploaded <- case maybeUser of
Just (Entity userId _) -> do
2018-07-28 17:30:00 +02:00
ukeys <- runDB $ selectList [PublicKeyUser ==. userId] []
return $ not (null ukeys)
2017-09-25 12:47:01 +02:00
Nothing -> return False
2018-07-28 17:30:00 +02:00
challengeLayout False challenge (challengeHowTo
challenge
settings
repo
(idToBeShown challenge maybeUser)
isIDSet
isSSHUploaded
(join $ userAltRepoScheme <$> entityVal <$> maybeUser)
2018-07-28 17:30:00 +02:00
mToken)
2015-11-11 22:10:41 +01:00
2018-07-14 07:42:28 +02:00
idToBeShown :: p -> Maybe (Entity User) -> Text
2018-07-28 17:04:27 +02:00
idToBeShown _ maybeUser =
2015-11-11 22:10:41 +01:00
case maybeUser of
Just user -> case userLocalId $ entityVal user of
Just localId -> localId
Nothing -> defaultIdToBe
Nothing -> defaultIdToBe
where defaultIdToBe = "YOURID" :: Text
externalRepoPlaceholder :: Text
externalRepoPlaceholder = "URL_TO_YOUR_REPO"
defaultRepo :: RepoScheme -> Text -> Challenge -> Repo -> Maybe (Entity User) -> Text
defaultRepo SelfHosted repoHost challenge _ maybeUser = repoHost ++ (idToBeShown challenge maybeUser) ++ "/" ++ (challengeName challenge)
defaultRepo Branches _ _ repo _ = repoUrl repo
defaultRepo NoInternalGitServer _ _ _ _ = externalRepoPlaceholder
2018-07-14 07:42:28 +02:00
defaultBranch :: IsString a => RepoScheme -> Maybe a
defaultBranch SelfHosted = Just "master"
defaultBranch Branches = Nothing
defaultBranch NoInternalGitServer = Nothing
2015-11-11 22:10:41 +01:00
challengeHowTo :: Challenge -> AppSettings -> Repo -> Text -> Bool -> Bool -> Maybe Text -> Maybe Text -> WidgetFor App ()
challengeHowTo challenge settings repo shownId isIDSet isSSHUploaded mAltRepoScheme mToken = $(widgetFile "challenge-how-to")
where myBranch = "my-brilliant-branch" :: Text
urlToYourRepo = case mAltRepoScheme of
Just altRepoScheme -> encodeSlash (altRepoScheme <> (challengeName challenge))
Nothing -> externalRepoPlaceholder
2015-09-06 15:33:37 +02:00
2021-02-17 09:31:23 +01:00
postHealR :: ChallengeId -> Handler TypedContent
postHealR challengeId = runViewProgress $ doHeal challengeId
doHeal :: Key Challenge -> Channel -> HandlerFor App ()
2021-02-17 09:31:23 +01:00
doHeal challengeId chan = do
challenge <- runDB $ get404 challengeId
_ <- getRepoDirOrClone (challengePrivateRepo challenge) chan
_ <- getRepoDirOrClone (challengePublicRepo challenge) chan
2021-02-17 09:31:23 +01:00
return ()
2019-03-20 16:31:08 +01:00
postArchiveR :: ChallengeId -> Handler Html
postArchiveR challengeId = doSetArchive True challengeId
postUnarchiveR :: ChallengeId -> Handler Html
postUnarchiveR challengeId = doSetArchive False challengeId
doSetArchive :: Bool -> ChallengeId -> Handler Html
doSetArchive status challengeId = do
runDB $ update challengeId [ChallengeArchived =. Just status]
challenge <- runDB $ get404 challengeId
getShowChallengeR $ challengeName challenge
archiveForm :: ChallengeId -> Form ChallengeId
archiveForm challengeId = renderBootstrap3 BootstrapBasicForm $ areq hiddenField "" (Just challengeId)
2015-09-06 15:33:37 +02:00
getChallengeSubmissionR :: Text -> Handler Html
2021-02-08 18:12:02 +01:00
getChallengeSubmissionR challengeName = do
(Entity _ challenge) <- runDB $ getBy404 $ UniqueName challengeName
2015-11-11 22:10:41 +01:00
maybeUser <- maybeAuth
Just repo <- runDB $ get $ challengePublicRepo challenge
app <- getYesod
let scheme = appRepoScheme $ appSettings app
let repoHost = appRepoHost $ appSettings app
let defaultUrl = fromMaybe (defaultRepo scheme repoHost challenge repo maybeUser)
2021-02-08 18:12:02 +01:00
((<> challengeName) <$> (join $ userAltRepoScheme <$> entityVal <$> maybeUser))
2021-03-03 13:15:38 +01:00
Entity userId _ <- requireAuth
2021-06-29 08:48:58 +02:00
defaultTeam <- fetchDefaultTeam userId
(formWidget, formEnctype) <- generateFormPost $ submissionForm userId (Just defaultUrl) (defaultBranch scheme) (repoGitAnnexRemote repo) (Just defaultTeam)
2015-09-06 15:33:37 +02:00
challengeLayout True challenge $ challengeSubmissionWidget formWidget formEnctype challenge
2021-02-15 21:35:09 +01:00
declareChallengeSubmissionSwagger :: Declare (Definitions Schema) Swagger
declareChallengeSubmissionSwagger = do
-- param schemas
let challengeNameSchema = toParamSchema (Proxy :: Proxy String)
let stringSchema = toParamSchema (Proxy :: Proxy String)
challengeSubmissionResponse <- declareResponse (Proxy :: Proxy Int)
2021-02-22 14:43:09 +01:00
wrongSubmissionResponse <- declareResponse (Proxy :: Proxy GonitoStatus)
2021-02-15 21:35:09 +01:00
return $ mempty
& paths .~
fromList [ ("/api/challenge-submission/{challengeName}",
mempty & DS.post ?~ (mempty
& parameters .~ [ Inline $ mempty
& name .~ "challengeName"
& required ?~ True
& schema .~ ParamOther (mempty
& in_ .~ ParamPath
& paramSchema .~ challengeNameSchema),
Inline $ mempty
& name .~ "f1"
& description .~ Just "submission description"
& required ?~ False
& schema .~ ParamOther (mempty
& in_ .~ ParamFormData
& paramSchema .~ stringSchema),
Inline $ mempty
& name .~ "f2"
& description .~ Just "submission tags"
& required ?~ False
& schema .~ ParamOther (mempty
& in_ .~ ParamFormData
& paramSchema .~ stringSchema),
Inline $ mempty
& name .~ "f3"
& description .~ Just "repo URL"
& required ?~ True
& schema .~ ParamOther (mempty
& in_ .~ ParamFormData
& paramSchema .~ stringSchema),
Inline $ mempty
& name .~ "f4"
& description .~ Just "repo branch"
& required ?~ True
& schema .~ ParamOther (mempty
& in_ .~ ParamFormData
& paramSchema .~ stringSchema),
Inline $ mempty
& name .~ "f5"
& description .~ Just "git-annex remote specification"
& required ?~ False
& schema .~ ParamOther (mempty
& in_ .~ ParamFormData
& paramSchema .~ stringSchema)]
& produces ?~ MimeList ["application/json"]
& description ?~ "Initiates a submission based on a given repo URL/branch. Returns an asynchrous job ID."
2021-02-22 14:43:09 +01:00
& at 200 ?~ Inline challengeSubmissionResponse
& at 422 ?~ Inline wrongSubmissionResponse))
2021-02-15 21:35:09 +01:00
]
challengeSubmissionApi :: Swagger
challengeSubmissionApi = spec & definitions .~ defs
where
(defs, spec) = runDeclare declareChallengeSubmissionSwagger mempty
2021-09-15 13:10:44 +02:00
declareMakePublicSwagger :: Declare (Definitions Schema) Swagger
declareMakePublicSwagger = do
-- param schemas
let idSchema = toParamSchema (Proxy :: Proxy Int)
asyncJobResponse <- declareResponse (Proxy :: Proxy Int)
wrongSubmissionResponse <- declareResponse (Proxy :: Proxy GonitoStatus)
return $ mempty
& paths .~
fromList [ ("/api/make-public/{submissionId}",
mempty & DS.get ?~ (mempty
& parameters .~ [ Inline $ mempty
& name .~ "submissionId"
& required ?~ True
& schema .~ ParamOther (mempty
& in_ .~ ParamPath
& paramSchema .~ idSchema)]
& produces ?~ MimeList ["application/json"]
& description ?~ "Initiates opening a submission. Returns an asynchrous job ID."
& at 200 ?~ Inline asyncJobResponse
& at 422 ?~ Inline wrongSubmissionResponse))
]
makePublicApi :: Swagger
makePublicApi = spec & definitions .~ defs
where
(defs, spec) = runDeclare declareMakePublicSwagger mempty
2021-02-22 14:43:09 +01:00
data ChallangeSubmissionStatus = SubmissionOK | SubmissionWrong Text
deriving (Eq, Show)
data GonitoStatus = GonitoStatus {
detail :: Text
} deriving (Eq, Show, Generic)
instance ToJSON GonitoStatus
instance ToSchema GonitoStatus
2021-01-17 20:37:25 +01:00
postChallengeSubmissionJsonR :: Text -> Handler Value
2021-02-08 18:12:02 +01:00
postChallengeSubmissionJsonR challengeName = do
2021-01-17 20:37:25 +01:00
Entity userId _ <- requireAuthPossiblyByToken
2021-02-22 14:43:09 +01:00
challengeEnt@(Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName
2021-06-29 08:48:58 +02:00
((result, _), _) <- runFormPostNoToken $ submissionForm userId Nothing Nothing Nothing Nothing
2021-01-17 20:37:25 +01:00
let submissionData' = case result of
FormSuccess res -> Just res
_ -> Nothing
Just submissionData = submissionData'
2021-02-22 14:43:09 +01:00
status <- checkSubmission challengeEnt submissionData
case status of
SubmissionOK -> runViewProgressAsynchronously $ doCreateSubmission userId challengeId submissionData
SubmissionWrong errorMsg -> sendResponseStatus status422 $ toJSON (GonitoStatus errorMsg)
checkSubmission :: Entity Challenge -> ChallengeSubmissionData -> Handler ChallangeSubmissionStatus
checkSubmission (Entity _ challenge) submissionData = do
let repo = challengeSubmissionDataRepo submissionData
if (null $ repoSpecUrl repo)
then
return $ SubmissionWrong "empty URL"
else
do
if (null $ repoSpecBranch repo)
then
return $ SubmissionWrong "empty branch"
else
do
if (willClone challenge submissionData)
then
do
return SubmissionOK
else
do
return $ SubmissionWrong "Refusing to clone the submission from this URL."
2021-01-17 20:37:25 +01:00
2015-09-06 15:33:37 +02:00
postChallengeSubmissionR :: Text -> Handler TypedContent
2021-02-08 18:12:02 +01:00
postChallengeSubmissionR challengeName = do
2021-01-17 20:37:25 +01:00
userId <- requireAuthId
2021-02-08 18:12:02 +01:00
(Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName
2021-06-29 08:48:58 +02:00
((result, _), _) <- runFormPost $ submissionForm userId Nothing Nothing Nothing Nothing
2020-03-28 18:08:44 +01:00
let submissionData' = case result of
2015-09-06 15:33:37 +02:00
FormSuccess res -> Just res
_ -> Nothing
2020-03-28 18:08:44 +01:00
Just submissionData = submissionData'
2015-09-06 15:33:37 +02:00
2020-03-28 18:08:44 +01:00
runViewProgress $ doCreateSubmission userId challengeId submissionData
2017-09-28 11:29:48 +02:00
2017-09-28 16:11:22 +02:00
postTriggerLocallyR :: Handler TypedContent
postTriggerLocallyR = do
(Just challengeName) <- lookupPostParam "challenge"
(Just localId) <- lookupPostParam "user"
mBranch <- lookupPostParam "branch"
mGitAnnexRemote <- lookupPostParam "git-annex-remote"
2017-09-28 16:11:22 +02:00
[Entity userId _] <- runDB $ selectList [UserLocalId ==. Just localId] []
2019-12-07 22:34:24 +01:00
app <- getYesod
let repoHost = appRepoHost $ appSettings app
let localRepo = repoHost ++ localId ++ "/" ++ challengeName
trigger userId challengeName localRepo mBranch mGitAnnexRemote
2017-09-28 16:11:22 +02:00
2017-09-28 11:29:48 +02:00
postTriggerRemotelyR :: Handler TypedContent
postTriggerRemotelyR = do
2017-09-28 16:11:22 +02:00
(Just challengeName) <- lookupPostParam "challenge"
2021-02-08 18:12:02 +01:00
(Just theUrl) <- lookupPostParam "url"
2017-09-28 16:11:22 +02:00
(Just token) <- lookupPostParam "token"
2017-09-28 11:29:48 +02:00
mBranch <- lookupPostParam "branch"
mGitAnnexRemote <- lookupPostParam "git-annex-remote"
2021-02-08 18:12:02 +01:00
doTrigger token challengeName theUrl mBranch mGitAnnexRemote
2020-02-21 22:56:39 +01:00
postTriggerRemotelySimpleR :: Text -> Text -> Text -> Text -> Handler TypedContent
2021-02-08 18:12:02 +01:00
postTriggerRemotelySimpleR token challengeName theUrl branch =
doTrigger token challengeName (decodeSlash theUrl) (Just branch) Nothing
2020-02-21 22:56:39 +01:00
getTriggerRemotelySimpleR :: Text -> Text -> Text -> Text -> Handler TypedContent
2021-02-08 18:12:02 +01:00
getTriggerRemotelySimpleR token challengeName theUrl branch =
doTrigger token challengeName (decodeSlash theUrl) (Just branch) Nothing
2020-02-21 22:56:39 +01:00
2020-05-30 23:40:03 +02:00
data GitServerPayload = GitServerPayload {
gitServerPayloadRef :: Text,
-- Unfortunately, the URL is given in "ssh_url" field
-- for Gogs and "git_ssh_url" for GitLab, hence two
-- fields here
gitServerPayloadSshUrl :: Maybe Text,
gitServerPayloadGitSshUrl :: Maybe Text
}
deriving (Show, Eq)
instance FromJSON GitServerPayload where
parseJSON (Object o) = GitServerPayload
<$> o .: "ref"
<*> ((o .: "repository") >>= (.:? "ssh_url"))
<*> ((o .: "repository") >>= (.:? "git_ssh_url"))
postTriggerByWebhookR :: Text -> Text -> Handler TypedContent
postTriggerByWebhookR token challengeName = do
payload <- requireJsonBody :: Handler GitServerPayload
let ref = gitServerPayloadRef payload
let refPrefix = "refs/heads/"
if refPrefix `isPrefixOf` ref
then
do
let branch = T.replace refPrefix "" ref
2021-02-08 18:12:02 +01:00
let theUrl = fromMaybe (fromJust $ gitServerPayloadGitSshUrl payload)
2020-05-30 23:40:03 +02:00
(gitServerPayloadSshUrl payload)
2021-02-08 18:12:02 +01:00
doTrigger token challengeName theUrl (Just branch) Nothing
2020-05-30 23:40:03 +02:00
else
error $ "unexpected ref `" ++ (T.unpack ref) ++ "`"
2020-02-21 22:56:39 +01:00
doTrigger :: Text -> Text -> Text -> Maybe Text -> Maybe Text -> Handler TypedContent
2021-02-08 18:12:02 +01:00
doTrigger token challengeName theUrl mBranch mGitAnnexRemote = do
2017-09-28 16:11:22 +02:00
[Entity userId _] <- runDB $ selectList [UserTriggerToken ==. Just token] []
2021-02-08 18:12:02 +01:00
trigger userId challengeName theUrl mBranch mGitAnnexRemote
2017-09-28 16:11:22 +02:00
trigger :: UserId -> Text -> Text -> Maybe Text -> Maybe Text -> Handler TypedContent
2021-02-08 18:12:02 +01:00
trigger userId challengeName theUrl mBranch mGitAnnexRemote = do
2017-09-28 11:29:48 +02:00
let branch = fromMaybe "master" mBranch
2017-09-28 16:11:22 +02:00
mChallengeEnt <- runDB $ getBy $ UniqueName challengeName
2020-03-28 18:08:44 +01:00
let defSubmission = ChallengeSubmissionData {
challengeSubmissionDataDescription = Nothing,
challengeSubmissionDataTags = Nothing,
challengeSubmissionDataRepo = RepoSpec {
2021-02-08 18:12:02 +01:00
repoSpecUrl=theUrl,
2020-03-28 18:08:44 +01:00
repoSpecBranch=branch,
2021-03-03 15:50:26 +01:00
repoSpecGitAnnexRemote=mGitAnnexRemote},
challengeSubmissionDataTeam = Nothing
2020-03-28 18:08:44 +01:00
}
2017-09-28 16:11:22 +02:00
case mChallengeEnt of
2020-03-28 18:08:44 +01:00
Just (Entity challengeId _) -> runOpenViewProgress $ doCreateSubmission userId challengeId defSubmission
2017-09-28 16:11:22 +02:00
Nothing -> return $ toTypedContent (("Unknown challenge `" ++ (Data.Text.unpack challengeName) ++ "`. Cannot be triggered, must be submitted manually at Gonito.net!\n") :: String)
2017-09-28 11:29:48 +02:00
2019-09-24 22:52:25 +02:00
isBefore :: UTCTime -> Maybe UTCTime -> Bool
isBefore _ Nothing = True
isBefore moment (Just deadline) = moment <= deadline
2020-05-30 21:56:52 +02:00
-- | An attempt to filtre out mistaken/unwanted submissions (without cloning
-- the submission repo, just by looking at the metadata)
willClone :: Challenge -> ChallengeSubmissionData -> Bool
2020-05-30 22:06:21 +02:00
willClone challenge submissionData =
2021-02-08 18:12:02 +01:00
(challengeName challenge) `isInfixOf` theUrl && branch /= dontPeek && not (dontPeek `isInfixOf` theUrl)
where theUrl = repoSpecUrl $ challengeSubmissionDataRepo submissionData
2020-05-30 22:06:21 +02:00
branch = repoSpecBranch $ challengeSubmissionDataRepo submissionData
dontPeek = "dont-peek"
2020-05-30 21:56:52 +02:00
-- | Main place where submission is done (whether manually or by trigger)
doCreateSubmission :: UserId -> Key Challenge -> ChallengeSubmissionData -> Channel -> Handler ()
2020-03-28 18:08:44 +01:00
doCreateSubmission userId challengeId challengeSubmissionData chan = do
2019-03-20 16:31:08 +01:00
challenge <- runDB $ get404 challengeId
2019-09-24 22:52:25 +02:00
2021-02-08 18:12:02 +01:00
theVersion <- runDB $ getBy404 $ UniqueVersionByCommit $ challengeVersion challenge
2019-09-24 22:52:25 +02:00
theNow <- liftIO getCurrentTime
2021-02-08 18:12:02 +01:00
if theNow `isBefore` (versionDeadline $ entityVal theVersion)
2019-09-24 22:52:25 +02:00
then
2020-05-30 21:56:52 +02:00
do
let wanted = willClone challenge challengeSubmissionData
if wanted
then
doCreateSubmission' (challengeArchived challenge) userId challengeId challengeSubmissionData chan
else
msg chan "Refusing to clone the submission from this URL"
2019-09-24 22:52:25 +02:00
else
msg chan "Submission is past the deadline, no submission will be accepted from now on."
2019-03-20 16:31:08 +01:00
2020-03-28 18:08:44 +01:00
doCreateSubmission' :: Maybe Bool -> UserId -> Key Challenge -> ChallengeSubmissionData -> Channel -> Handler ()
doCreateSubmission' (Just True) _ _ _ chan = msg chan "This challenge is archived, you cannot submit to it. Ask the site admin to unarchive it."
doCreateSubmission' _ userId challengeId challengeSubmissionData chan = do
let mDescription = challengeSubmissionDataDescription challengeSubmissionData
let mTags = challengeSubmissionDataTags challengeSubmissionData
let repoSpec = challengeSubmissionDataRepo challengeSubmissionData
maybeRepoKey <- getSubmissionRepo userId challengeId repoSpec chan
case maybeRepoKey of
2015-09-28 23:43:55 +02:00
Just repoId -> do
2018-11-12 22:01:51 +01:00
2018-11-14 17:41:01 +01:00
challenge <- runDB $ get404 challengeId
2018-11-14 20:59:40 +01:00
user <- runDB $ get404 userId
2018-11-14 17:41:01 +01:00
2019-02-22 14:41:43 +01:00
relevantIndicators <- getOngoingTargets challengeId
2019-09-10 08:59:30 +02:00
(Entity _ currentVersion) <- runDB $ getBy404 $ UniqueVersionByCommit $ challengeVersion challenge
let submittedMajorVersion = versionMajor currentVersion
2018-11-13 16:15:02 +01:00
mMainEnt <- runDB $ fetchMainTest challengeId
bestScoreSoFar <- case mMainEnt of
Just (Entity _ mainTest) -> do
let orderDirection = case getMetricOrdering (evaluationSchemeMetric $ testMetric mainTest) of
TheHigherTheBetter -> E.desc
TheLowerTheBetter -> E.asc
2018-11-13 16:15:02 +01:00
bestResultSoFar <- runDB $ E.select $ E.from $ \(evaluation, submission, variant, out, test, theVersion) -> do
2018-11-13 16:15:02 +01:00
E.where_ (submission ^. SubmissionChallenge E.==. E.val challengeId
2018-11-17 09:49:25 +01:00
E.&&. submission ^. SubmissionIsHidden E.==. E.val False
2018-11-13 16:15:02 +01:00
E.&&. variant ^. VariantSubmission E.==. submission ^. SubmissionId
E.&&. evaluation ^. EvaluationChecksum E.==. out ^. OutChecksum
2018-11-14 17:41:01 +01:00
E.&&. (E.not_ (E.isNothing (evaluation ^. EvaluationScore)))
2018-11-13 16:15:02 +01:00
E.&&. out ^. OutVariant E.==. variant ^. VariantId
2019-09-10 08:59:30 +02:00
E.&&. evaluation ^. EvaluationTest E.==. test ^. TestId
E.&&. test ^. TestChallenge E.==. E.val challengeId
E.&&. test ^. TestName E.==. E.val (testName mainTest)
E.&&. test ^. TestMetric E.==. E.val (testMetric mainTest)
E.&&. test ^. TestActive
E.&&. (evaluation ^. EvaluationVersion E.==. theVersion ^. VersionCommit)
2021-02-08 18:12:02 +01:00
E.&&. theVersion ^. VersionCommit E.==. test ^. TestCommit
E.&&. theVersion ^. VersionMajor E.>=. E.val submittedMajorVersion)
2018-11-13 16:15:02 +01:00
E.orderBy [orderDirection (evaluation ^. EvaluationScore)]
E.limit 1
return evaluation
let bestScoreSoFar' = join (evaluationScore <$> entityVal <$> (listToMaybe bestResultSoFar))
return bestScoreSoFar'
Nothing -> return Nothing
2018-11-12 22:01:51 +01:00
case bestScoreSoFar of
Just s -> msg chan ("best score so far is: " ++ (Data.Text.pack $ show s))
Nothing -> msg chan "first submission so far"
2015-09-28 23:43:55 +02:00
repo <- runDB $ get404 repoId
repoDir <- getRepoDirOrClone repoId chan
gonitoMetadata <- liftIO
$ extractMetadataFromRepoDir repoDir (ExtractionOptions {
extractionOptionsDescription = mDescription,
extractionOptionsTags = Just $ parseTags mTags,
extractionOptionsGeneralParams = Nothing,
2018-11-03 12:30:39 +01:00
extractionOptionsUnwantedParams = Nothing,
extractionOptionsParamFiles = Nothing,
2018-11-13 14:48:41 +01:00
extractionOptionsMLRunPath = Nothing,
2018-11-16 12:43:44 +01:00
extractionOptionsExternalLinks = Nothing,
extractionOptionsDependencies = Nothing })
2021-06-29 08:48:58 +02:00
mTeamId <- case challengeSubmissionDataTeam challengeSubmissionData of
Just tid -> return $ Just tid
Nothing -> fetchDefaultTeam userId
2021-03-03 13:15:38 +01:00
submissionId <- getSubmission userId
2021-03-03 13:15:38 +01:00
mTeamId
repoId
(repoCurrentCommit repo)
challengeId
(gonitoMetadataDescription gonitoMetadata)
chan
2018-11-12 20:41:46 +01:00
_ <- runDB $ mapM insert $ map (\l -> ExternalLink {
externalLinkSubmission = submissionId,
externalLinkTitle = linkTitle l,
externalLinkUrl = linkUrl l }) $ gonitoMetadataExternalLinks gonitoMetadata
_ <- runDB $ mapM insertUnique $ map (\s -> Dependency {
dependencySubRepoCommit = s,
dependencySuperRepoCommit = (repoCurrentCommit repo) }) $ gonitoMetadataDependencies gonitoMetadata
2018-11-16 12:43:44 +01:00
2020-09-05 15:07:23 +02:00
outs <- getOuts False chan submissionId (gonitoMetadataGeneralParams gonitoMetadata)
2018-11-12 22:01:51 +01:00
2018-11-14 20:59:40 +01:00
currentTagIds <- runDB $ selectList [SubmissionTagSubmission ==. submissionId] []
runDB $ addTags submissionId (gonitoMetadataTags gonitoMetadata) (
map (submissionTagTag . entityVal) currentTagIds)
msg chan "SUBMISSION CREATED"
app <- getYesod
let mHook = appAnnouncementHook $ appSettings app
2018-11-14 20:59:40 +01:00
let submissionLink = linkInAnnouncement mHook app "submission" ("q/" ++ (fromSHA1ToText (repoCurrentCommit repo)))
2019-02-22 14:41:43 +01:00
case mMainEnt of
Just (Entity mainTestId mainTest) -> do
newScores <- mapM (getScoreForOut mainTestId) outs
let newScores' = catMaybes newScores
let newScores'' = case getMetricOrdering (evaluationSchemeMetric $ testMetric mainTest) of
TheHigherTheBetter -> reverse $ sort newScores'
TheLowerTheBetter -> sort newScores'
let compOp = case getMetricOrdering (evaluationSchemeMetric $ testMetric mainTest) of
TheLowerTheBetter -> (<)
TheHigherTheBetter -> (>)
case bestScoreSoFar of
Just b -> case newScores'' of
2018-11-12 22:01:51 +01:00
(s:_) -> if compOp s b
2018-11-14 17:41:01 +01:00
then
do
let challengeLink = linkInAnnouncement mHook app (challengeTitle challenge) ("challenge/"
++ (challengeName challenge))
let formattingOpts = getTestFormattingOpts mainTest
2018-11-14 20:59:40 +01:00
let message = ("Whoa! New best result for "
++ challengeLink
++ " challenge by "
++ (fromMaybe "???" $ userName user)
++ ", "
++ (T.pack $ evaluationSchemeName $ testMetric mainTest)
2018-11-14 20:59:40 +01:00
++ ": "
++ (T.pack $ formatTheResult formattingOpts (SimpleRun s))
2018-11-14 17:41:01 +01:00
++ " ("
++ (if s > b
then "+"
else "")
++ (T.pack $ formatTheResult formattingOpts (SimpleRun (s-b)))
2018-11-14 20:59:40 +01:00
++ ")."
++ " See " ++ submissionLink ++ "."
++ " :clap:")
2018-11-14 17:41:01 +01:00
msg chan message
case mHook of
Just hook -> liftIO $ sendAnnouncement hook message
2018-11-14 17:41:01 +01:00
Nothing -> return ()
2018-11-12 22:01:51 +01:00
else return ()
[] -> return ()
Nothing -> return ()
2018-11-12 22:01:51 +01:00
Nothing -> return ()
2018-07-24 15:33:35 +02:00
if appAutoOpening $ appSettings app
then
doMakePublic userId submissionId chan
2018-07-24 15:33:35 +02:00
else
return ()
2019-02-22 14:41:43 +01:00
if not (null relevantIndicators)
then
checkIndicators user challengeId submissionId submissionLink relevantIndicators chan
else
return ()
2015-09-28 23:43:55 +02:00
Nothing -> return ()
2019-02-22 14:41:43 +01:00
checkIndicators :: User -> ChallengeId -> SubmissionId -> Text -> [IndicatorEntry] -> Channel -> Handler ()
checkIndicators user challengeId submissionId submissionLink relevantIndicators chan = do
msg chan "Checking indicators..."
theNow <- liftIO $ getCurrentTime
mapM_ (\indicator -> checkIndicator theNow user challengeId submissionId submissionLink indicator chan) relevantIndicators
checkIndicator :: UTCTime -> User -> ChallengeId -> SubmissionId -> Text -> IndicatorEntry -> Channel -> Handler ()
checkIndicator theNow user challengeId submissionId submissionLink indicator chan = do
(entries, _) <- runDB $ getChallengeSubmissionInfos 1 (\(Entity sid _) -> sid == submissionId) (const True) id challengeId
2019-02-22 14:41:43 +01:00
mapM_ (\t -> checkTarget theNow user submissionLink entries indicator t chan) (indicatorEntryTargets indicator)
checkTarget :: UTCTime -> User -> Text -> [TableEntry] -> IndicatorEntry -> Entity Target -> Channel -> Handler ()
checkTarget theNow user submissionLink entries indicator target chan = do
app <- getYesod
let status = getTargetStatus theNow entries indicator target
if status == TargetPassed
then
do
let message = "Congratulations!!! The target " ++ indicatorText
++ " was beaten by "
++ (fromMaybe "???" $ userName user)
++ ", "
++ " See " ++ submissionLink ++ "."
++ (T.replicate 10 " :champagne: ") ++ " :mleczko: "
msg chan message
case appAnnouncementHook $ appSettings app of
Just hook -> liftIO $ sendAnnouncement hook message
2019-02-22 14:41:43 +01:00
Nothing -> return ()
else
return ()
where indicatorText = prettyIndicatorEntry indicator
2019-08-29 21:34:13 +02:00
getScoreForOut :: (PersistQueryRead (YesodPersistBackend site), YesodPersist site, BaseBackend (YesodPersistBackend site) ~ SqlBackend) => Key Test -> Out -> HandlerFor site (Maybe Double)
2018-11-12 22:01:51 +01:00
getScoreForOut mainTestId out = do
mEvaluation <- runDB $ selectFirst [EvaluationChecksum ==. (outChecksum out),
EvaluationTest ==. mainTestId]
[]
return $ case mEvaluation of
Just evaluation -> evaluationScore $ entityVal evaluation
Nothing -> Nothing
2021-03-03 13:15:38 +01:00
getSubmission :: UserId -> Maybe TeamId -> Key Repo -> SHA1 -> Key Challenge -> Text -> Channel -> Handler (Key Submission)
getSubmission userId mTeamId repoId commit challengeId subDescription chan = do
2019-08-27 22:36:51 +02:00
challenge <- runDB $ get404 challengeId
2015-09-29 14:15:49 +02:00
maybeSubmission <- runDB $ getBy $ UniqueSubmissionRepoCommitChallenge repoId commit challengeId
case maybeSubmission of
Just (Entity submissionId _) -> do
2015-09-29 14:15:49 +02:00
msg chan "Submission already there, re-checking"
return submissionId
Nothing -> do
msg chan "Creating new submission"
time <- liftIO getCurrentTime
runDB $ insert $ Submission {
submissionRepo=repoId,
submissionCommit=commit,
submissionChallenge=challengeId,
2021-02-08 18:12:02 +01:00
submissionDescription=subDescription,
2015-09-30 20:32:06 +02:00
submissionStamp=time,
2016-02-14 08:44:16 +01:00
submissionSubmitter=userId,
submissionIsPublic=False,
2019-08-27 22:36:51 +02:00
submissionIsHidden=False,
2021-03-03 09:19:34 +01:00
submissionVersion=challengeVersion challenge,
2021-03-03 13:15:38 +01:00
submissionTeam=mTeamId }
2015-09-29 14:15:49 +02:00
getSubmissionRepo :: UserId -> Key Challenge -> RepoSpec -> Channel -> Handler (Maybe (Key Repo))
2019-08-29 08:56:22 +02:00
getSubmissionRepo userId challengeId repoSpec chan = getPossiblyExistingRepo checkRepoAvailibility userId challengeId repoSpec chan
2015-09-28 23:43:55 +02:00
checkRepoAvailibility :: Key Challenge -> Key Repo -> Channel -> Handler Bool
checkRepoAvailibility challengeId repoId chan = do
maybeOtherChallengeId <- runDB $ selectFirst ( [ChallengePublicRepo ==. repoId]
||. [ChallengePrivateRepo ==. repoId]) []
case maybeOtherChallengeId of
Just _ -> do
err chan "Repository already used as a challenge repo, please use a different repo or a different branch"
return False
Nothing -> do
maybeOtherSubmissionId <- runDB $ selectFirst [SubmissionRepo ==. repoId,
SubmissionChallenge !=. challengeId] []
case maybeOtherSubmissionId of
Just _ -> do
err chan "Repository already used as a submission repo for a different challenge, please use a different repo or a different branch"
return False
Nothing -> return True
2019-08-29 21:34:13 +02:00
challengeSubmissionWidget :: (ToMarkup a1, ToWidget App a2) => a2 -> a1 -> Challenge -> WidgetFor App ()
2015-09-06 15:33:37 +02:00
challengeSubmissionWidget formWidget formEnctype challenge = $(widgetFile "challenge-submission")
externalRepoInfo :: AppSettings -> WidgetFor site ()
externalRepoInfo settings = $(widgetFile "external-repo")
2020-03-28 18:08:44 +01:00
data ChallengeSubmissionData = ChallengeSubmissionData {
challengeSubmissionDataDescription :: Maybe Text,
challengeSubmissionDataTags :: Maybe Text,
2021-03-03 13:15:38 +01:00
challengeSubmissionDataRepo :: RepoSpec,
challengeSubmissionDataTeam :: Maybe TeamId }
2020-03-28 18:08:44 +01:00
2021-06-29 08:48:58 +02:00
fetchUserTeams :: (YesodPersist site, BackendCompatible SqlBackend (YesodPersistBackend site), PersistQueryRead (YesodPersistBackend site), PersistUniqueRead (YesodPersistBackend site)) => Key User -> HandlerFor site [Entity Team]
fetchUserTeams userId = runDB $ E.select $ E.from $ \(team, teamMember) -> do
E.where_ (teamMember ^. TeamMemberTeam E.==. team ^. TeamId
E.&&. teamMember ^. TeamMemberUser E.==. E.val userId)
E.orderBy [E.desc (teamMember ^. TeamMemberIsCaptain), E.asc (team ^. TeamIdent)]
return team
fetchDefaultTeam :: Key User -> HandlerFor App (Maybe (Key Team))
fetchDefaultTeam userId = do
myTeams <- fetchUserTeams userId
app <- getYesod
let autoTeam = appAutoTeam $ appSettings app
if autoTeam
then
return $ entityKey <$> listToMaybe myTeams
else
return Nothing
2020-03-28 18:08:44 +01:00
submissionForm :: UserId -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe (Maybe TeamId) -> Form ChallengeSubmissionData
2021-06-29 08:48:58 +02:00
submissionForm userId defaultUrl defBranch defaultGitAnnexRemote defaultTeam = renderBootstrap3 BootstrapBasicForm $ ChallengeSubmissionData
<$> aopt textField (fieldWithTooltip MsgSubmissionDescription MsgSubmissionDescriptionTooltip) Nothing
2017-09-27 19:38:42 +02:00
<*> aopt textField (tagsfs MsgSubmissionTags) Nothing
2020-03-28 18:08:44 +01:00
<*> (RepoSpec <$> areq textField (bfs MsgSubmissionUrl) defaultUrl
<*> areq textField (bfs MsgSubmissionBranch) defBranch
<*> aopt textField (bfs MsgSubmissionGitAnnexRemote) (Just defaultGitAnnexRemote))
2021-06-29 08:48:58 +02:00
<*> aopt (selectField teams) (bfs MsgAsTeam) defaultTeam
2021-03-03 13:15:38 +01:00
where teams = do
2021-06-29 08:48:58 +02:00
myTeams <- fetchUserTeams userId
2021-03-03 13:15:38 +01:00
optionsPairs $ map (\t -> (teamIdent $ entityVal t, entityKey t)) myTeams
2015-09-06 15:33:37 +02:00
2020-12-10 23:24:10 +01:00
getUserInfoR :: Handler Value
getUserInfoR = do
(Entity _ user) <- requireAuthPossiblyByToken
return $ String $ userIdent user
getCurrentTimeR :: Handler Value
getCurrentTimeR = do
theNow <- liftIO $ getCurrentTime
return $ toJSON theNow
getFormatAsLocalTimeR :: String -> Handler Value
getFormatAsLocalTimeR t = do
let ut = TR.read $ DLU.replace "T" " " $ DLU.replace "Z" " " t
tz <- liftIO $ getTimeZone ut
return $ toJSON $ utcToLocalTime tz ut
getMyEvaluationTriggerTokenJsonR :: Handler Value
getMyEvaluationTriggerTokenJsonR = do
(Entity _ user) <- requireAuthPossiblyByToken
return $ String $ fromMaybe "" $ userTriggerToken user
2020-12-10 23:24:10 +01:00
getAddUserR :: Handler Value
getAddUserR = do
mInfo <- authorizationTokenAuth
case mInfo of
2021-02-08 18:12:02 +01:00
Just infos -> do
let ident = jwtAuthInfoIdent infos
2020-12-10 23:24:10 +01:00
x <- runDB $ getBy $ UniqueUser ident
case x of
Just _ -> return $ Bool False
Nothing -> do
2021-06-28 18:38:15 +02:00
-- family or given name can be used for a team name
-- (as an ugly work-around...), hence we look at TEAM_FIELD and when
-- it is set to "given_name" or "family_name" it is not
-- considered a part of the user's
-- name
app <- getYesod
let teamField = appTeamField $ appSettings app
let uname = intercalate " " $ catMaybes (
[if teamField /= (Just "given_name")
then jwtAuthInfoGivenName infos
else Nothing,
if teamField /= (Just "family_name")
then jwtAuthInfoFamilyName infos
else Nothing])
let mUName = if (null uname)
then Nothing
else (Just uname)
userId <- runDB $ insert User
2020-12-10 23:24:10 +01:00
{ userIdent = ident
, userPassword = Nothing
2021-06-28 18:38:15 +02:00
, userName = mUName
2020-12-10 23:24:10 +01:00
, userIsAdmin = False
, userLocalId = Nothing
, userIsAnonymous = False
, userAvatar = Nothing
, userVerificationKey = Nothing
, userKeyExpirationDate = Nothing
, userTriggerToken = Nothing
, userAltRepoScheme = Nothing
}
2021-06-28 18:38:15 +02:00
case teamField of
Just teamFieldName -> do
case jwtAuthInfoCustomField teamFieldName infos of
Just team -> do
t <- runDB $ getBy $ UniqueTeam team
(teamId, isCaptain) <- case t of
Just (Entity existingTeamId _) -> return (existingTeamId, False)
Nothing -> do
newTeamId <- runDB $ insert $ Team {teamIdent = team,
teamAvatar = Nothing}
return (newTeamId, True)
runDB $ addMemberToTeam userId teamId isCaptain
return ()
Nothing -> return ()
Nothing -> return ()
2020-12-10 23:24:10 +01:00
return $ Bool True
Nothing -> return $ Bool False
2020-12-09 21:55:31 +01:00
2021-04-27 11:49:22 +02:00
addUserApi :: Swagger
addUserApi = spec & definitions .~ defs
where
(defs, spec) = runDeclare declareAddUserApi mempty
declareAddUserApi :: Declare (Definitions Schema) Swagger
declareAddUserApi = do
-- param schemas
response <- declareResponse (Proxy :: Proxy Bool)
return $ mempty
& paths .~
fromList [ ("/api/add-user",
mempty & DS.get ?~ (mempty
& parameters .~ [ ]
& produces ?~ MimeList ["application/json"]
& description ?~ "Creates a new user"
& at 200 ?~ Inline response))
]
userInfoApi :: Swagger
userInfoApi = spec & definitions .~ defs
where
(defs, spec) = runDeclare declareUserInfoApi mempty
declareUserInfoApi :: Declare (Definitions Schema) Swagger
declareUserInfoApi = do
-- param schemas
response <- declareResponse (Proxy :: Proxy String)
return $ mempty
& paths .~
fromList [ ("/api/user-info",
mempty & DS.get ?~ (mempty
& parameters .~ [ ]
& produces ?~ MimeList ["application/json"]
& description ?~ "Returns the identifier of the user"
& at 200 ?~ Inline response))
]
currentTimeApi :: Swagger
currentTimeApi = spec & definitions .~ defs
where
(defs, spec) = runDeclare declareCurrentTimeApi mempty
declareCurrentTimeApi :: Declare (Definitions Schema) Swagger
declareCurrentTimeApi = do
-- param schemas
response <- declareResponse (Proxy :: Proxy String)
return $ mempty
& paths .~
fromList [ ("/api/current-time",
mempty & DS.get ?~ (mempty
& parameters .~ [ ]
& produces ?~ MimeList ["application/json"]
& description ?~ "Returns the current time as measured on the server side"
& at 200 ?~ Inline response))
]
formatAsLocalTimeApi :: Swagger
formatAsLocalTimeApi = spec & definitions .~ defs
where
(defs, spec) = runDeclare declareFormatAsLocalTimeApi mempty
declareFormatAsLocalTimeApi :: Declare (Definitions Schema) Swagger
declareFormatAsLocalTimeApi = do
-- param schemas
response <- declareResponse (Proxy :: Proxy String)
let utcTimeSchema = toParamSchema (Proxy :: Proxy String)
return $ mempty
& paths .~
fromList [ ("/api/format-as-local-time/{utcTime}",
mempty & DS.get ?~ (mempty
& parameters .~ [ ]
& produces ?~ MimeList ["application/json"]
& description ?~ "Formats the given UTC time stamp as a local time"
& parameters .~ [ Inline $ mempty
& name .~ "utcTime"
& required ?~ True
& schema .~ ParamOther (mempty
& in_ .~ ParamPath
& paramSchema .~ utcTimeSchema) ]
& at 200 ?~ Inline response))
]
myEvaluationTriggerTokenApi :: Swagger
myEvaluationTriggerTokenApi = spec & definitions .~ defs
where
(defs, spec) = runDeclare declareMyEvaluationTriggerTokenApi mempty
declareMyEvaluationTriggerTokenApi :: Declare (Definitions Schema) Swagger
declareMyEvaluationTriggerTokenApi = do
-- param schemas
response <- declareResponse (Proxy :: Proxy String)
return $ mempty
& paths .~
fromList [ ("/api/my-evaluation-trigger-token",
mempty & DS.get ?~ (mempty
& parameters .~ [ ]
& produces ?~ MimeList ["application/json"]
& description ?~ "Returns the token for triggering evaluations"
& at 200 ?~ Inline response))
]
2021-04-27 11:49:22 +02:00
2021-02-05 14:44:46 +01:00
declareAllSubmissionsApi :: String -> String -> Declare (Definitions Schema) Swagger
declareAllSubmissionsApi q d = do
-- param schemas
let challengeNameSchema = toParamSchema (Proxy :: Proxy String)
allSubmissionsResponse <- declareResponse (Proxy :: Proxy SubmissionsView)
return $ mempty
& paths .~
fromList [ ("/api/" ++ q ++ "/{challengeName}",
mempty & DS.get ?~ (mempty
& parameters .~ [ Inline $ mempty
& name .~ "challengeName"
& required ?~ True
& schema .~ ParamOther (mempty
& in_ .~ ParamPath
& paramSchema .~ challengeNameSchema) ]
& produces ?~ MimeList ["application/json"]
2021-02-08 12:27:44 +01:00
& description ?~ T.pack d
2021-02-05 14:44:46 +01:00
& at 200 ?~ Inline allSubmissionsResponse))
]
allSubmissionsApi :: Swagger
allSubmissionsApi = spec & definitions .~ defs
where
(defs, spec) = runDeclare (declareAllSubmissionsApi "challenge-all-submissions" "Returns all submissions for a challenge") mempty
mySubmissionsApi :: Swagger
mySubmissionsApi = spec & definitions .~ defs
where
(defs, spec) = runDeclare (declareAllSubmissionsApi "challenge-my-submissions" "Returns all submissions for a challenge for the user") mempty
2020-12-31 08:46:35 +01:00
getChallengeAllSubmissionsJsonR :: Text -> Handler Value
2021-02-05 11:31:03 +01:00
getChallengeAllSubmissionsJsonR challengeName = do
v <- fetchAllSubmissionsView challengeName
2020-12-31 08:46:35 +01:00
return $ toJSON v
2020-12-10 21:36:17 +01:00
getChallengeMySubmissionsJsonR :: Text -> Handler Value
2021-02-05 11:31:03 +01:00
getChallengeMySubmissionsJsonR challengeName = do
v <- fetchMySubmissionsView challengeName
2020-12-31 08:46:35 +01:00
return $ toJSON v
fetchAllSubmissionsView :: Text -> Handler SubmissionsView
2021-02-05 11:31:03 +01:00
fetchAllSubmissionsView challengeName = do
fetchChallengeSubmissionsView (const True) challengeName
2020-12-09 21:55:31 +01:00
2020-12-31 08:46:35 +01:00
fetchMySubmissionsView :: Text -> Handler SubmissionsView
2021-02-05 11:31:03 +01:00
fetchMySubmissionsView challengeName = do
2021-01-17 20:37:25 +01:00
Entity userId _ <- requireAuthPossiblyByToken
2021-02-05 11:31:03 +01:00
fetchChallengeSubmissionsView (\(Entity _ submission) -> (submissionSubmitter submission == userId)) challengeName
2020-12-31 08:46:35 +01:00
convertTagInfoToView :: (Entity Import.Tag, Entity SubmissionTag) -> TagView
convertTagInfoToView tagInfo =
TagView {
tagViewName = tagName $ entityVal $ fst tagInfo,
tagViewDescription = tagDescription $ entityVal $ fst tagInfo,
tagViewColor = tagColor $ entityVal $ fst tagInfo,
2020-12-31 08:46:35 +01:00
tagViewAccepted = submissionTagAccepted $ entityVal $ snd tagInfo
}
convertEvaluationToView :: Map TestReference Evaluation -> Entity Test -> Maybe EvaluationView
2021-02-08 18:12:02 +01:00
convertEvaluationToView theMapping entTest =
2020-12-31 08:46:35 +01:00
case join $ evaluationScore <$> mEvaluation of
Just s ->
Just $ EvaluationView {
evaluationViewScore = formatTruncatedScore formattingOps mEvaluation,
evaluationViewFullScore = s,
evaluationViewTest = testRef
}
Nothing -> Nothing
2021-02-08 18:12:02 +01:00
where mEvaluation = Map.lookup testRef theMapping
2020-12-31 08:46:35 +01:00
formattingOps = getTestFormattingOpts $ entityVal entTest
testRef = getTestReference entTest
-- convertTableEntryToView :: Maybe UserId -> [Entity Test] -> TableEntry -> SubmissionView
convertTableEntryToView :: [Entity Test] -> TableEntry -> HandlerFor App SubmissionView
convertTableEntryToView tests entry = do
mUserEnt <- maybeAuthPossiblyByToken
2020-12-31 08:46:35 +01:00
isReevaluable <- runDB $ canBeReevaluated $ entityKey $ tableEntrySubmission entry
let isVisible = True
2020-12-31 08:46:35 +01:00
return $ SubmissionView {
submissionViewId = fromSqlKey $ entityKey $ tableEntrySubmission entry,
submissionViewVariantId = fromSqlKey $ entityKey $ tableEntryVariant entry,
submissionViewRank = tableEntryRank entry,
submissionViewSubmitter = formatSubmitter $ entityVal $ tableEntrySubmitter entry,
submissionViewWhen = submissionStamp submission,
submissionViewVersion = tableEntryVersion entry,
submissionViewDescription = descriptionToBeShown submission
(entityVal $ tableEntryVariant entry)
(map entityVal $ tableEntryParams entry),
2020-12-31 08:46:35 +01:00
submissionViewTags = Import.map convertTagInfoToView $ tableEntryTagsInfo entry,
submissionViewHash = fromSHA1ToText $ submissionCommit submission,
submissionViewEvaluations = catMaybes $ Import.map (convertEvaluationToView $ tableEntryMapping entry) tests,
submissionViewIsOwner = (entityKey <$> mUserEnt) == Just (submissionSubmitter submission),
2020-12-31 08:46:35 +01:00
submissionViewIsReevaluable = isReevaluable,
submissionViewIsVisible = isVisible,
2021-03-03 22:02:39 +01:00
submissionViewIsPublic = submissionIsPublic submission,
submissionViewTeam = teamIdent <$> entityVal <$> tableEntryTeam entry
2020-12-31 08:46:35 +01:00
}
where submission = entityVal $ tableEntrySubmission entry
fetchChallengeSubmissionsView :: ((Entity Submission) -> Bool) -> Text -> Handler SubmissionsView
2021-02-08 18:12:02 +01:00
fetchChallengeSubmissionsView condition challengeName = do
Entity challengeId _ <- runDB $ getBy404 $ UniqueName challengeName
2020-12-31 08:46:35 +01:00
(evaluationMaps, tests') <- runDB $ getChallengeSubmissionInfos 1 condition (const True) id challengeId
let tests = sortBy testComparator tests'
submissions <- mapM (convertTableEntryToView tests) evaluationMaps
return $ SubmissionsView {
submissionsViewSubmissions = submissions,
submissionsViewTests = map getTestReference tests
}
-- TODO switch to fetchChallengeSubmissionSview
2015-09-29 22:31:56 +02:00
getChallengeMySubmissionsR :: Text -> Handler Html
2021-02-08 18:12:02 +01:00
getChallengeMySubmissionsR challengeName = do
2015-09-30 20:42:25 +02:00
userId <- requireAuthId
2021-02-08 18:12:02 +01:00
getChallengeSubmissions (\(Entity _ submission) -> (submissionSubmitter submission == userId)) challengeName
2015-09-29 22:31:56 +02:00
getChallengeAllSubmissionsR :: Text -> Handler Html
2021-02-08 18:12:02 +01:00
getChallengeAllSubmissionsR challengeName = getChallengeSubmissions (\_ -> True) challengeName
2015-09-30 20:42:25 +02:00
2020-12-31 08:46:35 +01:00
data EvaluationView = EvaluationView {
evaluationViewScore :: Text,
evaluationViewFullScore :: Double,
evaluationViewTest :: TestReference
}
instance ToJSON EvaluationView where
toJSON e = object
[ "score" .= evaluationViewScore e
, "full-score" .= evaluationViewFullScore e
, "test" .= evaluationViewTest e
]
2021-02-05 14:44:46 +01:00
instance ToSchema EvaluationView where
declareNamedSchema _ = do
stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String)
doubleSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Double)
testRefSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy TestReference)
return $ NamedSchema (Just "Evaluation") $ mempty
& type_ .~ SwaggerObject
& properties .~
fromList [ ("score", stringSchema)
, ("full-score", doubleSchema)
, ("test", testRefSchema)
]
& required .~ [ "score", "full-score", "test" ]
2020-12-31 08:46:35 +01:00
data TagView = TagView {
tagViewName :: Text,
tagViewDescription :: Maybe Text,
tagViewColor :: Maybe Text,
2020-12-31 08:46:35 +01:00
tagViewAccepted :: Maybe Bool }
instance ToJSON TagView where
toJSON t = object
[ "name" .= tagViewName t
, "description" .= tagViewDescription t
, "color" .= tagViewColor t
2020-12-31 08:46:35 +01:00
, "accepted" .= tagViewAccepted t
]
2021-02-05 14:44:46 +01:00
instance ToSchema TagView where
declareNamedSchema _ = do
stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String)
boolSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Bool)
2021-05-29 15:06:22 +02:00
return $ NamedSchema (Just "TagView") $ mempty
2021-02-05 14:44:46 +01:00
& type_ .~ SwaggerObject
& properties .~
fromList [ ("name", stringSchema)
, ("description", stringSchema)
, ("color", stringSchema)
2021-02-05 14:44:46 +01:00
, ("accepted", boolSchema)
]
& required .~ [ "name", "color", "description" ]
2021-02-05 14:44:46 +01:00
2020-12-31 08:46:35 +01:00
data SubmissionView = SubmissionView {
submissionViewId :: Int64,
submissionViewVariantId :: Int64,
submissionViewRank :: Int,
submissionViewSubmitter :: Text,
submissionViewWhen :: UTCTime,
2021-09-25 18:37:08 +02:00
submissionViewVersion :: ((Int, Int, Int), Maybe Import.Tag),
2020-12-31 08:46:35 +01:00
submissionViewDescription :: Text,
submissionViewTags :: [TagView],
submissionViewHash :: Text,
submissionViewEvaluations :: [EvaluationView],
submissionViewIsOwner :: Bool,
submissionViewIsReevaluable :: Bool,
submissionViewIsVisible :: Bool,
2021-03-03 22:02:39 +01:00
submissionViewIsPublic :: Bool,
submissionViewTeam :: Maybe Text
2020-12-31 08:46:35 +01:00
}
instance ToJSON SubmissionView where
toJSON s = object
["id" .= submissionViewId s
, "variant" .= submissionViewVariantId s
, "rank" .= submissionViewRank s
, "submitter" .= submissionViewSubmitter s
, "when" .= submissionViewWhen s
2021-09-25 18:37:08 +02:00
, "version" .= (fst $ submissionViewVersion s)
, "phase" .= (snd $ submissionViewVersion s)
2020-12-31 08:46:35 +01:00
, "description" .= submissionViewDescription s
, "tags" .= submissionViewTags s
, "hash" .= submissionViewHash s
, "evaluations" .= submissionViewEvaluations s
, "isOwner" .= submissionViewIsOwner s
, "isReevaluable" .= submissionViewIsReevaluable s
, "isVisible" .= submissionViewIsVisible s
, "isPublic" .= submissionViewIsPublic s
2021-03-03 22:02:39 +01:00
, "team" .= submissionViewTeam s
2020-12-31 08:46:35 +01:00
]
2021-02-05 14:44:46 +01:00
instance ToSchema SubmissionView where
declareNamedSchema _ = do
stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String)
boolSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Bool)
intSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Int)
tagsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [TagView])
evalsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [EvaluationView])
2021-09-25 18:37:08 +02:00
tagSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [Import.Tag])
2021-02-05 14:44:46 +01:00
return $ NamedSchema (Just "SubmissionView") $ mempty
& type_ .~ SwaggerObject
& properties .~
fromList [ ("id", submissionIdSchema)
, ("variant", variantIdSchema)
2021-02-05 14:44:46 +01:00
, ("rank", intSchema)
, ("submitter", submitterSchema)
2021-02-05 14:44:46 +01:00
, ("when", stringSchema)
, ("version", versionSchema)
2021-09-25 18:37:08 +02:00
, ("phase", tagSchema)
2021-02-05 14:44:46 +01:00
, ("description", stringSchema)
, ("tags", tagsSchema)
, ("hash", hashSchema)
2021-02-05 14:44:46 +01:00
, ("evaluations", evalsSchema)
, ("isOwner", boolSchema)
, ("isReevaluable", boolSchema)
, ("isVisible", isVisibleSchema)
, ("isPublic", isPublicSchema)
2021-03-03 22:02:39 +01:00
, ("team", stringSchema)
2021-02-05 14:44:46 +01:00
]
& required .~ [ "id", "variant", "rank", "submitter", "when", "version",
"description", "tags", "hash", "evaluations",
"isOwner", "isReevaluable", "isVisible", "isPublic" ]
2020-12-31 08:46:35 +01:00
data SubmissionsView = SubmissionsView {
submissionsViewSubmissions :: [SubmissionView],
submissionsViewTests :: [TestReference]
}
instance ToJSON SubmissionsView where
toJSON ss = object
[ "tests" .= submissionsViewTests ss,
"submissions" .= submissionsViewSubmissions ss
]
2021-02-05 14:44:46 +01:00
instance ToSchema SubmissionsView where
declareNamedSchema _ = do
submissionViewsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [SubmissionView])
testRefsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [TestReference])
2021-05-29 15:06:22 +02:00
return $ NamedSchema (Just "SubmissionsView") $ mempty
2021-02-05 14:44:46 +01:00
& type_ .~ SwaggerObject
& properties .~
fromList [ ("submissions", submissionViewsSchema)
, ("tests", testRefsSchema)
2021-02-05 14:44:46 +01:00
]
& required .~ [ "tests", "submission" ]
2015-09-30 20:42:25 +02:00
getChallengeSubmissions :: ((Entity Submission) -> Bool) -> Text -> Handler Html
2021-02-08 18:12:02 +01:00
getChallengeSubmissions condition challengeName = do
Entity challengeId challenge <- runDB $ getBy404 $ UniqueName challengeName
(evaluationMaps, tests') <- runDB $ getChallengeSubmissionInfos 1 condition (const True) id challengeId
2018-09-08 21:24:25 +02:00
let tests = sortBy testComparator tests'
2016-02-16 21:10:10 +01:00
mauth <- maybeAuth
let muserId = (\(Entity uid _) -> uid) <$> mauth
2015-09-29 22:31:56 +02:00
app <- getYesod
let scheme = appRepoScheme $ appSettings app
challengeRepo <- runDB $ get404 $ challengePublicRepo challenge
2018-09-01 14:23:41 +02:00
let params = getNumericalParams evaluationMaps
2018-07-28 17:04:27 +02:00
2018-07-28 17:30:00 +02:00
challengeLayout True challenge (challengeAllSubmissionsWidget muserId
challenge
scheme
challengeRepo
evaluationMaps
tests
params)
2018-09-01 14:23:41 +02:00
getNumericalParams :: [TableEntry] -> [Text]
getNumericalParams entries = filter (isNumericalParam entries) $ getAllParams entries
isNumericalParam :: [TableEntry] -> Text -> Bool
isNumericalParam entries param =
all doesTextRepresentNumber
$ concat
$ map ((map parameterValue)
. (filter (\p -> parameterName p == param))
. (map entityVal)
. tableEntryParams) entries
doesTextRepresentNumber :: Text -> Bool
doesTextRepresentNumber t = isJust $ ((TR.readMaybe $ T.unpack t) :: Maybe Double)
getAllParams :: [TableEntry] -> [Text]
getAllParams entries = sort
$ nub
$ concat
$ map (\entry -> map (parameterName . entityVal) (tableEntryParams entry)) entries
2018-07-28 17:30:00 +02:00
challengeAllSubmissionsWidget :: Maybe UserId
-> Challenge
-> RepoScheme
-> Repo
-> [TableEntry]
-> [Entity Test]
-> [Text]
-> WidgetFor App ()
2018-07-28 17:04:27 +02:00
challengeAllSubmissionsWidget muserId challenge scheme challengeRepo submissions tests params =
$(widgetFile "challenge-all-submissions")
2018-11-12 10:11:58 +01:00
where delta = Number 4
higherTheBetterArray = getIsHigherTheBetterArray $ map entityVal tests
2018-07-28 22:02:47 +02:00
paramGraphsWidget :: Challenge -> [Entity Test] -> [Text] -> WidgetFor App ()
paramGraphsWidget challenge tests params = $(widgetFile "param-graphs")
2018-09-01 14:01:17 +02:00
where chartJSs = getChartJss challenge selectedTests params
selectedTests = reverse $ getMainTests tests
2018-09-01 14:01:17 +02:00
getChartJss :: Challenge -> [Entity Test] -> [Text] -> JavascriptUrl (Route App)
getChartJss challenge tests params =
mconcat $ [(getChartJs challenge test param) | test <- tests, param <- params]
2018-07-28 17:04:27 +02:00
2018-07-28 17:30:00 +02:00
getChartJs :: Challenge
-> Entity Test
2018-07-28 17:30:00 +02:00
-> Text
-> JavascriptUrl (Route App)
getChartJs challenge (Entity testId test) param = [julius|
$.getJSON("@{ChallengeParamGraphDataR (challengeName challenge) testId param}", function(data) {
2018-07-28 17:04:27 +02:00
c3.generate({
bindto: '#chart-' + #{toJSON param} + '-' + #{toJSON testId},
2018-07-28 17:04:27 +02:00
data: data,
axis: {
x: {
label: #{toJSON param},
},
y: {
label: #{toJSON testFormatted},
}
}
}) });
|]
where testFormatted = formatTest test
2015-09-29 22:31:56 +02:00
2018-07-05 22:17:25 +02:00
challengeLayout :: Bool -> Challenge -> WidgetFor App () -> HandlerFor App Html
2015-09-06 14:24:49 +02:00
challengeLayout withHeader challenge widget = do
2017-09-27 19:38:42 +02:00
tagsAvailableAsJSON <- runDB $ getAvailableTagsAsJSON
2021-02-08 18:12:02 +01:00
theVersion <- runDB $ getBy404 $ UniqueVersionByCommit $ challengeVersion challenge
let versionFormatted = formatVersion ((versionMajor $ entityVal theVersion),
(versionMinor $ entityVal theVersion),
(versionPatch $ entityVal theVersion))
2016-05-03 12:29:56 +02:00
maybeUser <- maybeAuth
2015-09-06 14:24:49 +02:00
bc <- widgetToPageContent widget
2015-09-04 23:23:32 +02:00
defaultLayout $ do
2015-09-06 14:24:49 +02:00
setTitle "Challenge"
$(widgetFile "challenge")
getTestProgressR :: Int -> Int -> Handler TypedContent
getTestProgressR m d = runViewProgress $ doTestProgress m d
2021-07-30 12:19:27 +02:00
getTestProgressJsonR :: Int -> Int -> Handler Value
getTestProgressJsonR m d = do
_ <- requireAuthPossiblyByToken
runViewProgressAsynchronously $ doTestProgress m d
declareTestProgressSwagger :: Declare (Definitions Schema) Swagger
declareTestProgressSwagger = do
-- param schemas
let numberSchema = toParamSchema (Proxy :: Proxy Int)
numberResponse <- declareResponse (Proxy :: Proxy Int)
return $ mempty
& paths .~
fromList [ ("/api/test-progress/{num}/{delay}",
mempty & DS.get ?~ (mempty
& parameters .~ [ Inline $ mempty
& name .~ "num"
& description ?~ "The number up to which to count"
& required ?~ True
& schema .~ ParamOther (mempty
& in_ .~ ParamPath
& paramSchema .~ numberSchema),
Inline $ mempty
& name .~ "delay"
& description ?~ "Delay in seconds"
& required ?~ True
& schema .~ ParamOther (mempty
& in_ .~ ParamPath
& paramSchema .~ numberSchema)
]
& produces ?~ MimeList ["application/json"]
& description ?~ "Counts up to a given number, returns an ID of an asynchronous job. This is just a sample end-point for testing logging of asynchronous jobs."
& at 200 ?~ Inline numberResponse))
]
testProgressApi :: Swagger
testProgressApi = spec & definitions .~ defs
where
(defs, spec) = runDeclare declareTestProgressSwagger mempty
doTestProgress :: Int -> Int -> Channel -> Handler ()
doTestProgress m d chan = do
2021-03-03 15:50:26 +01:00
_ <- forM [1..m] $ (\i -> do
msg chan $ (Data.Text.pack $ ("GO\n" ++ show i))
liftIO $ threadDelay (d * 1000000)
return ())
return ()
2021-07-30 12:19:27 +02:00
declareViewProgressWithWebSocketsSwagger :: Declare (Definitions Schema) Swagger
declareViewProgressWithWebSocketsSwagger = do
-- param schemas
let numberSchema = toParamSchema (Proxy :: Proxy Int)
numberResponse <- declareResponse (Proxy :: Proxy Int)
return $ mempty
& paths .~
fromList [ ("/api/view-progress-with-web-sockets/{jobId}",
mempty & DS.get ?~ (mempty
& parameters .~ [ Inline $ mempty
& name .~ "jobId"
& description ?~ "The ID for the job to be shown"
& required ?~ True
& schema .~ ParamOther (mempty
& in_ .~ ParamPath
& paramSchema .~ numberSchema)]
& produces ?~ MimeList ["application/json"]
& description ?~ "Initiates a web socket communication with which progress logs can be read. Returns just the Job ID (the same number as the parameter)"
& at 200 ?~ Inline numberResponse))
]
viewProgressWithWebSockets :: Swagger
viewProgressWithWebSockets = spec & definitions .~ defs
where
(defs, spec) = runDeclare declareViewProgressWithWebSocketsSwagger mempty
declareViewProgressLogSwagger :: Declare (Definitions Schema) Swagger
declareViewProgressLogSwagger = do
let numberSchema = toParamSchema (Proxy :: Proxy Int)
numberResponse <- declareResponse (Proxy :: Proxy Int)
return $ mempty
& paths .~
fromList [ ("/api/view-progress-log/{jobId}",
mempty & DS.get ?~ (mempty
& parameters .~ [ Inline $ mempty
& name .~ "jobId"
& description ?~ "The ID for the job to be shown"
& required ?~ True
& schema .~ ParamOther (mempty
& in_ .~ ParamPath
& paramSchema .~ numberSchema)]
& produces ?~ MimeList ["text/html"]
& description ?~ "Returns HTML code with embedded JS script for showing logs via web sockets"
& at 200 ?~ Inline numberResponse))
]
viewProgressLog :: Swagger
viewProgressLog = spec & definitions .~ defs
where
(defs, spec) = runDeclare declareViewProgressLogSwagger mempty