From bc675006d8c72a2994be832236036447ebe1efc1 Mon Sep 17 00:00:00 2001 From: Felix Hamann Date: Sun, 21 Jul 2019 00:18:49 +0200 Subject: [PATCH 01/12] feat(alert-icons): add custom icons for alerts --- frontend/src/utils/alerts/alert-icons.js | 16 ++++++++++++++++ frontend/src/utils/alerts/alerts.js | 14 ++++++++++++++ frontend/src/utils/alerts/alerts.scss | 8 ++++---- templates/widgets/alerts/alerts.hamlet | 5 +++++ 4 files changed, 39 insertions(+), 4 deletions(-) create mode 100644 frontend/src/utils/alerts/alert-icons.js diff --git a/frontend/src/utils/alerts/alert-icons.js b/frontend/src/utils/alerts/alert-icons.js new file mode 100644 index 000000000..85fe1d3aa --- /dev/null +++ b/frontend/src/utils/alerts/alert-icons.js @@ -0,0 +1,16 @@ +// +// Fontawesome icons to be used on alerts. +// +// If you want to add new icons stick to the format of the existing ones. +// They are necessary due to weird unicode conversions during transpilation. +// https://fontawesome.com/icons + +export const ALERT_ICONS = { + info: '"\\f05a"', + checkmark: '"\\f058"', + exclamation: '"\\f06a"', + warning: '"\\f071"', + cross: '"\\f00d"', + registered: '"\\f274"', + deregistered: '"\\f273"', +}; diff --git a/frontend/src/utils/alerts/alerts.js b/frontend/src/utils/alerts/alerts.js index e7e04ddbb..4d1a1cf7a 100644 --- a/frontend/src/utils/alerts/alerts.js +++ b/frontend/src/utils/alerts/alerts.js @@ -1,5 +1,6 @@ import { Utility } from '../../core/utility'; import './alerts.scss'; +import { ALERT_ICONS } from './alert-icons'; const ALERTS_INITIALIZED_CLASS = 'alerts--initialized'; const ALERTS_ELEVATED_CLASS = 'alerts--elevated'; @@ -16,6 +17,12 @@ const ALERT_INVISIBLE_CLASS = 'alert--invisible'; const ALERT_AUTO_HIDE_DELAY = 10; const ALERT_AUTOCLOSING_MATCHER = '.alert-info, .alert-success'; +/* + * Dataset-Inputs: + * - decay (data-decay): Custom time (in seconds) for this alert to stay visible + * - icon (data-icon): Custom icon (from the list in alert-icons.js) to show on the alert + */ + @Utility({ selector: '[uw-alerts]', }) @@ -87,6 +94,13 @@ export class Alerts { this._toggleAlert(alertElement); }); + const customIcon = alertElement.dataset.icon; + if (customIcon && ALERT_ICONS[customIcon]) { + alertElement.style.setProperty('--alert-icon', ALERT_ICONS[customIcon]); + } else if (customIcon) { + throw new Error('Alert: Custom icon "' + customIcon + '" could not be found!'); + } + if (autoHideDelay > 0 && alertElement.matches(ALERT_AUTOCLOSING_MATCHER)) { window.setTimeout(() => this._toggleAlert(alertElement), autoHideDelay * 1000); } diff --git a/frontend/src/utils/alerts/alerts.scss b/frontend/src/utils/alerts/alerts.scss index d2faf1b22..8beff3b70 100644 --- a/frontend/src/utils/alerts/alerts.scss +++ b/frontend/src/utils/alerts/alerts.scss @@ -124,7 +124,7 @@ z-index: 40; &::before { - content: '\f05a'; + content: var(--alert-icon, var(--alert-icon-default, '\f05a')); position: absolute; font-family: 'Font Awesome 5 Free'; font-size: 24px; @@ -189,7 +189,7 @@ background-color: var(--color-success); .alert__icon::before { - content: '\f058'; + --alert-icon-default: '\f058'; } } @@ -197,7 +197,7 @@ background-color: var(--color-warning); .alert__icon::before { - content: '\f06a'; + --alert-icon-default: '\f06a'; } } @@ -205,6 +205,6 @@ background-color: var(--color-error); .alert__icon::before { - content: '\f071'; + --alert-icon-default: '\f071'; } } diff --git a/templates/widgets/alerts/alerts.hamlet b/templates/widgets/alerts/alerts.hamlet index 4527e62d3..8ddc0f6cd 100644 --- a/templates/widgets/alerts/alerts.hamlet +++ b/templates/widgets/alerts/alerts.hamlet @@ -3,6 +3,11 @@ $newline never
$forall (status, msg) <- mmsgs $with status2 <- bool status "info" (status == "") +
From f2963cff0765073b2be0cff84a3cd21c6f5e5db9 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 24 Jul 2019 15:02:12 +0200 Subject: [PATCH 02/12] refactor(icons): only allow semantic icons from now on --- src/Utils/Icon.hs | 182 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 182 insertions(+) create mode 100644 src/Utils/Icon.hs diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs new file mode 100644 index 000000000..865bba69f --- /dev/null +++ b/src/Utils/Icon.hs @@ -0,0 +1,182 @@ +module Utils.Icon where + +-- | A @Widget@ for any site; no language interpolation, etc. +type WidgetSiteless = forall site. forall m. (MonadIO m, MonadThrow m, MonadBaseControl IO m) + => WidgetT site m () + +import Data.Universe +import Utils.PathPiece +import Text.Hamlet + + +----------- +-- Icons -- +----------- +-- We collect all used icons here for an overview. +-- For consistency, some conditional icons are also provided, having suffix True/False +-- IMPORTANT: Alert-Icons must be registered in alert-icons.js as well + +data Icon + = IconNew + | IconOK + | IconNotOK + | IconWarning + | IconProblem + | IconVisible + | IconNotVisible + | IconCourse + | IconEnrolTrue + | IconEnrolFalse + | IconExam + | IconExamRegisterTrue + | IconExamRegisterFalse + | IconCommentTrue + | IconCommentFalse + | IconFileDownload + | IconFileZip + | IconFileCSV + | IconSFTQuestion -- for SheetFileType only + | IconSFTHint -- for SheetFileType only + | IconSFTSolution -- for SheetFileType only + | IconSFTMarking -- for SheetFileType only + deriving (Eq, Enum, Bounded, Show, Read) + +iconText :: Icon -> Text +iconText = \case + IconNew -> "seedling" + IconOK -> "check" + IconNotOK -> "times" + IconWarning -> "exclamation" + IconProblem -> "bolt" + IconVisible -> "eye" + IconNotVisible -> "eye-slash" + IconCourse -> "graduation-cap" + IconEnrolTrue -> "user-plus" + IconEnrolFalse -> "user-slash" + IconExam -> "file-invoice" + IconExamRegisterTrue -> "calendar-check" + IconExamRegisterFalse -> "calendar-times" + IconCommentTrue -> "comment-alt" + IconCommentFalse -> "comment-slash" + IconFileDownload -> "file-download" + IconFileZip -> "file-archive" + IconFileCSV -> "file-csv" + IconSFTQuestion -> "question-circle" -- for SheetFileType only, should all be round (similar) + IconSFTHint -> "life-ring" -- for SheetFileType only + IconSFTSolution -> "exclamation-circle" -- for SheetFileType only + IconSFTMarking -> "check-circle" -- for SheetFileType only + +instance Universe Icon +instance Finte Icon +nullaryPathPiece ''Icon $ camelToPathPiece' 1 + +-- Create an icon from font-awesome without additional space +icon :: Icon -> Markup +icon iconName = + [shamlet|$newline never + |] + + +-- for compatibility and convenience +iconShortcuts :: Q [Dec] +iconShortcuts = forM universeF + (\ic -> + iname <- newName $ 'i' : (drop 1 $ show ic) + valD (varP iname) (normalB [|icon iname|]) + ) + +iconQuestion :: Markup +iconQuestion = icon IconQuestion + +iconNew :: Markup +iconNew = icon IconNew + +iconOK :: Markup +iconOK = icon IconOK + +iconNotOK :: Markup +iconNotOK = icon IconNotOK + +iconWarning :: Markup +iconWarning = icon IconWarning + +iconProblem :: Markup +iconProblem = icon IconProblem + +iconHint :: Markup +iconHint = icon + +-- Icons for Course +iconCourse :: Markup +iconCourse = fontAwesomeIcon "graduation-cap" + +iconExam :: Markup +iconExam = fontAwesomeIcon "file-invoice" + +iconEnrol :: Bool -> Markup +iconEnrol True = fontAwesomeIcon "user-plus" +iconEnrol False = fontAwesomeIcon "user-slash" + +iconExamRegister :: Bool -> Markup +iconExamRegister True = fontAwesomeIcon "calendar-check" +iconExamRegister False = fontAwesomeIcon "calendar-times" + + +-- Icons for SheetFileType +iconSolution :: Markup +iconSolution =fontAwesomeIcon "exclamation-circle" + +iconMarking :: Markup +iconMarking = fontAwesomeIcon "check-circle" + +fileDownload :: Markup +fileDownload = fontAwesomeIcon "file-download" + +zipDownload :: Markup +zipDownload = fontAwesomeIcon "file-archive" + +iconCSV :: Markup +iconCSV = fontAwesomeIcon "file-csv" + + +-- Generic Conditional icons + +isVisible :: Bool -> Markup +-- ^ Display an icon that denotes that something™ is visible or invisible +isVisible True = fontAwesomeIcon "eye" +isVisible False = fontAwesomeIcon "eye-slash" +-- +-- For documentation on how to avoid these unneccessary functions +-- we implement them here just once for the first icon: +-- +isVisibleWidget :: Bool -> WidgetSiteless +-- ^ Widget having an icon that denotes that something™ is visible or invisible +isVisibleWidget = toWidget . isVisible + +maybeIsVisibleWidget :: Maybe Bool -> WidgetSiteless +-- ^ Maybe a widget with an icon that denotes that something™ is visible or invisible +maybeIsVisibleWidget = toWidget . foldMap isVisible + +-- Other _frequently_ used icons: +hasComment :: Bool -> Markup +-- ^ Display an icon that denotes that something™ has a comment or not +hasComment True = fontAwesomeIcon "comment-alt" +hasComment False = fontAwesomeIcon "comment-slash" -- comment-alt-slash is not available for free + +hasTickmark :: Bool -> Markup +-- ^ Display an icon that denotes that something™ is okay +hasTickmark True = iconOK +hasTickmark False = mempty + +isBad :: Bool -> Markup +-- ^ Display an icon that denotes that something™ is bad +isBad True = iconProblem +isBad False = mempty + +isNew :: Bool -> Markup +isNew True = iconNew +isNew False = mempty + +boolSymbol :: Bool -> Markup +boolSymbol True = iconOK +boolSymbol False = iconNotOK From 495fdd18dd2579b652b6caf93629e5be5d3b2974 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 24 Jul 2019 15:03:35 +0200 Subject: [PATCH 03/12] refactor(icons): only allow semantics icons from now on --- src/Handler/Utils/Table/Cells.hs | 15 ++- src/Handler/Utils/Table/Pagination.hs | 2 +- src/Language/Haskell/TH/Instances.hs | 12 +- src/Model/Types/Sheet.hs | 8 +- src/Utils.hs | 120 +----------------- src/Utils/Icon.hs | 170 +++++++++++--------------- src/Utils/Message.hs | 1 + templates/exam-show.hamlet | 8 +- 8 files changed, 105 insertions(+), 231 deletions(-) diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 948febc54..2620ee83f 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -122,8 +122,7 @@ 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 icon - where icon = hasComment True +commentCell (Just link) = anchorCell link $ hasComment True -- | whether something is visible or hidden isVisibleCell :: (IsDBTable m a) => Bool -> DBCell m a @@ -134,11 +133,15 @@ isVisibleCell False = (cell . toWidget $ isVisible False) & addUrgencyClass -- | for simple file downloads fileCell :: IsDBTable m a => Route UniWorX -> DBCell m a -fileCell route = anchorCell route fileDownload +fileCell route = anchorCell route iconFileDownload -- | for zip-archive downloads zipCell :: IsDBTable m a => Route UniWorX -> DBCell m a -zipCell route = anchorCell route zipDownload +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 @@ -197,11 +200,11 @@ cellHasEMail = emailCell . view _userEmail 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 diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 4f6676899..ad436a996 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -285,7 +285,7 @@ instance Button UniWorX ButtonCsvMode where btnLabel BtnCsvExport = [whamlet| $newline never - #{iconCSV} + #{iconFileCSV} \ _{BtnCsvExport} |] btnLabel BtnCsvImport diff --git a/src/Language/Haskell/TH/Instances.hs b/src/Language/Haskell/TH/Instances.hs index 48c419705..d4730efe6 100644 --- a/src/Language/Haskell/TH/Instances.hs +++ b/src/Language/Haskell/TH/Instances.hs @@ -7,8 +7,18 @@ module Language.Haskell.TH.Instances import Language.Haskell.TH import Language.Haskell.TH.Lift (deriveLift) import Data.Binary (Binary) - +import Data.Semigroup +import Data.Monoid () +import Control.Applicative instance Binary Loc deriveLift ''Loc + + +instance Semigroup (Q [Dec]) where + (<>) = liftA2 (<>) + +instance Monoid (Q [Dec]) where + mempty = pure mempty + mappend = (<>) diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs index 4a6c60a32..2f6e43200 100644 --- a/src/Model/Types/Sheet.hs +++ b/src/Model/Types/Sheet.hs @@ -171,10 +171,10 @@ instance PathPiece SheetFileType where fromPathPiece = finiteFromPathPiece sheetFile2markup :: SheetFileType -> Markup -sheetFile2markup SheetExercise = iconQuestion -sheetFile2markup SheetHint = iconHint -sheetFile2markup SheetSolution = iconSolution -sheetFile2markup SheetMarking = iconMarking +sheetFile2markup SheetExercise = iconSFTQuestion +sheetFile2markup SheetHint = iconSFTHint +sheetFile2markup SheetSolution = iconSFTSolution +sheetFile2markup SheetMarking = iconSFTMarking -- partitionFileType' :: Ord a => [(SheetFileType,a)] -> Map SheetFileType (Set a) -- partitionFileType' = groupMap diff --git a/src/Utils.hs b/src/Utils.hs index 7fbe88857..11db44ba0 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -23,6 +23,7 @@ import Utils.TH as Utils import Utils.DateTime as Utils import Utils.PathPiece as Utils import Utils.Route as Utils +import Utils.Icon as Utils import Utils.Message as Utils import Utils.Lang as Utils import Utils.Parameters as Utils @@ -79,9 +80,10 @@ import Algebra.Lattice (top, bottom, (/\), (\/), BoundedJoinSemiLattice, Bounded import Data.Constraint (Dict(..)) -{-# ANN choice ("HLint: ignore Use asum" :: String) #-} +{- # ANN choice ("HLint: ignore Use asum" :: String) # -} +$(iconShortcuts) -- declares constants for all known icons ----------- -- Yesod -- @@ -114,122 +116,6 @@ unsupportedAuthPredicate = do --- | A @Widget@ for any site; no language interpolation, etc. -type WidgetSiteless = forall site. forall m. (MonadIO m, MonadThrow m, MonadBaseControl IO m) - => WidgetT site m () - - ------------ --- Icons -- ------------ - --- Create an icon from font-awesome without additional space -fontAwesomeIcon :: Text -> Markup -fontAwesomeIcon iconName = - [shamlet|$newline never - |] - --- We collect all used icons here for an overview. --- For consistency, some conditional icons are also provided, e.g. `isIvisble` - -iconQuestion :: Markup -iconQuestion = fontAwesomeIcon "question-circle" - -iconNew :: Markup -iconNew = fontAwesomeIcon "seedling" - -iconOK :: Markup -iconOK = fontAwesomeIcon "check" - -iconNotOK :: Markup -iconNotOK = fontAwesomeIcon "times" - -iconWarning :: Markup -iconWarning = fontAwesomeIcon "exclamation" - -iconProblem :: Markup -iconProblem = fontAwesomeIcon "bolt" - -iconHint :: Markup -iconHint = fontAwesomeIcon "life-ring" - --- Icons for Course -iconCourse :: Markup -iconCourse = fontAwesomeIcon "graduation-cap" - -iconExam :: Markup -iconExam = fontAwesomeIcon "file-invoice" - -iconEnrol :: Bool -> Markup -iconEnrol True = fontAwesomeIcon "user-plus" -iconEnrol False = fontAwesomeIcon "user-slash" - -iconExamRegister :: Bool -> Markup -iconExamRegister True = fontAwesomeIcon "calendar-check" -iconExamRegister False = fontAwesomeIcon "calendar-times" - - --- Icons for SheetFileType -iconSolution :: Markup -iconSolution =fontAwesomeIcon "exclamation-circle" - -iconMarking :: Markup -iconMarking = fontAwesomeIcon "check-circle" - -fileDownload :: Markup -fileDownload = fontAwesomeIcon "file-download" - -zipDownload :: Markup -zipDownload = fontAwesomeIcon "file-archive" - -iconCSV :: Markup -iconCSV = fontAwesomeIcon "file-csv" - - --- Generic Conditional icons - -isVisible :: Bool -> Markup --- ^ Display an icon that denotes that something™ is visible or invisible -isVisible True = fontAwesomeIcon "eye" -isVisible False = fontAwesomeIcon "eye-slash" --- --- For documentation on how to avoid these unneccessary functions --- we implement them here just once for the first icon: --- -isVisibleWidget :: Bool -> WidgetSiteless --- ^ Widget having an icon that denotes that something™ is visible or invisible -isVisibleWidget = toWidget . isVisible - -maybeIsVisibleWidget :: Maybe Bool -> WidgetSiteless --- ^ Maybe a widget with an icon that denotes that something™ is visible or invisible -maybeIsVisibleWidget = toWidget . foldMap isVisible - --- Other _frequently_ used icons: -hasComment :: Bool -> Markup --- ^ Display an icon that denotes that something™ has a comment or not -hasComment True = fontAwesomeIcon "comment-alt" -hasComment False = fontAwesomeIcon "comment-slash" -- comment-alt-slash is not available for free - -hasTickmark :: Bool -> Markup --- ^ Display an icon that denotes that something™ is okay -hasTickmark True = iconOK -hasTickmark False = mempty - -isBad :: Bool -> Markup --- ^ Display an icon that denotes that something™ is bad -isBad True = iconProblem -isBad False = mempty - -isNew :: Bool -> Markup -isNew True = iconNew -isNew False = mempty - -boolSymbol :: Bool -> Markup -boolSymbol True = iconOK -boolSymbol False = iconNotOK - - - --------------------- -- Text and String -- --------------------- diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 865bba69f..09299e310 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -1,13 +1,22 @@ module Utils.Icon where +import ClassyPrelude.Yesod hiding (foldlM, Proxy) + +import Data.Universe +import Data.Char +import Utils.PathPiece +-- import Text.Hamlet +import Text.Blaze (Markup) +import Control.Lens +import Language.Haskell.TH +import Language.Haskell.TH.Instances () +import Language.Haskell.TH.Lift (deriveLift) +import Instances.TH.Lift () + -- | A @Widget@ for any site; no language interpolation, etc. type WidgetSiteless = forall site. forall m. (MonadIO m, MonadThrow m, MonadBaseControl IO m) => WidgetT site m () -import Data.Universe -import Utils.PathPiece -import Text.Hamlet - ----------- -- Icons -- @@ -23,7 +32,7 @@ data Icon | IconWarning | IconProblem | IconVisible - | IconNotVisible + | IconInvisible | IconCourse | IconEnrolTrue | IconEnrolFalse @@ -49,7 +58,7 @@ iconText = \case IconWarning -> "exclamation" IconProblem -> "bolt" IconVisible -> "eye" - IconNotVisible -> "eye-slash" + IconInvisible -> "eye-slash" IconCourse -> "graduation-cap" IconEnrolTrue -> "user-plus" IconEnrolFalse -> "user-slash" @@ -57,7 +66,7 @@ iconText = \case IconExamRegisterTrue -> "calendar-check" IconExamRegisterFalse -> "calendar-times" IconCommentTrue -> "comment-alt" - IconCommentFalse -> "comment-slash" + IconCommentFalse -> "comment-slash" -- comment-alt-slash is not available for free IconFileDownload -> "file-download" IconFileZip -> "file-archive" IconFileCSV -> "file-csv" @@ -67,85 +76,74 @@ iconText = \case IconSFTMarking -> "check-circle" -- for SheetFileType only instance Universe Icon -instance Finte Icon +instance Finite Icon nullaryPathPiece ''Icon $ camelToPathPiece' 1 +deriveLift ''Icon -- Create an icon from font-awesome without additional space icon :: Icon -> Markup -icon iconName = +icon ic = let ict = iconText ic in [shamlet|$newline never - |] + |] - --- for compatibility and convenience +-- declare constats for all icons for compatibility and convenience +-- "IconCourse" generates "iconCourse = icon IconCourse" iconShortcuts :: Q [Dec] -iconShortcuts = forM universeF - (\ic -> - iname <- newName $ 'i' : (drop 1 $ show ic) - valD (varP iname) (normalB [|icon iname|]) - ) - -iconQuestion :: Markup -iconQuestion = icon IconQuestion - -iconNew :: Markup -iconNew = icon IconNew - -iconOK :: Markup -iconOK = icon IconOK - -iconNotOK :: Markup -iconNotOK = icon IconNotOK - -iconWarning :: Markup -iconWarning = icon IconWarning - -iconProblem :: Markup -iconProblem = icon IconProblem - -iconHint :: Markup -iconHint = icon - --- Icons for Course -iconCourse :: Markup -iconCourse = fontAwesomeIcon "graduation-cap" - -iconExam :: Markup -iconExam = fontAwesomeIcon "file-invoice" - -iconEnrol :: Bool -> Markup -iconEnrol True = fontAwesomeIcon "user-plus" -iconEnrol False = fontAwesomeIcon "user-slash" - -iconExamRegister :: Bool -> Markup -iconExamRegister True = fontAwesomeIcon "calendar-check" -iconExamRegister False = fontAwesomeIcon "calendar-times" +iconShortcuts = foldMap mkIcon (universeF :: [Icon]) + where + mkIcon :: Icon -> Q [Dec] + mkIcon ic = do + do + iname <- newName $ over (ix 0) Data.Char.toLower $ show ic + isig <- sigD iname [t|Markup|] + idef <- valD (varP iname) (normalB [|icon ic|]) [] + return $ [isig, idef] --- Icons for SheetFileType -iconSolution :: Markup -iconSolution =fontAwesomeIcon "exclamation-circle" - -iconMarking :: Markup -iconMarking = fontAwesomeIcon "check-circle" - -fileDownload :: Markup -fileDownload = fontAwesomeIcon "file-download" - -zipDownload :: Markup -zipDownload = fontAwesomeIcon "file-archive" - -iconCSV :: Markup -iconCSV = fontAwesomeIcon "file-csv" - - --- Generic Conditional icons +---------------------- +-- Conditional icons +-- +-- Some case are special, hence no Template Haskell here isVisible :: Bool -> Markup -- ^ Display an icon that denotes that something™ is visible or invisible -isVisible True = fontAwesomeIcon "eye" -isVisible False = fontAwesomeIcon "eye-slash" --- +isVisible True = icon IconVisible +isVisible False = icon IconInvisible + +hasComment :: Bool -> Markup +-- ^ Display an icon that denotes that something™ has a comment or not +hasComment True = icon IconCommentTrue +hasComment False = icon IconCommentFalse + +hasTickmark :: Bool -> Markup +-- ^ Maybe display an icon that denotes that something™ is okay +hasTickmark True = icon IconOK +hasTickmark False = mempty + +isBad :: Bool -> Markup +-- ^ Maybe display an icon that denotes that something™ is bad +isBad True = icon IconProblem +isBad False = mempty + +-- ^ Maybe display an icon that denotes that something™ is bad +isNew :: Bool -> Markup +isNew True = icon IconNew +isNew False = mempty + +boolSymbol :: Bool -> Markup +boolSymbol True = icon IconOK +boolSymbol False = icon IconNotOK + +iconEnrol :: Bool -> Markup +iconEnrol True = icon IconEnrolTrue +iconEnrol False = icon IconEnrolFalse + +iconExamRegister :: Bool -> Markup +iconExamRegister True = icon IconExamRegisterTrue +iconExamRegister False = icon IconExamRegisterTrue + + +---------------- -- For documentation on how to avoid these unneccessary functions -- we implement them here just once for the first icon: -- @@ -156,27 +154,3 @@ isVisibleWidget = toWidget . isVisible maybeIsVisibleWidget :: Maybe Bool -> WidgetSiteless -- ^ Maybe a widget with an icon that denotes that something™ is visible or invisible maybeIsVisibleWidget = toWidget . foldMap isVisible - --- Other _frequently_ used icons: -hasComment :: Bool -> Markup --- ^ Display an icon that denotes that something™ has a comment or not -hasComment True = fontAwesomeIcon "comment-alt" -hasComment False = fontAwesomeIcon "comment-slash" -- comment-alt-slash is not available for free - -hasTickmark :: Bool -> Markup --- ^ Display an icon that denotes that something™ is okay -hasTickmark True = iconOK -hasTickmark False = mempty - -isBad :: Bool -> Markup --- ^ Display an icon that denotes that something™ is bad -isBad True = iconProblem -isBad False = mempty - -isNew :: Bool -> Markup -isNew True = iconNew -isNew False = mempty - -boolSymbol :: Bool -> Markup -boolSymbol True = iconOK -boolSymbol False = iconNotOK diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs index 04dc41dcf..c4153b17d 100644 --- a/src/Utils/Message.hs +++ b/src/Utils/Message.hs @@ -47,6 +47,7 @@ instance Exception UnknownMessageStatus data Message = Message { messageStatus :: MessageStatus , messageContent :: Html + -- , messageIcon :: Maybe Icon } instance Eq Message where diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet index e7d2a777b..188b76453 100644 --- a/templates/exam-show.hamlet +++ b/templates/exam-show.hamlet @@ -24,7 +24,7 @@ $maybe Entity _ ExamResult{examResultResult} <- result $maybe desc <- examDescription
#{desc} - +
$if not examVisible @@ -84,7 +84,7 @@ $maybe desc <- examDescription $maybe registerWdgt <- registerWidget
_{MsgExamRegistration}
^{registerWdgt} - + $if not (null occurrences)
@@ -121,7 +121,7 @@ $if not (null occurrences) $if occurrenceAssignmentsShown $if registered - #{fontAwesomeIcon "check"} + #{iconOK} $if gradingShown && not (null parts)
@@ -148,7 +148,7 @@ $if gradingShown && not (null parts) $of Just (ExamAttended (Just ps)) #{showFixed True ps} $of Just (ExamAttended Nothing) - #{fontAwesomeIcon "check"} + #{iconOK} $of Just ExamNoShow _{MsgExamNoShow} $of Just ExamVoided From d70a9585f093c0701adf724ffe84cbaf3f1a592d Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 25 Jul 2019 00:19:09 +0200 Subject: [PATCH 04/12] feat(alerticons): allow alerts to have custom icons --- frontend/src/utils/alerts/alert-icons.js | 12 ++-- src/Foundation.hs | 9 +-- src/Handler/Admin.hs | 2 +- src/Handler/Exam.hs | 13 +--- src/Import/NoModel.hs | 6 +- src/Utils.hs | 6 +- src/Utils/Form.hs | 3 +- src/Utils/Icon.hs | 29 +++++--- src/Utils/Message.hs | 88 +++++++++++++++++++++--- templates/widgets/alerts/alerts.hamlet | 18 ++--- 10 files changed, 134 insertions(+), 52 deletions(-) diff --git a/frontend/src/utils/alerts/alert-icons.js b/frontend/src/utils/alerts/alert-icons.js index 85fe1d3aa..eb497d9bd 100644 --- a/frontend/src/utils/alerts/alert-icons.js +++ b/frontend/src/utils/alerts/alert-icons.js @@ -6,11 +6,15 @@ // https://fontawesome.com/icons export const ALERT_ICONS = { - info: '"\\f05a"', + calendarcheck: '"\\f274"', + calendartimes: '"\\f273"', checkmark: '"\\f058"', - exclamation: '"\\f06a"', - warning: '"\\f071"', cross: '"\\f00d"', - registered: '"\\f274"', deregistered: '"\\f273"', + exclamation: '"\\f06a"', + info: '"\\f05a"', + registered: '"\\f274"', + userplus: '"\\f234"', + userslash: '"\\f504"', + warning: '"\\f071"', }; diff --git a/src/Foundation.hs b/src/Foundation.hs index 8103ebfda..a2df4f68c 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -5,7 +5,7 @@ module Foundation where import Import.NoFoundation hiding (embedFile) -import qualified ClassyPrelude.Yesod as Yesod (addMessage, getHttpManager) +import qualified ClassyPrelude.Yesod as Yesod (getHttpManager) import Database.Persist.Sql (ConnectionPool, runSqlPool) import Text.Hamlet (hamletFile) @@ -1216,9 +1216,10 @@ instance Yesod UniWorX where , massInputShortcircuit ] - lift . bracketOnError getMessages (mapM_ $ uncurry Yesod.addMessage) $ \msgs -> do - Just msgs' <- return . forM msgs $ \(msgState, content) -> Message <$> fromPathPiece msgState <*> return content - addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict $ JSON.encode msgs' + lift . bracketOnError getMessages (mapM_ addMessage') $ \msgs -> do + -- @gkleen: the following line is redundant, but what does this block do anyway? + -- Just msgs' <- return . forM msgs $ \(msgState, content) -> Message <$> fromPathPiece msgState <*> return content + addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict $ JSON.encode msgs -- Since we implement `errorHandler` ourselves we don't need `defaultMessageWidget` defaultMessageWidget _title _body = error "defaultMessageWidget: undefined" diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index a2f4eafa3..7d02ee2e2 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -113,7 +113,7 @@ postAdminTestR = do formResultModal emailResult AdminTestR $ \(email, ls) -> do jId <- mapWriterT runDB $ do jId <- queueJob $ JobSendTestEmail email ls - tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] + tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] Nothing return jId writeJobCtl $ JobCtlPerform jId addMessage Warning [shamlet|Inkorrekt ausgegebener Alert|] -- For testing alert handling when short circuiting; for proper (not fallback-solution) handling always use `tell` within `formResultModal` diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index f649c0e75..dec5b8998 100644 --- a/src/Handler/Exam.hs +++ b/src/Handler/Exam.hs @@ -1048,21 +1048,14 @@ postERegisterR tid ssh csh examn = do now <- liftIO getCurrentTime insert_ $ ExamRegistration eId uid Nothing now audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent - addMessageWidget Success [whamlet| -
#{iconExamRegister True} -
  -
