Merge branch 'dashboard' into 'master'

Dashboard

See merge request gonito/gonito!1
This commit is contained in:
Karol Kaczmarek 2018-09-17 11:26:11 +02:00
commit 5ade94b225
14 changed files with 291 additions and 6 deletions

View File

@ -54,6 +54,7 @@ import Handler.EditSubmission
import Handler.Achievements import Handler.Achievements
import Handler.Score import Handler.Score
import Handler.ExtraPoints import Handler.ExtraPoints
import Handler.Dashboard
-- This line actually creates our YesodDispatch instance. It is the second half -- This line actually creates our YesodDispatch instance. It is the second half
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the -- of the call to mkYesodData which occurs in Foundation.hs. Please see the

View File

@ -126,6 +126,8 @@ instance Yesod App where
isAuthorized (EditAchievementR _) _ = isAdmin isAuthorized (EditAchievementR _) _ = isAdmin
isAuthorized ExtraPointsR _ = isAdmin isAuthorized ExtraPointsR _ = isAdmin
isAuthorized DashboardR _ = return Authorized
isAuthorized (ShowChallengeR _) _ = return Authorized isAuthorized (ShowChallengeR _) _ = return Authorized
isAuthorized (ChallengeReadmeR _) _ = return Authorized isAuthorized (ChallengeReadmeR _) _ = return Authorized
isAuthorized (ChallengeAllSubmissionsR _) _ = return Authorized isAuthorized (ChallengeAllSubmissionsR _) _ = return Authorized

View File

