2016-02-12 13:00:33 +01:00
module Handler.Query where
import Import
2017-02-25 19:13:55 +01:00
import Handler.SubmissionView
2018-01-25 16:34:05 +01:00
import Handler.Shared
2018-11-10 11:20:17 +01:00
import Handler.TagUtils
2018-11-12 14:12:51 +01:00
import PersistSHA1
import Handler.Tables
import qualified Yesod.Table as Table
2016-02-12 13:00:33 +01:00
import Database.Persist.Sql
2018-01-25 16:34:05 +01:00
import qualified Database.Esqueleto as E
import Database.Esqueleto ( ( ^. ) )
2016-02-12 13:00:33 +01:00
2018-11-12 14:12:51 +01:00
import qualified Data.Text as T
import Data.List ( nub )
2018-01-25 16:34:05 +01:00
import Yesod.Form.Bootstrap3 ( BootstrapFormLayout ( .. ) , renderBootstrap3 )
rawCommitQuery :: ( MonadIO m , RawSql a ) => Text -> ReaderT SqlBackend m [ a ]
2018-11-17 13:49:44 +01:00
rawCommitQuery sha1Prefix =
rawSql " SELECT ?? FROM submission WHERE is_public AND cast(commit as text) like ? " [ PersistText $ " \ \ \ \ x " ++ sha1Prefix ++ " % " ]
2016-02-12 13:00:33 +01:00
findSubmissions :: Text -> Handler [ FullSubmissionInfo ]
findSubmissions sha1Prefix = do
2016-02-16 21:10:10 +01:00
mauthId <- maybeAuth
submissions <- runDB $ case mauthId of
Just ( Entity authId _ ) -> rawSql " SELECT ?? FROM submission WHERE (is_public OR submitter = ?) AND cast(commit as text) like ? " [ toPersistValue authId , PersistText $ " \ \ \ \ x " ++ sha1Prefix ++ " % " ]
2018-01-25 16:34:05 +01:00
Nothing -> rawCommitQuery sha1Prefix
2016-02-12 13:00:33 +01:00
mapM getFullInfo submissions
2018-01-25 16:34:05 +01:00
getApiTxtScoreR :: Text -> Handler Text
getApiTxtScoreR sha1Prefix = do
submissions <- runDB $ rawCommitQuery sha1Prefix
case submissions of
[ submission ] -> doGetScore submission
[] -> return " NONE "
_ -> return " AMBIGUOUS ARGUMENT "
2018-07-06 16:54:17 +02:00
doGetScore :: ( BaseBackend ( YesodPersistBackend site ) ~ SqlBackend , PersistUniqueRead ( YesodPersistBackend site ) , BackendCompatible SqlBackend ( YesodPersistBackend site ) , YesodPersist site , PersistQueryRead ( YesodPersistBackend site ) ) => Entity Submission -> HandlerFor site Text
2018-01-25 16:34:05 +01:00
doGetScore submission = do
let challengeId = submissionChallenge $ entityVal submission
2019-09-10 08:59:30 +02:00
mainTest <- runDB $ fetchMainTest challengeId
2018-01-25 16:34:05 +01:00
let mainTestId = entityKey mainTest
let submissionId = entityKey submission
evals <- runDB $ E . select
2018-07-06 16:54:17 +02:00
$ E . from $ \ ( out , evaluation , variant ) -> do
E . where_ ( variant ^. VariantSubmission E .==. E . val submissionId
E .&&. out ^. OutVariant E .==. variant ^. VariantId
2018-01-25 16:34:05 +01:00
E .&&. out ^. OutTest E .==. E . val mainTestId
E .&&. evaluation ^. EvaluationTest E .==. E . val mainTestId
E .&&. out ^. OutChecksum E .==. evaluation ^. EvaluationChecksum )
E . orderBy []
return ( evaluation )
case evals of
[ eval ] -> return $ formatTruncatedScore ( testPrecision $ entityVal mainTest ) ( Just $ entityVal eval )
_ -> return " NONE "
2016-02-12 13:00:33 +01:00
getQueryFormR :: Handler Html
getQueryFormR = do
( formWidget , formEnctype ) <- generateFormPost queryForm
defaultLayout $ do
setTitle " Searching for submissions "
$ ( widgetFile " query-form " )
postQueryFormR :: Handler Html
postQueryFormR = do
( ( result , formWidget ) , formEnctype ) <- runFormPost queryForm
case result of
FormSuccess query -> processQuery query
_ -> defaultLayout $ do
setTitle " Searching for submissions "
$ ( widgetFile " query-form " )
getQueryResultsR :: Text -> Handler Html
getQueryResultsR = processQuery
2018-11-10 11:20:17 +01:00
isFullQuery :: Text -> Bool
isFullQuery query = length query == 40
2016-02-12 13:00:33 +01:00
processQuery :: Text -> Handler Html
processQuery query = do
submissions <- findSubmissions query
defaultLayout $ do
setTitle " query results "
$ ( widgetFile " query-results " )
2018-11-12 14:12:51 +01:00
resultTable :: Entity Submission -> WidgetFor App ()
resultTable ( Entity submissionId submission ) = do
( tableEntries , tests ) <- handlerToWidget $ runDB $ getChallengeSubmissionInfos ( \ s -> entityKey s == submissionId )
( submissionChallenge submission )
let paramNames =
nub
$ map ( parameterName . entityVal )
$ concat
$ map tableEntryParams tableEntries
let resultId = show $ fromSqlKey submissionId
let jsSelector = String $ T . pack ( " #t " ++ resultId ++ " > table " )
let delta = Number $ fromIntegral ( ( length paramNames ) + 1 )
let higherTheBetterArray = getIsHigherTheBetterArray $ map entityVal tests
$ ( widgetFile " result-table " )
2019-11-29 22:10:48 +01:00
submissionHeader :: FullSubmissionInfo -> WidgetFor App ()
submissionHeader submission =
$ ( widgetFile " submission-header " )
2018-11-12 14:12:51 +01:00
where commitSha1AsText = fromSHA1ToText $ submissionCommit $ fsiSubmission submission
submitter = formatSubmitter $ fsiUser submission
publicSubmissionBranch = getPublicSubmissionBranch $ fsiSubmissionId submission
publicSubmissionRepo = getReadOnlySubmissionUrl ( fsiScheme submission ) ( fsiChallengeRepo submission ) $ challengeName $ fsiChallenge submission
browsableUrl = browsableGitRepoBranch ( fsiScheme submission ) ( fsiChallengeRepo submission ) ( challengeName $ fsiChallenge submission ) publicSubmissionBranch
stamp = T . pack $ show $ submissionStamp $ fsiSubmission submission
2019-11-29 22:10:48 +01:00
queryResult :: FullSubmissionInfo -> WidgetFor App ()
queryResult submission = do
$ ( widgetFile " query-result " )
2016-02-12 13:00:33 +01:00
queryForm :: Form Text
queryForm = renderBootstrap3 BootstrapBasicForm $ areq textField ( fieldSettingsLabel MsgGitCommitSha1 ) Nothing