diff --git a/frontend/src/utils/alerts/alert-icons.js b/frontend/src/utils/alerts/alert-icons.js index 85fe1d3aa..eb497d9bd 100644 --- a/frontend/src/utils/alerts/alert-icons.js +++ b/frontend/src/utils/alerts/alert-icons.js @@ -6,11 +6,15 @@ // https://fontawesome.com/icons export const ALERT_ICONS = { - info: '"\\f05a"', + calendarcheck: '"\\f274"', + calendartimes: '"\\f273"', checkmark: '"\\f058"', - exclamation: '"\\f06a"', - warning: '"\\f071"', cross: '"\\f00d"', - registered: '"\\f274"', deregistered: '"\\f273"', + exclamation: '"\\f06a"', + info: '"\\f05a"', + registered: '"\\f274"', + userplus: '"\\f234"', + userslash: '"\\f504"', + warning: '"\\f071"', }; diff --git a/src/Foundation.hs b/src/Foundation.hs index 8103ebfda..a2df4f68c 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -5,7 +5,7 @@ module Foundation where import Import.NoFoundation hiding (embedFile) -import qualified ClassyPrelude.Yesod as Yesod (addMessage, getHttpManager) +import qualified ClassyPrelude.Yesod as Yesod (getHttpManager) import Database.Persist.Sql (ConnectionPool, runSqlPool) import Text.Hamlet (hamletFile) @@ -1216,9 +1216,10 @@ instance Yesod UniWorX where , massInputShortcircuit ] - lift . bracketOnError getMessages (mapM_ $ uncurry Yesod.addMessage) $ \msgs -> do - Just msgs' <- return . forM msgs $ \(msgState, content) -> Message <$> fromPathPiece msgState <*> return content - addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict $ JSON.encode msgs' + lift . bracketOnError getMessages (mapM_ addMessage') $ \msgs -> do + -- @gkleen: the following line is redundant, but what does this block do anyway? + -- Just msgs' <- return . forM msgs $ \(msgState, content) -> Message <$> fromPathPiece msgState <*> return content + addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict $ JSON.encode msgs -- Since we implement `errorHandler` ourselves we don't need `defaultMessageWidget` defaultMessageWidget _title _body = error "defaultMessageWidget: undefined" diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index a2f4eafa3..7d02ee2e2 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -113,7 +113,7 @@ postAdminTestR = do formResultModal emailResult AdminTestR $ \(email, ls) -> do jId <- mapWriterT runDB $ do jId <- queueJob $ JobSendTestEmail email ls - tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] + tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] Nothing return jId writeJobCtl $ JobCtlPerform jId addMessage Warning [shamlet|Inkorrekt ausgegebener Alert|] -- For testing alert handling when short circuiting; for proper (not fallback-solution) handling always use `tell` within `formResultModal` diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index f649c0e75..dec5b8998 100644 --- a/src/Handler/Exam.hs +++ b/src/Handler/Exam.hs @@ -1048,21 +1048,14 @@ postERegisterR tid ssh csh examn = do now <- liftIO getCurrentTime insert_ $ ExamRegistration eId uid Nothing now audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent - addMessageWidget Success [whamlet| -
#{iconExamRegister True} -
  -
