module Handler.Dashboard where import Import import Data.Time.LocalTime import Handler.Shared import Handler.Common (checkIfAdmin) import Handler.Tables import Data.SubmissionConditions (parseCondition, checkCondition, VariantEntry(..)) import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs) import qualified Yesod.Table as Table import qualified Data.Text as T import qualified Data.Map as M import Handler.Tables (timestampCell) import GEval.Core (isBetter) import GEval.EvaluationScheme import Text.Blaze import qualified Database.Esqueleto as E import Database.Esqueleto ((^.)) data IndicatorEntry = IndicatorEntry { indicatorEntryIndicator :: Entity Indicator, indicatorEntryTest :: Entity Test, indicatorEntryChallenge :: Entity Challenge, indicatorEntryFilterCondition :: Maybe Text, indicatorEntryTargetCondition :: Maybe Text, indicatorEntryTargets :: [Entity Target] } data TargetStatus = TargetPassed | TargetFailed | TargetOngoing deriving (Eq, Show) isOngoingStatus :: TargetStatus -> Bool isOngoingStatus TargetPassed = False isOngoingStatus TargetFailed = False isOngoingStatus TargetOngoing = True 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, mName, filterCondition, targetCondition, deadlineDay, deadlineTime, value) -> do targetId <- runDB $ insert $ Indicator testId filterCondition targetCondition _ <- runDB $ insert $ Target targetId (UTCTime { utctDay = deadlineDay, utctDayTime = timeOfDayToTime deadlineTime }) value mName 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 :: (Text.Blaze.ToMarkup a1, ToWidget App a2) => Maybe (Entity User) -> Key Indicator -> a2 -> a1 -> HandlerT App IO Html doEditIndicator mUser indicatorId formWidget formEnctype = do (addTargetformWidget, addTargetFormEnctype) <- generateFormPost addTargetForm indicator <- runDB $ get404 indicatorId indicatorEntry <- indicatorToEntry (Entity indicatorId indicator) let mPrecision = testPrecision $ entityVal $ indicatorEntryTest indicatorEntry 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 (mName, deadlineDay, deadlineTime, value) -> do _ <- insert $ Target indicatorId (UTCTime { utctDay = deadlineDay, utctDayTime = timeOfDayToTime deadlineTime }) value mName 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 :: (Text.Blaze.ToMarkup a1, ToWidget App a2) => Maybe (Entity User) -> a2 -> a1 -> HandlerFor App Html doDashboard mUser formWidget formEnctype = do indicators <- runDB $ selectList [] [Asc IndicatorId] indicatorEntries <- mapM indicatorToEntry indicators let indicatorJSs = getIndicatorChartJss indicatorEntries defaultLayout $ do setTitle "Dashboard" $(widgetFile "dashboard") getIndicatorChartJss :: [IndicatorEntry] -> JavascriptUrl (Route App) getIndicatorChartJss entries = mconcat $ map (getIndicatorChartJs . entityKey . indicatorEntryIndicator) entries getIndicatorChartJs :: IndicatorId -> JavascriptUrl (Route App) getIndicatorChartJs indicatorId = [julius| $.getJSON("@{IndicatorGraphDataR indicatorId}", function(data) { c3.generate(data) }); |] 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, Maybe Text, Day, TimeOfDay, Double) targetForm = renderBootstrap3 BootstrapBasicForm $ (,,,,,,) <$> testSelectFieldList Nothing <*> aopt textField (bfs MsgTargetName) 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 (Maybe Text, Day, TimeOfDay, Double) addTargetForm = renderBootstrap3 BootstrapBasicForm $ (,,,) <$> aopt textField (bfs MsgTargetName) Nothing <*> 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) -> Maybe Int -> Table.Table App (Entity Target) targetTable mUser mPrecision = mempty ++ Table.text "target name" ((fromMaybe T.empty) . targetName . entityVal) ++ Table.text "target value" (formatScore mPrecision . targetValue . entityVal) ++ timestampCell "deadline" (targetDeadline . entityVal) ++ targetStatusCell mUser prettyIndicatorEntry :: IndicatorEntry -> Text prettyIndicatorEntry entry = prettyTestTitle (entityVal $ indicatorEntryTest entry) (entityVal $ indicatorEntryChallenge entry) filterEntries :: Maybe Text -> [TableEntry] -> [TableEntry] filterEntries Nothing = id filterEntries (Just condition) = filter (\entry -> checkCondition conditionParsed (toVariantEntry entry)) where conditionParsed = parseCondition condition toVariantEntry :: TableEntry -> VariantEntry toVariantEntry entry = VariantEntry { variantEntryTags = map (entityVal . fst) $ tableEntryTagsInfo entry, variantEntryParams = map entityVal $ tableEntryParams entry } getTargetStatus :: UTCTime -> [TableEntry] -> IndicatorEntry -> Entity Target -> TargetStatus getTargetStatus theNow entries indicator target = if null entries' then if theNow > (targetDeadline $ entityVal target) then TargetFailed else TargetOngoing else TargetPassed where entries' = filter (\v -> isBetter (evaluationSchemeMetric $ testMetric $ entityVal $ indicatorEntryTest indicator) v (targetValue $ entityVal target)) $ catMaybes $ map evaluationScore $ catMaybes $ map (\e -> (tableEntryMapping e) M.!? testId) $ filter (\e -> (submissionStamp $ entityVal $ tableEntrySubmission e) < theNow) $ filterEntries (indicatorEntryTargetCondition indicator) entries testId = getTestReference $ indicatorEntryTest indicator getOngoingTargets :: ChallengeId -> Handler [IndicatorEntry] getOngoingTargets challengeId = do indicators <- runDB $ E.select $ E.from $ \(test, indicator) -> do E.where_ (test ^. TestChallenge E.==. E.val challengeId E.&&. indicator ^. IndicatorTest E.==. test ^. TestId) return indicator indicatorEntries <- mapM indicatorToEntry indicators theNow <- liftIO $ getCurrentTime (entries, _) <- runDB $ getChallengeSubmissionInfos 1 (const True) (const True) id challengeId let indicatorEntries' = map (onlyWithOngoingTargets theNow entries) indicatorEntries return indicatorEntries' onlyWithOngoingTargets :: UTCTime -> [TableEntry] -> IndicatorEntry -> IndicatorEntry onlyWithOngoingTargets theNow entries indicatorEntry = indicatorEntry { indicatorEntryTargets = filter (\t -> isOngoingStatus (getTargetStatus theNow entries indicatorEntry t)) (indicatorEntryTargets indicatorEntry) } formatTargets :: IndicatorEntry -> Text formatTargets entry = T.intercalate ", " $ (map (formatTarget (testPrecision $ entityVal $ indicatorEntryTest entry))) $ indicatorEntryTargets entry formatTarget :: Maybe Int -> Entity Target -> Text formatTarget mPrecision (Entity _ target) = (case targetName target of Just name -> name <> " " Nothing -> T.empty) <> (formatScore mPrecision (targetValue target)) <> " (" <> (T.pack $ formatTime defaultTimeLocale "%Y-%m-%d %H:%M" $ 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)