Add extra fields to leaderboard entries
This commit is contained in:
parent
f7d61aa256
commit
c43d54a6be
66
Handler/JWT.hs
Normal file
66
Handler/JWT.hs
Normal file
@ -0,0 +1,66 @@
|
||||
module Handler.JWT where
|
||||
|
||||
import Import hiding (Proxy, fromList)
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Word8 (isSpace, toLower)
|
||||
import Network.Wai (requestHeaders)
|
||||
import qualified Jose.Jwt as JWT
|
||||
import qualified Jose.Jwa as JWA
|
||||
|
||||
import Data.Aeson
|
||||
|
||||
data JwtAuthInfo = JwtAuthInfo Text
|
||||
deriving (Show, Eq)
|
||||
|
||||
instance FromJSON JwtAuthInfo where
|
||||
parseJSON (Object v) =
|
||||
JwtAuthInfo <$> v .: "preferred_username"
|
||||
parseJSON _ = mzero
|
||||
|
||||
jwtAuthInfoIdent :: JwtAuthInfo -> Text
|
||||
jwtAuthInfoIdent (JwtAuthInfo ident) = ident
|
||||
|
||||
authorizationTokenAuth :: Handler (Maybe JwtAuthInfo)
|
||||
authorizationTokenAuth = do
|
||||
app <- getYesod
|
||||
let mJwk = appJSONWebKey $ appSettings app
|
||||
|
||||
case mJwk of
|
||||
Just jwk -> do
|
||||
req <- waiRequest
|
||||
case lookup "Authorization" (Network.Wai.requestHeaders req) of
|
||||
Nothing -> return Nothing
|
||||
Just authHead -> case BS.break isSpace authHead of
|
||||
(strategy, token')
|
||||
| BS.map Data.Word8.toLower strategy == "bearer" -> do
|
||||
let token = BS.filter (/= 32) token'
|
||||
einfo <- liftIO $ JWT.decode [jwk] (Just (JWT.JwsEncoding JWA.RS256)) token
|
||||
return $ case einfo of
|
||||
Right (JWT.Jws (_, infos)) -> decode $ fromStrict infos
|
||||
_ -> Nothing
|
||||
| otherwise -> return Nothing
|
||||
Nothing -> return Nothing
|
||||
|
||||
maybeAuthPossiblyByToken :: Handler (Maybe (Entity User))
|
||||
maybeAuthPossiblyByToken = do
|
||||
mInfo <- authorizationTokenAuth
|
||||
case mInfo of
|
||||
Just infos -> do
|
||||
x <- runDB $ getBy $ UniqueUser $ jwtAuthInfoIdent infos
|
||||
case x of
|
||||
Just entUser -> return $ Just entUser
|
||||
Nothing -> maybeAuth
|
||||
Nothing -> maybeAuth
|
||||
|
||||
|
||||
requireAuthPossiblyByToken :: Handler (Entity User)
|
||||
requireAuthPossiblyByToken = do
|
||||
mInfo <- authorizationTokenAuth
|
||||
case mInfo of
|
||||
Just infos -> do
|
||||
x <- runDB $ getBy $ UniqueUser $ jwtAuthInfoIdent infos
|
||||
case x of
|
||||
Just entUser -> return entUser
|
||||
Nothing -> requireAuth
|
||||
Nothing -> requireAuth
|
||||
@ -21,16 +21,12 @@ import Handler.MakePublic
|
||||
import Handler.Dashboard
|
||||
import Handler.Common
|
||||
import Handler.Evaluate
|
||||
import Handler.JWT
|
||||
|
||||
import Database.Persist.Sql (fromSqlKey)
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Word8 (isSpace, toLower)
|
||||
import Network.Wai (requestHeaders)
|
||||
import qualified Jose.Jwt as JWT
|
||||
import qualified Jose.Jwa as JWA
|
||||
|
||||
|
||||
import Data.Maybe (fromJust)
|
||||
@ -79,6 +75,9 @@ instance ToJSON LeaderboardEntry where
|
||||
(leaderboardParams entry)
|
||||
, "times" .= leaderboardNumberOfSubmissions entry
|
||||
, "hash" .= (fromSHA1ToText $ submissionCommit $ leaderboardBestSubmission entry)
|
||||
, "isPublic" .= (submissionIsPublic $ leaderboardBestSubmission entry)
|
||||
, "isReevaluable" .= (leaderboardIsReevaluable entry)
|
||||
, "isVisible" .= (leaderboardIsVisible entry)
|
||||
]
|
||||
|
||||
declareLeaderboardSwagger :: Declare (Definitions Schema) Swagger
|
||||
@ -161,6 +160,7 @@ instance ToSchema LeaderboardEntryView where
|
||||
declareNamedSchema _ = do
|
||||
stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String)
|
||||
intSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Int)
|
||||
boolSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Bool)
|
||||
evaluationsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [EvaluationView])
|
||||
return $ NamedSchema (Just "LeaderboardEntry") $ mempty
|
||||
& type_ .~ SwaggerObject
|
||||
@ -172,6 +172,9 @@ instance ToSchema LeaderboardEntryView where
|
||||
, ("times", intSchema)
|
||||
, ("hash", stringSchema)
|
||||
, ("evaluations", evaluationsSchema)
|
||||
, ("isPublic", boolSchema)
|
||||
, ("isReevaluable", boolSchema)
|
||||
, ("isVisible", boolSchema)
|
||||
]
|
||||
& required .~ [ "submitter", "when", "version", "description", "times", "hash", "evaluations" ]
|
||||
|
||||
@ -890,61 +893,6 @@ submissionForm defaultUrl defBranch defaultGitAnnexRemote = renderBootstrap3 Boo
|
||||
<*> areq textField (bfs MsgSubmissionBranch) defBranch
|
||||
<*> aopt textField (bfs MsgSubmissionGitAnnexRemote) (Just defaultGitAnnexRemote))
|
||||
|
||||
data JwtAuthInfo = JwtAuthInfo Text
|
||||
deriving (Show, Eq)
|
||||
|
||||
instance FromJSON JwtAuthInfo where
|
||||
parseJSON (Object v) =
|
||||
JwtAuthInfo <$> v .: "preferred_username"
|
||||
parseJSON _ = mzero
|
||||
|
||||
jwtAuthInfoIdent :: JwtAuthInfo -> Text
|
||||
jwtAuthInfoIdent (JwtAuthInfo ident) = ident
|
||||
|
||||
authorizationTokenAuth :: Handler (Maybe JwtAuthInfo)
|
||||
authorizationTokenAuth = do
|
||||
app <- getYesod
|
||||
let mJwk = appJSONWebKey $ appSettings app
|
||||
|
||||
case mJwk of
|
||||
Just jwk -> do
|
||||
req <- waiRequest
|
||||
case lookup "Authorization" (Network.Wai.requestHeaders req) of
|
||||
Nothing -> return Nothing
|
||||
Just authHead -> case BS.break isSpace authHead of
|
||||
(strategy, token')
|
||||
| BS.map Data.Word8.toLower strategy == "bearer" -> do
|
||||
let token = BS.filter (/= 32) token'
|
||||
einfo <- liftIO $ JWT.decode [jwk] (Just (JWT.JwsEncoding JWA.RS256)) token
|
||||
return $ case einfo of
|
||||
Right (JWT.Jws (_, infos)) -> decode $ fromStrict infos
|
||||
_ -> Nothing
|
||||
| otherwise -> return Nothing
|
||||
Nothing -> return Nothing
|
||||
|
||||
maybeAuthPossiblyByToken :: Handler (Maybe (Entity User))
|
||||
maybeAuthPossiblyByToken = do
|
||||
mInfo <- authorizationTokenAuth
|
||||
case mInfo of
|
||||
Just infos -> do
|
||||
x <- runDB $ getBy $ UniqueUser $ jwtAuthInfoIdent infos
|
||||
case x of
|
||||
Just entUser -> return $ Just entUser
|
||||
Nothing -> maybeAuth
|
||||
Nothing -> maybeAuth
|
||||
|
||||
|
||||
requireAuthPossiblyByToken :: Handler (Entity User)
|
||||
requireAuthPossiblyByToken = do
|
||||
mInfo <- authorizationTokenAuth
|
||||
case mInfo of
|
||||
Just infos -> do
|
||||
x <- runDB $ getBy $ UniqueUser $ jwtAuthInfoIdent infos
|
||||
case x of
|
||||
Just entUser -> return entUser
|
||||
Nothing -> requireAuth
|
||||
Nothing -> requireAuth
|
||||
|
||||
getUserInfoR :: Handler Value
|
||||
getUserInfoR = do
|
||||
(Entity _ user) <- requireAuthPossiblyByToken
|
||||
|
||||
@ -7,6 +7,7 @@ import Handler.Shared
|
||||
import Handler.Evaluate
|
||||
import Handler.SubmissionView
|
||||
import Handler.TagUtils
|
||||
import Handler.JWT
|
||||
|
||||
import Data.Diff
|
||||
|
||||
@ -70,7 +71,9 @@ data LeaderboardEntry = LeaderboardEntry {
|
||||
leaderboardNumberOfSubmissions :: Int,
|
||||
leaderboardTags :: [(Entity Import.Tag, Entity SubmissionTag)],
|
||||
leaderboardParams :: [Parameter],
|
||||
leaderboardVersion :: (Int, Int, Int)
|
||||
leaderboardVersion :: (Int, Int, Int),
|
||||
leaderboardIsVisible :: Bool,
|
||||
leaderboardIsReevaluable :: Bool
|
||||
}
|
||||
|
||||
data TableEntry = TableEntry {
|
||||
@ -329,14 +332,14 @@ getLeaderboardEntriesByCriterion maxPriority challengeId condition preselector s
|
||||
return (entries, (evaluationMaps, mainTests))
|
||||
|
||||
|
||||
toLeaderboardEntry :: (Foldable t, YesodPersist site, PersistQueryRead (YesodPersistBackend site), PersistUniqueRead (YesodPersistBackend site), BaseBackend (YesodPersistBackend site) ~ SqlBackend) => Key Challenge -> [Entity Test] -> t TableEntry -> HandlerFor site LeaderboardEntry
|
||||
toLeaderboardEntry :: Foldable t => Key Challenge -> [Entity Test] -> t TableEntry -> Handler LeaderboardEntry
|
||||
toLeaderboardEntry challengeId tests ss = do
|
||||
let bestOne = DL.maximumBy submissionComparator ss
|
||||
let (TableEntry bestSubmission bestVariant user evals _ _ _ _) = bestOne
|
||||
let submissionId = entityKey bestSubmission
|
||||
tagEnts <- runDB $ getTags submissionId
|
||||
|
||||
parameters <- runDB $ selectList [ParameterVariant ==. (entityKey bestVariant)] [Asc ParameterName]
|
||||
theParameters <- runDB $ selectList [ParameterVariant ==. (entityKey bestVariant)] [Asc ParameterName]
|
||||
|
||||
submission <- runDB $ get404 submissionId
|
||||
(Just (Entity _ version)) <- runDB $ getBy $ UniqueVersionByCommit $ submissionVersion submission
|
||||
@ -349,6 +352,12 @@ toLeaderboardEntry challengeId tests ss = do
|
||||
allUserSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId,
|
||||
SubmissionSubmitter ==. entityKey user]
|
||||
[Desc SubmissionStamp]
|
||||
|
||||
mUserId <- maybeAuthPossiblyByToken
|
||||
|
||||
isReevaluable <- runDB $ canBeReevaluated $ entityKey $ tableEntrySubmission bestOne
|
||||
isVisible <- runDB $ checkWhetherVisible submission (entityKey <$> mUserId)
|
||||
|
||||
return $ LeaderboardEntry {
|
||||
leaderboardUser = entityVal user,
|
||||
leaderboardUserId = entityKey user,
|
||||
@ -359,8 +368,10 @@ toLeaderboardEntry challengeId tests ss = do
|
||||
leaderboardEvaluationMap = evals,
|
||||
leaderboardNumberOfSubmissions = length allUserSubmissions,
|
||||
leaderboardTags = tagEnts,
|
||||
leaderboardParams = map entityVal parameters,
|
||||
leaderboardVersion = theVersion
|
||||
leaderboardParams = map entityVal theParameters,
|
||||
leaderboardVersion = theVersion,
|
||||
leaderboardIsReevaluable = isReevaluable,
|
||||
leaderboardIsVisible = isVisible
|
||||
}
|
||||
where mainTestEnt@(Entity _ mainTest) = getMainTest tests
|
||||
mainTestRef = getTestReference mainTestEnt
|
||||
|
||||
@ -60,6 +60,7 @@ library
|
||||
Gonito.ExtractMetadata
|
||||
Data.Diff
|
||||
Handler.Swagger
|
||||
Handler.JWT
|
||||
|
||||
if flag(dev) || flag(library-only)
|
||||
cpp-options: -DDEVELOPMENT
|
||||
|
||||
Loading…
Reference in New Issue
Block a user