@ -11,7 +11,6 @@ import Handler.Shared
import Handler.AchievementUtils import Handler.AchievementUtils
import Data.Time.Clock
import Data.Time.LocalTime import Data.Time.LocalTime
import Data.Text import Data.Text
@ -103,7 +102,7 @@ $if canGiveUpWorkingOn
getSubmissionForAchievementR :: SubmissionId -> WorkingOnId -> Handler Html getSubmissionForAchievementR :: SubmissionId -> WorkingOnId -> Handler Html
getSubmissionForAchievementR submissionId workingOnId = do getSubmissionForAchievementR submissionId workingOnId = do
(Entity userId user) <- requireAuth (Entity userId _) <- requireAuth
submission <- runDB $ get404 submissionId submission <- runDB $ get404 submissionId
workingOn <- runDB $ get404 workingOnId workingOn <- runDB $ get404 workingOnId
if submissionSubmitter submission == userId && workingOnUser workingOn == userId if submissionSubmitter submission == userId && workingOnUser workingOn == userId
@ -151,7 +150,7 @@ getStartWorkingOnR achievementId = do
getGiveUpWorkingOnR :: AchievementId -> Handler Html getGiveUpWorkingOnR :: AchievementId -> Handler Html
getGiveUpWorkingOnR achievementId = do getGiveUpWorkingOnR achievementId = do
(Entity userId user) <- requireAuth (Entity userId _) <- requireAuth
alreadyWorkingOn <- runDB $ selectList [WorkingOnUser ==. userId, alreadyWorkingOn <- runDB $ selectList [WorkingOnUser ==. userId,
WorkingOnAchievement ==. achievementId, WorkingOnAchievement ==. achievementId,
@ -171,11 +170,11 @@ getGiveUpWorkingOnR achievementId = do
determineWhetherCanStartWorkingOn Nothing _ _ = False determineWhetherCanStartWorkingOn Nothing _ _ = False
determineWhetherCanStartWorkingOn (Just (Entity userId user)) peopleWorkingOn maxWinners = determineWhetherCanStartWorkingOn (Just (Entity userId _)) peopleWorkingOn maxWinners =
(Import.all (\e -> (userId /= entityKey e)) peopleWorkingOn) && (checkLimit peopleWorkingOn maxWinners) (Import.all (\e -> (userId /= entityKey e)) peopleWorkingOn) && (checkLimit peopleWorkingOn maxWinners)
determineWhetherCanGiveUpWorkingOn Nothing _ = False determineWhetherCanGiveUpWorkingOn Nothing _ = False
determineWhetherCanGiveUpWorkingOn (Just (Entity userId user)) peopleWorkingOn = determineWhetherCanGiveUpWorkingOn (Just (Entity userId _)) peopleWorkingOn =
(Import.any (\e -> (userId == entityKey e)) peopleWorkingOn) (Import.any (\e -> (userId == entityKey e)) peopleWorkingOn)
checkLimit _ Nothing = True checkLimit _ Nothing = True
@ -230,7 +229,6 @@ getEditAchievementR achievementId = do
postEditAchievementR :: AchievementId -> Handler Html postEditAchievementR :: AchievementId -> Handler Html
postEditAchievementR achievementId = do postEditAchievementR achievementId = do
tagsAvailableAsJSON <- runDB $ getAvailableTagsAsJSON tagsAvailableAsJSON <- runDB $ getAvailableTagsAsJSON
achievement <- runDB $ get404 achievementId
((result, formWidget), formEnctype) <- runFormPost (achievementForm Nothing Nothing) ((result, formWidget), formEnctype) <- runFormPost (achievementForm Nothing Nothing)
mUser <- maybeAuth mUser <- maybeAuth

212
Handler/Dashboard.hs Normal file
View File

@ -0,0 +1,212 @@
module Handler.Dashboard where
import Import
import Data.Time.LocalTime
import Handler.Shared
import Handler.Common (checkIfAdmin)
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs)
import qualified Yesod.Table as Table
import qualified Data.Text as T
import Handler.Tables (timestampCell)
data IndicatorEntry = IndicatorEntry {
indicatorEntryIndicator :: Entity Indicator,
indicatorEntryTest :: Entity Test,
indicatorEntryChallenge :: Entity Challenge,
indicatorEntryFilterCondition :: Maybe Text,
indicatorEntryTargetCondition :: Maybe Text,
indicatorEntryTargets :: [Entity Target]
}
getDashboardR :: Handler Html
getDashboardR = do
(formWidget, formEnctype) <- generateFormPost targetForm
mUser <- maybeAuth
doDashboard mUser formWidget formEnctype
postDashboardR :: Handler Html
postDashboardR = do
((result, formWidget), formEnctype) <- runFormPost targetForm
mUser <- maybeAuth
when (checkIfAdmin mUser) $ do
case result of
FormSuccess (testId, filterCondition, targetCondition, deadlineDay, deadlineTime, value) -> do
targetId <- runDB $ insert $ Indicator testId filterCondition targetCondition
_ <- runDB $ insert $ Target targetId (UTCTime { utctDay = deadlineDay, utctDayTime = timeOfDayToTime deadlineTime }) value
return ()
_ -> do
return ()
doDashboard mUser formWidget formEnctype
getDeleteIndicatorR :: IndicatorId -> Handler Html
getDeleteIndicatorR indicatorId = do
(formWidget, formEnctype) <- generateFormPost targetForm
mUser <- maybeAuth
when (checkIfAdmin mUser) $ runDB $ do
targets <- selectList [TargetIndicator ==. indicatorId] []
mapM_ delete $ map entityKey targets
delete indicatorId
setMessage $ toHtml (("Indicator deleted along with its targets!" :: Text))
doDashboard mUser formWidget formEnctype
getEditIndicatorR :: IndicatorId -> Handler Html
getEditIndicatorR indicatorId = do
indicator <- runDB $ get404 indicatorId
(formWidget, formEnctype) <- generateFormPost (indicatorForm indicator)
mUser <- maybeAuth
doEditIndicator mUser indicatorId formWidget formEnctype
postEditIndicatorR :: IndicatorId -> Handler Html
postEditIndicatorR indicatorId = do
indicator <- runDB $ get404 indicatorId
((result, formWidget), formEnctype) <- runFormPost (indicatorForm indicator)
mUser <- maybeAuth
when (checkIfAdmin mUser) $ do
case result of
FormSuccess changedIndicator -> do
runDB $ replace indicatorId changedIndicator
return ()
_ -> do
return ()
doEditIndicator mUser indicatorId formWidget formEnctype
doEditIndicator mUser indicatorId formWidget formEnctype = do
(addTargetformWidget, addTargetFormEnctype) <- generateFormPost addTargetForm
indicator <- runDB $ get404 indicatorId
indicatorEntry <- indicatorToEntry (Entity indicatorId indicator)
defaultLayout $ do
setTitle "Dashboard"
$(widgetFile "edit-indicator")
postAddTargetR :: IndicatorId -> Handler Html
postAddTargetR indicatorId = do
((result, _), _) <- runFormPost addTargetForm
mUser <- maybeAuth
when (checkIfAdmin mUser) $ runDB $ do
case result of
FormSuccess (deadlineDay, deadlineTime, value) -> do
_ <- insert $ Target indicatorId (UTCTime { utctDay = deadlineDay, utctDayTime = timeOfDayToTime deadlineTime }) value
return ()
_ -> do
return ()
getEditIndicatorR indicatorId
getDeleteTargetR :: TargetId -> Handler Html
getDeleteTargetR targetId = do
(formWidget, formEnctype) <- generateFormPost targetForm
mUser <- maybeAuth
target <- runDB $ get404 targetId
when (checkIfAdmin mUser) $ runDB $ do
delete targetId
setMessage $ toHtml (("Target deleted!" :: Text))
doEditIndicator mUser (targetIndicator target) formWidget formEnctype
doDashboard mUser formWidget formEnctype = do
indicators <- runDB $ selectList [] [Asc IndicatorId]
indicatorEntries <- mapM indicatorToEntry indicators
defaultLayout $ do
setTitle "Dashboard"
$(widgetFile "dashboard")
indicatorToEntry :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, PersistQueryRead (YesodPersistBackend site), YesodPersist site) => Entity Indicator -> HandlerFor site IndicatorEntry
indicatorToEntry indicatorEnt@(Entity indicatorId indicator) = runDB $ do
let theTestId = indicatorTest indicator
test <- get404 theTestId
let theChallengeId = testChallenge test
challenge <- get404 theChallengeId
targets <- selectList [TargetIndicator ==. indicatorId] [Asc TargetDeadline]
return $ IndicatorEntry {
indicatorEntryIndicator = indicatorEnt,
indicatorEntryTest = Entity theTestId test,
indicatorEntryChallenge = Entity theChallengeId challenge,
indicatorEntryFilterCondition = indicatorFilterCondition indicator,
indicatorEntryTargetCondition = indicatorTargetCondition indicator,
indicatorEntryTargets = targets
}
targetForm :: Form (TestId, Maybe Text, Maybe Text, Day, TimeOfDay, Double)
targetForm = renderBootstrap3 BootstrapBasicForm $ (,,,,,)
<$> testSelectFieldList Nothing
<*> aopt textField (fieldWithTooltip MsgFilterCondition MsgFilterConditionTooltip) Nothing
<*> aopt textField (fieldWithTooltip MsgTargetCondition MsgTargetConditionTooltip) Nothing
<*> areq dayField (bfs MsgTargetDeadlineDay) Nothing
<*> areq timeFieldTypeTime (bfs MsgTargetDeadlineTime) Nothing
<*> areq doubleField (bfs MsgTargetValue) Nothing
indicatorForm :: Indicator -> Form Indicator
indicatorForm indicator = renderBootstrap3 BootstrapBasicForm $ Indicator
<$> testSelectFieldList (Just $ indicatorTest indicator)
<*> aopt textField (fieldWithTooltip MsgFilterCondition MsgFilterConditionTooltip) (Just $ indicatorFilterCondition indicator)
<*> aopt textField (fieldWithTooltip MsgTargetCondition MsgTargetConditionTooltip) (Just $ indicatorTargetCondition indicator)
addTargetForm :: Form (Day, TimeOfDay, Double)
addTargetForm = renderBootstrap3 BootstrapBasicForm $ (,,)
<$> areq dayField (bfs MsgTargetDeadlineDay) Nothing
<*> areq timeFieldTypeTime (bfs MsgTargetDeadlineTime) Nothing
<*> areq doubleField (bfs MsgTargetValue) Nothing
indicatorTable :: Maybe (Entity User) -> Table.Table App (IndicatorEntry)
indicatorTable mUser = mempty
++ Table.text "indicator" prettyIndicatorEntry
++ Table.text "filter condition" ((fromMaybe T.empty) . indicatorEntryFilterCondition)
++ Table.text "target condition" ((fromMaybe T.empty) . indicatorEntryTargetCondition)
++ Table.text "targets" formatTargets
++ indicatorStatusCell mUser
targetTable :: Maybe (Entity User) -> Table.Table App (Entity Target)
targetTable mUser = mempty
++ Table.text "target value" (T.pack . show . targetValue . entityVal)
++ timestampCell "deadline" (targetDeadline . entityVal)
++ targetStatusCell mUser
prettyIndicatorEntry :: IndicatorEntry -> Text
prettyIndicatorEntry entry = prettyTestTitle (entityVal $ indicatorEntryTest entry)
(entityVal $ indicatorEntryChallenge entry)
formatTargets :: IndicatorEntry -> Text
formatTargets = T.intercalate ", " . (map formatTarget) . indicatorEntryTargets
formatTarget :: Entity Target -> Text
formatTarget (Entity _ target) = (T.pack $ show $ targetValue target) <> " (" <> (T.pack $ show $ targetDeadline target) ++ ")"
indicatorStatusCell :: Maybe (Entity User) -> Table.Table App IndicatorEntry
indicatorStatusCell mUser = Table.widget "" (indicatorStatusCellWidget mUser)
indicatorStatusCellWidget :: Maybe (Entity User) -> IndicatorEntry -> WidgetFor App ()
indicatorStatusCellWidget mUser indicatorEntry = $(widgetFile "indicator-status")
where indicatorId = entityKey $ indicatorEntryIndicator indicatorEntry
targetStatusCell :: Maybe (Entity User) -> Table.Table App (Entity Target)
targetStatusCell mUser = Table.widget "" (targetStatusCellWidget mUser)
targetStatusCellWidget :: Maybe (Entity User) -> Entity Target -> WidgetFor App ()
targetStatusCellWidget mUser targetEnt = $(widgetFile "target-status")
where targetId = entityKey $ targetEnt
testSelectFieldList :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, RenderMessage site AppMessage, RenderMessage site FormMessage, PersistQueryRead (YesodPersistBackend site), YesodPersist site) => Maybe TestId -> AForm (HandlerFor site) (Key Test)
testSelectFieldList mTestId = areq (selectField tests) (bfs MsgTest) mTestId
where
tests = do
testEnts <- runDB $ selectList [] [Asc TestName]
challenges <- runDB $ mapM (\(Entity _ val) -> get404 (testChallenge val)) testEnts
let items = Import.map (\(t, ch) -> (prettyTestTitle (entityVal t) ch, entityKey t)) $ zip testEnts challenges
optionsPairs $ sortBy (\a b -> fst a `compare` fst b) items
prettyTestTitle :: Test -> Challenge -> Text
prettyTestTitle t ch = (challengeTitle ch) ++ " / " ++ (testName t) ++ " / " ++ (pack $ show $ testMetric t)

