-- 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 qualified Data.Set as Set import Handler.Utils.Table.Pagination import Handler.Utils.DateTime import Handler.Utils.Widgets import Handler.Utils.Occurrences import Handler.Utils.LMS (lmsUserStatusWidget) import Handler.Utils.Qualification (isValidQualification) 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 iconBoolCell :: IsDBTable m a => Bool -> DBCell m a iconBoolCell = cell . toWidget . boolSymbol 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 cellHasMatrikelnummerLinked :: (IsDBTable m a, HasEntity u User) => u -> DBCell m a cellHasMatrikelnummerLinked usr | Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid) | otherwise = mempty where usrEntity = usr ^. hasEntityUser 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 qualificationValidUntilCell :: (IsDBTable m c, HasQualification a, HasQualificationUser a) => a -> DBCell m c qualificationValidUntilCell q = textCell (qsh <> ": ") <> dayCell vtd where qsh = q ^. hasQualification . _qualificationShorthand . _CI vtd = q ^. hasQualificationUser . _qualificationUserValidUntil qualificationValidIconCell :: (IsDBTable m c, HasQualificationUser a) => Day -> a -> DBCell m c qualificationValidIconCell = (iconBoolCell .) . isValidQualification 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 => Bool -> Maybe (CryptoUUIDUser -> Route UniWorX) -> LmsUser -> DBCell m a lmsStatusCell extendedInfo Nothing lu = wgtCell $ lmsUserStatusWidget extendedInfo lu lmsStatusCell extendedInfo (Just toLink) lu = cell $ do uuid <- liftHandler $ encrypt $ lu ^. _lmsUserUser modal (lmsUserStatusWidget extendedInfo 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{..}) | 32 >= 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 avsPersonNoLinkedCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c avsPersonNoLinkedCell a = cell $ do uuid <- liftHandler $ encrypt $ a ^. _userAvsUser modal (toWgt $ toMessage $ a ^. _userAvsNoPerson) (Left $ SomeRoute $ AdminAvsUserR uuid) avsPersonCardCell :: (IsDBTable m c) => Set AvsDataPersonCard -> DBCell m c avsPersonCardCell cards = wgtCell [whamlet| $newline never
    $forall c <- validColors
  • _{c} |] where validCards = Set.filter avsDataValid cards validColors = Set.toDescList $ Set.map avsDataCardColor validCards