301 lines
13 KiB
Haskell
301 lines
13 KiB
Haskell
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)
|