411 lines
16 KiB
Haskell
411 lines
16 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
|
--
|
|
-- 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
|
|
<div>
|
|
^{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
|
|
<ul .list--iconless .list--inline .list--comma-separated>
|
|
$forall c <- validColors
|
|
<li>
|
|
_{c}
|
|
|]
|
|
where
|
|
validCards = Set.filter avsDataValid cards
|
|
validColors = Set.toDescList $ Set.map avsDataCardColor validCards |