96 lines
3.0 KiB
Haskell
96 lines
3.0 KiB
Haskell
module Utils.Message
|
|
( MessageClass(..)
|
|
, UnknownMessageClass(..)
|
|
, Message(..)
|
|
, addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget
|
|
) 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 MessageClass = Error | Warning | Info | Success
|
|
deriving (Eq, Ord, Enum, Bounded, Show, Read, Lift)
|
|
|
|
instance Universe MessageClass
|
|
instance Finite MessageClass
|
|
|
|
deriveJSON defaultOptions
|
|
{ constructorTagModifier = camelToPathPiece
|
|
} ''MessageClass
|
|
|
|
nullaryPathPiece ''MessageClass camelToPathPiece
|
|
derivePersistField "MessageClass"
|
|
|
|
data UnknownMessageClass = UnknownMessageClass !Text
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
instance Exception UnknownMessageClass
|
|
|
|
|
|
data Message = Message
|
|
{ messageClass :: MessageClass
|
|
, messageContent :: Html
|
|
}
|
|
|
|
instance Eq Message where
|
|
a == b = ((==) `on` messageClass) a b && ((==) `on` renderHtml . messageContent) a b
|
|
|
|
instance Ord Message where
|
|
a `compare` b = (compare `on` messageClass) a b `mappend` (compare `on` renderHtml . messageContent) a b
|
|
|
|
instance ToJSON Message where
|
|
toJSON Message{..} = object
|
|
[ "class" .= messageClass
|
|
, "content" .= renderHtml messageContent
|
|
]
|
|
|
|
instance FromJSON Message where
|
|
parseJSON = withObject "Message" $ \o -> do
|
|
messageClass <- o .: "class"
|
|
messageContent <- preEscapedText . sanitizeBalance <$> o .: "content"
|
|
return Message{..}
|
|
|
|
|
|
addMessage :: MonadHandler m => MessageClass-> Html -> m ()
|
|
addMessage mc = ClassyPrelude.Yesod.addMessage (toPathPiece mc)
|
|
|
|
addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageClass -> msg -> m ()
|
|
addMessageI mc = ClassyPrelude.Yesod.addMessageI (toPathPiece mc)
|
|
|
|
addMessageIHamlet :: ( MonadHandler m
|
|
, RenderMessage (HandlerSite m) msg
|
|
, HandlerSite m ~ site
|
|
) => MessageClass -> HtmlUrlI18n msg (Route site) -> m ()
|
|
addMessageIHamlet mc iHamlet = do
|
|
mr <- getMessageRender
|
|
ClassyPrelude.Yesod.addMessage (toPathPiece mc) =<< withUrlRenderer (iHamlet $ toHtml . mr)
|
|
|
|
addMessageFile :: MessageClass -> FilePath -> ExpQ
|
|
addMessageFile mc tPath = [e|addMessageIHamlet mc $(ihamletFile tPath)|]
|
|
|
|
addMessageWidget :: forall m site.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ site
|
|
, Yesod site
|
|
) => MessageClass -> WidgetT site IO () -> m ()
|
|
-- ^ _Note_: `addMessageWidget` ignores `pageTitle` and `pageHead`
|
|
addMessageWidget mc wgt = do
|
|
PageContent{pageBody} <- liftHandlerT $ widgetToPageContent wgt
|
|
addMessageIHamlet mc (const pageBody :: HtmlUrlI18n (SomeMessage site) (Route site))
|