360 lines
14 KiB
Haskell
360 lines
14 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-25 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Handler.Utils.Widgets where
|
|
|
|
import Import
|
|
import qualified Data.Text as T
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import Text.Hamlet (shamletFile)
|
|
|
|
import Handler.Utils.DateTime
|
|
|
|
import qualified Data.Char as Char
|
|
import qualified Data.HashMap.Strict as Aeson -- ON UPDATE replace with: import qualified Data.Aeson.KeyMap as Aeson
|
|
import Data.Scientific
|
|
|
|
---------
|
|
-- Simple utilities for consistent display
|
|
-- Please use these throughout, to ensure that users have a consistent experience
|
|
|
|
tidFromText :: Text -> Maybe TermId
|
|
tidFromText = fmap TermKey . maybeRight . termFromText
|
|
|
|
-- | Display given UTCTime and maybe an invisible icon if it is in the future
|
|
--
|
|
-- Also see `Handler.Utils.Table.Cells.dateTimeCellVisible` for a similar function (in case of refactoring)
|
|
visibleUTCTime :: SelDateTimeFormat -> UTCTime -> Widget
|
|
visibleUTCTime dtf t = do
|
|
let timeStampWgt = formatTimeW dtf t
|
|
now <- liftIO getCurrentTime
|
|
if now >= t
|
|
then timeStampWgt
|
|
else $(widgetFile "widgets/date-time/yet-invisible")
|
|
|
|
|
|
-- | Simple link to a known route
|
|
simpleLink :: HasRoute UniWorX url => Widget -> url -> Widget
|
|
simpleLink lbl url = do
|
|
let route = urlRoute url
|
|
isAuth <- liftHandler . $cachedHereBinary route $ hasReadAccessTo route
|
|
if | isAuth -> do
|
|
tUrl <- toTextUrl url
|
|
[whamlet|
|
|
$newline never
|
|
<a href=#{tUrl}>
|
|
^{lbl}
|
|
|]
|
|
| otherwise -> lbl
|
|
|
|
simpleLinkI :: (RenderMessage UniWorX msg, HasRoute UniWorX url) => msg -> url -> Widget
|
|
simpleLinkI = simpleLink . i18n
|
|
|
|
-- | toWidget-Version of @nameHtml@, for convenience
|
|
nameWidget :: Text -- ^ userDisplayName
|
|
-> Text -- ^ userSurname
|
|
-> Widget
|
|
nameWidget displayName surname = toWidget $ nameHtml displayName surname
|
|
|
|
userWidget :: HasUser c => c -> Widget
|
|
userWidget x = nameWidget (x ^. _userDisplayName) (x ^._userSurname)
|
|
|
|
userIdWidget :: UserId -> Widget
|
|
userIdWidget uid = maybeM (msg2widget MsgUserUnknown) userWidget (liftHandler $ runDBRead $ get uid)
|
|
|
|
linkUserWidget :: HasRoute UniWorX url => (CryptoUUIDUser -> url) -> Entity User -> Widget
|
|
linkUserWidget lnk (Entity uid usr) = do
|
|
uuid <- encrypt uid
|
|
simpleLink (userWidget usr) (lnk uuid)
|
|
|
|
-- | like linkUserWidget, but on Id only. Requires DB access, use with caution
|
|
linkUserIdWidget :: HasRoute UniWorX url => (CryptoUUIDUser -> url) -> UserId -> Widget
|
|
linkUserIdWidget lnk uid = maybeM (msg2widget MsgUserUnknown) (linkUserWidget lnk . Entity uid) (liftHandler $ runDBRead $ get uid)
|
|
|
|
userEmailWidget :: HasUser c => c -> Widget
|
|
userEmailWidget x = nameEmailWidget (x ^. _userDisplayEmail) (x ^. _userDisplayName) (x ^. _userSurname)
|
|
|
|
-- | toWidget-Version of @nameEmailHtml@, for convenience
|
|
nameEmailWidget :: UserEmail -- ^ userEmail
|
|
-> Text -- ^ userDisplayName
|
|
-> Text -- ^ userSurname
|
|
-> Widget
|
|
nameEmailWidget email displayName surname = toWidget $ nameEmailHtml email displayName surname
|
|
|
|
-- | uncurried Version for @nameEmailWidget@ needed in hamlet, where TH cannot be used
|
|
nameEmailWidget' :: (UserEmail, Text, Text)-> Widget
|
|
nameEmailWidget' = $(uncurryN 3) nameEmailWidget
|
|
|
|
-- | Show user's displayName, highlighting the surname if possible.
|
|
-- Otherwise appends the surname in parenthesis
|
|
nameHtml :: Text -> Text -> Html
|
|
nameHtml displayName surname
|
|
| null surname = toHtml displayName
|
|
| otherwise = case reverse $ T.splitOn surname displayName of
|
|
[_notContained]
|
|
| (suffix:prefixes) <- reverse $ T.splitOn (T.toTitle surname) (T.toTitle displayName), notNull prefixes ->
|
|
let prefix = T.intercalate surname $ reverse prefixes
|
|
in [shamlet|$newline never
|
|
#{prefix} #
|
|
<b .surname>#{surname}
|
|
#{withLeadingSpace suffix}
|
|
|]
|
|
| (suffix:prefixes) <- reverse $ T.splitOn (fullyNormalize surname) (fullyNormalize displayName), notNull prefixes ->
|
|
let prefix = T.intercalate surname $ reverse prefixes
|
|
in [shamlet|$newline never
|
|
#{prefix} #
|
|
<b .surname>#{surname}
|
|
#{withLeadingSpace suffix}
|
|
|]
|
|
| otherwise -> [shamlet|$newline never
|
|
#{displayName} (
|
|
<b .surname>#{surname}
|
|
)|]
|
|
(suffix:prefixes) ->
|
|
let prefix = T.intercalate surname $ reverse prefixes
|
|
in [shamlet|$newline never
|
|
#{prefix}
|
|
<b .surname>#{surname}
|
|
#{withLeadingSpace suffix}
|
|
|]
|
|
[] -> error "Data.Text.splitOn returned empty list in violation of specification."
|
|
where
|
|
fullyNormalize :: Text -> Text
|
|
fullyNormalize = T.toTitle . T.unwords . map text2asciiAlphaNum . T.words
|
|
|
|
withLeadingSpace :: Text -> Text
|
|
withLeadingSpace t
|
|
| T.null t = t
|
|
| Just (' ', _) <- T.uncons t = t
|
|
| otherwise = T.cons ' ' t
|
|
|
|
nameHtml' :: HasUser u => u -> Html
|
|
nameHtml' u = nameHtml (u ^. _userDisplayName) (u ^. _userSurname)
|
|
|
|
-- | Like nameHtml just show a users displayname with hightlighted surname,
|
|
-- but also wrap the name with a mailto-link
|
|
nameEmailHtml :: UserEmail -> Text -> Text -> Html
|
|
nameEmailHtml email displayName surname =
|
|
wrapMailto email $ nameHtml displayName surname
|
|
|
|
-- | Wrap mailto around given Html using single hamlet-file for consistency
|
|
wrapMailto :: UserEmail -> Html -> Html
|
|
wrapMailto (CI.original -> email) linkText
|
|
| null email = linkText
|
|
| otherwise = $(shamletFile "templates/widgets/link-email.hamlet")
|
|
|
|
-- | Just show an email address in a standard way, for convenience inside hamlet files.
|
|
mailtoHtml :: UserEmail -> Html
|
|
mailtoHtml email = wrapMailto email $(shamletFile "templates/widgets/email.hamlet")
|
|
|
|
-- | Generic i18n text for "edited at sometime by someone"
|
|
editedByW :: SelDateTimeFormat -> UTCTime -> Text -> Widget
|
|
editedByW fmt tm usr = do
|
|
ft <- handlerToWidget $ formatTime fmt tm
|
|
[whamlet|_{MsgUtilEditedBy usr ft}|]
|
|
|
|
|
|
-- | like `modal`, but only conditionally displays the modal link only after checking access rights. WARNING: this might be too slow for large dbTable. Use `modalAccessCheckOnClick` instead
|
|
modalAccess :: Widget -> Widget -> Bool -> Route UniWorX -> Widget
|
|
modalAccess wdgtNo wdgtYes writeAccess route = do
|
|
authOk <- liftHandler . $cachedHereBinary (route, writeAccess) $ bool hasReadAccessTo hasWriteAccessTo writeAccess route
|
|
if authOk
|
|
then modal wdgtYes (Left $ SomeRoute route)
|
|
else wdgtNo
|
|
|
|
-- also see Handler.Utils.Table.Cells.companyCell
|
|
companyWidget :: Bool -> (CompanyShorthand, CompanyName, Bool) -> Widget
|
|
companyWidget = companyWidget' False
|
|
|
|
companyWidget' :: Bool -> Bool -> (CompanyShorthand, CompanyName, Bool) -> Widget
|
|
companyWidget' useShort isPrimary (csh, cname, isSupervisor)
|
|
| isPrimary, isSupervisor = simpleLink (toWgt $ name <> iconSupervisor) curl
|
|
| isPrimary = simpleLink (toWgt name ) curl
|
|
| isSupervisor = toWgt name <> simpleLink (toWgt iconSupervisor) curl
|
|
| otherwise = toWgt name
|
|
where
|
|
curl = FirmUsersR csh
|
|
corg = ciOriginal $ bool cname csh useShort
|
|
name
|
|
| isSupervisor = text2markup (corg <> " ")
|
|
| otherwise = text2markup corg
|
|
|
|
widgetMailPrefPin :: HasUser u => u -> Widget
|
|
widgetMailPrefPin usr = if not prefPost && hasPin
|
|
then [whamlet|^{modWgt} ^{pinWgt}|]
|
|
else modWgt
|
|
where
|
|
prefPost :: Bool = usr ^. _userPrefersPostal
|
|
hasPin :: Bool = isJust (usr ^. _userPinPassword)
|
|
modWgt :: Widget = toWidget $ iconLetterOrEmail prefPost
|
|
pinWgt :: Widget = toWidget iconPinProtect
|
|
|
|
---------------------
|
|
-- Status Tooltips --
|
|
---------------------
|
|
|
|
-- | generate a generic colored icon to display success or failure to user
|
|
mkErrorFlag :: Handler (Maybe Bool -> Widget)
|
|
mkErrorFlag = do
|
|
-- we abuse messageTooltip for colored icons here
|
|
msgSuccessTooltip <- messageI Success MsgMessageSuccess
|
|
msgWarningTooltip <- messageI Warning MsgMessageWarning
|
|
msgErrorTooltip <- messageI Error MsgMessageError
|
|
let flagError Nothing = messageTooltip msgWarningTooltip
|
|
flagError (Just False) = messageTooltip msgErrorTooltip
|
|
flagError (Just True) = messageTooltip msgSuccessTooltip
|
|
return flagError
|
|
|
|
|
|
----------
|
|
-- HEAT --
|
|
----------
|
|
|
|
|
|
boolHeat :: Bool -- ^ @isHot@
|
|
-> Milli
|
|
boolHeat = bool 0 1
|
|
|
|
heat :: ( Real a, Real b )
|
|
=> a -> b -> Milli
|
|
-- ^ Distinguishes @full@, zero is mapped to 1, @full@ is mapped to 0
|
|
heat (realToFrac -> full) (realToFrac -> achieved)
|
|
= fromRational $ cutOffCoPercent 0.3 (full^2) (achieved^2)
|
|
|
|
invHeat :: ( Real a, Real b )
|
|
=> a -> b -> Milli
|
|
-- ^ Distinguishes @full@, zero is mapped to 0, @full@ is mapped to 1
|
|
invHeat full achieved = 1 - heat full achieved
|
|
|
|
coHeat :: ( Real a, Real b)
|
|
=> a -> b -> Milli
|
|
-- ^ Distinguishes zero, zero is mapped to 1, @full@ is mapped to 0
|
|
coHeat full achieved = 1 - invCoHeat full achieved
|
|
|
|
invCoHeat :: ( Real a, Real b)
|
|
=> a -> b -> Milli
|
|
-- ^ Distinguishes zero, zero is mapped to 0, @full@ is mapped to 1
|
|
invCoHeat (realToFrac -> full) (realToFrac -> achieved)
|
|
= fromRational $ cutOffPercent 0.3 (full^2) (achieved^2)
|
|
|
|
dualHeat :: ( Real a, Real b, Real c )
|
|
=> a -> b -> c -> Milli
|
|
-- ^ Distinguishes zero, zero is mapped to 0, @optimal@ is mapped to 1, @full@ is mapped to 2
|
|
--
|
|
-- Falls back to `invCoHeat` if @full <= optimal@
|
|
dualHeat (realToFrac -> optimal) (realToFrac -> full) (realToFrac -> achieved)
|
|
| full <= optimal = 2 * invCoHeat full achieved
|
|
| achieved <= optimal = invCoHeat optimal achieved
|
|
| otherwise = fromRational $ 1 + cutOffPercent 0 ((full - optimal) ^ 2) ((achieved - optimal) ^ 2)
|
|
|
|
dualCoHeat :: ( Real a, Real b, Real c )
|
|
=> a -> b -> c -> Milli
|
|
-- ^ Distinguishes @full@, zero is mapped to 0, @optimal@ is mapped to 1, @full@ is mapped to 2
|
|
--
|
|
-- Falls back to `invHeat` if @full <= optimal@
|
|
dualCoHeat (realToFrac -> optimal) (realToFrac -> full) (realToFrac -> achieved)
|
|
| full <= optimal = 2 * invHeat full achieved
|
|
| achieved <= optimal = fromRational $ cutOffPercent 0 (optimal ^ 2) (achieved ^ 2)
|
|
| otherwise = 1 + invHeat (full - optimal) (achieved - optimal)
|
|
|
|
invDualHeat :: ( Real a, Real b, Real c )
|
|
=> a -> b -> c -> Milli
|
|
-- ^ Distinguishes zero, zero is mapped to 2, @optimal@ is mapped to 1, @full@ is mapped to 0
|
|
invDualHeat optimal full achieved = 2 - dualHeat optimal full achieved
|
|
|
|
invDualCoHeat :: ( Real a, Real b, Real c )
|
|
=> a -> b -> c -> Milli
|
|
-- ^ Distinguishes @full@, zero is mapped to 2, @optimal@ is mapped to 1, @full@ is mapped to 0
|
|
invDualCoHeat optimal full achieved = 2 - dualCoHeat optimal full achieved
|
|
|
|
|
|
-----------
|
|
-- COLOR --
|
|
-----------
|
|
|
|
-- TODO: someone with frontend capabilities should get rid of class tooltip__handle and check theme consistent colors
|
|
|
|
statusHtml :: MessageStatus -> Html -> Html
|
|
statusHtml sts wgt =
|
|
[shamlet|
|
|
<span .tooltip__handle .#{statusToUrgencyClass sts}>
|
|
^{wgt}
|
|
|]
|
|
|
|
statusWidget :: MessageStatus -> Widget -> Widget
|
|
statusWidget sts wgt =
|
|
[whamlet|
|
|
<span .tooltip__handle .#{statusToUrgencyClass sts}>
|
|
^{wgt}
|
|
|]
|
|
|
|
heatedWidget :: Milli -> Widget -> Widget
|
|
heatedWidget ht wgt =
|
|
[whamlet|
|
|
<span .heated style="--hotness: #{ht}">
|
|
^{wgt}
|
|
|]
|
|
|
|
|
|
examOccurrenceMappingDescriptionWidget :: ExamOccurrenceRule -> Set ExamOccurrenceMappingDescription -> Widget
|
|
examOccurrenceMappingDescriptionWidget rule descriptions = $(widgetFile "widgets/exam-occurrence-mapping-description")
|
|
where
|
|
titleCase :: [CI Char] -> String
|
|
titleCase = over _head Char.toUpper . map CI.foldedCase
|
|
doPrefix
|
|
| ExamRoomMatriculation <- rule
|
|
= False
|
|
| otherwise
|
|
= True
|
|
|
|
|
|
roomReferenceWidget :: RoomReference -> Widget
|
|
roomReferenceWidget RoomReferenceSimple{..} = msg2widget $ MsgRoomReferenceSimpleAt roomRefText
|
|
roomReferenceWidget RoomReferenceLink{..} = $(widgetFile "widgets/room-reference/link")
|
|
where
|
|
linkText = uriToString id roomRefLink mempty
|
|
instrModal = modal (i18n MsgRoomReferenceLinkInstructions) $ Right $(widgetFile "widgets/room-reference/link-instructions-modal")
|
|
|
|
roomReferenceShortWidget :: RoomReference -> Widget
|
|
roomReferenceShortWidget RoomReferenceSimple{..} = text2widget roomRefText
|
|
roomReferenceShortWidget RoomReferenceLink{..} = $(widgetFile "widgets/room-reference/link")
|
|
where
|
|
linkText = uriToString id roomRefLink mempty
|
|
instrModal = modal (i18n MsgRoomReferenceLinkInstructions) $ Right $(widgetFile "widgets/room-reference/link-instructions-modal")
|
|
|
|
|
|
----------
|
|
-- JSON --
|
|
----------
|
|
|
|
-- Data.Aeson.Encode.Pretty.encodePretty did not render in Html properly, hence jsonWidget
|
|
jsonWidget :: ToJSON a => a -> Widget
|
|
jsonWidget x = jsonWidgetAux $ toJSON x
|
|
where
|
|
jsonWidgetAux :: Value -> Widget
|
|
jsonWidgetAux Null = [whamlet|Null|]
|
|
jsonWidgetAux (Bool b) = toWidget $ boolSymbol b
|
|
jsonWidgetAux (String s) = [whamlet|#{s}|]
|
|
jsonWidgetAux (Number n)
|
|
| isInteger n = [whamlet|#{formatScientific Fixed (Just 0) n}|]
|
|
| otherwise = [whamlet|#{formatScientific Generic Nothing n}|]
|
|
jsonWidgetAux (Array l)
|
|
| 1 >= length l = foldMap jsonWidgetAux l -- empty arrays don't show
|
|
| otherwise =
|
|
[whamlet|
|
|
<ul>
|
|
$forall x <- sort l
|
|
<li>^{jsonWidgetAux x}
|
|
|]
|
|
jsonWidgetAux (Object o) = case Aeson.toList o of -- toAscList not supported
|
|
[ ] -> mempty -- empty objects don't show
|
|
[(_,v)] -> jsonWidgetAux v
|
|
r -> [whamlet|
|
|
<dl .deflist>
|
|
$forall (k,v) <- sort r
|
|
<dt .deflist__dt>#{k}
|
|
<dd .deflist__dd>^{jsonWidgetAux v}
|
|
|]
|