gonito/Handler/Query.hs

125 lines
5.0 KiB
Haskell
Raw Normal View History

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
import Yesod.Table (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]
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"
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
tests <- runDB $ selectList [TestChallenge ==. challengeId] []
let mainTest = getMainTest tests
let mainTestId = entityKey mainTest
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
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")
queryResult submission = do
$(widgetFile "query-result")
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
2016-02-12 13:00:33 +01:00
queryForm :: Form Text
queryForm = renderBootstrap3 BootstrapBasicForm $ areq textField (fieldSettingsLabel MsgGitCommitSha1) Nothing