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