Add indicators to the database, make it possible to edit them in the dashboard.

The dashboard itself (in terms of graphs) is not part of this commit.
This commit is contained in:
Filip Gralinski 2018-09-14 15:44:20 +02:00 committed by Filip Graliński
parent 69dedeecbd
commit e1b1ff53f1
12 changed files with 286 additions and 0 deletions

View File

@ -54,6 +54,7 @@ import Handler.EditSubmission
import Handler.Achievements
import Handler.Score
import Handler.ExtraPoints
import Handler.Dashboard
-- 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

View File

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

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

@ -98,6 +98,7 @@ SubmissionTag
tag TagId
accepted Bool Maybe
UniqueSubmissionTag submission tag
-- for machine learning courses
Achievement
name Text
challenge ChallengeId
@ -133,4 +134,13 @@ Participant
user UserId
course CourseId
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)

View File

@ -52,6 +52,12 @@
/score/#UserId ScoreR 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-and-variant/#SubmissionId/#VariantId EditSubmissionAndVariantR GET POST
/add-variant-param/#SubmissionId/#VariantId AddVariantParamR POST

View File

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

View File

@ -66,3 +66,12 @@ ParameterName: parameter name
ParameterValue: parameter value
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!
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="@{TagsR}">_{MsgListTags}</a>
<li><a href="@{AchievementsR}">_{MsgAchievements}</a>
<li><a href="@{DashboardR}">_{MsgDashboard}</a>
$if userIsAdmin $ entityVal user
<li class="dropdown">
<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="@{ListChallengesR}">_{MsgListChallenges}</a>
<li><a href="@{TagsR}">_{MsgListTags}</a>
<li><a href="@{DashboardR}">_{MsgDashboard}</a>
<ul class="nav navbar-nav navbar-collapse collapse navbar-right">
<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">