gonito/Handler/ShowChallenge.hs
Filip Gralinski 9f4942a657 All solutions are visible now
All the data (except for the repo URL and dev outputs) could be
inferred, anyway. So it would not make much sense to hide it.
2021-08-21 16:11:15 +02:00

1729 lines
77 KiB
Haskell

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DoAndIfThenElse #-}
module Handler.ShowChallenge where
import Import hiding (Proxy, fromList)
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs)
import qualified Data.Text.Lazy as TL
import Text.Markdown
import qualified Data.Text as T
import qualified Data.HashMap.Strict as HMS
import qualified Yesod.Table as Table
import Control.Concurrent.Lifted (threadDelay)
import Handler.Extract
import Handler.Shared
import Handler.Runner
import Handler.Tables
import Handler.TagUtils
import Handler.MakePublic
import Handler.Dashboard
import Handler.Common
import Handler.Evaluate
import Handler.JWT
import Handler.Team
import Database.Persist.Sql (fromSqlKey)
import qualified Data.Map as Map
import Web.Announcements
import Data.Maybe (fromJust)
import Text.Blaze
import Data.Aeson
import Gonito.ExtractMetadata (ExtractionOptions(..),
extractMetadataFromRepoDir,
GonitoMetadata(..),
parseTags,
Link(..))
import qualified Text.Read as TR
import GEval.Core
import GEval.EvaluationScheme
import GEval.Formatting
import GEval.Common (MetricResult(..))
import PersistSHA1
import System.IO (readFile)
import Data.Text (pack, unpack)
import Data.List (nub)
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 ((.=), (^.))
import Data.Proxy as DPR
import Data.HashMap.Strict.InsOrd (fromList)
instance ToJSON LeaderboardEntry where
toJSON entry = object
[ "submitter" .= (formatSubmitter $ leaderboardUser entry)
, "team" .= (teamIdent <$> entityVal <$> leaderboardTeam entry)
, "when" .= (submissionStamp $ leaderboardBestSubmission entry)
, "version" .= leaderboardVersion entry
, "description" .= descriptionToBeShown (leaderboardBestSubmission entry)
(leaderboardBestVariant entry)
(leaderboardParams entry)
, "times" .= leaderboardNumberOfSubmissions entry
, "hash" .= (fromSHA1ToText $ submissionCommit $ leaderboardBestSubmission entry)
, "isPublic" .= (submissionIsPublic $ leaderboardBestSubmission entry)
, "isReevaluable" .= (leaderboardIsReevaluable entry)
, "isVisible" .= (leaderboardIsVisible entry)
, "id" .= (leaderboardBestSubmissionId entry)
, "variant" .= (leaderboardBestVariantId entry)
]
declareLeaderboardSwagger :: Declare (Definitions Schema) Swagger
declareLeaderboardSwagger = do
-- param schemas
let challengeNameSchema = toParamSchema (Proxy :: Proxy String)
leaderboardResponse <- declareResponse (Proxy :: Proxy LeaderboardView)
return $ mempty
& paths .~
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" ]
getLeaderboardJsonR :: Text -> Handler Value
getLeaderboardJsonR challengeName = do
Entity challengeId challenge <- runDB $ getBy404 $ UniqueName challengeName
leaderboardStyle <- determineLeaderboardStyle challenge
(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])
return $ NamedSchema (Just "LeaderboardEntry") $ mempty
& type_ .~ SwaggerObject
& properties .~
fromList [ ("submitter", submitterSchema)
, ("team", stringSchema)
, ("when", stringSchema)
, ("version", versionSchema)
, ("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)
, ("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
}
determineLeaderboardStyle :: Challenge -> Handler LeaderboardStyle
determineLeaderboardStyle challenge = do
app <- getYesod
let leaderboardStyle = appLeaderboardStyle $ appSettings app
return $ case challengeIsCompetition challenge of
Just True -> BySubmitter
_ -> leaderboardStyle
getShowChallengeR :: Text -> Handler Html
getShowChallengeR challengeName = do
app <- getYesod
challengeEnt@(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName challengeName
leaderboardStyle <- determineLeaderboardStyle challenge
isHealthy <- isChallengeHealthy challenge
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)
mauth <- maybeAuth
let params = getNumericalParams entries
let scheme = appRepoScheme $ appSettings app
challengeRepo <- runDB $ get404 $ challengePublicRepo challenge
challengeLayout True challenge (showChallengeWidget mauth
challengeEnt
scheme
challengeRepo
repo
leaderboard
altLeaderboard
params
tests
altTests
isHealthy)
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)
getChallengeReadmeR :: Text -> Handler Html
getChallengeReadmeR challengeName = do
(Entity _ challenge) <- runDB $ getBy404 $ UniqueName challengeName
readme <- challengeReadme challengeName
challengeLayout False challenge $ toWidget readme
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
-- 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
doChallengeReadmeContents :: Text -> Handler TL.Text
doChallengeReadmeContents challengeName = do
(Entity _ challenge) <- runDB $ getBy404 $ UniqueName challengeName
let repoId = challengePublicRepo challenge
repoDir <- getRepoDir repoId
let readmeFilePath = repoDir </> readmeFile
theContents <- liftIO $ System.IO.readFile readmeFilePath
return $ TL.pack theContents
showChallengeWidget :: Maybe (Entity User)
-> Entity Challenge
-> RepoScheme
-> Repo
-> Repo
-> [LeaderboardEntry]
-> (Maybe [LeaderboardEntry])
-> [Text]
-> [Entity Test]
-> (Maybe [Entity Test])
-> Bool
-> WidgetFor App ()
showChallengeWidget mUserEnt
(Entity challengeId challenge)
scheme
challengeRepo
repo
leaderboard
mAltLeaderboard
params
tests
mAltTests
isHealthy
= $(widgetFile "show-challenge")
where leaderboardWithRanks = zip [1..] leaderboard
mAltLeaderboardWithRanks = zip [1..] <$> mAltLeaderboard
maybeRepoLink = getRepoLink repo
delta = Number 4
higherTheBetterArray = getIsHigherTheBetterArray $ map entityVal tests
mUserId = entityKey <$> mUserEnt
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
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
fixGonito t = (T.replace "https://gonito.net" "https://gonito.net/gitlist" t) <> ".git"
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
theUrl = repoUrl repo
bareRepoName = drop sitePrefixLen theUrl
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
getChallengeHowToR :: Text -> Handler Html
getChallengeHowToR challengeName = do
(Entity _ challenge) <- runDB $ getBy404 $ UniqueName challengeName
maybeUser <- maybeAuth
app <- getYesod
let settings = appSettings app
let publicRepoId = challengePublicRepo challenge
repo <- runDB $ get404 publicRepoId
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
let isIDSet = case maybeUser of
Just (Entity _ user) -> isJust $ userLocalId user
Nothing -> False
isSSHUploaded <- case maybeUser of
Just (Entity userId _) -> do
ukeys <- runDB $ selectList [PublicKeyUser ==. userId] []
return $ not (null ukeys)
Nothing -> return False
challengeLayout False challenge (challengeHowTo
challenge
settings
repo
(idToBeShown challenge maybeUser)
isIDSet
isSSHUploaded
(join $ userAltRepoScheme <$> entityVal <$> maybeUser)
mToken)
idToBeShown :: p -> Maybe (Entity User) -> Text
idToBeShown _ maybeUser =
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
defaultBranch :: IsString a => RepoScheme -> Maybe a
defaultBranch SelfHosted = Just "master"
defaultBranch Branches = Nothing
defaultBranch NoInternalGitServer = Nothing
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
postHealR :: ChallengeId -> Handler TypedContent
postHealR challengeId = runViewProgress $ doHeal challengeId
doHeal :: Key Challenge -> Channel -> HandlerFor App ()
doHeal challengeId chan = do
challenge <- runDB $ get404 challengeId
_ <- getRepoDirOrClone (challengePrivateRepo challenge) chan
_ <- getRepoDirOrClone (challengePublicRepo challenge) chan
return ()
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)
getChallengeSubmissionR :: Text -> Handler Html
getChallengeSubmissionR challengeName = do
(Entity _ challenge) <- runDB $ getBy404 $ UniqueName challengeName
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)
((<> challengeName) <$> (join $ userAltRepoScheme <$> entityVal <$> maybeUser))
Entity userId _ <- requireAuth
defaultTeam <- fetchDefaultTeam userId
(formWidget, formEnctype) <- generateFormPost $ submissionForm userId (Just defaultUrl) (defaultBranch scheme) (repoGitAnnexRemote repo) (Just defaultTeam)
challengeLayout True challenge $ challengeSubmissionWidget formWidget formEnctype challenge
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)
wrongSubmissionResponse <- declareResponse (Proxy :: Proxy GonitoStatus)
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."
& at 200 ?~ Inline challengeSubmissionResponse
& at 422 ?~ Inline wrongSubmissionResponse))
]
challengeSubmissionApi :: Swagger
challengeSubmissionApi = spec & definitions .~ defs
where
(defs, spec) = runDeclare declareChallengeSubmissionSwagger mempty
data ChallangeSubmissionStatus = SubmissionOK | SubmissionWrong Text
deriving (Eq, Show)
data GonitoStatus = GonitoStatus {
detail :: Text
} deriving (Eq, Show, Generic)
instance ToJSON GonitoStatus
instance ToSchema GonitoStatus
postChallengeSubmissionJsonR :: Text -> Handler Value
postChallengeSubmissionJsonR challengeName = do
Entity userId _ <- requireAuthPossiblyByToken
challengeEnt@(Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName
((result, _), _) <- runFormPostNoToken $ submissionForm userId Nothing Nothing Nothing Nothing
let submissionData' = case result of
FormSuccess res -> Just res
_ -> Nothing
Just submissionData = submissionData'
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."
postChallengeSubmissionR :: Text -> Handler TypedContent
postChallengeSubmissionR challengeName = do
userId <- requireAuthId
(Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName
((result, _), _) <- runFormPost $ submissionForm userId Nothing Nothing Nothing Nothing
let submissionData' = case result of
FormSuccess res -> Just res
_ -> Nothing
Just submissionData = submissionData'
runViewProgress $ doCreateSubmission userId challengeId submissionData
postTriggerLocallyR :: Handler TypedContent
postTriggerLocallyR = do
(Just challengeName) <- lookupPostParam "challenge"
(Just localId) <- lookupPostParam "user"
mBranch <- lookupPostParam "branch"
mGitAnnexRemote <- lookupPostParam "git-annex-remote"
[Entity userId _] <- runDB $ selectList [UserLocalId ==. Just localId] []
app <- getYesod
let repoHost = appRepoHost $ appSettings app
let localRepo = repoHost ++ localId ++ "/" ++ challengeName
trigger userId challengeName localRepo mBranch mGitAnnexRemote
postTriggerRemotelyR :: Handler TypedContent
postTriggerRemotelyR = do
(Just challengeName) <- lookupPostParam "challenge"
(Just theUrl) <- lookupPostParam "url"
(Just token) <- lookupPostParam "token"
mBranch <- lookupPostParam "branch"
mGitAnnexRemote <- lookupPostParam "git-annex-remote"
doTrigger token challengeName theUrl mBranch mGitAnnexRemote
postTriggerRemotelySimpleR :: Text -> Text -> Text -> Text -> Handler TypedContent
postTriggerRemotelySimpleR token challengeName theUrl branch =
doTrigger token challengeName (decodeSlash theUrl) (Just branch) Nothing
getTriggerRemotelySimpleR :: Text -> Text -> Text -> Text -> Handler TypedContent
getTriggerRemotelySimpleR token challengeName theUrl branch =
doTrigger token challengeName (decodeSlash theUrl) (Just branch) Nothing
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
let theUrl = fromMaybe (fromJust $ gitServerPayloadGitSshUrl payload)
(gitServerPayloadSshUrl payload)
doTrigger token challengeName theUrl (Just branch) Nothing
else
error $ "unexpected ref `" ++ (T.unpack ref) ++ "`"
doTrigger :: Text -> Text -> Text -> Maybe Text -> Maybe Text -> Handler TypedContent
doTrigger token challengeName theUrl mBranch mGitAnnexRemote = do
[Entity userId _] <- runDB $ selectList [UserTriggerToken ==. Just token] []
trigger userId challengeName theUrl mBranch mGitAnnexRemote
trigger :: UserId -> Text -> Text -> Maybe Text -> Maybe Text -> Handler TypedContent
trigger userId challengeName theUrl mBranch mGitAnnexRemote = do
let branch = fromMaybe "master" mBranch
mChallengeEnt <- runDB $ getBy $ UniqueName challengeName
let defSubmission = ChallengeSubmissionData {
challengeSubmissionDataDescription = Nothing,
challengeSubmissionDataTags = Nothing,
challengeSubmissionDataRepo = RepoSpec {
repoSpecUrl=theUrl,
repoSpecBranch=branch,
repoSpecGitAnnexRemote=mGitAnnexRemote},
challengeSubmissionDataTeam = Nothing
}
case mChallengeEnt of
Just (Entity challengeId _) -> runOpenViewProgress $ doCreateSubmission userId challengeId defSubmission
Nothing -> return $ toTypedContent (("Unknown challenge `" ++ (Data.Text.unpack challengeName) ++ "`. Cannot be triggered, must be submitted manually at Gonito.net!\n") :: String)
isBefore :: UTCTime -> Maybe UTCTime -> Bool
isBefore _ Nothing = True
isBefore moment (Just deadline) = moment <= deadline
-- | An attempt to filtre out mistaken/unwanted submissions (without cloning
-- the submission repo, just by looking at the metadata)
willClone :: Challenge -> ChallengeSubmissionData -> Bool
willClone challenge submissionData =
(challengeName challenge) `isInfixOf` theUrl && branch /= dontPeek && not (dontPeek `isInfixOf` theUrl)
where theUrl = repoSpecUrl $ challengeSubmissionDataRepo submissionData
branch = repoSpecBranch $ challengeSubmissionDataRepo submissionData
dontPeek = "dont-peek"
-- | Main place where submission is done (whether manually or by trigger)
doCreateSubmission :: UserId -> Key Challenge -> ChallengeSubmissionData -> Channel -> Handler ()
doCreateSubmission userId challengeId challengeSubmissionData chan = do
challenge <- runDB $ get404 challengeId
theVersion <- runDB $ getBy404 $ UniqueVersionByCommit $ challengeVersion challenge
theNow <- liftIO getCurrentTime
if theNow `isBefore` (versionDeadline $ entityVal theVersion)
then
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"
else
msg chan "Submission is past the deadline, no submission will be accepted from now on."
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
Just repoId -> do
challenge <- runDB $ get404 challengeId
user <- runDB $ get404 userId
relevantIndicators <- getOngoingTargets challengeId
(Entity _ currentVersion) <- runDB $ getBy404 $ UniqueVersionByCommit $ challengeVersion challenge
let submittedMajorVersion = versionMajor currentVersion
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
bestResultSoFar <- runDB $ E.select $ E.from $ \(evaluation, submission, variant, out, test, theVersion) -> do
E.where_ (submission ^. SubmissionChallenge E.==. E.val challengeId
E.&&. submission ^. SubmissionIsHidden E.==. E.val False
E.&&. variant ^. VariantSubmission E.==. submission ^. SubmissionId
E.&&. evaluation ^. EvaluationChecksum E.==. out ^. OutChecksum
E.&&. (E.not_ (E.isNothing (evaluation ^. EvaluationScore)))
E.&&. out ^. OutVariant E.==. variant ^. VariantId
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)
E.&&. theVersion ^. VersionCommit E.==. test ^. TestCommit
E.&&. theVersion ^. VersionMajor E.>=. E.val submittedMajorVersion)
E.orderBy [orderDirection (evaluation ^. EvaluationScore)]
E.limit 1
return evaluation
let bestScoreSoFar' = join (evaluationScore <$> entityVal <$> (listToMaybe bestResultSoFar))
return bestScoreSoFar'
Nothing -> return Nothing
case bestScoreSoFar of
Just s -> msg chan ("best score so far is: " ++ (Data.Text.pack $ show s))
Nothing -> msg chan "first submission so far"
repo <- runDB $ get404 repoId
repoDir <- getRepoDirOrClone repoId chan
gonitoMetadata <- liftIO
$ extractMetadataFromRepoDir repoDir (ExtractionOptions {
extractionOptionsDescription = mDescription,
extractionOptionsTags = Just $ parseTags mTags,
extractionOptionsGeneralParams = Nothing,
extractionOptionsUnwantedParams = Nothing,
extractionOptionsParamFiles = Nothing,
extractionOptionsMLRunPath = Nothing,
extractionOptionsExternalLinks = Nothing,
extractionOptionsDependencies = Nothing })
mTeamId <- case challengeSubmissionDataTeam challengeSubmissionData of
Just tid -> return $ Just tid
Nothing -> fetchDefaultTeam userId
submissionId <- getSubmission userId
mTeamId
repoId
(repoCurrentCommit repo)
challengeId
(gonitoMetadataDescription gonitoMetadata)
chan
_ <- 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
outs <- getOuts False chan submissionId (gonitoMetadataGeneralParams gonitoMetadata)
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
let submissionLink = linkInAnnouncement mHook app "submission" ("q/" ++ (fromSHA1ToText (repoCurrentCommit repo)))
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
(s:_) -> if compOp s b
then
do
let challengeLink = linkInAnnouncement mHook app (challengeTitle challenge) ("challenge/"
++ (challengeName challenge))
let formattingOpts = getTestFormattingOpts mainTest
let message = ("Whoa! New best result for "
++ challengeLink
++ " challenge by "
++ (fromMaybe "???" $ userName user)
++ ", "
++ (T.pack $ show $ testMetric mainTest)
++ ": "
++ (T.pack $ formatTheResult formattingOpts (SimpleRun s))
++ " ("
++ (if s > b
then "+"
else "")
++ (T.pack $ formatTheResult formattingOpts (SimpleRun (s-b)))
++ ")."
++ " See " ++ submissionLink ++ "."
++ " :clap:")
msg chan message
case mHook of
Just hook -> liftIO $ sendAnnouncement hook message
Nothing -> return ()
else return ()
[] -> return ()
Nothing -> return ()
Nothing -> return ()
if appAutoOpening $ appSettings app
then
doMakePublic userId submissionId chan
else
return ()
if not (null relevantIndicators)
then
checkIndicators user challengeId submissionId submissionLink relevantIndicators chan
else
return ()
Nothing -> return ()
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
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
Nothing -> return ()
else
return ()
where indicatorText = prettyIndicatorEntry indicator
getScoreForOut :: (PersistQueryRead (YesodPersistBackend site), YesodPersist site, BaseBackend (YesodPersistBackend site) ~ SqlBackend) => Key Test -> Out -> HandlerFor site (Maybe Double)
getScoreForOut mainTestId out = do
mEvaluation <- runDB $ selectFirst [EvaluationChecksum ==. (outChecksum out),
EvaluationTest ==. mainTestId]
[]
return $ case mEvaluation of
Just evaluation -> evaluationScore $ entityVal evaluation
Nothing -> Nothing
getSubmission :: UserId -> Maybe TeamId -> Key Repo -> SHA1 -> Key Challenge -> Text -> Channel -> Handler (Key Submission)
getSubmission userId mTeamId repoId commit challengeId subDescription chan = do
challenge <- runDB $ get404 challengeId
maybeSubmission <- runDB $ getBy $ UniqueSubmissionRepoCommitChallenge repoId commit challengeId
case maybeSubmission of
Just (Entity submissionId _) -> do
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,
submissionDescription=subDescription,
submissionStamp=time,
submissionSubmitter=userId,
submissionIsPublic=False,
submissionIsHidden=False,
submissionVersion=challengeVersion challenge,
submissionTeam=mTeamId }
getSubmissionRepo :: UserId -> Key Challenge -> RepoSpec -> Channel -> Handler (Maybe (Key Repo))
getSubmissionRepo userId challengeId repoSpec chan = getPossiblyExistingRepo checkRepoAvailibility userId challengeId repoSpec chan
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
challengeSubmissionWidget :: (ToMarkup a1, ToWidget App a2) => a2 -> a1 -> Challenge -> WidgetFor App ()
challengeSubmissionWidget formWidget formEnctype challenge = $(widgetFile "challenge-submission")
externalRepoInfo settings = $(widgetFile "external-repo")
data ChallengeSubmissionData = ChallengeSubmissionData {
challengeSubmissionDataDescription :: Maybe Text,
challengeSubmissionDataTags :: Maybe Text,
challengeSubmissionDataRepo :: RepoSpec,
challengeSubmissionDataTeam :: Maybe TeamId }
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
submissionForm :: UserId -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe (Maybe TeamId) -> Form ChallengeSubmissionData
submissionForm userId defaultUrl defBranch defaultGitAnnexRemote defaultTeam = renderBootstrap3 BootstrapBasicForm $ ChallengeSubmissionData
<$> aopt textField (fieldWithTooltip MsgSubmissionDescription MsgSubmissionDescriptionTooltip) Nothing
<*> aopt textField (tagsfs MsgSubmissionTags) Nothing
<*> (RepoSpec <$> areq textField (bfs MsgSubmissionUrl) defaultUrl
<*> areq textField (bfs MsgSubmissionBranch) defBranch
<*> aopt textField (bfs MsgSubmissionGitAnnexRemote) (Just defaultGitAnnexRemote))
<*> aopt (selectField teams) (bfs MsgAsTeam) defaultTeam
where teams = do
myTeams <- fetchUserTeams userId
optionsPairs $ map (\t -> (teamIdent $ entityVal t, entityKey t)) myTeams
getUserInfoR :: Handler Value
getUserInfoR = do
(Entity _ user) <- requireAuthPossiblyByToken
return $ String $ userIdent user
getAddUserR :: Handler Value
getAddUserR = do
mInfo <- authorizationTokenAuth
case mInfo of
Just infos -> do
let ident = jwtAuthInfoIdent infos
x <- runDB $ getBy $ UniqueUser ident
case x of
Just _ -> return $ Bool False
Nothing -> do
-- 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
{ userIdent = ident
, userPassword = Nothing
, userName = mUName
, userIsAdmin = False
, userLocalId = Nothing
, userIsAnonymous = False
, userAvatar = Nothing
, userVerificationKey = Nothing
, userKeyExpirationDate = Nothing
, userTriggerToken = Nothing
, userAltRepoScheme = Nothing
}
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 ()
return $ Bool True
Nothing -> return $ Bool False
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))
]
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"]
& description ?~ T.pack d
& 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
getChallengeAllSubmissionsJsonR :: Text -> Handler Value
getChallengeAllSubmissionsJsonR challengeName = do
v <- fetchAllSubmissionsView challengeName
return $ toJSON v
getChallengeMySubmissionsJsonR :: Text -> Handler Value
getChallengeMySubmissionsJsonR challengeName = do
v <- fetchMySubmissionsView challengeName
return $ toJSON v
fetchAllSubmissionsView :: Text -> Handler SubmissionsView
fetchAllSubmissionsView challengeName = do
fetchChallengeSubmissionsView (const True) challengeName
fetchMySubmissionsView :: Text -> Handler SubmissionsView
fetchMySubmissionsView challengeName = do
Entity userId _ <- requireAuthPossiblyByToken
fetchChallengeSubmissionsView (\(Entity _ submission) -> (submissionSubmitter submission == userId)) challengeName
convertTagInfoToView :: (Entity Import.Tag, Entity SubmissionTag) -> TagView
convertTagInfoToView tagInfo =
TagView {
tagViewName = tagName $ entityVal $ fst tagInfo,
tagViewDescription = tagDescription $ entityVal $ fst tagInfo,
tagViewAccepted = submissionTagAccepted $ entityVal $ snd tagInfo
}
convertEvaluationToView :: Map TestReference Evaluation -> Entity Test -> Maybe EvaluationView
convertEvaluationToView theMapping entTest =
case join $ evaluationScore <$> mEvaluation of
Just s ->
Just $ EvaluationView {
evaluationViewScore = formatTruncatedScore formattingOps mEvaluation,
evaluationViewFullScore = s,
evaluationViewTest = testRef
}
Nothing -> Nothing
where mEvaluation = Map.lookup testRef theMapping
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
mUserId <- maybeAuthPossiblyByToken
isReevaluable <- runDB $ canBeReevaluated $ entityKey $ tableEntrySubmission entry
let isVisible = True
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),
submissionViewTags = Import.map convertTagInfoToView $ tableEntryTagsInfo entry,
submissionViewHash = fromSHA1ToText $ submissionCommit submission,
submissionViewEvaluations = catMaybes $ Import.map (convertEvaluationToView $ tableEntryMapping entry) tests,
submissionViewIsOwner = (entityKey <$> mUserId) == Just (submissionSubmitter submission),
submissionViewIsReevaluable = isReevaluable,
submissionViewIsVisible = isVisible,
submissionViewIsPublic = submissionIsPublic submission,
submissionViewTeam = teamIdent <$> entityVal <$> tableEntryTeam entry
}
where submission = entityVal $ tableEntrySubmission entry
fetchChallengeSubmissionsView :: ((Entity Submission) -> Bool) -> Text -> Handler SubmissionsView
fetchChallengeSubmissionsView condition challengeName = do
Entity challengeId _ <- runDB $ getBy404 $ UniqueName challengeName
(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
getChallengeMySubmissionsR :: Text -> Handler Html
getChallengeMySubmissionsR challengeName = do
userId <- requireAuthId
getChallengeSubmissions (\(Entity _ submission) -> (submissionSubmitter submission == userId)) challengeName
getChallengeAllSubmissionsR :: Text -> Handler Html
getChallengeAllSubmissionsR challengeName = getChallengeSubmissions (\_ -> True) challengeName
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
]
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" ]
data TagView = TagView {
tagViewName :: Text,
tagViewDescription :: Maybe Text,
tagViewAccepted :: Maybe Bool }
instance ToJSON TagView where
toJSON t = object
[ "name" .= tagViewName t
, "description" .= tagViewDescription t
, "accepted" .= tagViewAccepted t
]
instance ToSchema TagView where
declareNamedSchema _ = do
stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String)
boolSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Bool)
return $ NamedSchema (Just "TagView") $ mempty
& type_ .~ SwaggerObject
& properties .~
fromList [ ("name", stringSchema)
, ("description", stringSchema)
, ("accepted", boolSchema)
]
& required .~ [ "name", "description" ]
data SubmissionView = SubmissionView {
submissionViewId :: Int64,
submissionViewVariantId :: Int64,
submissionViewRank :: Int,
submissionViewSubmitter :: Text,
submissionViewWhen :: UTCTime,
submissionViewVersion :: (Int, Int, Int),
submissionViewDescription :: Text,
submissionViewTags :: [TagView],
submissionViewHash :: Text,
submissionViewEvaluations :: [EvaluationView],
submissionViewIsOwner :: Bool,
submissionViewIsReevaluable :: Bool,
submissionViewIsVisible :: Bool,
submissionViewIsPublic :: Bool,
submissionViewTeam :: Maybe Text
}
instance ToJSON SubmissionView where
toJSON s = object
["id" .= submissionViewId s
, "variant" .= submissionViewVariantId s
, "rank" .= submissionViewRank s
, "submitter" .= submissionViewSubmitter s
, "when" .= submissionViewWhen s
, "version" .= submissionViewVersion s
, "description" .= submissionViewDescription s
, "tags" .= submissionViewTags s
, "hash" .= submissionViewHash s
, "evaluations" .= submissionViewEvaluations s
, "isOwner" .= submissionViewIsOwner s
, "isReevaluable" .= submissionViewIsReevaluable s
, "isVisible" .= submissionViewIsVisible s
, "isPublic" .= submissionViewIsPublic s
, "team" .= submissionViewTeam s
]
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])
return $ NamedSchema (Just "SubmissionView") $ mempty
& type_ .~ SwaggerObject
& properties .~
fromList [ ("id", submissionIdSchema)
, ("variant", variantIdSchema)
, ("rank", intSchema)
, ("submitter", submitterSchema)
, ("when", stringSchema)
, ("version", versionSchema)
, ("description", stringSchema)
, ("tags", tagsSchema)
, ("hash", hashSchema)
, ("evaluations", evalsSchema)
, ("isOwner", boolSchema)
, ("isReevaluable", boolSchema)
, ("isVisible", isVisibleSchema)
, ("isPublic", isPublicSchema)
, ("team", stringSchema)
]
& required .~ [ "id", "variant", "rank", "submitter", "when", "version",
"description", "tags", "hash", "evaluations",
"isOwner", "isReevaluable", "isVisible", "isPublic" ]
data SubmissionsView = SubmissionsView {
submissionsViewSubmissions :: [SubmissionView],
submissionsViewTests :: [TestReference]
}
instance ToJSON SubmissionsView where
toJSON ss = object
[ "tests" .= submissionsViewTests ss,
"submissions" .= submissionsViewSubmissions ss
]
instance ToSchema SubmissionsView where
declareNamedSchema _ = do
submissionViewsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [SubmissionView])
testRefsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [TestReference])
return $ NamedSchema (Just "SubmissionsView") $ mempty
& type_ .~ SwaggerObject
& properties .~
fromList [ ("submissions", submissionViewsSchema)
, ("tests", testRefsSchema)
]
& required .~ [ "tests", "submission" ]
getChallengeSubmissions :: ((Entity Submission) -> Bool) -> Text -> Handler Html
getChallengeSubmissions condition challengeName = do
Entity challengeId challenge <- runDB $ getBy404 $ UniqueName challengeName
(evaluationMaps, tests') <- runDB $ getChallengeSubmissionInfos 1 condition (const True) id challengeId
let tests = sortBy testComparator tests'
mauth <- maybeAuth
let muserId = (\(Entity uid _) -> uid) <$> mauth
app <- getYesod
let scheme = appRepoScheme $ appSettings app
challengeRepo <- runDB $ get404 $ challengePublicRepo challenge
let params = getNumericalParams evaluationMaps
challengeLayout True challenge (challengeAllSubmissionsWidget muserId
challenge
scheme
challengeRepo
evaluationMaps
tests
params)
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
challengeAllSubmissionsWidget :: Maybe UserId
-> Challenge
-> RepoScheme
-> Repo
-> [TableEntry]
-> [Entity Test]
-> [Text]
-> WidgetFor App ()
challengeAllSubmissionsWidget muserId challenge scheme challengeRepo submissions tests params =
$(widgetFile "challenge-all-submissions")
where delta = Number 4
higherTheBetterArray = getIsHigherTheBetterArray $ map entityVal tests
paramGraphsWidget :: Challenge -> [Entity Test] -> [Text] -> WidgetFor App ()
paramGraphsWidget challenge tests params = $(widgetFile "param-graphs")
where chartJSs = getChartJss challenge selectedTests params
selectedTests = reverse $ getMainTests tests
getChartJss :: Challenge -> [Entity Test] -> [Text] -> JavascriptUrl (Route App)
getChartJss challenge tests params =
mconcat $ [(getChartJs challenge test param) | test <- tests, param <- params]
getChartJs :: Challenge
-> Entity Test
-> Text
-> JavascriptUrl (Route App)
getChartJs challenge (Entity testId test) param = [julius|
$.getJSON("@{ChallengeParamGraphDataR (challengeName challenge) testId param}", function(data) {
c3.generate({
bindto: '#chart-' + #{toJSON param} + '-' + #{toJSON testId},
data: data,
axis: {
x: {
label: #{toJSON param},
},
y: {
label: #{toJSON testFormatted},
}
}
}) });
|]
where testFormatted = formatTest test
challengeLayout :: Bool -> Challenge -> WidgetFor App () -> HandlerFor App Html
challengeLayout withHeader challenge widget = do
tagsAvailableAsJSON <- runDB $ getAvailableTagsAsJSON
theVersion <- runDB $ getBy404 $ UniqueVersionByCommit $ challengeVersion challenge
let versionFormatted = formatVersion ((versionMajor $ entityVal theVersion),
(versionMinor $ entityVal theVersion),
(versionPatch $ entityVal theVersion))
maybeUser <- maybeAuth
bc <- widgetToPageContent widget
defaultLayout $ do
setTitle "Challenge"
$(widgetFile "challenge")
getTestProgressR :: Int -> Int -> Handler TypedContent
getTestProgressR m d = runViewProgress $ doTestProgress m d
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
_ <- forM [1..m] $ (\i -> do
msg chan $ (Data.Text.pack $ ("GO\n" ++ show i))
liftIO $ threadDelay (d * 1000000)
return ())
return ()
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