125 lines
4.3 KiB
Haskell
125 lines
4.3 KiB
Haskell
module Utils.Message
|
|
( MessageStatus(..)
|
|
, UnknownMessageStatus(..)
|
|
, addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget
|
|
, statusToUrgencyClass
|
|
, Message(..)
|
|
, messageI, messageIHamlet, messageFile, messageWidget
|
|
) where
|
|
|
|
import Data.Universe
|
|
import Utils.PathPiece
|
|
import Data.Aeson
|
|
import Data.Aeson.TH
|
|
|
|
import qualified ClassyPrelude.Yesod (addMessage, addMessageI)
|
|
import ClassyPrelude.Yesod hiding (addMessage, addMessageI)
|
|
|
|
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
|
|
|
|
deriveJSON defaultOptions
|
|
{ constructorTagModifier = camelToPathPiece
|
|
} ''MessageStatus
|
|
|
|
nullaryPathPiece ''MessageStatus camelToPathPiece
|
|
derivePersistField "MessageStatus"
|
|
|
|
newtype UnknownMessageStatus = UnknownMessageStatus Text
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
instance Exception UnknownMessageStatus
|
|
|
|
|
|
data Message = Message
|
|
{ messageStatus :: MessageStatus
|
|
, messageContent :: Html
|
|
}
|
|
|
|
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
|
|
]
|
|
|
|
instance FromJSON Message where
|
|
parseJSON = withObject "Message" $ \o -> do
|
|
messageStatus <- o .: "status"
|
|
messageContent <- preEscapedText . sanitizeBalance <$> o .: "content"
|
|
return Message{..}
|
|
|
|
statusToUrgencyClass :: MessageStatus -> Text
|
|
statusToUrgencyClass status = "urgency__" <> toPathPiece status
|
|
|
|
addMessage :: MonadHandler m => MessageStatus -> Html -> m ()
|
|
addMessage mc = ClassyPrelude.Yesod.addMessage (toPathPiece mc)
|
|
|
|
addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageStatus -> msg -> m ()
|
|
addMessageI mc = ClassyPrelude.Yesod.addMessageI (toPathPiece mc)
|
|
|
|
messageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageStatus -> msg -> m Message
|
|
messageI messageStatus 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 (toPathPiece 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
|
|
mr <- getMessageRender
|
|
Message mc <$> withUrlRenderer (iHamlet $ toHtml . mr)
|
|
|
|
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 -> WidgetT site IO () -> 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} <- liftHandlerT $ widgetToPageContent wgt
|
|
addMessageIHamlet mc (const pageBody :: HtmlUrlI18n (SomeMessage site) (Route site))
|
|
|
|
messageWidget :: forall m site.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ site
|
|
, Yesod site
|
|
) => MessageStatus -> WidgetT site IO () -> m Message
|
|
messageWidget mc wgt = do
|
|
PageContent{pageBody} <- liftHandlerT $ widgetToPageContent wgt
|
|
messageIHamlet mc (const pageBody :: HtmlUrlI18n (SomeMessage site) (Route site))
|