fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'alert-icons' into 'master'

Browse Source 
feat(alert-icons): add custom icons for alerts

See merge request !258
This commit is contained in:
Steffen Jost 2019-07-25 12:23:10 +02:00
commit 823b367d5a
19 changed files with 353 additions and 197 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
frontend/src/utils/alerts/alerts.js
View File

@ -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);

33
frontend/src/utils/alerts/alerts.scss
View File

@ -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';
* }
*/
}

4
src/Database/Esqueleto/Utils.hs
View File

@ -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

13
src/Foundation.hs
View File

@ -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

2
src/Handler/Admin.hs
View File

@ -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`

8
src/Handler/Course.hs
View File

@ -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"]

13
src/Handler/Exam.hs
View File

@ -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|
<div>#{iconExamRegister True}
<div>&nbsp;
<div>_{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|
<div>#{iconExamRegister False}
<div>&nbsp;
<div>_{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"]

15
src/Handler/Utils/Table/Cells.hs
View File

@ -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

2
src/Handler/Utils/Table/Pagination.hs
View File

@ -305,7 +305,7 @@ instance Button UniWorX ButtonCsvMode where
btnLabel BtnCsvExport
= [whamlet|
$newline never
#{iconCSV}
#{iconFileCSV}
\ _{BtnCsvExport}
|]
btnLabel x = [whamlet|_{x}|]

6
src/Import/NoModel.hs
View File

@ -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)

12
src/Language/Haskell/TH/Instances.hs
View File

@ -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 = (<>)

8
src/Model/Types/Sheet.hs
View File

@ -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

124
src/Utils.hs
View File

@ -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
<i .fas .fa-#{iconName}>|]
-- 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)]
---------------------

18
src/Utils/Form.hs
View File

@ -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|<div .notification .notification-#{toPathPiece messageStatus}>#{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|<div .notification .notification-#{toPathPiece messageStatus}>#{messageContent}|]
})
---------------------
-- Form evaluation --

168
src/Utils/Icon.hs Normal file
View File

@ -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
<i .fas .fa-#{iconText ic}>
|]
-- 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

86
src/Utils/Message.hs
View File

@ -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

6
templates/corrections-overview.hamlet
View File

@ -56,8 +56,10 @@
$# Always iterate over orderedSheetNames for consistent sorting! Newest first, except in this table
$forall shn <- orderedSheetNames
<th .table__th colspan=5>#{shn}
$# ^{simpleLinkI (SomeMessage MsgMenuCorrectors) (CSheetR tid ssh csh shn SCorrR)}
<th .table__th colspan=5>
$# Links currently look ugly in table headers; used an icon as a workaround:
^{simpleLink (toWidget iconLink) (CSheetR tid ssh csh shn SShowR)}
#{shn}
<tr .table__row .table__row--head>
<th .table__th>_{MsgNrSubmissionsTotal}
<th .table__th>_{MsgNrSubmissionsNotCorrected}

8
templates/exam-show.hamlet
View File

@ -24,7 +24,7 @@ $maybe Entity _ ExamResult{examResultResult} <- result
$maybe desc <- examDescription
<section>
#{desc}
<section>
<dl .deflist>
$if not examVisible
@ -84,7 +84,7 @@ $maybe desc <- examDescription
$maybe registerWdgt <- registerWidget
<dt .deflist__dt>_{MsgExamRegistration}
<dd .deflist__dd>^{registerWdgt}
$if not (null occurrences)
<section>
@ -124,7 +124,7 @@ $if not (null occurrences)
$if occurrenceAssignmentsShown
<td .table__td>
$if registered
#{fontAwesomeIcon "check"}
#{iconOK}
$if gradingShown && not (null parts)
<section>
@ -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

13
templates/widgets/alerts/alerts.hamlet
View File

@ -1,10 +1,9 @@
$newline never
<div #alerts-1 .alerts uw-alerts>
<div .alerts__toggler>
$forall (status, msg) <- mmsgs
$with status2 <- bool status "info" (status == "")
<div .alert.alert-#{status2}>
<div .alert__closer>
<div .alert__icon>
<div .alert__content>
#{msg}
$forall Message{..} <- mmsgs
<div .alert .alert-#{toPathPiece messageStatus}>
<div .alert__closer>
<div .alert__icon .fas .fa-fw .fa-#{maybe "info-circle" iconText messageIcon}>
<div .alert__content>
#{messageContent}