View File

@ -1,5 +1,6 @@
#!/bin/bash -xe #!/bin/bash -xe
rm -rf ../geval
git clone git://gonito.net/geval git clone git://gonito.net/geval
mv geval .. mv geval ..
stack install stack install

View File

@ -98,6 +98,7 @@ SubmissionTag
tag TagId tag TagId
accepted Bool Maybe accepted Bool Maybe
UniqueSubmissionTag submission tag UniqueSubmissionTag submission tag
-- for machine learning courses
Achievement Achievement
name Text name Text
challenge ChallengeId challenge ChallengeId
@ -133,4 +134,13 @@ Participant
user UserId user UserId
course CourseId course CourseId
UniqueUserCourse user course UniqueUserCourse user course
-- for "KPI" dashboard
Indicator
test TestId
filterCondition Text Maybe
targetCondition Text Maybe
Target
indicator IndicatorId
deadline UTCTime
value Double
-- By default this file is used in Model.hs (which is imported by Foundation.hs) -- By default this file is used in Model.hs (which is imported by Foundation.hs)

View File

@ -52,6 +52,12 @@
/score/#UserId ScoreR GET /score/#UserId ScoreR GET
/my-score MyScoreR GET /my-score MyScoreR GET
/dashboard DashboardR GET POST
/edit-indicator/#IndicatorId EditIndicatorR GET POST
/delete-indicator/#IndicatorId DeleteIndicatorR GET
/delete-target/#TargetId DeleteTargetR GET
/add-target/#IndicatorId AddTargetR POST
/edit-submission/#SubmissionId EditSubmissionR GET POST /edit-submission/#SubmissionId EditSubmissionR GET POST
/edit-submission-and-variant/#SubmissionId/#VariantId EditSubmissionAndVariantR GET POST /edit-submission-and-variant/#SubmissionId/#VariantId EditSubmissionAndVariantR GET POST
/add-variant-param/#SubmissionId/#VariantId AddVariantParamR POST /add-variant-param/#SubmissionId/#VariantId AddVariantParamR POST

