diff --git a/frontend/src/utils/alerts/alerts.js b/frontend/src/utils/alerts/alerts.js index e7e04ddbb..3c4eba683 100644 --- a/frontend/src/utils/alerts/alerts.js +++ b/frontend/src/utils/alerts/alerts.js @@ -16,6 +16,11 @@ 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 + */ + @Utility({ selector: '[uw-alerts]', }) @@ -132,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); @@ -142,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); @@ -150,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/frontend/src/utils/alerts/alerts.scss b/frontend/src/utils/alerts/alerts.scss index d2faf1b22..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: '\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 { - content: '\f058'; - } + /* .alert__icon::before { + * --alert-icon-default: '\f058'; + * } + */ } .alert-warning { background-color: var(--color-warning); - .alert__icon::before { - content: '\f06a'; - } + /* .alert__icon::before { + * --alert-icon-default: '\f06a'; + * } + */ } .alert-error { background-color: var(--color-error); - .alert__icon::before { - content: '\f071'; - } + /* .alert__icon::before { + * --alert-icon-default: '\f071'; + * } + */ } diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index a3bf2192a..323137301 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -29,6 +29,10 @@ import Database.Esqueleto.Utils.TH {-# ANN all ("HLint: ignore Use all" :: String) #-} +{-# ANN any ("HLint: ignore Use any" :: String) #-} +{-# ANN all ("HLint: ignore Use all" :: String) #-} + + -- -- Description : Convenience for using `Esqueleto`, -- intended to be imported qualified diff --git a/src/Foundation.hs b/src/Foundation.hs index c534d6baf..6f1d4681b 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) @@ -1215,9 +1215,8 @@ 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') $ + addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict . JSON.encode -- Since we implement `errorHandler` ourselves we don't need `defaultMessageWidget` defaultMessageWidget _title _body = error "defaultMessageWidget: undefined" @@ -2849,6 +2848,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/src/Handler/Admin.hs b/src/Handler/Admin.hs index a2f4eafa3..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)})|] + 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/Handler/Course.hs b/src/Handler/Course.hs index 3c3e40366..f7c226ee7 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 @@ -1419,7 +1419,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"] @@ -1433,7 +1433,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"] diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index d9c0ab776..61c4fe2a0 100644 --- a/src/Handler/Exam.hs +++ b/src/Handler/Exam.hs @@ -1518,21 +1518,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/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 e36c0672b..27f476312 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -305,7 +305,7 @@ instance Button UniWorX ButtonCsvMode where btnLabel BtnCsvExport = [whamlet| $newline never - #{iconCSV} + #{iconFileCSV} \ _{BtnCsvExport} |] btnLabel x = [whamlet|_{x}|] diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 2385d2d99..e530b0d0f 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 @@ -54,7 +54,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(..)) @@ -71,7 +71,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/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 1792d9af8..982ba28f5 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 @@ -80,9 +81,10 @@ 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 ----------- -- Yesod -- @@ -113,122 +115,10 @@ unsupportedAuthPredicate = do unauthorizedI (UnsupportedAuthPredicate (toPathPiece tag) route) |] - - --- | 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 - +-- | 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 73e6473e4..e1a2a24b4 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -751,15 +751,15 @@ wformMessage :: (MonadHandler m) => Message -> WForm m () wformMessage = void . aFormToWForm . aformMessage formMessage :: (MonadHandler m) => Message -> MForm m (FormResult (), FieldView site) -formMessage Message{..} = do - 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 -- diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs new file mode 100644 index 000000000..582f9f35c --- /dev/null +++ b/src/Utils/Icon.hs @@ -0,0 +1,168 @@ +module Utils.Icon where + +import ClassyPrelude.Yesod hiding (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 () +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) + => WidgetT site m () + + +----------- +-- 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 + | IconInvisible + | IconCourse + | IconEnrolTrue + | IconEnrolFalse + | IconExam + | IconExamRegisterTrue + | IconExamRegisterFalse + | IconCommentTrue + | IconCommentFalse + | IconLink + | IconFileDownload + | IconFileZip + | IconFileCSV + | IconSFTQuestion -- for SheetFileType only + | IconSFTHint -- for SheetFileType only + | IconSFTSolution -- for SheetFileType only + | IconSFTMarking -- for SheetFileType only + | IconEmail + deriving (Eq, Ord, Enum, Bounded, Show, Read) + +iconText :: Icon -> Text +iconText = \case + IconNew -> "seedling" + IconOK -> "check" + IconNotOK -> "times" + IconWarning -> "exclamation" + IconProblem -> "bolt" + IconVisible -> "eye" + IconInvisible -> "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" -- comment-alt-slash is not available for free + IconLink -> "link" + 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 + IconEmail -> "envelope" + +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 = [shamlet| + $newline never + + |] + +-- declare constats for all icons for compatibility and convenience +-- "IconCourse" generates "iconCourse = icon IconCourse" +iconShortcuts :: Q [Dec] +iconShortcuts = foldMap mkIcon (universeF :: [Icon]) + where + mkIcon :: Icon -> Q [Dec] + mkIcon ic = 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] + + +---------------------- +-- 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 = 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 IconExamRegisterFalse + + +---------------- +-- 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 diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs index 04dc41dcf..d72d065bf 100644 --- a/src/Utils/Message.hs +++ b/src/Utils/Message.hs @@ -1,6 +1,8 @@ module Utils.Message ( MessageStatus(..) - , UnknownMessageStatus(..) + -- , UnknownMessageStatus(..) + , getMessages + , addMessage',addMessageIcon, addMessageIconI -- messages with special icons (needs registering in alert-icons.js) , addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget , statusToUrgencyClass , Message(..) @@ -8,12 +10,13 @@ module Utils.Message ) 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 +31,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 @@ -38,15 +44,55 @@ 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 +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 -- should not happen + = let messageIcon = Nothing + messageContent = msgContent <> "!!" -- mark legacy case, should no longer occur ($logDebug instead ???) + in Message{..} + | otherwise -- should not happen + = let messageStatus = Utils.Message.Error + messageContent = msgContent <> "!!!" -- mark legacy case, should no longer occur ($logDebug instead ???) + messageIcon = Nothing + in Message{..} + + data Message = Message - { messageStatus :: MessageStatus + { messageStatus :: MessageStatus , messageContent :: Html + , messageIcon :: Maybe Icon } instance Eq Message where @@ -59,26 +105,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 @@ -87,15 +146,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)|] @@ -122,3 +182,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/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} diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet index 6a0d8321e..d2d92be3c 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)
@@ -124,7 +124,7 @@ $if not (null occurrences) $if occurrenceAssignmentsShown $if registered - #{fontAwesomeIcon "check"} + #{iconOK} $if gradingShown && not (null parts)
@@ -151,7 +151,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 diff --git a/templates/widgets/alerts/alerts.hamlet b/templates/widgets/alerts/alerts.hamlet index 4527e62d3..dca147265 100644 --- a/templates/widgets/alerts/alerts.hamlet +++ b/templates/widgets/alerts/alerts.hamlet @@ -1,10 +1,9 @@ $newline never
- $forall (status, msg) <- mmsgs - $with status2 <- bool status "info" (status == "") -
-
-
-
- #{msg} + $forall Message{..} <- mmsgs +
+
+
+
+ #{messageContent}