-- SPDX-FileCopyrightText: 2022-24 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros ,Steffen Jost -- -- 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| |] semicolonCell :: IsDBTable m a => DBCell m a semicolonCell = 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 -- not to be confused with i18nCell 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 -- to be used with icons directly, for results of `icon`, use either `wgtCell` or `iconFixedCell` 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) -- | Show Text if it is small, create modal otherwise modalCellLarge :: (IsDBTable m a, ToWidget UniWorX t, MonoFoldable t, Element t ~ Char) => t -> DBCell m a modalCellLarge content | length content > 32 = modalCell content | otherwise = stringCell 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 $ formatTimeW SelFormatTime t dateTimeCell :: IsDBTable m a => UTCTime -> DBCell m a dateTimeCell t = cell $ formatTimeW SelFormatDateTime t dateCell :: IsDBTable m a => UTCTime -> DBCell m a dateCell t = cell $ formatTimeW SelFormatDate t dayCell :: IsDBTable m a => Day -> DBCell m a dayCell utctDay = cell $ formatTimeW SelFormatDate UTCTime{..} 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; link is only displayed if the user has sufficient rights 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 modalAccess nWdgt nWdgt False $ toLink uuid in cell lWdgt -- | like `cellHasUserModal` but but always display link without prior access rights checks cellHasUserModalAdmin :: (IsDBTable m c, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m c cellHasUserModalAdmin 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 -- | like `cellHasUserModal` but with fixed route and showing an edit icon instead; link is only displayed if the user has sufficient rights cellEditUserModal :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c cellEditUserModal user = let userEntity = user ^. hasEntityUser uid = userEntity ^. _entityKey nWdgt = toWidget $ icon IconUserEdit lWdgt = do uuid <- liftHandler $ encrypt uid modalAccess mempty nWdgt True $ ForProfileR uuid in cell lWdgt -- | like `cellEditUserModal` but always displays the link without prior access rights checks cellEditUserModalAdmin :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c cellEditUserModalAdmin user = let userEntity = user ^. hasEntityUser uid = userEntity ^. _entityKey nWdgt = toWidget $ icon IconUserEdit lWdgt = do uuid <- liftHandler $ encrypt uid modal nWdgt (Left $ SomeRoute $ ForProfileR 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) => Bool -> u -> DBCell m a cellHasMatrikelnummerLinked isAdmin usr | Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey if isAdmin then modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid) else modalAccess mempty (text2widget matNr) False (AdminAvsUserR uuid) | otherwise = mempty where usrEntity = usr ^. hasEntityUser cellHasMatrikelnummerLinkedAdmin :: (IsDBTable m a, HasEntity u User) => u -> DBCell m a cellHasMatrikelnummerLinkedAdmin 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)} |] -- also see Handler.Utils.Widgets.companyWidget companyCell :: IsDBTable m a => CompanyShorthand -> CompanyName -> Bool -> DBCell m a companyCell csh cname isSupervisor = anchorCell curl name where curl = FirmUsersR csh corg = ciOriginal cname name | isSupervisor = text2markup (corg <> " ") <> icon IconSupervisor | otherwise = text2markup corg companyIdCell :: IsDBTable m a => CompanyId -> DBCell m a companyIdCell cid = companyCell csh csh False where csh = unCompanyKey cid 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 qualificationValidIconCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Day -> Maybe b -> a -> DBCell m c qualificationValidIconCell d qb qu = do blockIcon $ isValidQualification d qu qb where blockIcon = cell . toWidget . iconQualificationBlock qualificationValidUntilCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Day -> Maybe b -> a -> DBCell m c qualificationValidUntilCell = qualificationValidUntilCell' (Just LmsUserAllR) qualificationValidUntilCell' :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Maybe (CryptoUUIDUser -> Route UniWorX) -> Day -> Maybe b -> a -> DBCell m c qualificationValidUntilCell' mbToLink d qb qu = cell $ case mbToLink of Nothing -> headWgt <> dateWgt Just toLink -> do uuid <- liftHandler $ encrypt $ qu ^. hasQualificationUser . _qualificationUserUser let modalWgt = modalAccess dateWgt dateWgt False $ toLink uuid headWgt <> modalWgt where dateWgt = formatTimeW SelFormatDate (qu ^. hasQualificationUser . _qualificationUserValidUntil) iconWgt = toWidget $ iconQualificationBlock $ isValidQualification d qu qb headWgt = iconWgt <> [whamlet| |] qualificationValidReasonCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Bool -> Day -> Maybe b -> a -> DBCell m c qualificationValidReasonCell = qualificationValidReasonCell' (Just LmsUserAllR) qualificationValidReasonCell' :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Maybe (CryptoUUIDUser -> Route UniWorX) -> Bool -> Day -> Maybe b -> a -> DBCell m c qualificationValidReasonCell' mbToLink showReason d qb qu = ic <> foldMap blc qb where ic = cell . toWidget . iconQualificationBlock $ isValidQualification d qu qb blc (view hasQualificationUserBlock -> QualificationUserBlock{..}) | showReason = spacerCell <> dc qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason | qualificationUserBlockUnblock = mempty | otherwise = spacerCell <> dateCell qualificationUserBlockFrom dc tstamp | Just toLink <- mbToLink = cell $ do uuid <- liftHandler $ encrypt uid let dWgt = formatTimeW SelFormatDate tstamp modalAccess dWgt dWgt False $ toLink uuid -- anchorCellM (toLink <$> encrypt uid) | otherwise = dateCell tstamp uid = qu ^. hasQualificationUser . _qualificationUserUser qualificationValidReasonCell'' :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Maybe (CryptoUUIDUser -> Route UniWorX) -> Bool -> Day -> Maybe b -> a -> Bool -> DBCell m c qualificationValidReasonCell'' mbToLink showReason d qb qu extValid = ic <> icErr <> foldMap blc qb where quValid = isValidQualification d qu qb icErr = cell . toWidget . isBad $ quValid /= extValid ic = cell . toWidget $ iconQualificationBlock quValid blc (view hasQualificationUserBlock -> QualificationUserBlock{..}) | showReason = spacerCell <> dc qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason | qualificationUserBlockUnblock = mempty | otherwise = spacerCell <> dateCell qualificationUserBlockFrom dc tstamp | Just toLink <- mbToLink = cell $ do uuid <- liftHandler $ encrypt uid let dWgt = formatTimeW SelFormatDate tstamp modalAccess dWgt dWgt False $ toLink uuid -- anchorCellM (toLink <$> encrypt uid) | otherwise = dateCell tstamp uid = qu ^. hasQualificationUser . _qualificationUserUser 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 mkLink = wgtCell . lmsUserStatusWidget extendedInfo mkLink lmsStateCell :: IsDBTable m a => LmsState -> DBCell m a lmsStateCell LmsFailed = iconBoolCell False lmsStateCell LmsOpen = iconSpacerCell lmsStateCell LmsPassed = iconBoolCell True 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 let nWgt = toWgt $ toMessage $ a ^. _userAvsNoPerson modalAccess nWgt nWgt False $ AdminAvsUserR uuid avsPersonNoLinkedCellAdmin :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c avsPersonNoLinkedCellAdmin a = cell $ do uuid <- liftHandler $ encrypt $ a ^. _userAvsUser let nWgt = toWgt $ toMessage $ a ^. _userAvsNoPerson modal nWgt (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