gonito/Handler/Query.hs
2018-11-12 14:12:51 +01:00

125 lines
5.0 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 Yesod.Table (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 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 ++ "%"]
findSubmissions :: Text -> Handler [FullSubmissionInfo]
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
mapM getFullInfo submissions
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
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
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"
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
defaultLayout $ do
setTitle "query results"
$(widgetFile "query-results")
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
queryForm :: Form Text
queryForm = renderBootstrap3 BootstrapBasicForm $ areq textField (fieldSettingsLabel MsgGitCommitSha1) Nothing