View File

@ -52,6 +52,7 @@ library
Handler.AchievementUtils Handler.AchievementUtils
Handler.ExtraPoints Handler.ExtraPoints
Handler.Runner Handler.Runner
Handler.Dashboard
if flag(dev) || flag(library-only) if flag(dev) || flag(library-only)
cpp-options: -DDEVELOPMENT cpp-options: -DDEVELOPMENT

View File

@ -66,3 +66,12 @@ ParameterName: parameter name
ParameterValue: parameter value ParameterValue: parameter value
ChallengeName: computer-friendly name ("slug") ChallengeName: computer-friendly name ("slug")
ChallengeNameTooltip: to be used in the URLs (only lower-case letters, digits or hyphens, must start with a lower-case letter), once set cannot be changed! ChallengeNameTooltip: to be used in the URLs (only lower-case letters, digits or hyphens, must start with a lower-case letter), once set cannot be changed!
FilterCondition: filter condition
FilterConditionTooltip: the condition used to pre-select all submission — an extra graph will be drawed for all submissions matching this condition (not necessarily the target condition)
TargetCondition: target condition
TargetConditionTooltip: the condition which is required for a submission to be considered for realising the target
TargetDeadlineDay: target day
TargetDeadlineTime: target time
TargetValue: target value to be reached before the target date
Test: test
Dashboard: dashboard

