module Utils.Message
  ( MessageClass(..)
  , UnknownMessageClass(..)
  , addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget
  , 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 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"

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

messageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageClass -> msg -> m Message
messageI messageClass msg = do
  messageContent <- toHtml . ($ msg) <$> getMessageRender
  return Message{..}

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)

messageIHamlet :: ( MonadHandler m
                  , RenderMessage (HandlerSite m) msg
                  , HandlerSite m ~ site
                  ) => MessageClass -> HtmlUrlI18n msg (Route site) -> m Message
messageIHamlet mc iHamlet = do
  mr <- getMessageRender
  Message mc <$> withUrlRenderer (iHamlet $ toHtml . mr)

addMessageFile :: MessageClass -> FilePath -> ExpQ
addMessageFile mc tPath = [e|addMessageIHamlet mc $(ihamletFile tPath)|]

messageFile :: MessageClass -> FilePath -> ExpQ
messageFile mc tPath = [e|messageIHamlet 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))

messageWidget :: forall m site.
                 ( MonadHandler m
                 , HandlerSite m ~ site
                 , Yesod site
                 ) => MessageClass -> WidgetT site IO () -> m Message
messageWidget mc wgt = do
  PageContent{pageBody} <- liftHandlerT $ widgetToPageContent wgt
  messageIHamlet mc (const pageBody :: HtmlUrlI18n (SomeMessage site) (Route site))
