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