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
2019-11-30 11:56:07 +01:00
getApiTxtScoreMainMetricR :: Text -> Handler Text
getApiTxtScoreMainMetricR sha1Prefix = getApiTxtScore Nothing sha1Prefix
getApiTxtScoreWithMetricR :: Text -> Text -> Handler Text
getApiTxtScoreWithMetricR sha1Prefix metricName = getApiTxtScore ( Just metricName ) sha1Prefix
getApiTxtScore :: Maybe Text -> Text -> Handler Text
getApiTxtScore mMetricName sha1Prefix = do
2018-01-25 16:34:05 +01:00
submissions <- runDB $ rawCommitQuery sha1Prefix
case submissions of
2019-11-30 11:56:07 +01:00
[ submission ] -> doGetScore mMetricName submission
2018-01-25 16:34:05 +01:00
[] -> return " NONE "
_ -> return " AMBIGUOUS ARGUMENT "
2019-11-30 11:56:07 +01:00
doGetScore :: ( BaseBackend ( YesodPersistBackend site ) ~ SqlBackend , PersistUniqueRead ( YesodPersistBackend site ) , BackendCompatible SqlBackend ( YesodPersistBackend site ) , YesodPersist site , PersistQueryRead ( YesodPersistBackend site ) ) => Maybe Text -> Entity Submission -> HandlerFor site Text
doGetScore mMetricName submission = do
2018-01-25 16:34:05 +01:00
let challengeId = submissionChallenge $ entityVal submission
2019-11-30 11:56:07 +01:00
mTestEnt <- runDB $ fetchTestByName mMetricName challengeId
case mTestEnt of
Just testEnt -> do
let theTestId = entityKey testEnt
let submissionId = entityKey submission
evals <- runDB $ E . select
$ E . from $ \ ( out , evaluation , variant ) -> do
E . where_ ( variant ^. VariantSubmission E .==. E . val submissionId
E .&&. out ^. OutVariant E .==. variant ^. VariantId
E .&&. out ^. OutTest E .==. E . val theTestId
E .&&. evaluation ^. EvaluationTest E .==. E . val theTestId
E .&&. out ^. OutChecksum E .==. evaluation ^. EvaluationChecksum )
E . orderBy []
return ( evaluation )
case evals of
[ eval ] -> return $ formatTruncatedScore ( testPrecision $ entityVal testEnt ) ( Just $ entityVal eval )
_ -> return " NONE "
Nothing -> return " NONE "
2018-01-25 16:34:05 +01:00
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 " )
2019-11-30 08:36:21 +01:00
getViewVariantR :: VariantId -> Handler Html
getViewVariantR variantId = do
mauthId <- maybeAuth
variant <- runDB $ get404 variantId
let theSubmissionId = variantSubmission variant
theSubmission <- runDB $ get404 theSubmissionId
2019-11-30 11:25:53 +01:00
( [ entry ] , tests' ) <- runDB $ getChallengeSubmissionInfos ( \ e -> entityKey e == theSubmissionId )
( \ e -> entityKey e == variantId )
( submissionChallenge theSubmission )
let tests = sortBy ( flip testComparator ) tests'
2019-11-30 11:04:52 +01:00
2019-11-30 08:36:21 +01:00
if submissionIsPublic theSubmission || Just ( submissionSubmitter theSubmission ) == ( entityKey <$> mauthId )
then
do
fullSubmissionInfo <- getFullInfo ( Entity theSubmissionId theSubmission )
testOutputs <- runDB $ E . select
$ E . from $ \ ( out , test ) -> do
E . where_ ( out ^. OutTest E .==. test ^. TestId
E .&&. out ^. OutVariant E .==. E . val variantId )
E . orderBy []
return ( out , test )
let outputs =
sortBy ( \ a b -> ( ( snd b ) ` compare ` ( snd a ) ) )
$ nub
$ map ( \ ( out , test ) -> ( outChecksum $ entityVal out , testName $ entityVal test ) ) testOutputs
defaultLayout $ do
setTitle " Variant "
$ ( widgetFile " view-variant " )
else
error " Cannot access this submission variant "
2019-11-30 11:04:52 +01:00
outputEvaluationsTable :: TableEntry -> Table . Table App ( Entity Test )
outputEvaluationsTable tableEntry = mempty
++ Table . text " Metric " ( formatTestEvaluationScheme . entityVal )
++ Table . text " Score " ( \ test -> ( formatTruncatedScore ( testPrecision $ entityVal test )
$ extractScore ( getTestReference test ) tableEntry ) )
paramsTable :: Table . Table App Parameter
paramsTable = mempty
++ Table . text " Parameter " parameterName
++ Table . text " Value " parameterValue
viewOutput :: TableEntry -> [ Entity Test ] -> ( SHA1 , Text ) -> WidgetFor App ()
viewOutput entry tests ( outputHash , testSet ) = do
let tests' = filter ( \ e -> ( testName $ entityVal e ) == testSet ) tests
2019-11-30 08:36:21 +01:00
let outputSha1AsText = fromSHA1ToText $ outputHash
$ ( widgetFile " view-output " )
2018-11-12 14:12:51 +01:00
resultTable :: Entity Submission -> WidgetFor App ()
resultTable ( Entity submissionId submission ) = do
2019-11-30 11:04:52 +01:00
( tableEntries , tests ) <- handlerToWidget
$ runDB
$ getChallengeSubmissionInfos ( \ s -> entityKey s == submissionId )
( const True )
( submissionChallenge submission )
2018-11-12 14:12:51 +01:00
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