forked from filipg/gonito
263 lines
11 KiB
Haskell
263 lines
11 KiB
Haskell
module Handler.Query where
|
|
|
|
import Import
|
|
|
|
import Handler.SubmissionView
|
|
import Handler.Shared
|
|
import Handler.TagUtils
|
|
import PersistSHA1
|
|
|
|
import Handler.Tables
|
|
|
|
import qualified Yesod.Table as Table
|
|
|
|
import Database.Persist.Sql
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import Database.Esqueleto ((^.))
|
|
|
|
import qualified Data.Text as T
|
|
|
|
import Data.List (nub)
|
|
import Data.List.Extra (groupOn)
|
|
|
|
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
|
|
|
|
rawCommitQuery :: (MonadIO m, RawSql a) => Text -> ReaderT SqlBackend m [a]
|
|
rawCommitQuery sha1Prefix =
|
|
rawSql "SELECT ?? FROM submission WHERE is_public AND cast(commit as text) like ?" [PersistText $ "\\\\x" ++ sha1Prefix ++ "%"]
|
|
|
|
rawOutQuery :: (MonadIO m, RawSql a) => Text -> ReaderT SqlBackend m [a]
|
|
rawOutQuery sha1Prefix =
|
|
rawSql "SELECT ?? FROM out WHERE cast(checksum as text) like ?" [PersistText $ "\\\\x" ++ sha1Prefix ++ "%"]
|
|
|
|
groupBySecond :: Eq b => [(FullSubmissionInfo, b)] -> [(FullSubmissionInfo, [b])]
|
|
groupBySecond lst = map putOut $ groupOn (fsiSubmissionId . fst) lst
|
|
where putOut ((ha, hb):t) = (ha, hb:nub (map snd t))
|
|
putOut [] = error "should not be here"
|
|
|
|
findSubmissions :: Text -> Handler [(FullSubmissionInfo, [SHA1])]
|
|
findSubmissions sha1Prefix = do
|
|
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 ++ "%"]
|
|
Nothing -> rawCommitQuery sha1Prefix
|
|
justSubmissions' <- mapM getFullInfo submissions
|
|
let justSubmissions = map (\s -> (s, [])) justSubmissions'
|
|
|
|
outs <- runDB $ rawOutQuery sha1Prefix
|
|
submissionsByOuts <- mapM fetchSubmissionByOut outs
|
|
|
|
return (justSubmissions ++ groupBySecond submissionsByOuts)
|
|
|
|
fetchSubmissionByOut :: Entity Out -> HandlerFor App (FullSubmissionInfo, SHA1)
|
|
fetchSubmissionByOut (Entity _ out) = do
|
|
variant <- runDB $ get404 $ outVariant out
|
|
let theSubmissionId = variantSubmission variant
|
|
theSubmission <- runDB $ get404 theSubmissionId
|
|
let theSubmissionEnt = Entity theSubmissionId theSubmission
|
|
fsi <- getFullInfo theSubmissionEnt
|
|
return (fsi, outChecksum out)
|
|
|
|
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
|
|
submissions <- findSubmissions sha1Prefix
|
|
case submissions of
|
|
[] -> return noneMessage
|
|
((fsi, _):_) -> case submissions of
|
|
[(_, [])] -> doGetScore mMetricName (Entity (fsiSubmissionId fsi)
|
|
(fsiSubmission fsi))
|
|
_ -> do
|
|
let hashes = nub $ concat $ map snd submissions
|
|
case hashes of
|
|
[h] -> doGetScoreForOut mMetricName
|
|
(Entity (fsiSubmissionId fsi)
|
|
(fsiSubmission fsi))
|
|
h
|
|
[] -> return noneMessage
|
|
_ -> return ambiguousArgumentMessage
|
|
where ambiguousArgumentMessage = "AMBIGUOUS ARGUMENT"
|
|
noneMessage = "NONE"
|
|
|
|
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
|
|
let challengeId = submissionChallenge $ entityVal submission
|
|
|
|
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"
|
|
|
|
doGetScoreForOut :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, PersistUniqueRead (YesodPersistBackend site), BackendCompatible SqlBackend (YesodPersistBackend site), YesodPersist site, PersistQueryRead (YesodPersistBackend site)) => Maybe Text -> Entity Submission -> SHA1 -> HandlerFor site Text
|
|
doGetScoreForOut mMetricName submission sha1code = do
|
|
let submissionId = entityKey submission
|
|
|
|
evals <- runDB $ E.select
|
|
$ E.from $ \(out, evaluation, variant, test) -> do
|
|
E.where_ (variant ^. VariantSubmission E.==. E.val submissionId
|
|
E.&&. out ^. OutVariant E.==. variant ^. VariantId
|
|
E.&&. out ^. OutTest E.==. test ^. TestId
|
|
E.&&. evaluation ^. EvaluationTest E.==. test ^. TestId
|
|
E.&&. out ^. OutChecksum E.==. evaluation ^. EvaluationChecksum
|
|
E.&&. out ^. OutChecksum E.==. E.val sha1code)
|
|
E.orderBy [E.asc (test ^. TestPriority)]
|
|
return (evaluation, test)
|
|
|
|
let evalSelected = case evals of
|
|
[] -> Nothing
|
|
((eval, test):_) -> case mMetricName of
|
|
Nothing -> Just (eval, test)
|
|
Just mn -> find (\(_, t) -> formatTestEvaluationScheme (entityVal t) == mn) evals
|
|
case evalSelected of
|
|
Nothing -> return "None"
|
|
Just (eval, testEnt) -> return $ formatTruncatedScore (testPrecision $ entityVal testEnt)
|
|
(Just $ entityVal eval)
|
|
|
|
|
|
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
|
|
|
|
isFullQuery :: Text -> Bool
|
|
isFullQuery query = length query == 40
|
|
|
|
processQuery :: Text -> Handler Html
|
|
processQuery query = do
|
|
submissions' <- findSubmissions query
|
|
let submissions = map fst submissions'
|
|
defaultLayout $ do
|
|
setTitle "query results"
|
|
$(widgetFile "query-results")
|
|
|
|
|
|
getViewVariantR :: VariantId -> Handler Html
|
|
getViewVariantR variantId = do
|
|
mauthId <- maybeAuth
|
|
variant <- runDB $ get404 variantId
|
|
let theSubmissionId = variantSubmission variant
|
|
theSubmission <- runDB $ get404 theSubmissionId
|
|
|
|
([entry], tests') <- runDB $ getChallengeSubmissionInfos (\e -> entityKey e == theSubmissionId)
|
|
(\e -> entityKey e == variantId)
|
|
(submissionChallenge theSubmission)
|
|
let tests = sortBy (flip testComparator) tests'
|
|
|
|
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"
|
|
|
|
|
|
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
|
|
let outputSha1AsText = fromSHA1ToText $ outputHash
|
|
$(widgetFile "view-output")
|
|
|
|
resultTable :: Entity Submission -> WidgetFor App ()
|
|
resultTable (Entity submissionId submission) = do
|
|
(tableEntries, tests) <- handlerToWidget
|
|
$ runDB
|
|
$ getChallengeSubmissionInfos (\s -> entityKey s == submissionId)
|
|
(const True)
|
|
(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")
|
|
|
|
|
|
submissionHeader :: FullSubmissionInfo -> WidgetFor App ()
|
|
submissionHeader submission =
|
|
$(widgetFile "submission-header")
|
|
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
|
|
|
|
queryResult :: FullSubmissionInfo -> WidgetFor App ()
|
|
queryResult submission = do
|
|
$(widgetFile "query-result")
|
|
|
|
queryForm :: Form Text
|
|
queryForm = renderBootstrap3 BootstrapBasicForm $ areq textField (fieldSettingsLabel MsgGitCommitSha1) Nothing
|