feat(alerticons): allow alerts to have custom icons
This commit is contained in:
Steffen Jost
parent
495fdd18dd
commit
d70a9585f0
@ -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"',
|
||||
};
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -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`
|
||||
|
||||
@ -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|
|
||||
<div>#{iconExamRegister True}
|
||||
<div>
|
||||
<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>
|
||||
<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"]
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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)]
|
||||
|
||||
|
||||
---------------------
|
||||
|
||||
@ -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|<div .notification .notification-#{toPathPiece messageStatus}>#{messageContent}|]
|
||||
, fvInput = [whamlet|<div .notification .notification-#{toPathPiece messageStatus} *{icn}>#{messageContent}|]
|
||||
})
|
||||
|
||||
---------------------
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
----------------
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
|
||||
@ -1,15 +1,15 @@
|
||||
$newline never
|
||||
<div #alerts-1 .alerts uw-alerts>
|
||||
<div .alerts__toggler>
|
||||
$forall (status, msg) <- mmsgs
|
||||
$with status2 <- bool status "info" (status == "")
|
||||
<!--
|
||||
TODO:
|
||||
If a custom icon is set for this alert then add "data-icon=#{icon}" to the .alert element.
|
||||
A list of available icons can be found in frontend/src/utils/alerts/alert-icons.js
|
||||
-->
|
||||
<div .alert.alert-#{status2}>
|
||||
$forall Message{..} <- mmsgs
|
||||
$with icn <- maybeAttribute "data-icon" iconJS messageIcon
|
||||
<div .alert .alert-#{toPathPiece messageStatus} *{icn}>
|
||||
<div .alert__closer>
|
||||
<div .alert__icon>
|
||||
<div .alert__content>
|
||||
#{msg}
|
||||
#{messageContent}
|
||||
<!--
|
||||
TODO:
|
||||
If a custom icon is set for this alert then add "data-icon=#{icon}" to the .alert element.
|
||||
A list of available icons can be found in frontend/src/utils/alerts/alert-icons.js
|
||||
-->
|
||||
|
||||
Loading…
Reference in New Issue
Block a user