gonito/Handler/Dashboard.hs

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)