2021-02-22 14:43:09 +01:00
{- # LANGUAGE DeriveGeneric # -}
{- # LANGUAGE DoAndIfThenElse # -}
2015-09-04 23:23:32 +02:00
module Handler.ShowChallenge where
2021-01-25 06:53:37 +01:00
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
2021-02-15 20:41:09 +01:00
import qualified Data.HashMap.Strict as HMS
2015-12-12 18:53:20 +01:00
import qualified Yesod.Table as Table
2021-02-27 18:38:38 +01:00
import Control.Concurrent.Lifted ( threadDelay )
2021-09-02 20:58:17 +02:00
import Data.Time.LocalTime
2021-09-02 22:38:59 +02:00
import qualified Data.List.Utils as DLU
2021-09-02 20:58:17 +02:00
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
2021-02-22 12:44:33 +01:00
import Handler.JWT
2021-06-28 18:38:15 +02:00
import Handler.Team
2022-01-18 22:54:07 +01:00
import Handler.Announcements
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
2018-11-03 17:25:49 +01:00
import Gonito.ExtractMetadata ( ExtractionOptions ( .. ) ,
extractMetadataFromRepoDir ,
GonitoMetadata ( .. ) ,
2018-11-12 20:41:46 +01:00
parseTags ,
Link ( .. ) )
2018-10-06 23:30:12 +02:00
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
2019-08-12 18:19:02 +02:00
import GEval.EvaluationScheme
2021-08-21 11:57:39 +02:00
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 )
2017-09-27 22:44:00 +02:00
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 ( ( ^. ) )
2021-01-25 06:53:37 +01:00
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
2021-01-25 06:53:37 +01:00
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 )
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 )
2021-02-22 12:44:33 +01:00
, " isPublic " .= ( submissionIsPublic $ leaderboardBestSubmission entry )
2021-09-15 12:55:16 +02:00
, " isOwner " .= ( leaderboardIsOwner entry )
2021-02-22 12:44:33 +01:00
, " isReevaluable " .= ( leaderboardIsReevaluable entry )
, " isVisible " .= ( leaderboardIsVisible entry )
2021-05-29 18:40:13 +02:00
, " id " .= ( leaderboardBestSubmissionId entry )
, " variant " .= ( leaderboardBestVariantId entry )
2020-10-15 22:27:16 +02:00
]
2021-01-25 06:53:37 +01:00
declareLeaderboardSwagger :: Declare ( Definitions Schema ) Swagger
declareLeaderboardSwagger = do
-- param schemas
let challengeNameSchema = toParamSchema ( Proxy :: Proxy String )
2021-02-15 20:41:09 +01:00
leaderboardResponse <- declareResponse ( Proxy :: Proxy LeaderboardView )
2021-01-25 06:53:37 +01:00
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 ) )
]
2021-01-25 06:53:37 +01:00
leaderboardApi :: Swagger
leaderboardApi = spec & definitions .~ defs
where
( defs , spec ) = runDeclare declareLeaderboardSwagger mempty
2021-02-15 20:41:09 +01:00
data LeaderboardView = LeaderboardView {
leaderboardViewTests :: [ Entity Test ] ,
leaderboardViewEntries :: [ LeaderboardEntryView ]
}
2021-01-25 06:53:37 +01:00
2021-02-15 20:41:09 +01:00
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 " ]
2021-01-25 06:53:37 +01:00
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
2021-02-15 20:41:09 +01:00
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
2021-05-29 18:40:13 +02:00
-- 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 ) )
2021-02-15 20:41:09 +01:00
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 )
2021-02-22 12:44:33 +01:00
boolSchema <- declareSchemaRef ( DPR . Proxy :: DPR . Proxy Bool )
2021-02-15 20:41:09 +01:00
evaluationsSchema <- declareSchemaRef ( DPR . Proxy :: DPR . Proxy [ EvaluationView ] )
2021-09-25 18:37:08 +02:00
tagSchema <- declareSchemaRef ( DPR . Proxy :: DPR . Proxy Import . Tag )
2021-05-29 18:40:13 +02:00
2021-02-15 20:41:09 +01:00
return $ NamedSchema ( Just " LeaderboardEntry " ) $ mempty
& type_ .~ SwaggerObject
& properties .~
2021-05-29 18:40:13 +02:00
fromList [ ( " submitter " , submitterSchema )
2021-03-03 22:02:39 +01:00
, ( " team " , stringSchema )
2021-02-15 20:41:09 +01:00
, ( " when " , stringSchema )
2021-05-29 18:40:13 +02:00
, ( " version " , versionSchema )
2021-09-25 18:37:08 +02:00
, ( " phase " , tagSchema )
2021-02-15 20:41:09 +01:00
, ( " description " , stringSchema )
2021-05-29 18:40:13 +02:00
, ( " 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 )
2021-02-15 20:41:09 +01:00
, ( " evaluations " , evaluationsSchema )
2021-09-15 12:55:16 +02:00
, ( " isOwner " , boolSchema )
2021-05-29 18:40:13 +02:00
, ( " isPublic " , isPublicSchema )
2021-02-22 12:44:33 +01:00
, ( " isReevaluable " , boolSchema )
2021-05-29 18:40:13 +02:00
, ( " isVisible " , isVisibleSchema )
, ( " id " , submissionIdSchema )
, ( " variantId " , variantIdSchema )
2021-02-15 20:41:09 +01:00
]
& 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
2019-12-16 16:39:20 +01:00
( leaderboard , ( entries , tests ) ) <- getLeaderboardEntries 1 leaderboardStyle challengeId
showAltLeaderboard <- runDB $ hasMetricsOfSecondPriority challengeId
( altLeaderboard , altTests ) <- if showAltLeaderboard
then
do
2020-09-05 16:14:20 +02:00
( leaderboard' , ( _ , tests' ) ) <- getLeaderboardEntries 3 ByTag challengeId
2019-12-16 16:39:20 +01:00
return $ ( Just leaderboard' , Just tests' )
else
return ( Nothing , Nothing )
2016-02-16 21:10:10 +01:00
mauth <- maybeAuth
2018-06-06 13:43:17 +02:00
2018-09-01 14:23:41 +02:00
let params = getNumericalParams entries
2018-07-28 22:10:55 +02:00
2018-06-06 13:43:17 +02:00
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
2018-07-28 22:10:55 +02:00
leaderboard
2019-12-16 16:39:20 +01:00
altLeaderboard
2018-07-28 22:10:55 +02:00
params
2019-12-16 16:39:20 +01:00
tests
2021-02-17 09:31:23 +01:00
altTests
isHealthy )
2019-12-16 16:39:20 +01:00
2020-02-22 19:12:07 +01:00
hasMetricsOfSecondPriority :: ( PersistQueryRead backend , MonadIO m , BaseBackend backend ~ SqlBackend ) => Key Challenge -> ReaderT backend m Bool
2019-12-16 16:39:20 +01:00
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 ]
2019-12-16 16:39:20 +01:00
-> ( Maybe [ LeaderboardEntry ] )
2018-07-28 22:10:55 +02:00
-> [ Text ]
-> [ Entity Test ]
2019-12-16 16:39:20 +01:00
-> ( 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 )
2018-07-28 22:10:55 +02:00
scheme
challengeRepo
repo
leaderboard
2019-12-16 16:39:20 +01:00
mAltLeaderboard
2018-07-28 22:10:55 +02:00
params
tests
2019-12-16 16:39:20 +01:00
mAltTests
2021-02-17 09:31:23 +01:00
isHealthy
2018-07-28 22:10:55 +02:00
= $ ( widgetFile " show-challenge " )
2015-12-12 18:53:20 +01:00
where leaderboardWithRanks = zip [ 1 .. ] leaderboard
2019-12-16 16:39:20 +01:00
mAltLeaderboardWithRanks = zip [ 1 .. ] <$> mAltLeaderboard
2016-01-10 20:32:11 +01:00
maybeRepoLink = getRepoLink repo
2018-09-08 09:12:47 +02:00
delta = Number 4
2018-09-08 19:21:06 +02:00
higherTheBetterArray = getIsHigherTheBetterArray $ map entityVal tests
2019-03-20 16:31:08 +01:00
mUserId = entityKey <$> mUserEnt
2016-01-10 20:32:11 +01:00
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
2016-01-10 20:32:11 +01:00
| 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
2016-01-10 20:32:11 +01:00
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
2018-06-06 10:30:53 +02:00
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
2020-02-22 09:12:13 +01:00
( 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
2021-08-21 15:02:08 +02:00
externalRepoPlaceholder :: Text
externalRepoPlaceholder = " URL_TO_YOUR_REPO "
2019-11-29 09:17:17 +01:00
defaultRepo :: RepoScheme -> Text -> Challenge -> Repo -> Maybe ( Entity User ) -> Text
defaultRepo SelfHosted repoHost challenge _ maybeUser = repoHost ++ ( idToBeShown challenge maybeUser ) ++ " / " ++ ( challengeName challenge )
2019-11-30 11:04:52 +01:00
defaultRepo Branches _ _ repo _ = repoUrl repo
2021-08-21 15:02:08 +02:00
defaultRepo NoInternalGitServer _ _ _ _ = externalRepoPlaceholder
2018-06-06 10:30:53 +02:00
2018-07-14 07:42:28 +02:00
defaultBranch :: IsString a => RepoScheme -> Maybe a
2018-06-06 10:30:53 +02:00
defaultBranch SelfHosted = Just " master "
defaultBranch Branches = Nothing
2021-08-21 15:02:08 +02:00
defaultBranch NoInternalGitServer = Nothing
2015-11-11 22:10:41 +01:00
2020-02-22 09:12:13 +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 ) )
2021-08-21 15:02:08 +02:00
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
2021-02-24 07:03:36 +01:00
doHeal :: Key Challenge -> Channel -> HandlerFor App ()
2021-02-17 09:31:23 +01:00
doHeal challengeId chan = do
challenge <- runDB $ get404 challengeId
2021-02-24 07:03:36 +01:00
_ <- 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
2018-06-06 10:30:53 +02:00
Just repo <- runDB $ get $ challengePublicRepo challenge
app <- getYesod
let scheme = appRepoScheme $ appSettings app
2019-11-29 09:17:17 +01:00
let repoHost = appRepoHost $ appSettings app
2018-06-06 10:30:53 +02:00
2020-03-28 18:21:32 +01:00
let defaultUrl = fromMaybe ( defaultRepo scheme repoHost challenge repo maybeUser )
2021-02-08 18:12:02 +01:00
( ( <> challengeName ) <$> ( join $ userAltRepoScheme <$> entityVal <$> maybeUser ) )
2020-03-28 18:21:32 +01:00
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 "
2018-12-07 09:11:50 +01:00
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
2018-12-07 09:11:50 +01:00
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 "
2018-12-07 09:11:50 +01:00
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
2018-12-07 09:11:50 +01: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
2021-07-28 21:37:06 +02: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
2021-07-28 21:37:06 +02: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
2021-02-27 11:48:30 +01:00
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
2021-07-28 21:37:06 +02:00
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
2017-09-27 22:44:00 +02:00
2020-09-05 14:22:12 +02:00
repoDir <- getRepoDirOrClone repoId chan
2017-09-27 22:44:00 +02:00
2018-10-06 23:30:12 +02:00
gonitoMetadata <- liftIO
$ extractMetadataFromRepoDir repoDir ( ExtractionOptions {
extractionOptionsDescription = mDescription ,
2018-11-03 17:25:49 +01:00
extractionOptionsTags = Just $ parseTags mTags ,
2018-10-06 23:30:12 +02:00
extractionOptionsGeneralParams = Nothing ,
2018-11-03 12:30:39 +01:00
extractionOptionsUnwantedParams = Nothing ,
2018-10-06 23:30:12 +02:00
extractionOptionsParamFiles = Nothing ,
2018-11-13 14:48:41 +01:00
extractionOptionsMLRunPath = Nothing ,
2018-11-16 12:43:44 +01:00
extractionOptionsExternalLinks = Nothing ,
extractionOptionsDependencies = Nothing } )
2018-10-06 23:30:12 +02:00
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
2018-10-06 23:30:12 +02:00
submissionId <- getSubmission userId
2021-03-03 13:15:38 +01:00
mTeamId
2018-10-06 23:30:12 +02:00
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
2018-11-23 12:49:49 +01:00
_ <- 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
2022-01-18 22:54:07 +01:00
let submissionLink = linkInAnnouncement app " submission " ( " q/ " ++ ( fromSHA1ToText ( repoCurrentCommit repo ) ) )
2019-02-22 14:41:43 +01:00
2021-07-28 21:37:06 +02: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
2022-01-18 22:54:07 +01:00
let challengeLink = linkInAnnouncement app ( challengeTitle challenge ) ( " challenge/ "
2021-08-21 10:26:46 +02:00
++ ( challengeName challenge ) )
2021-08-21 11:57:39 +02:00
let formattingOpts = getTestFormattingOpts mainTest
2022-01-18 22:54:07 +01:00
let message = [ AnnouncementText " Whoa! New best result for " ,
challengeLink ,
AnnouncementText ( " challenge by "
2018-11-14 20:59:40 +01:00
++ ( fromMaybe " ??? " $ userName user )
++ " , "
2021-08-31 21:25:19 +02:00
++ ( T . pack $ evaluationSchemeName $ testMetric mainTest )
2018-11-14 20:59:40 +01:00
++ " : "
2021-08-21 11:57:39 +02:00
++ ( T . pack $ formatTheResult formattingOpts ( SimpleRun s ) )
2018-11-14 17:41:01 +01:00
++ " ( "
++ ( if s > b
then " + "
else " " )
2021-08-21 11:57:39 +02:00
++ ( T . pack $ formatTheResult formattingOpts ( SimpleRun ( s - b ) ) )
2018-11-14 20:59:40 +01:00
++ " ). "
2022-01-18 22:54:07 +01:00
++ " See " ) ,
submissionLink ,
AnnouncementText ( " . " ++ " :clap: " ) ]
msg chan $ renderAnnouncementMessage Nothing message
sendChallengeAnnouncement challengeId message
2018-11-12 22:01:51 +01:00
else return ()
[] -> return ()
2021-07-28 21:37:06 +02:00
Nothing -> return ()
2018-11-12 22:01:51 +01:00
Nothing -> return ()
2017-09-27 22:44:00 +02:00
2018-07-24 15:33:35 +02:00
if appAutoOpening $ appSettings app
then
2018-09-01 10:48:08 +02:00
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 ()
2022-01-18 22:54:07 +01:00
checkIndicators :: User -> ChallengeId -> SubmissionId -> AnnouncementPiece -> [ IndicatorEntry ] -> Channel -> Handler ()
2019-02-22 14:41:43 +01:00
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
2022-01-18 22:54:07 +01:00
checkIndicator :: UTCTime -> User -> ChallengeId -> SubmissionId -> AnnouncementPiece -> IndicatorEntry -> Channel -> Handler ()
2019-02-22 14:41:43 +01:00
checkIndicator theNow user challengeId submissionId submissionLink indicator chan = do
2020-01-04 10:32:52 +01:00
( 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 )
2022-01-18 22:54:07 +01:00
checkTarget :: UTCTime -> User -> AnnouncementPiece -> [ TableEntry ] -> IndicatorEntry -> Entity Target -> Channel -> Handler ()
2019-02-22 14:41:43 +01:00
checkTarget theNow user submissionLink entries indicator target chan = do
2022-01-18 22:54:07 +01:00
let challengeId = entityKey $ indicatorEntryChallenge indicator
2019-02-22 14:41:43 +01:00
let status = getTargetStatus theNow entries indicator target
if status == TargetPassed
then
do
2022-01-18 22:54:07 +01:00
let message = [ AnnouncementText ( " Congratulations!!! The target " ++ indicatorText
2019-02-22 14:41:43 +01:00
++ " was beaten by "
++ ( fromMaybe " ??? " $ userName user )
++ " , "
2022-01-18 22:54:07 +01:00
++ " See " ) ,
submissionLink ,
AnnouncementText ( " . "
++ ( T . replicate 10 " :champagne: " ) ++ " :mleczko: " ) ]
msg chan $ renderAnnouncementMessage Nothing message
sendChallengeAnnouncement challengeId message
2019-02-22 14:41:43 +01:00
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
2017-09-27 22:44:00 +02:00
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 ,
2018-06-27 13:09:11 +02:00
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
2018-08-30 21:58:27 +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 " )
2021-08-31 21:25:19 +02:00
externalRepoInfo :: AppSettings -> WidgetFor site ()
2021-08-21 15:02:08 +02:00
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
2021-07-23 20:20:52 +02: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
2017-09-27 22:44:00 +02:00
<$> 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
2021-09-02 20:58:17 +02:00
getCurrentTimeR :: Handler Value
getCurrentTimeR = do
2021-09-02 22:38:59 +02:00
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
2021-09-02 20:58:17 +02:00
2021-08-31 22:36:10 +02:00
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 ) )
]
2021-09-02 20:58:17 +02:00
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 ) )
]
2021-09-02 22:38:59 +02:00
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 ) )
]
2021-08-31 22:36:10 +02:00
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 ,
2021-09-25 16:05:48 +02:00
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
2021-09-15 12:55:16 +02:00
mUserEnt <- maybeAuthPossiblyByToken
2020-12-31 08:46:35 +01:00
isReevaluable <- runDB $ canBeReevaluated $ entityKey $ tableEntrySubmission entry
2021-08-21 15:15:10 +02:00
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 ,
2021-07-23 20:20:52 +02:00
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 ,
2021-09-15 12:55:16 +02:00
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 ,
2021-09-25 16:05:48 +02:00
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
2021-09-25 16:05:48 +02:00
, " 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 )
2021-09-25 16:05:48 +02:00
, ( " color " , stringSchema )
2021-02-05 14:44:46 +01:00
, ( " accepted " , boolSchema )
]
2021-09-25 16:05:48 +02:00
& 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 .~
2021-05-29 18:40:13 +02:00
fromList [ ( " id " , submissionIdSchema )
, ( " variant " , variantIdSchema )
2021-02-05 14:44:46 +01:00
, ( " rank " , intSchema )
2021-05-29 18:40:13 +02:00
, ( " submitter " , submitterSchema )
2021-02-05 14:44:46 +01:00
, ( " when " , stringSchema )
2021-05-29 18:40:13 +02:00
, ( " version " , versionSchema )
2021-09-25 18:37:08 +02:00
, ( " phase " , tagSchema )
2021-02-05 14:44:46 +01:00
, ( " description " , stringSchema )
, ( " tags " , tagsSchema )
2021-05-29 18:40:13 +02:00
, ( " hash " , hashSchema )
2021-02-05 14:44:46 +01:00
, ( " evaluations " , evalsSchema )
, ( " isOwner " , boolSchema )
, ( " isReevaluable " , boolSchema )
2021-05-29 18:40:13 +02:00
, ( " 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 .~
2021-02-15 11:32:51 +01:00
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
2020-01-04 10:32:52 +01:00
( 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
2018-06-06 13:43:17 +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 )
2018-07-28 22:10:55 +02:00
getAllParams :: [ TableEntry ] -> [ Text ]
getAllParams entries = sort
$ nub
$ concat
$ map ( \ entry -> map ( parameterName . entityVal ) ( tableEntryParams entry ) ) entries
2018-09-08 09:12:47 +02:00
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
2018-09-08 09:12:47 +02:00
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
2018-09-08 19:21:06 +02:00
selectedTests = reverse $ getMainTests tests
2018-07-28 21:22:52 +02:00
2018-09-01 14:01:17 +02:00
getChartJss :: Challenge -> [ Entity Test ] -> [ Text ] -> JavascriptUrl ( Route App )
getChartJss challenge tests params =
2018-07-28 21:22:52 +02:00
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
2018-07-28 19:16:07 +02:00
-> Entity Test
2018-07-28 17:30:00 +02:00
-> Text
-> JavascriptUrl ( Route App )
2018-07-28 19:16:07 +02:00
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 ( {
2018-07-28 19:16:07 +02:00
bindto : '# chart - ' + # { t o J S O N p a r a m } + ' - ' + # { t o J S O N t e s t I d } ,
2018-07-28 17:04:27 +02:00
data : data ,
axis : {
x : {
label : # { toJSON param } ,
} ,
y : {
label : # { toJSON testFormatted } ,
}
}
} ) } ) ;
| ]
where testFormatted = formatTest test
2018-06-06 13:43:17 +02:00
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 " )
2021-02-27 18:38:38 +01:00
2021-03-01 08:25:08 +01:00
getTestProgressR :: Int -> Int -> Handler TypedContent
getTestProgressR m d = runViewProgress $ doTestProgress m d
2021-02-27 18:38:38 +01:00
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
2021-03-01 08:25:08 +01:00
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 () )
2021-02-27 18:38:38 +01:00
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
2021-08-09 22:19:40 +02:00
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