_{MsgExamRegisteredSuccess examn} - |] + addMessageIconI Success IconExamRegisterTrue (MsgExamRegisteredSuccess examn) redirect $ CExamR tid ssh csh examn EShowR BtnExamDeregister -> do runDB $ do deleteBy $ UniqueExamRegistration eId uid audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent - addMessageWidget Info [whamlet| -
#{iconExamRegister False} -
  -
_{MsgExamDeregisteredSuccess examn} - |] -- yes, it's a success message, but it should be visually different from a positive success, since most will just note the positive green color! See discussion on commit 5f4925a4 + addMessageIconI Info IconExamRegisterFalse (MsgExamDeregisteredSuccess examn) + -- yes, it's a success message, but it should be visually different from a positive success, since most will just note the positive green color! See discussion on commit 5f4925a4 redirect $ CExamR tid ssh csh examn EShowR invalidArgs ["Register/Deregister button required"] diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index cd1bd66c2..a8be4118c 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -3,7 +3,7 @@ module Import.NoModel , MForm ) where -import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, cons, HasHttpManager(..)) +import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, getMessages, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, cons, HasHttpManager(..)) import Model.Types.TH.JSON as Import import Model.Types.TH.Wordlist as Import @@ -53,7 +53,7 @@ import Data.Ratio as Import ((%)) import Net.IP as Import (IP) import Database.Persist.Sql as Import (SqlReadT, SqlWriteT, fromSqlKey, toSqlKey) - + import Ldap.Client.Pool as Import import System.Random as Import (Random(..)) @@ -70,7 +70,7 @@ import Data.Time.LocalTime as Import hiding (utcToLocalTime, localTimeToUTC) import Time.Types as Import (WeekDay(..)) import Network.Mime as Import - + import Data.Aeson.TH as Import import Data.Aeson.Types as Import (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), toJSONKeyText, FromJSONKeyFunction(..), ToJSONKeyFunction(..), Value) diff --git a/src/Utils.hs b/src/Utils.hs index 11db44ba0..62d957e78 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -80,7 +80,7 @@ import Algebra.Lattice (top, bottom, (/\), (\/), BoundedJoinSemiLattice, Bounded import Data.Constraint (Dict(..)) -{- # ANN choice ("HLint: ignore Use asum" :: String) # -} +{-# ANN module ("HLint: ignore Use asum" :: String) #-} $(iconShortcuts) -- declares constants for all known icons @@ -114,6 +114,10 @@ unsupportedAuthPredicate = do unauthorizedI (UnsupportedAuthPredicate (toPathPiece tag) route) |] +-- | allows conditional attributes in hamlet via *{..} syntax +maybeAttribute :: Text -> (a -> Text) -> Maybe a -> [(Text,Text)] +maybeAttribute _ _ Nothing = [] +maybeAttribute a c (Just v) = [(a,c v)] --------------------- diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index ecbf65f1a..a888efb29 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -742,13 +742,14 @@ wformMessage = void . aFormToWForm . aformMessage formMessage :: (MonadHandler m) => Message -> MForm m (FormResult (), FieldView site) formMessage Message{..} = do + let icn = maybeAttribute "data-icon" iconJS messageIcon return (FormSuccess (), FieldView { fvLabel = mempty , fvTooltip = Nothing , fvId = idFormMessageNoinput , fvErrors = Nothing , fvRequired = False - , fvInput = [whamlet|
#{messageContent}|] + , fvInput = [whamlet|
#{messageContent}|] }) --------------------- diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 09299e310..4d9dd168d 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -1,6 +1,6 @@ module Utils.Icon where -import ClassyPrelude.Yesod hiding (foldlM, Proxy) +import ClassyPrelude.Yesod hiding (Proxy) import Data.Universe import Data.Char @@ -12,6 +12,8 @@ import Language.Haskell.TH import Language.Haskell.TH.Instances () import Language.Haskell.TH.Lift (deriveLift) import Instances.TH.Lift () +import Data.Aeson +import Data.Aeson.TH -- | A @Widget@ for any site; no language interpolation, etc. type WidgetSiteless = forall site. forall m. (MonadIO m, MonadThrow m, MonadBaseControl IO m) @@ -23,8 +25,10 @@ type WidgetSiteless = forall site. forall m. (MonadIO m, MonadThrow m, MonadBase ----------- -- We collect all used icons here for an overview. -- For consistency, some conditional icons are also provided, having suffix True/False --- IMPORTANT: Alert-Icons must be registered in alert-icons.js as well +--------------------------------------------------------------------------- +-- IMPORTANT: Alert-Icons must be registered in alert-icons.js as well!!! +--------------------------------------------------------------------------- data Icon = IconNew | IconOK @@ -48,7 +52,7 @@ data Icon | IconSFTHint -- for SheetFileType only | IconSFTSolution -- for SheetFileType only | IconSFTMarking -- for SheetFileType only - deriving (Eq, Enum, Bounded, Show, Read) + deriving (Eq, Ord, Enum, Bounded, Show, Read) iconText :: Icon -> Text iconText = \case @@ -75,11 +79,19 @@ iconText = \case IconSFTSolution -> "exclamation-circle" -- for SheetFileType only IconSFTMarking -> "check-circle" -- for SheetFileType only +-- | like iconText, but eliminates '-' since these are problemativ in alert-icons.js +iconJS :: Icon -> Text +iconJS = filter ('-' /=) . iconText + instance Universe Icon instance Finite Icon nullaryPathPiece ''Icon $ camelToPathPiece' 1 deriveLift ''Icon +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + } ''Icon + -- Create an icon from font-awesome without additional space icon :: Icon -> Markup icon ic = let ict = iconText ic in @@ -93,11 +105,10 @@ iconShortcuts = foldMap mkIcon (universeF :: [Icon]) where mkIcon :: Icon -> Q [Dec] mkIcon ic = do - do - iname <- newName $ over (ix 0) Data.Char.toLower $ show ic - isig <- sigD iname [t|Markup|] - idef <- valD (varP iname) (normalB [|icon ic|]) [] - return $ [isig, idef] + iname <- newName $ over (ix 0) Data.Char.toLower $ show ic + isig <- sigD iname [t|Markup|] + idef <- valD (varP iname) (normalB [|icon ic|]) [] + return [isig, idef] ---------------------- @@ -140,7 +151,7 @@ iconEnrol False = icon IconEnrolFalse iconExamRegister :: Bool -> Markup iconExamRegister True = icon IconExamRegisterTrue -iconExamRegister False = icon IconExamRegisterTrue +iconExamRegister False = icon IconExamRegisterFalse ---------------- diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs index c4153b17d..4302dac79 100644 --- a/src/Utils/Message.hs +++ b/src/Utils/Message.hs @@ -1,19 +1,23 @@ module Utils.Message - ( MessageStatus(..) + ( MessageStatus(..), MessageIconStatus(..) , UnknownMessageStatus(..) + , getMessages + , addMessage',addMessageIcon, addMessageIconI -- messages with special icons (needs registering in alert-icons.js) , addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget , statusToUrgencyClass , Message(..) , messageI, messageIHamlet, messageFile, messageWidget + , encodeMessageIconStatus, decodeMessageIconStatus, decodeMessageIconStatus' ) where import Data.Universe +import Utils.Icon import Utils.PathPiece import Data.Aeson import Data.Aeson.TH -import qualified ClassyPrelude.Yesod (addMessage, addMessageI) -import ClassyPrelude.Yesod hiding (addMessage, addMessageI) +import qualified ClassyPrelude.Yesod (addMessage, addMessageI, getMessages) +import ClassyPrelude.Yesod hiding (addMessage, addMessageI, getMessages) import Text.Hamlet @@ -28,8 +32,11 @@ import Text.HTML.SanitizeXSS (sanitizeBalance) data MessageStatus = Error | Warning | Info | Success deriving (Eq, Ord, Enum, Bounded, Show, Read, Lift) + instance Universe MessageStatus instance Finite MessageStatus +instance Default MessageStatus where + def = Info deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece @@ -43,11 +50,52 @@ newtype UnknownMessageStatus = UnknownMessageStatus Text instance Exception UnknownMessageStatus +-- ms2mis :: MessageStatus -> MessageIconStatus +-- ms2mis s = def { misStatus= s} + +data MessageIconStatus = MIS { misStatus :: MessageStatus, misIcon :: Maybe Icon } + deriving (Eq, Ord, Show, Read, Lift) + +instance Default MessageIconStatus where + def = MIS { misStatus=def, misIcon=Nothing } + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''MessageIconStatus + +encodeMessageStatus :: MessageStatus -> Text +encodeMessageStatus ms = encodeMessageIconStatus $ def{ misStatus=ms } + +encodeMessageIconStatus :: MessageIconStatus -> Text +encodeMessageIconStatus = decodeUtf8 . toStrict . encode + +decodeMessageIconStatus :: Text -> Maybe MessageIconStatus +decodeMessageIconStatus = decode' . fromStrict . encodeUtf8 + +decodeMessageIconStatus' :: Text -> MessageIconStatus +decodeMessageIconStatus' t + | Just mis <- decodeMessageIconStatus t = mis + | otherwise = def + +decodeMessage :: (Text, Html) -> Message +decodeMessage (mis, msgContent) + | Just MIS{ misStatus=messageStatus, misIcon=messageIcon } <- decodeMessageIconStatus mis + = let messageContent = msgContent in Message{..} + | Just messageStatus <- fromPathPiece mis + = let messageIcon = Nothing -- legacy case, should no longer occur ($logDebug ???) + messageContent = msgContent <> "!!!" + in Message{..} + | otherwise -- should not happen, if refactored correctly ($logDebug ???) + = let messageStatus = Utils.Message.Warning + messageContent = msgContent <> "!!!!" + messageIcon = Nothing + in Message{..} + data Message = Message - { messageStatus :: MessageStatus + { messageStatus :: MessageStatus , messageContent :: Html - -- , messageIcon :: Maybe Icon + , messageIcon :: Maybe Icon } instance Eq Message where @@ -60,26 +108,39 @@ instance ToJSON Message where toJSON Message{..} = object [ "status" .= messageStatus , "content" .= renderHtml messageContent + , "icon" .= messageIcon ] instance FromJSON Message where parseJSON = withObject "Message" $ \o -> do messageStatus <- o .: "status" messageContent <- preEscapedText . sanitizeBalance <$> o .: "content" + messageIcon <- o .: "icon" return Message{..} statusToUrgencyClass :: MessageStatus -> Text statusToUrgencyClass status = "urgency__" <> toPathPiece status +addMessage' :: MonadHandler m => Message -> m () +addMessage' Message{..} = ClassyPrelude.Yesod.addMessage (encodeMessageIconStatus mis) messageContent + where mis = MIS{misStatus=messageStatus, misIcon=messageIcon} + +addMessageIcon :: MonadHandler m => MessageStatus -> Icon -> Html -> m () +addMessageIcon ms mi = ClassyPrelude.Yesod.addMessage $ encodeMessageIconStatus MIS{misStatus=ms, misIcon=Just mi} + +addMessageIconI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageStatus -> Icon -> msg -> m () +addMessageIconI ms mi = ClassyPrelude.Yesod.addMessageI $ encodeMessageIconStatus MIS{misStatus=ms, misIcon=Just mi} + addMessage :: MonadHandler m => MessageStatus -> Html -> m () -addMessage mc = ClassyPrelude.Yesod.addMessage (toPathPiece mc) +addMessage mc = ClassyPrelude.Yesod.addMessage $ encodeMessageStatus mc addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageStatus -> msg -> m () -addMessageI mc = ClassyPrelude.Yesod.addMessageI (toPathPiece mc) +addMessageI mc = ClassyPrelude.Yesod.addMessageI $ encodeMessageStatus mc messageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageStatus -> msg -> m Message messageI messageStatus msg = do messageContent <- toHtml . ($ msg) <$> getMessageRender + let messageIcon = Nothing return Message{..} addMessageIHamlet :: ( MonadHandler m @@ -88,15 +149,16 @@ addMessageIHamlet :: ( MonadHandler m ) => MessageStatus -> HtmlUrlI18n msg (Route site) -> m () addMessageIHamlet mc iHamlet = do mr <- getMessageRender - ClassyPrelude.Yesod.addMessage (toPathPiece mc) =<< withUrlRenderer (iHamlet $ toHtml . mr) + ClassyPrelude.Yesod.addMessage (encodeMessageStatus mc) =<< withUrlRenderer (iHamlet $ toHtml . mr) messageIHamlet :: ( MonadHandler m , RenderMessage (HandlerSite m) msg , HandlerSite m ~ site ) => MessageStatus -> HtmlUrlI18n msg (Route site) -> m Message -messageIHamlet mc iHamlet = do +messageIHamlet ms iHamlet = do mr <- getMessageRender - Message mc <$> withUrlRenderer (iHamlet $ toHtml . mr) + let mi = Nothing + Message ms <$> withUrlRenderer (iHamlet $ toHtml . mr) <*> pure mi addMessageFile :: MessageStatus -> FilePath -> ExpQ addMessageFile mc tPath = [e|addMessageIHamlet mc $(ihamletFile tPath)|] @@ -123,3 +185,9 @@ messageWidget :: forall m site. messageWidget mc wgt = do PageContent{pageBody} <- liftHandlerT $ widgetToPageContent wgt messageIHamlet mc (const pageBody :: HtmlUrlI18n (SomeMessage site) (Route site)) + + +getMessages :: MonadHandler m => m [Message] +getMessages = fmap decodeMessage <$> ClassyPrelude.Yesod.getMessages + + diff --git a/templates/widgets/alerts/alerts.hamlet b/templates/widgets/alerts/alerts.hamlet index 8ddc0f6cd..0dd303f8a 100644 --- a/templates/widgets/alerts/alerts.hamlet +++ b/templates/widgets/alerts/alerts.hamlet @@ -1,15 +1,15 @@ $newline never
- $forall (status, msg) <- mmsgs - $with status2 <- bool status "info" (status == "") - -
+ $forall Message{..} <- mmsgs + $with icn <- maybeAttribute "data-icon" iconJS messageIcon +
- #{msg} + #{messageContent} + From d838d36239833d47b250550ede26126a09d22c53 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 25 Jul 2019 07:39:18 +0200 Subject: [PATCH 05/12] chore(alert messages): minor code cleaning --- src/Utils/Message.hs | 31 ++++++++++++++----------------- 1 file changed, 14 insertions(+), 17 deletions(-) diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs index 4302dac79..d72d065bf 100644 --- a/src/Utils/Message.hs +++ b/src/Utils/Message.hs @@ -1,13 +1,12 @@ module Utils.Message - ( MessageStatus(..), MessageIconStatus(..) - , UnknownMessageStatus(..) + ( MessageStatus(..) + -- , UnknownMessageStatus(..) , getMessages , addMessage',addMessageIcon, addMessageIconI -- messages with special icons (needs registering in alert-icons.js) , addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget , statusToUrgencyClass , Message(..) , messageI, messageIHamlet, messageFile, messageWidget - , encodeMessageIconStatus, decodeMessageIconStatus, decodeMessageIconStatus' ) where import Data.Universe @@ -45,13 +44,11 @@ deriveJSON defaultOptions nullaryPathPiece ''MessageStatus camelToPathPiece derivePersistField "MessageStatus" -newtype UnknownMessageStatus = UnknownMessageStatus Text +newtype UnknownMessageStatus = UnknownMessageStatus Text -- kann das weg? deriving (Eq, Ord, Read, Show, Generic, Typeable) instance Exception UnknownMessageStatus --- ms2mis :: MessageStatus -> MessageIconStatus --- ms2mis s = def { misStatus= s} data MessageIconStatus = MIS { misStatus :: MessageStatus, misIcon :: Maybe Icon } deriving (Eq, Ord, Show, Read, Lift) @@ -72,23 +69,23 @@ encodeMessageIconStatus = decodeUtf8 . toStrict . encode decodeMessageIconStatus :: Text -> Maybe MessageIconStatus decodeMessageIconStatus = decode' . fromStrict . encodeUtf8 -decodeMessageIconStatus' :: Text -> MessageIconStatus -decodeMessageIconStatus' t - | Just mis <- decodeMessageIconStatus t = mis - | otherwise = def +-- decodeMessageIconStatus' :: Text -> MessageIconStatus +-- decodeMessageIconStatus' t +-- | Just mis <- decodeMessageIconStatus t = mis +-- | otherwise = def decodeMessage :: (Text, Html) -> Message decodeMessage (mis, msgContent) | Just MIS{ misStatus=messageStatus, misIcon=messageIcon } <- decodeMessageIconStatus mis = let messageContent = msgContent in Message{..} - | Just messageStatus <- fromPathPiece mis - = let messageIcon = Nothing -- legacy case, should no longer occur ($logDebug ???) - messageContent = msgContent <> "!!!" + | Just messageStatus <- fromPathPiece mis -- should not happen + = let messageIcon = Nothing + messageContent = msgContent <> "!!" -- mark legacy case, should no longer occur ($logDebug instead ???) in Message{..} - | otherwise -- should not happen, if refactored correctly ($logDebug ???) - = let messageStatus = Utils.Message.Warning - messageContent = msgContent <> "!!!!" - messageIcon = Nothing + | otherwise -- should not happen + = let messageStatus = Utils.Message.Error + messageContent = msgContent <> "!!!" -- mark legacy case, should no longer occur ($logDebug instead ???) + messageIcon = Nothing in Message{..} From 56c2fccb84ff71163ccc22291cf42c0cea88b2de Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 25 Jul 2019 07:48:12 +0200 Subject: [PATCH 06/12] feat(corrections assignment): add convenience to table header links look ugly in table headers so as a workaround we use an icon instead for a much needed link in the corrections assignment table --- src/Utils/Icon.hs | 2 ++ templates/corrections-overview.hamlet | 6 ++++-- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 4d9dd168d..a5d0c8a92 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -45,6 +45,7 @@ data Icon | IconExamRegisterFalse | IconCommentTrue | IconCommentFalse + | IconLink | IconFileDownload | IconFileZip | IconFileCSV @@ -71,6 +72,7 @@ iconText = \case IconExamRegisterFalse -> "calendar-times" IconCommentTrue -> "comment-alt" IconCommentFalse -> "comment-slash" -- comment-alt-slash is not available for free + IconLink -> "link" IconFileDownload -> "file-download" IconFileZip -> "file-archive" IconFileCSV -> "file-csv" diff --git a/templates/corrections-overview.hamlet b/templates/corrections-overview.hamlet index 64a647387..747f99d15 100644 --- a/templates/corrections-overview.hamlet +++ b/templates/corrections-overview.hamlet @@ -56,8 +56,10 @@ $# Always iterate over orderedSheetNames for consistent sorting! Newest first, except in this table $forall shn <- orderedSheetNames - #{shn} - $# ^{simpleLinkI (SomeMessage MsgMenuCorrectors) (CSheetR tid ssh csh shn SCorrR)} + + $# Links currently look ugly in table headers; used an icon as a workaround: + ^{simpleLink (toWidget iconLink) (CSheetR tid ssh csh shn SShowR)} + #{shn} _{MsgNrSubmissionsTotal} _{MsgNrSubmissionsNotCorrected} From b2b3895aa97d19580987d4b7f845798d6603c44a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 25 Jul 2019 07:57:27 +0200 Subject: [PATCH 07/12] feat(course enrolement): show proper icons in alerts --- frontend/src/utils/alerts/alert-icons.js | 2 +- src/Handler/Course.hs | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/frontend/src/utils/alerts/alert-icons.js b/frontend/src/utils/alerts/alert-icons.js index eb497d9bd..434d98568 100644 --- a/frontend/src/utils/alerts/alert-icons.js +++ b/frontend/src/utils/alerts/alert-icons.js @@ -15,6 +15,6 @@ export const ALERT_ICONS = { info: '"\\f05a"', registered: '"\\f274"', userplus: '"\\f234"', - userslash: '"\\f504"', + userslash: '"\\f506"', warning: '"\\f071"', }; diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 141824f9d..b978c75f3 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -557,11 +557,11 @@ postCRegisterR tid ssh csh = do formResult regResult $ \(mbSfId,codeOk) -> if | isRegistered -> do runDB $ deleteBy $ UniqueParticipant aid cid - addMessageI Info MsgCourseDeregisterOk + addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk | codeOk -> do actTime <- liftIO getCurrentTime regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime mbSfId - when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk + when (isJust regOk) $ addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk | otherwise -> addMessageI Warning MsgCourseSecretWrong -- addMessage Info $ toHtml $ show regResult -- For debugging only redirect $ CourseR tid ssh csh CShowR @@ -1418,7 +1418,7 @@ postCUserR tid ssh csh uCId = do | Just (Entity pId _) <- mRegistration -> do runDB $ delete pId - addMessageI Info MsgCourseDeregisterOk + addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk redirect $ CourseR tid ssh csh CUsersR | otherwise -> invalidArgs ["User not registered"] @@ -1432,7 +1432,7 @@ postCUserR tid ssh csh uCId = do pId <- runDB . insertUnique $ CourseParticipant cid uid now primaryField case pId of Just _ -> do - addMessageI Success MsgCourseRegisterOk + addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk redirect currentRoute Nothing -> invalidArgs ["User already registered"] From 864338174a24fd53b3cfd4da5e25b5475eb92f67 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 25 Jul 2019 08:38:01 +0200 Subject: [PATCH 08/12] refactor(alert messages): custom icons without js --- frontend/src/utils/alerts/alert-icons.js | 20 -------------- frontend/src/utils/alerts/alerts.js | 9 ------- frontend/src/utils/alerts/alerts.scss | 33 ++++++++++++++++-------- src/Foundation.hs | 12 ++++++--- templates/widgets/alerts/alerts.hamlet | 16 ++++-------- 5 files changed, 35 insertions(+), 55 deletions(-) delete mode 100644 frontend/src/utils/alerts/alert-icons.js diff --git a/frontend/src/utils/alerts/alert-icons.js b/frontend/src/utils/alerts/alert-icons.js deleted file mode 100644 index 434d98568..000000000 --- a/frontend/src/utils/alerts/alert-icons.js +++ /dev/null @@ -1,20 +0,0 @@ -// -// Fontawesome icons to be used on alerts. -// -// If you want to add new icons stick to the format of the existing ones. -// They are necessary due to weird unicode conversions during transpilation. -// https://fontawesome.com/icons - -export const ALERT_ICONS = { - calendarcheck: '"\\f274"', - calendartimes: '"\\f273"', - checkmark: '"\\f058"', - cross: '"\\f00d"', - deregistered: '"\\f273"', - exclamation: '"\\f06a"', - info: '"\\f05a"', - registered: '"\\f274"', - userplus: '"\\f234"', - userslash: '"\\f506"', - warning: '"\\f071"', -}; diff --git a/frontend/src/utils/alerts/alerts.js b/frontend/src/utils/alerts/alerts.js index 4d1a1cf7a..e54f898fd 100644 --- a/frontend/src/utils/alerts/alerts.js +++ b/frontend/src/utils/alerts/alerts.js @@ -1,6 +1,5 @@ import { Utility } from '../../core/utility'; import './alerts.scss'; -import { ALERT_ICONS } from './alert-icons'; const ALERTS_INITIALIZED_CLASS = 'alerts--initialized'; const ALERTS_ELEVATED_CLASS = 'alerts--elevated'; @@ -20,7 +19,6 @@ const ALERT_AUTOCLOSING_MATCHER = '.alert-info, .alert-success'; /* * Dataset-Inputs: * - decay (data-decay): Custom time (in seconds) for this alert to stay visible - * - icon (data-icon): Custom icon (from the list in alert-icons.js) to show on the alert */ @Utility({ @@ -94,13 +92,6 @@ export class Alerts { this._toggleAlert(alertElement); }); - const customIcon = alertElement.dataset.icon; - if (customIcon && ALERT_ICONS[customIcon]) { - alertElement.style.setProperty('--alert-icon', ALERT_ICONS[customIcon]); - } else if (customIcon) { - throw new Error('Alert: Custom icon "' + customIcon + '" could not be found!'); - } - if (autoHideDelay > 0 && alertElement.matches(ALERT_AUTOCLOSING_MATCHER)) { window.setTimeout(() => this._toggleAlert(alertElement), autoHideDelay * 1000); } diff --git a/frontend/src/utils/alerts/alerts.scss b/frontend/src/utils/alerts/alerts.scss index 8beff3b70..aa2f6acdc 100644 --- a/frontend/src/utils/alerts/alerts.scss +++ b/frontend/src/utils/alerts/alerts.scss @@ -32,6 +32,10 @@ font-size: 30px; transform: translateX(-50%); } + + &:hover::before { + color: var(--color-grey-medium); + } } .alerts--elevated { @@ -68,6 +72,10 @@ .alert a { color: var(--color-lightwhite); + + &:hover { + color: var(--color-grey); + } } @keyframes slide-in-alert { @@ -124,9 +132,9 @@ z-index: 40; &::before { - content: var(--alert-icon, var(--alert-icon-default, '\f05a')); + /* content: var(--alert-icon, var(--alert-icon-default, '\f05a')); */ position: absolute; - font-family: 'Font Awesome 5 Free'; + /* font-family: 'Font Awesome 5 Free'; */ font-size: 24px; top: 50%; left: 50%; @@ -188,23 +196,26 @@ .alert-success { background-color: var(--color-success); - .alert__icon::before { - --alert-icon-default: '\f058'; - } + /* .alert__icon::before { + * --alert-icon-default: '\f058'; + * } + */ } .alert-warning { background-color: var(--color-warning); - .alert__icon::before { - --alert-icon-default: '\f06a'; - } + /* .alert__icon::before { + * --alert-icon-default: '\f06a'; + * } + */ } .alert-error { background-color: var(--color-error); - .alert__icon::before { - --alert-icon-default: '\f071'; - } + /* .alert__icon::before { + * --alert-icon-default: '\f071'; + * } + */ } diff --git a/src/Foundation.hs b/src/Foundation.hs index a2df4f68c..4f345261c 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1216,10 +1216,8 @@ instance Yesod UniWorX where , massInputShortcircuit ] - lift . bracketOnError getMessages (mapM_ addMessage') $ \msgs -> do - -- @gkleen: the following line is redundant, but what does this block do anyway? - -- Just msgs' <- return . forM msgs $ \(msgState, content) -> Message <$> fromPathPiece msgState <*> return content - addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict $ JSON.encode msgs + lift . bracketOnError getMessages (mapM_ addMessage') $ + addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict . JSON.encode -- Since we implement `errorHandler` ourselves we don't need `defaultMessageWidget` defaultMessageWidget _title _body = error "defaultMessageWidget: undefined" @@ -2839,6 +2837,12 @@ instance YesodAuth UniWorX where authHttpManager = Yesod.getHttpManager + onLogin = addMessageI Success Auth.NowLoggedIn + + onErrorHtml dest msg = do + addMessage Error $ toHtml msg + redirect dest + renderAuthMessage _ _ = Auth.germanMessage -- TODO instance YesodAuthPersist UniWorX diff --git a/templates/widgets/alerts/alerts.hamlet b/templates/widgets/alerts/alerts.hamlet index 0dd303f8a..dca147265 100644 --- a/templates/widgets/alerts/alerts.hamlet +++ b/templates/widgets/alerts/alerts.hamlet @@ -2,14 +2,8 @@ $newline never
$forall Message{..} <- mmsgs - $with icn <- maybeAttribute "data-icon" iconJS messageIcon -
-
-
-
- #{messageContent} - +
+
+
+
+ #{messageContent} From bdaa9c6ecf2bccdd2722ffea6c380ec76ceb1e2f Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 25 Jul 2019 08:49:58 +0200 Subject: [PATCH 09/12] refactor(notifications): notifications don't support custom icons --- src/Utils/Form.hs | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index a888efb29..e7ae3b654 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -741,16 +741,15 @@ wformMessage :: (MonadHandler m) => Message -> WForm m () wformMessage = void . aFormToWForm . aformMessage formMessage :: (MonadHandler m) => Message -> MForm m (FormResult (), FieldView site) -formMessage Message{..} = do - let icn = maybeAttribute "data-icon" iconJS messageIcon - return (FormSuccess (), FieldView - { fvLabel = mempty - , fvTooltip = Nothing - , fvId = idFormMessageNoinput - , fvErrors = Nothing - , fvRequired = False - , fvInput = [whamlet|
#{messageContent}|] - }) +formMessage Message{ messageIcon = _, ..} = do -- custom icons are not currently implemented for `.notification` + return (FormSuccess (), FieldView + { fvLabel = mempty + , fvTooltip = Nothing + , fvId = idFormMessageNoinput + , fvErrors = Nothing + , fvRequired = False + , fvInput = [whamlet|
#{messageContent}|] + }) --------------------- -- Form evaluation -- From 8833cb5090738c351b8a47af558dfcb91040cf77 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 25 Jul 2019 08:57:44 +0200 Subject: [PATCH 10/12] feat(alerts js): support custom icons in Alerts HTTP-Header --- frontend/src/utils/alerts/alerts.js | 6 +++--- src/Handler/Admin.hs | 2 +- src/Utils/Icon.hs | 13 ++++++------- 3 files changed, 10 insertions(+), 11 deletions(-) diff --git a/frontend/src/utils/alerts/alerts.js b/frontend/src/utils/alerts/alerts.js index e54f898fd..3c4eba683 100644 --- a/frontend/src/utils/alerts/alerts.js +++ b/frontend/src/utils/alerts/alerts.js @@ -137,7 +137,7 @@ export class Alerts { if (alerts) { alerts.forEach((alert) => { - const alertElement = this._createAlertElement(alert.status, alert.content); + const alertElement = this._createAlertElement(alert.status, alert.content, alert.icon === null ? undefined : alert.icon); this._element.appendChild(alertElement); this._alertElements.push(alertElement); this._initAlert(alertElement); @@ -147,7 +147,7 @@ export class Alerts { } } - _createAlertElement(type, content) { + _createAlertElement(type, content, icon = 'info-circle') { const alertElement = document.createElement('div'); alertElement.classList.add(ALERT_CLASS, 'alert-' + type); @@ -155,7 +155,7 @@ export class Alerts { alertCloser.classList.add(ALERT_CLOSER_CLASS); const alertIcon = document.createElement('div'); - alertIcon.classList.add(ALERT_ICON_CLASS); + alertIcon.classList.add(ALERT_ICON_CLASS, 'fas', 'fa-fw', 'fa-' + icon); const alertContent = document.createElement('div'); alertContent.classList.add(ALERT_CONTENT_CLASS); diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 7d02ee2e2..27fc5c809 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -113,7 +113,7 @@ postAdminTestR = do formResultModal emailResult AdminTestR $ \(email, ls) -> do jId <- mapWriterT runDB $ do jId <- queueJob $ JobSendTestEmail email ls - tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] Nothing + tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] (Just IconEmail) return jId writeJobCtl $ JobCtlPerform jId addMessage Warning [shamlet|Inkorrekt ausgegebener Alert|] -- For testing alert handling when short circuiting; for proper (not fallback-solution) handling always use `tell` within `formResultModal` diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index a5d0c8a92..582f9f35c 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -53,6 +53,7 @@ data Icon | IconSFTHint -- for SheetFileType only | IconSFTSolution -- for SheetFileType only | IconSFTMarking -- for SheetFileType only + | IconEmail deriving (Eq, Ord, Enum, Bounded, Show, Read) iconText :: Icon -> Text @@ -80,10 +81,7 @@ iconText = \case IconSFTHint -> "life-ring" -- for SheetFileType only IconSFTSolution -> "exclamation-circle" -- for SheetFileType only IconSFTMarking -> "check-circle" -- for SheetFileType only - --- | like iconText, but eliminates '-' since these are problemativ in alert-icons.js -iconJS :: Icon -> Text -iconJS = filter ('-' /=) . iconText + IconEmail -> "envelope" instance Universe Icon instance Finite Icon @@ -96,9 +94,10 @@ deriveJSON defaultOptions -- Create an icon from font-awesome without additional space icon :: Icon -> Markup -icon ic = let ict = iconText ic in - [shamlet|$newline never - |] +icon ic = [shamlet| + $newline never + + |] -- declare constats for all icons for compatibility and convenience -- "IconCourse" generates "iconCourse = icon IconCourse" From 38afa901bab462b889ea036f142022afe4b32498 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 25 Jul 2019 10:00:55 +0200 Subject: [PATCH 11/12] fix: fix merge --- src/Database/Esqueleto/Utils.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 6ddf7edd3..132a11d2c 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -141,7 +141,7 @@ mkExistsFilter :: PathPiece a -> E.SqlExpr (E.Value Bool) mkExistsFilter query row criterias | Set.null criterias = true - | otherwise = any (E.exists . query row) criterias + | otherwise = any (E.exists . query row) $ Set.toList criterias -- | Combine several filters, using logical or anyFilter :: (Foldable f) From 0bd0260a3e916b6541f43e036744e80b8d0f00bb Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 25 Jul 2019 11:59:52 +0200 Subject: [PATCH 12/12] fix(merge): fix build --- src/Database/Esqueleto/Utils.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 132a11d2c..3659831a0 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -26,6 +26,10 @@ import qualified Database.Esqueleto.Internal.Sql as E import Database.Esqueleto.Utils.TH +{-# ANN any ("HLint: ignore Use any" :: String) #-} +{-# ANN all ("HLint: ignore Use all" :: String) #-} + + -- -- Description : Convenience for using `Esqueleto`, -- intended to be imported qualified