_{MsgExamRegisteredSuccess examn} - |] + addMessageIconI Success IconExamRegisterTrue (MsgExamRegisteredSuccess examn) redirect $ CExamR tid ssh csh examn EShowR BtnExamDeregister -> do runDB $ do deleteBy $ UniqueExamRegistration eId uid audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent - addMessageWidget Info [whamlet| -
#{iconExamRegister False} -
  -
_{MsgExamDeregisteredSuccess examn} - |] -- yes, it's a success message, but it should be visually different from a positive success, since most will just note the positive green color! See discussion on commit 5f4925a4 + addMessageIconI Info IconExamRegisterFalse (MsgExamDeregisteredSuccess examn) + -- yes, it's a success message, but it should be visually different from a positive success, since most will just note the positive green color! See discussion on commit 5f4925a4 redirect $ CExamR tid ssh csh examn EShowR invalidArgs ["Register/Deregister button required"] diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index cd1bd66c2..a8be4118c 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -3,7 +3,7 @@ module Import.NoModel , MForm ) where -import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, cons, HasHttpManager(..)) +import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, getMessages, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, cons, HasHttpManager(..)) import Model.Types.TH.JSON as Import import Model.Types.TH.Wordlist as Import @@ -53,7 +53,7 @@ import Data.Ratio as Import ((%)) import Net.IP as Import (IP) import Database.Persist.Sql as Import (SqlReadT, SqlWriteT, fromSqlKey, toSqlKey) - + import Ldap.Client.Pool as Import import System.Random as Import (Random(..)) @@ -70,7 +70,7 @@ import Data.Time.LocalTime as Import hiding (utcToLocalTime, localTimeToUTC) import Time.Types as Import (WeekDay(..)) import Network.Mime as Import - + import Data.Aeson.TH as Import import Data.Aeson.Types as Import (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), toJSONKeyText, FromJSONKeyFunction(..), ToJSONKeyFunction(..), Value) diff --git a/src/Utils.hs b/src/Utils.hs index 11db44ba0..62d957e78 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -80,7 +80,7 @@ import Algebra.Lattice (top, bottom, (/\), (\/), BoundedJoinSemiLattice, Bounded import Data.Constraint (Dict(..)) -{- # ANN choice ("HLint: ignore Use asum" :: String) # -} +{-# ANN module ("HLint: ignore Use asum" :: String) #-} $(iconShortcuts) -- declares constants for all known icons @@ -114,6 +114,10 @@ unsupportedAuthPredicate = do unauthorizedI (UnsupportedAuthPredicate (toPathPiece tag) route) |] +-- | allows conditional attributes in hamlet via *{..} syntax +maybeAttribute :: Text -> (a -> Text) -> Maybe a -> [(Text,Text)] +maybeAttribute _ _ Nothing = [] +maybeAttribute a c (Just v) = [(a,c v)] --------------------- diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index ecbf65f1a..a888efb29 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -742,13 +742,14 @@ wformMessage = void . aFormToWForm . aformMessage formMessage :: (MonadHandler m) => Message -> MForm m (FormResult (), FieldView site) formMessage Message{..} = do + let icn = maybeAttribute "data-icon" iconJS messageIcon return (FormSuccess (), FieldView { fvLabel = mempty , fvTooltip = Nothing , fvId = idFormMessageNoinput , fvErrors = Nothing , fvRequired = False - , fvInput = [whamlet|
#{messageContent}|] + , fvInput = [whamlet|
#{messageContent}|] }) --------------------- diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 09299e310..4d9dd168d 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -1,6 +1,6 @@ module Utils.Icon where -import ClassyPrelude.Yesod hiding (foldlM, Proxy) +import ClassyPrelude.Yesod hiding (Proxy) import Data.Universe import Data.Char @@ -12,6 +12,8 @@ import Language.Haskell.TH import Language.Haskell.TH.Instances () import Language.Haskell.TH.Lift (deriveLift) import Instances.TH.Lift () +import Data.Aeson +import Data.Aeson.TH -- | A @Widget@ for any site; no language interpolation, etc. type WidgetSiteless = forall site. forall m. (MonadIO m, MonadThrow m, MonadBaseControl IO m) @@ -23,8 +25,10 @@ type WidgetSiteless = forall site. forall m. (MonadIO m, MonadThrow m, MonadBase ----------- -- We collect all used icons here for an overview. -- For consistency, some conditional icons are also provided, having suffix True/False --- IMPORTANT: Alert-Icons must be registered in alert-icons.js as well +--------------------------------------------------------------------------- +-- IMPORTANT: Alert-Icons must be registered in alert-icons.js as well!!! +--------------------------------------------------------------------------- data Icon = IconNew | IconOK @@ -48,7 +52,7 @@ data Icon | IconSFTHint -- for SheetFileType only | IconSFTSolution -- for SheetFileType only | IconSFTMarking -- for SheetFileType only - deriving (Eq, Enum, Bounded, Show, Read) + deriving (Eq, Ord, Enum, Bounded, Show, Read) iconText :: Icon -> Text iconText = \case @@ -75,11 +79,19 @@ iconText = \case IconSFTSolution -> "exclamation-circle" -- for SheetFileType only IconSFTMarking -> "check-circle" -- for SheetFileType only +-- | like iconText, but eliminates '-' since these are problemativ in alert-icons.js +iconJS :: Icon -> Text +iconJS = filter ('-' /=) . iconText + instance Universe Icon instance Finite Icon nullaryPathPiece ''Icon $ camelToPathPiece' 1 deriveLift ''Icon +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + } ''Icon + -- Create an icon from font-awesome without additional space icon :: Icon -> Markup icon ic = let ict = iconText ic in @@ -93,11 +105,10 @@ iconShortcuts = foldMap mkIcon (universeF :: [Icon]) where mkIcon :: Icon -> Q [Dec] mkIcon ic = do - do - iname <- newName $ over (ix 0) Data.Char.toLower $ show ic - isig <- sigD iname [t|Markup|] - idef <- valD (varP iname) (normalB [|icon ic|]) [] - return $ [isig, idef] + iname <- newName $ over (ix 0) Data.Char.toLower $ show ic + isig <- sigD iname [t|Markup|] + idef <- valD (varP iname) (normalB [|icon ic|]) [] + return [isig, idef] ---------------------- @@ -140,7 +151,7 @@ iconEnrol False = icon IconEnrolFalse iconExamRegister :: Bool -> Markup iconExamRegister True = icon IconExamRegisterTrue -iconExamRegister False = icon IconExamRegisterTrue +iconExamRegister False = icon IconExamRegisterFalse ---------------- diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs index c4153b17d..4302dac79 100644 --- a/src/Utils/Message.hs +++ b/src/Utils/Message.hs @@ -1,19 +1,23 @@ module Utils.Message - ( MessageStatus(..) + ( MessageStatus(..), MessageIconStatus(..) , UnknownMessageStatus(..) + , getMessages + , addMessage',addMessageIcon, addMessageIconI -- messages with special icons (needs registering in alert-icons.js) , addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget , statusToUrgencyClass , Message(..) , messageI, messageIHamlet, messageFile, messageWidget + , encodeMessageIconStatus, decodeMessageIconStatus, decodeMessageIconStatus' ) where import Data.Universe +import Utils.Icon import Utils.PathPiece import Data.Aeson import Data.Aeson.TH -import qualified ClassyPrelude.Yesod (addMessage, addMessageI) -import ClassyPrelude.Yesod hiding (addMessage, addMessageI) +import qualified ClassyPrelude.Yesod (addMessage, addMessageI, getMessages) +import ClassyPrelude.Yesod hiding (addMessage, addMessageI, getMessages) import Text.Hamlet @@ -28,8 +32,11 @@ import Text.HTML.SanitizeXSS (sanitizeBalance) data MessageStatus = Error | Warning | Info | Success deriving (Eq, Ord, Enum, Bounded, Show, Read, Lift) + instance Universe MessageStatus instance Finite MessageStatus +instance Default MessageStatus where + def = Info deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece @@ -43,11 +50,52 @@ newtype UnknownMessageStatus = UnknownMessageStatus Text instance Exception UnknownMessageStatus +-- ms2mis :: MessageStatus -> MessageIconStatus +-- ms2mis s = def { misStatus= s} + +data MessageIconStatus = MIS { misStatus :: MessageStatus, misIcon :: Maybe Icon } + deriving (Eq, Ord, Show, Read, Lift) + +instance Default MessageIconStatus where + def = MIS { misStatus=def, misIcon=Nothing } + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''MessageIconStatus + +encodeMessageStatus :: MessageStatus -> Text +encodeMessageStatus ms = encodeMessageIconStatus $ def{ misStatus=ms } + +encodeMessageIconStatus :: MessageIconStatus -> Text +encodeMessageIconStatus = decodeUtf8 . toStrict . encode + +decodeMessageIconStatus :: Text -> Maybe MessageIconStatus +decodeMessageIconStatus = decode' . fromStrict . encodeUtf8 + +decodeMessageIconStatus' :: Text -> MessageIconStatus +decodeMessageIconStatus' t + | Just mis <- decodeMessageIconStatus t = mis + | otherwise = def + +decodeMessage :: (Text, Html) -> Message +decodeMessage (mis, msgContent) + | Just MIS{ misStatus=messageStatus, misIcon=messageIcon } <- decodeMessageIconStatus mis + = let messageContent = msgContent in Message{..} + | Just messageStatus <- fromPathPiece mis + = let messageIcon = Nothing -- legacy case, should no longer occur ($logDebug ???) + messageContent = msgContent <> "!!!" + in Message{..} + | otherwise -- should not happen, if refactored correctly ($logDebug ???) + = let messageStatus = Utils.Message.Warning + messageContent = msgContent <> "!!!!" + messageIcon = Nothing + in Message{..} + data Message = Message - { messageStatus :: MessageStatus + { messageStatus :: MessageStatus , messageContent :: Html - -- , messageIcon :: Maybe Icon + , messageIcon :: Maybe Icon } instance Eq Message where @@ -60,26 +108,39 @@ instance ToJSON Message where toJSON Message{..} = object [ "status" .= messageStatus , "content" .= renderHtml messageContent + , "icon" .= messageIcon ] instance FromJSON Message where parseJSON = withObject "Message" $ \o -> do messageStatus <- o .: "status" messageContent <- preEscapedText . sanitizeBalance <$> o .: "content" + messageIcon <- o .: "icon" return Message{..} statusToUrgencyClass :: MessageStatus -> Text statusToUrgencyClass status = "urgency__" <> toPathPiece status +addMessage' :: MonadHandler m => Message -> m () +addMessage' Message{..} = ClassyPrelude.Yesod.addMessage (encodeMessageIconStatus mis) messageContent + where mis = MIS{misStatus=messageStatus, misIcon=messageIcon} + +addMessageIcon :: MonadHandler m => MessageStatus -> Icon -> Html -> m () +addMessageIcon ms mi = ClassyPrelude.Yesod.addMessage $ encodeMessageIconStatus MIS{misStatus=ms, misIcon=Just mi} + +addMessageIconI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageStatus -> Icon -> msg -> m () +addMessageIconI ms mi = ClassyPrelude.Yesod.addMessageI $ encodeMessageIconStatus MIS{misStatus=ms, misIcon=Just mi} + addMessage :: MonadHandler m => MessageStatus -> Html -> m () -addMessage mc = ClassyPrelude.Yesod.addMessage (toPathPiece mc) +addMessage mc = ClassyPrelude.Yesod.addMessage $ encodeMessageStatus mc addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageStatus -> msg -> m () -addMessageI mc = ClassyPrelude.Yesod.addMessageI (toPathPiece mc) +addMessageI mc = ClassyPrelude.Yesod.addMessageI $ encodeMessageStatus mc messageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageStatus -> msg -> m Message messageI messageStatus msg = do messageContent <- toHtml . ($ msg) <$> getMessageRender + let messageIcon = Nothing return Message{..} addMessageIHamlet :: ( MonadHandler m @@ -88,15 +149,16 @@ addMessageIHamlet :: ( MonadHandler m ) => MessageStatus -> HtmlUrlI18n msg (Route site) -> m () addMessageIHamlet mc iHamlet = do mr <- getMessageRender - ClassyPrelude.Yesod.addMessage (toPathPiece mc) =<< withUrlRenderer (iHamlet $ toHtml . mr) + ClassyPrelude.Yesod.addMessage (encodeMessageStatus mc) =<< withUrlRenderer (iHamlet $ toHtml . mr) messageIHamlet :: ( MonadHandler m , RenderMessage (HandlerSite m) msg , HandlerSite m ~ site ) => MessageStatus -> HtmlUrlI18n msg (Route site) -> m Message -messageIHamlet mc iHamlet = do +messageIHamlet ms iHamlet = do mr <- getMessageRender - Message mc <$> withUrlRenderer (iHamlet $ toHtml . mr) + let mi = Nothing + Message ms <$> withUrlRenderer (iHamlet $ toHtml . mr) <*> pure mi addMessageFile :: MessageStatus -> FilePath -> ExpQ addMessageFile mc tPath = [e|addMessageIHamlet mc $(ihamletFile tPath)|] @@ -123,3 +185,9 @@ messageWidget :: forall m site. messageWidget mc wgt = do PageContent{pageBody} <- liftHandlerT $ widgetToPageContent wgt messageIHamlet mc (const pageBody :: HtmlUrlI18n (SomeMessage site) (Route site)) + + +getMessages :: MonadHandler m => m [Message] +getMessages = fmap decodeMessage <$> ClassyPrelude.Yesod.getMessages + + diff --git a/templates/widgets/alerts/alerts.hamlet b/templates/widgets/alerts/alerts.hamlet index 8ddc0f6cd..0dd303f8a 100644 --- a/templates/widgets/alerts/alerts.hamlet +++ b/templates/widgets/alerts/alerts.hamlet @@ -1,15 +1,15 @@ $newline never
- $forall (status, msg) <- mmsgs - $with status2 <- bool status "info" (status == "") - -
+ $forall Message{..} <- mmsgs + $with icn <- maybeAttribute "data-icon" iconJS messageIcon +
- #{msg} + #{messageContent} +