-- SPDX-FileCopyrightText: 2022 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros -- -- SPDX-License-Identifier: AGPL-3.0-or-later module Handler.Utils.Table.Cells where import Import hiding (link) import Text.Blaze (ToMarkup(..)) import Handler.Utils.Table.Pagination import Handler.Utils.DateTime import Handler.Utils.Widgets import Handler.Utils.Occurrences import Handler.Utils.LMS (lmsUserStatusWidget) type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles ! ---------------- -- Some basic cells are defined in Handler.Utils.Table.Pagination -- such as: i18nCell, cellTooltip, anchorCell for links, etc. ---------------- -- Special cells -- | Display a breakable space spacerCell :: IsDBTable m a => DBCell m a spacerCell = cell [whamlet| |] tellCell :: IsDBTable m a => a -> DBCell m a -> DBCell m a tellCell = flip mappend . writerCell . tell cellTell :: IsDBTable m a => DBCell m a -> a -> DBCell m a cellTell = flip tellCell indicatorCell :: IsDBTable m Any => DBCell m Any -- For dbTables that return a Bool to indicate content indicatorCell = writerCell . tell $ Any True writerCell :: IsDBTable m w => WriterT w m () -> DBCell m w writerCell act = mempty & cellContents %~ (<* act) -- for documentation purposes cellMaybe :: IsDBTable m b => (a -> DBCell m b) -> Maybe a -> DBCell m b cellMaybe = foldMap maybeCell :: IsDBTable m b => Maybe a -> (a -> DBCell m b) -> DBCell m b maybeCell = flip foldMap htmlCell :: (IsDBTable m a, ToMarkup c) => c -> DBCell m a htmlCell = cell . toWidget . toMarkup pathPieceCell :: (IsDBTable m a, PathPiece p) => p -> DBCell m a pathPieceCell = cell . toWidget . toPathPiece -- | execute a DB action that return a widget for the cell contents sqlCell :: (IsDBTable (YesodDB UniWorX) a) => YesodDB UniWorX Widget -> DBCell (YesodDB UniWorX) a sqlCell act = mempty & cellContents .~ lift act -- TODO: Formulate variant of sqlCell that types for tables having actions, i.e. MForm istead of YesodDB? -- sqlCell' :: (IsDBTable (MForm Handler) a) => _ -> DBCell (MForm Handler) a -- sqlCell' = flip (set' cellContents) mempty -- | Highlight table cells with warning: Is not yet implemented in frontend. markCell :: IsDBTable m a => MessageStatus -> (t -> Bool) -> (t -> DBCell m a) -> (t -> DBCell m a) markCell status condition normal x | condition x = normal x & addCellClass (statusToUrgencyClass status) | otherwise = normal x ifCell :: (t -> Bool) -> (t -> DBCell m a) -> (t -> DBCell m a) -> (t -> DBCell m a) ifCell decision cTrue cFalse x | decision x = cTrue x | otherwise = cFalse x linkEmptyCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a linkEmptyCell = anchorCell msgCell :: (ToMessage t, IsDBTable m a) => t -> DBCell m a msgCell = textCell . toMessage guardAuthCell :: (IsDBTable m a, MonadAP m, MonadThrow m) => m (Route UniWorX, Bool) -- ^ @(route, isWrite)@ -> DBCell m a -> DBCell m a guardAuthCell mkParams = over cellContents $ \act -> do (route, isWrite) <- lift mkParams ifM (fmap (is _Authorized) . lift $ evalAccess route isWrite) act (return mempty) -- Recall: for line numbers, use dbRow --------------------- -- Icon cells iconCell :: IsDBTable m a => Icon -> DBCell m a iconCell = cell . toWidget . icon ifIconCell :: IsDBTable m a => Bool -> Icon -> DBCell m a ifIconCell True = iconCell ifIconCell False = const iconSpacerCell addIconFixedWidth :: IsDBTable m a => DBCell m a -> DBCell m a addIconFixedWidth = addCellClass ("icon-fixed-width" :: Text) -- | Can be used directly with type Markup as delivered by most functions from Utils.Icon iconFixedCell :: (IsDBTable m a, ToWidget UniWorX wgt) => wgt -> DBCell m a iconFixedCell = addIconFixedWidth . cell . toWidget iconSpacerCell :: IsDBTable m a => DBCell m a iconSpacerCell = mempty & addIconFixedWidth -- | Maybe display a tickmark/checkmark icon tickmarkCell :: IsDBTable m a => Bool -> DBCell m a tickmarkCell = cell . toWidget . hasTickmark -- | Maybe display an icon for tainted rows isBadCell :: IsDBTable m a => Bool -> DBCell m a isBadCell = cell . toWidget . isBad -- | Maybe display a exclamation icon isNewCell :: IsDBTable m a => Bool -> DBCell m a isNewCell = cell . toWidget . isNew -- | Maybe display comment icon linking a given URL or show nothing at all commentCell :: IsDBTable m a => Maybe (Route UniWorX) -> DBCell m a commentCell Nothing = mempty commentCell (Just link) = anchorCell link $ hasComment True -- | whether something is visible or hidden isVisibleCell :: IsDBTable m a => Bool -> DBCell m a isVisibleCell True = cell . toWidget $ isVisible True isVisibleCell False = (cell . toWidget $ isVisible False) & addUrgencyClass where addUrgencyClass = addCellClass $ statusToUrgencyClass Warning -- | for simple file downloads fileCell :: IsDBTable m a => (Route UniWorX, [(Text, Text)]) -> DBCell m a fileCell route = anchorCell route iconFileDownload -- | for zip-archive downloads zipCell :: IsDBTable m a => (Route UniWorX, [(Text, Text)]) -> DBCell m a zipCell route = anchorCell route iconFileZip -- | for csv downloads csvCell :: IsDBTable m a => Route UniWorX -> DBCell m a csvCell route = anchorCell route iconFileCSV -- | Display an icon that opens a modal upon clicking modalCell :: (IsDBTable m a, ToWidget UniWorX w) => w -> DBCell m a modalCell content = cell $ modal (toWidget $ hasComment True) (Right $ toWidget content) markupCellLargeModal :: IsDBTable m a => StoredMarkup -> DBCell m a markupCellLargeModal mup | markupIsSmallish mup = cell $ toWidget mup | otherwise = modalCell mup ----------------- -- Datatype cells timeCell :: IsDBTable m a => UTCTime -> DBCell m a timeCell t = cell $ formatTime SelFormatTime t >>= toWidget dateTimeCell :: IsDBTable m a => UTCTime -> DBCell m a dateTimeCell t = cell $ formatTime SelFormatDateTime t >>= toWidget dateCell :: IsDBTable m a => UTCTime -> DBCell m a dateCell t = cell $ formatTime SelFormatDate t >>= toWidget dayCell :: IsDBTable m a => Day -> DBCell m a dayCell utctDay = cell $ formatTime SelFormatDate UTCTime{..} >>= toWidget where utctDayTime = 0 -- | Show a date, and highlight date earlier than given watershed with an icon and cell class Warning -- -- Cannot use `Handler.Utils.visibleUTCTime`, since setting the UrgencyClass must be done outside the monad, hence the watershed argument. dateTimeCellVisible :: IsDBTable m a => UTCTime -> UTCTime -> DBCell m a dateTimeCellVisible watershed t | watershed < t = cell $(widgetFile "widgets/date-time/yet-invisible") & addUrgencyClass | otherwise = cell timeStampWgt where timeStampWgt = formatTimeW SelFormatDateTime t addUrgencyClass = addCellClass $ statusToUrgencyClass Warning userCell :: IsDBTable m a => Text -> Text -> DBCell m a userCell displayName surname = cell $ nameWidget displayName surname {- Recall: userCell' :: IsDBTable m a => User -> DBCell m a userCell' = cellHasUser -} emailCell :: IsDBTable m a => CI Text -> DBCell m a emailCell email = cell $(widgetFile "widgets/link-email") where linkText= toWgt email cellHasUser :: (IsDBTable m c, HasUser a) => a -> DBCell m c cellHasUser = liftA2 userCell (view _userDisplayName) (view _userSurname) cellHasUserLink :: (IsDBTable m c, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m c -- cellHasUserLink toLink user = -- let uid = user ^. hasEntityUser . _entityKey -- nWdgt = nameWidget (user ^. hasEntityUser . _entityVal . _userDisplayName) (user ^. hasEntityUser . _entityVal . _userSurname) -- in anchorCellM (toLink <$> encrypt uid) nWdgt cellHasUserLink toLink user = let userEntity = user ^. hasEntityUser uid = userEntity ^. _entityKey nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname) in anchorCellM (toLink <$> encrypt uid) nWdgt -- | like `cellHasUserLink` but opens the user in a modal instead cellHasUserModal :: (IsDBTable m c, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m c cellHasUserModal toLink user = let userEntity = user ^. hasEntityUser uid = userEntity ^. _entityKey nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname) lWdgt = do uuid <- liftHandler $ encrypt uid modal nWdgt (Left $ SomeRoute $ toLink uuid) in cell lWdgt cellHasMatrikelnummer :: (IsDBTable m a, HasUser u) => u -> DBCell m a cellHasMatrikelnummer = maybe mempty textCell . view _userMatrikelnummer cellHasEMail :: (IsDBTable m a, HasUser u) => u -> DBCell m a cellHasEMail = emailCell . view _userDisplayEmail cellHasSemester :: (IsDBTable m c, HasStudyFeatures a) => a -> DBCell m c cellHasSemester = numCell . view _studyFeaturesSemester cellHasField :: (IsDBTable m c, HasStudyTerms a) => a -> DBCell m c cellHasField x = maybe (numCell $ x ^. _studyTermsKey) textCell $ x ^. _studyTermsName <|> x ^. _studyTermsShorthand cellHasDegreeShort :: (IsDBTable m c, HasStudyDegree a) => a -> DBCell m c cellHasDegreeShort x = maybe (numCell $ x ^. _studyDegreeKey) textCell $ x ^. _studyDegreeShorthand <|> x ^. _studyDegreeName -- Just for documentation purposes; inline this code instead: maybeDateTimeCell :: IsDBTable m a => Maybe UTCTime -> DBCell m a maybeDateTimeCell = maybe mempty dateTimeCell numCell :: (IsDBTable m a, ToMessage b) => b -> DBCell m a numCell = textCell . toMessage propCell :: (IsDBTable m a, Real b, ToMessage b) => b -> b -> DBCell m a propCell curr max' | max' /= 0 = i18nCell $ MsgTableProportion (toMessage curr) (toMessage max') (toRational curr / toRational max') | otherwise = i18nCell $ MsgTableProportionNoRatio (toMessage curr) (toMessage max') int64Cell :: IsDBTable m a => Int64-> DBCell m a int64Cell = numCell termCell :: IsDBTable m a => TermId -> DBCell m a termCell tid = anchorCell link name where link = TermCourseListR tid name = toWgt tid termCellCL :: IsDBTable m a => CourseLink -> DBCell m a termCellCL (tid,_,_) = termCell tid schoolCell :: IsDBTable m a => TermId -> SchoolId -> DBCell m a schoolCell tid ssh = anchorCell link name where link = TermSchoolCourseListR tid ssh name = toWgt ssh schoolCellCL :: IsDBTable m a => CourseLink -> DBCell m a schoolCellCL (tid,ssh,_) = schoolCell tid ssh courseCellCL :: IsDBTable m a => CourseLink -> DBCell m a courseCellCL (tid,ssh,csh) = anchorCell link name where link = CourseR tid ssh csh CShowR name = toWgt csh courseCell :: IsDBTable m a => Course -> DBCell m a courseCell Course{..} = anchorCell link name `mappend` desc where link = CourseR courseTerm courseSchool courseShorthand CShowR name = citext2widget courseName desc = case courseDescription of Nothing -> mempty (Just descr) -> cell [whamlet| $newline never
^{modal "Beschreibung" (Right $ toWidget descr)} |] qualificationCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c qualificationCell (view hasQualification -> Qualification{..}) = anchorCell link name where link = QualificationR qualificationSchool qualificationShorthand name = citext2widget qualificationName qualificationShortCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c qualificationShortCell (view hasQualification -> Qualification{..}) = anchorCell link name where link = QualificationR qualificationSchool qualificationShorthand name = citext2widget qualificationShorthand qualificationDescrCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c qualificationDescrCell (view hasQualification -> q@Qualification{..}) = qualificationCell q <> desc where desc = case qualificationDescription of Nothing -> mempty (Just descr) -> spacerCell <> markupCellLargeModal descr lmsShortCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c lmsShortCell (view hasQualification -> Qualification{..}) = anchorCell link name where link = LmsR qualificationSchool qualificationShorthand name = citext2widget qualificationShorthand sheetCell :: IsDBTable m a => CourseLink -> SheetName -> DBCell m a sheetCell crse shn = let tid = crse ^. _1 ssh = crse ^. _2 csh = crse ^. _3 link = CSheetR tid ssh csh shn SShowR in anchorCell link $ toWgt shn submissionCell :: IsDBTable m a => CourseLink -> SheetName -> SubmissionId -> DBCell m a submissionCell crse shn sid = let tid = crse ^. _1 ssh = crse ^. _2 csh = crse ^. _3 mkCid = encrypt sid mkRoute cid = CSubmissionR tid ssh csh shn cid SubShowR mkText = toWgt in anchorCellM' mkCid mkRoute mkText correctorStateCell :: IsDBTable m a => SheetCorrector -> DBCell m a correctorStateCell sc = i18nCell $ sheetCorrectorState sc correctorLoadCell :: IsDBTable m a => SheetCorrector -> DBCell m a correctorLoadCell sc = i18nCell $ sheetCorrectorLoad sc occurrencesCell :: IsDBTable m a => Occurrences -> DBCell m a occurrencesCell = cell . occurrencesWidget roomReferenceCell :: IsDBTable m a => RoomReference -> DBCell m a roomReferenceCell = cell . roomReferenceWidget cryptoidCell :: (IsDBTable m a, PathPiece cid) => cid -> DBCell m a cryptoidCell = addCellClass ("cryptoid" :: Text) . textCell . toPathPiece lmsStatusCell :: IsDBTable m a => LmsStatus -> DBCell m a lmsStatusCell ls = iconCell ic <> spacerCell <> dayCell (lmsStatusDay ls) where ic | isLmsSuccess ls = IconOK | otherwise = IconNotOK lmsStatusPlusCell :: IsDBTable m a => LmsUser -> DBCell m a lmsStatusPlusCell LmsUser{lmsUserStatus=Just lStat} = lmsStatusCell lStat lmsStatusPlusCell LmsUser{lmsUserStarted} = iconCell IconWaitingForUser <> spacerCell <> dateCell lmsUserStarted lmsStatusPlusCell' :: IsDBTable m a => Maybe (CryptoUUIDUser -> Route UniWorX) -> LmsUser -> DBCell m a lmsStatusPlusCell' Nothing lu = wgtCell $ lmsUserStatusWidget lu lmsStatusPlusCell' (Just toLink) lu = cell $ do uuid <- liftHandler $ encrypt $ lu ^. _lmsUserUser modal (lmsUserStatusWidget lu) (Left $ SomeRoute $ toLink uuid) qualificationBlockedCellNoReason :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a qualificationBlockedCellNoReason Nothing = mempty qualificationBlockedCellNoReason (Just QualificationBlocked{qualificationBlockedDay=d}) = iconCell IconBlocked <> spacerCell <> dayCell d qualificationBlockedCell :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a qualificationBlockedCell Nothing = mempty qualificationBlockedCell (Just QualificationBlocked{..}) | 12 >= length qualificationBlockedReason = mkCellWith textCell | otherwise = mkCellWith modalCell where mkCellWith c = c qualificationBlockedReason <> spacerCell <> iconCell IconBlocked <> spacerCell <> dayCell qualificationBlockedDay avsPersonNoCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c avsPersonNoCell = numCell . view _userAvsNoPerson