208 lines
8.1 KiB
Haskell
208 lines
8.1 KiB
Haskell
module Utils.Message
|
|
( MessageStatus(..)
|
|
-- , UnknownMessageStatus(..)
|
|
, getMessages
|
|
, addMessage',addMessageIcon, addMessageIconI -- messages with special icons (needs registering in alert-icons.js)
|
|
, addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget
|
|
, statusToUrgencyClass
|
|
, Message(..)
|
|
, messageIconI
|
|
, messageI, messageIHamlet, messageFile, messageWidget, messageTooltip
|
|
) where
|
|
|
|
import Data.Universe
|
|
import Utils.Icon
|
|
import Utils.PathPiece
|
|
import Data.Aeson
|
|
import Data.Aeson.TH
|
|
|
|
import qualified ClassyPrelude.Yesod (addMessage, addMessageI, getMessages)
|
|
import ClassyPrelude.Yesod hiding (addMessage, addMessageI, getMessages)
|
|
|
|
import Text.Hamlet
|
|
|
|
import Language.Haskell.TH
|
|
import Language.Haskell.TH.Syntax (Lift)
|
|
|
|
import Text.Blaze (preEscapedText)
|
|
import Text.Blaze.Html.Renderer.Text (renderHtml)
|
|
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
|
|
} ''MessageStatus
|
|
|
|
nullaryPathPiece ''MessageStatus camelToPathPiece
|
|
derivePersistField "MessageStatus"
|
|
|
|
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
|
|
, messageContent :: Html
|
|
, messageIcon :: Maybe Icon
|
|
}
|
|
|
|
instance Eq Message where
|
|
a == b = ((==) `on` messageStatus) a b && ((==) `on` renderHtml . messageContent) a b
|
|
|
|
instance Ord Message where
|
|
a `compare` b = (compare `on` messageStatus) a b `mappend` (compare `on` renderHtml . messageContent) a b
|
|
|
|
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 $ encodeMessageStatus mc
|
|
|
|
addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageStatus -> msg -> m ()
|
|
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{..}
|
|
|
|
messageIconI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageStatus -> Icon -> msg -> m Message
|
|
messageIconI messageStatus (Just -> messageIcon) msg = do
|
|
messageContent <- toHtml . ($ msg) <$> getMessageRender
|
|
return Message{..}
|
|
|
|
addMessageIHamlet :: ( MonadHandler m
|
|
, RenderMessage (HandlerSite m) msg
|
|
, HandlerSite m ~ site
|
|
) => MessageStatus -> HtmlUrlI18n msg (Route site) -> m ()
|
|
addMessageIHamlet mc iHamlet = do
|
|
mr <- getMessageRender
|
|
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 ms iHamlet = do
|
|
mr <- getMessageRender
|
|
let mi = Nothing
|
|
Message ms <$> withUrlRenderer (iHamlet $ toHtml . mr) <*> pure mi
|
|
|
|
addMessageFile :: MessageStatus -> FilePath -> ExpQ
|
|
addMessageFile mc tPath = [e|addMessageIHamlet mc $(ihamletFile tPath)|]
|
|
|
|
messageFile :: MessageStatus -> FilePath -> ExpQ
|
|
messageFile mc tPath = [e|messageIHamlet mc $(ihamletFile tPath)|]
|
|
|
|
addMessageWidget :: forall m site.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ site
|
|
, Yesod site
|
|
) => MessageStatus -> WidgetFor site () -> m ()
|
|
-- ^ _Note_: `addMessageWidget` ignores `pageTitle` and `pageHead`
|
|
-- also see Utils.Frontend.Modal.addMessageModal for large alerts with modal links
|
|
addMessageWidget mc wgt = do
|
|
PageContent{pageBody} <- liftHandler $ widgetToPageContent wgt
|
|
addMessageIHamlet mc (const pageBody :: HtmlUrlI18n (SomeMessage site) (Route site))
|
|
|
|
messageWidget :: forall m site.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ site
|
|
, Yesod site
|
|
) => MessageStatus -> WidgetFor site () -> m Message
|
|
messageWidget mc wgt = do
|
|
PageContent{pageBody} <- liftHandler $ widgetToPageContent wgt
|
|
messageIHamlet mc (const pageBody :: HtmlUrlI18n (SomeMessage site) (Route site))
|
|
|
|
|
|
getMessages :: MonadHandler m => m [Message]
|
|
getMessages = fmap decodeMessage <$> ClassyPrelude.Yesod.getMessages
|
|
|
|
messageTooltip :: forall site. Message -> WidgetFor site ()
|
|
messageTooltip Message{..} = let urgency = statusToUrgencyClass messageStatus
|
|
ic = iconText $ fromMaybe
|
|
(case messageStatus of
|
|
Utils.Message.Error -> IconProblem
|
|
Utils.Message.Warning -> IconWarning
|
|
Utils.Message.Success -> IconOK
|
|
Utils.Message.Info -> IconTooltipDefault)
|
|
messageIcon
|
|
tooltip = toWidget messageContent :: WidgetFor site ()
|
|
isInlineTooltip = False
|
|
in $(whamletFile "templates/widgets/tooltip.hamlet")
|