From 69dedeecbd1bd13aa2817daa25420af376c669a9 Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Fri, 14 Sep 2018 15:42:19 +0200 Subject: [PATCH 1/3] Fix some warnings in Achievements --- Handler/Achievements.hs | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/Handler/Achievements.hs b/Handler/Achievements.hs index 1aeff61..82d5590 100644 --- a/Handler/Achievements.hs +++ b/Handler/Achievements.hs @@ -11,7 +11,6 @@ import Handler.Shared import Handler.AchievementUtils -import Data.Time.Clock import Data.Time.LocalTime import Data.Text @@ -103,7 +102,7 @@ $if canGiveUpWorkingOn getSubmissionForAchievementR :: SubmissionId -> WorkingOnId -> Handler Html getSubmissionForAchievementR submissionId workingOnId = do - (Entity userId user) <- requireAuth + (Entity userId _) <- requireAuth submission <- runDB $ get404 submissionId workingOn <- runDB $ get404 workingOnId if submissionSubmitter submission == userId && workingOnUser workingOn == userId @@ -151,7 +150,7 @@ getStartWorkingOnR achievementId = do getGiveUpWorkingOnR :: AchievementId -> Handler Html getGiveUpWorkingOnR achievementId = do - (Entity userId user) <- requireAuth + (Entity userId _) <- requireAuth alreadyWorkingOn <- runDB $ selectList [WorkingOnUser ==. userId, WorkingOnAchievement ==. achievementId, @@ -171,11 +170,11 @@ getGiveUpWorkingOnR achievementId = do 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) determineWhetherCanGiveUpWorkingOn Nothing _ = False -determineWhetherCanGiveUpWorkingOn (Just (Entity userId user)) peopleWorkingOn = +determineWhetherCanGiveUpWorkingOn (Just (Entity userId _)) peopleWorkingOn = (Import.any (\e -> (userId == entityKey e)) peopleWorkingOn) checkLimit _ Nothing = True @@ -230,7 +229,6 @@ getEditAchievementR achievementId = do postEditAchievementR :: AchievementId -> Handler Html postEditAchievementR achievementId = do tagsAvailableAsJSON <- runDB $ getAvailableTagsAsJSON - achievement <- runDB $ get404 achievementId ((result, formWidget), formEnctype) <- runFormPost (achievementForm Nothing Nothing) mUser <- maybeAuth From e1b1ff53f13d1f4d78053e7a1550050994d70176 Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Fri, 14 Sep 2018 15:44:20 +0200 Subject: [PATCH 2/3] 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 | 1 + Foundation.hs | 2 + Handler/Dashboard.hs | 212 ++++++++++++++++++++++++++++++ config/models | 10 ++ config/routes | 6 + gonito.cabal | 1 + messages/en.msg | 9 ++ templates/dashboard.hamlet | 13 ++ templates/default-layout.hamlet | 2 + templates/edit-indicator.hamlet | 21 +++ templates/indicator-status.hamlet | 6 + templates/target-status.hamlet | 3 + 12 files changed, 286 insertions(+) create mode 100644 Handler/Dashboard.hs create mode 100644 templates/dashboard.hamlet create mode 100644 templates/edit-indicator.hamlet create mode 100644 templates/indicator-status.hamlet create mode 100644 templates/target-status.hamlet diff --git a/Application.hs b/Application.hs index 43c2343..16a8946 100644 --- a/Application.hs +++ b/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 diff --git a/Foundation.hs b/Foundation.hs index 88d29f5..aeb4bc9 100644 --- a/Foundation.hs +++ b/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 diff --git a/Handler/Dashboard.hs b/Handler/Dashboard.hs new file mode 100644 index 0000000..d1cac4a --- /dev/null +++ b/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) diff --git a/config/models b/config/models index ae57f1f..e3fb505 100644 --- a/config/models +++ b/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) diff --git a/config/routes b/config/routes index 81193bc..51e8f23 100644 --- a/config/routes +++ b/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 diff --git a/gonito.cabal b/gonito.cabal index cedcc40..5e06365 100644 --- a/gonito.cabal +++ b/gonito.cabal @@ -52,6 +52,7 @@ library Handler.AchievementUtils Handler.ExtraPoints Handler.Runner + Handler.Dashboard if flag(dev) || flag(library-only) cpp-options: -DDEVELOPMENT diff --git a/messages/en.msg b/messages/en.msg index 751021a..f3947d5 100644 --- a/messages/en.msg +++ b/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 diff --git a/templates/dashboard.hamlet b/templates/dashboard.hamlet new file mode 100644 index 0000000..1065d4b --- /dev/null +++ b/templates/dashboard.hamlet @@ -0,0 +1,13 @@ +

Dashboard + +^{Table.buildBootstrap (indicatorTable mUser) indicatorEntries} + +
+ +$if (checkIfAdmin mUser) +

Create a new target + +
+ ^{formWidget} +