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.

Application.hs

@@ -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

Foundation.hs

@@ -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

Handler/Dashboard.hs

@@ -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)

config/models

@@ -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)

config/routes

@@ -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

gonito.cabal

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

messages/en.msg

@@ -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

templates/dashboard.hamlet

@@ -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>

templates/default-layout.hamlet

@@ -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>

templates/edit-indicator.hamlet

@@ -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>

templates/indicator-status.hamlet

@@ -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">

templates/target-status.hamlet

@@ -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">