View File

@ -0,0 +1,13 @@
<h1>Dashboard
^{Table.buildBootstrap (indicatorTable mUser) indicatorEntries}
<hr>
$if (checkIfAdmin mUser)
<h2>Create a new target
<form method=post action=@{DashboardR}#form enctype=#{formEnctype}>
^{formWidget}
<button .btn .btn-primary type="submit">
_{MsgSubmit} <span class="glyphicon glyphicon-upload"></span>

View File

@ -19,6 +19,7 @@
<li><a href="@{ListChallengesR}">_{MsgListChallenges}</a> <li><a href="@{ListChallengesR}">_{MsgListChallenges}</a>
<li><a href="@{TagsR}">_{MsgListTags}</a> <li><a href="@{TagsR}">_{MsgListTags}</a>
<li><a href="@{AchievementsR}">_{MsgAchievements}</a> <li><a href="@{AchievementsR}">_{MsgAchievements}</a>
<li><a href="@{DashboardR}">_{MsgDashboard}</a>
$if userIsAdmin $ entityVal user $if userIsAdmin $ entityVal user
<li class="dropdown"> <li class="dropdown">
<a id="admin" href="#" class="dropdown-toggle" data-toggle="dropdown">_{MsgManage}<span class="caret"></span> <a id="admin" href="#" class="dropdown-toggle" data-toggle="dropdown">_{MsgManage}<span class="caret"></span>
@ -39,6 +40,7 @@
<li><a href="@{Presentation4RealR}">_{MsgAbout}</a> <li><a href="@{Presentation4RealR}">_{MsgAbout}</a>
<li><a href="@{ListChallengesR}">_{MsgListChallenges}</a> <li><a href="@{ListChallengesR}">_{MsgListChallenges}</a>
<li><a href="@{TagsR}">_{MsgListTags}</a> <li><a href="@{TagsR}">_{MsgListTags}</a>
<li><a href="@{DashboardR}">_{MsgDashboard}</a>
<ul class="nav navbar-nav navbar-collapse collapse navbar-right"> <ul class="nav navbar-nav navbar-collapse collapse navbar-right">
<li><a href="@{AuthR LoginR}">log in</a> <li><a href="@{AuthR LoginR}">log in</a>

View File

@ -0,0 +1,21 @@
<h2>#{prettyIndicatorEntry indicatorEntry}
<form method=post action=@{EditIndicatorR indicatorId}#form enctype=#{formEnctype}>
^{formWidget}
<button .btn .btn-primary type="submit">
_{MsgSubmit} <span class="glyphicon glyphicon-upload"></span>
<h4>Targets
^{Table.buildBootstrap (targetTable mUser) (indicatorEntryTargets indicatorEntry)}
$if (checkIfAdmin mUser)
<h4>Add a new target
<form method=post action=@{AddTargetR indicatorId}#form enctype=#{addTargetFormEnctype}>
^{addTargetformWidget}
<button .btn .btn-primary type="submit">
_{MsgSubmit} <span class="glyphicon glyphicon-upload"></span>
<hr>
<p><a href=@{DashboardR}>Back to Dashboard</p>

View File

@ -0,0 +1,6 @@
$if (checkIfAdmin mUser)
<a href="@{EditIndicatorR indicatorId}">
<span class="glyphicon glyphicon-pencil" title="click to edit the submission" aria-hidden="true">
<a href="@{DeleteIndicatorR indicatorId}">
<span class="glyphicon glyphicon-remove" title="click to remove the submission" aria-hidden="true">

View File

@ -0,0 +1,3 @@
$if (checkIfAdmin mUser)
<a href="@{DeleteTargetR targetId}">
<span class="glyphicon glyphicon-remove" title="click to remove the submission" aria-hidden="true">