feat(alerticons): allow alerts to have custom icons

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"',
 };

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
+          lift . bracketOnError getMessages (mapM_ addMessage') $ \msgs -> do
-            Just msgs' <- return . forM msgs $ \(msgState, content) -> Message <$> fromPathPiece msgState <*> return content
+            -- @gkleen: the following line is redundant, but what does this block do anyway?
-            addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict $ JSON.encode msgs'
+            -- 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"

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`

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|
+      addMessageIconI Success IconExamRegisterTrue  (MsgExamRegisteredSuccess examn)
-          <div>#{iconExamRegister True}
-          <div>&nbsp;
-          <div>_{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|
+      addMessageIconI Info    IconExamRegisterFalse (MsgExamDeregisteredSuccess examn)
-        <div>#{iconExamRegister False}
+      -- 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
-        <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
       redirect $ CExamR tid ssh csh examn EShowR
 
   invalidArgs ["Register/Deregister button required"]

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)
 

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

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|<div .notification .notification-#{toPathPiece messageStatus}>#{messageContent}|]
+      , fvInput    = [whamlet|<div .notification .notification-#{toPathPiece messageStatus} *{icn}>#{messageContent}|]
       })
 
 ---------------------

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
-        iname <- newName $ over (ix 0) Data.Char.toLower $ show ic
+      isig <- sigD iname [t|Markup|]
-        isig <- sigD iname [t|Markup|]
+      idef <- valD (varP iname) (normalB [|icon ic|]) []
-        idef <- valD (varP iname) (normalB [|icon ic|]) []
+      return [isig, idef]
-        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
 
 
 ----------------

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 qualified ClassyPrelude.Yesod (addMessage, addMessageI, getMessages)
-import ClassyPrelude.Yesod hiding (addMessage, addMessageI)
+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
+
+

templates/widgets/alerts/alerts.hamlet

@@ -1,15 +1,15 @@
 $newline never
 <div #alerts-1 .alerts uw-alerts>
   <div .alerts__toggler>
-  $forall (status, msg) <- mmsgs
+  $forall Message{..} <- mmsgs
-    $with status2 <- bool status "info" (status == "")
+    $with icn <- maybeAttribute "data-icon" iconJS messageIcon
-      <!--
+      <div .alert .alert-#{toPathPiece messageStatus} *{icn}>
-        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}>
         <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
+        -->