{-# LANGUAGE CPP                      #-}
{-# LANGUAGE LambdaCase               #-}
{-# LANGUAGE NamedFieldPuns           #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE ViewPatterns             #-}
module ToxToXMPP where

import Control.Monad
import Crypto.Tox
import Data.Conduit                 as C
import qualified Data.Conduit.List  as CL
import Data.Function
import Data.Monoid
import qualified Data.Text          as T
         ;import Data.Text          (Text)
import Data.Text.Encoding           as T
import Data.Word
import Data.XML.Types               as XML
import EventUtil
import Network.Address
import Network.Tox.Crypto.Transport as Tox hiding (UserStatus (..))
import Network.Tox.NodeId
import Util                         (unsplitJID)
import XMPPServer                   as XMPP

available :: StanzaType
available = PresenceStatus { presenceShow      = Available
                           , presencePriority  = Nothing
                           , presenceStatus    = []
                           , presenceWhiteList = []
                           }

xmppHostname :: PublicKey -> Text
xmppHostname k = T.pack $ show (key2id k) ++ ".tox"

toxUserStatus :: Word8 -> JabberShow
toxUserStatus 0 = Available
toxUserStatus 1 = Away
toxUserStatus 2 = DoNotDisturb
toxUserStatus _ = Away -- Default, shouldn't occur.

toxToXmpp :: Monad m => SockAddr -> PublicKey -> Text -> ConduitM Tox.CryptoMessage XML.Event m ()
toxToXmpp laddr me theirhost = do
    CL.sourceList $ XMPP.greet' "jabber:server" theirhost
    let me_u    = Nothing
        me_h    = xmppHostname me
        im_from = (Just $ unsplitJID (Nothing, theirhost, Nothing)) -- /from/
        im_to   = (Just $ unsplitJID
                            ( me_u
                            -- /to/ should match local address of this node.
                            , me_h
                            , Nothing))
    let
      statelessMessages = \case

        UpToN MESSAGE bs ->
            xmppInstantMessage "jabber:server" im_from im_to [] (T.decodeUtf8 bs)

        TwoByte TYPING st -> xmppTyping "jabber:server" im_from im_to st

        UpToN NICKNAME bs ->
            xmppInstantMessage "jabber:server" im_from im_to
                [ attr "style" "font-weight:bold; color:red" ]
                ("NICKNAME(todo) " <> T.decodeUtf8 bs)

        toxmsg | msgID toxmsg == PacketRequest -> return ()

        toxmsg -> do
            xmppInstantMessage "jabber:server" im_from im_to
                [ attr "style" "font-weight:bold; color:red" ]
                (T.pack $ "Unhandled message: " ++ show (msgID toxmsg))

    flip fix available $ \loop status -> do
        let go (TwoByte USERSTATUS st) = do
                let status' = status { presenceShow = toxUserStatus st }
                xmppPresence "jabber:server" im_from status'
                loop status'

            go (UpToN STATUSMESSAGE bs) = do
                let status' = status { presenceStatus = [("",T.decodeUtf8 bs)] }
                xmppPresence "jabber:server" im_from status'
                loop status'

            go (OneByte ONLINE) = do
                xmppPresence "jabber:server" im_from status
                loop status

            go x = do
                statelessMessages x
                loop status
        await >>= mapM_ go

xmppPresence :: Monad m => Text -> Maybe Text -> StanzaType -> ConduitM i XML.Event m ()
xmppPresence namespace mjid p = do
    let ns n = n { nameNamespace = Just namespace }
        setFrom = maybe id
                        (\jid -> (attr "from" jid :) )
                        mjid
        typ Offline = [attr "type" "unavailable"]
        typ _       = []
        shw ExtendedAway = ["xa"]
        shw Chatty       = ["chat"]
        shw Away         = ["away"]
        shw DoNotDisturb = ["dnd"]
        shw _            = []
        jabberShow stat =
          [ EventBeginElement "{jabber:client}show" []
          , EventContent (ContentText stat)
          , EventEndElement "{jabber:client}show" ]
    C.yield       $ EventBeginElement (ns "presence") (setFrom $ typ $ presenceShow p)
    mapM_ C.yield $ shw (presenceShow p) >>= jabberShow
    forM_ (presencePriority p) $ \prio -> do
        C.yield   $ EventBeginElement (ns "priority") []
        C.yield   $   EventContent $ ContentText (T.pack $ show prio)
        C.yield   $ EventEndElement (ns "priority")
    forM_ (presenceStatus p) $ \(lang,txt) -> do
        let atts | T.null lang = []
                 | otherwise   = [ ("xml:lang", [ContentText lang]) ]
        C.yield   $ EventBeginElement (ns "status") atts
        C.yield   $   EventContent $ ContentText txt
        C.yield   $ EventEndElement (ns "status")
    C.yield       $ EventEndElement (ns "presence")

xmppTyping :: Monad m => Text
                              -> Maybe Text
                              -> Maybe Text
                              -> Word8
                              -> ConduitM i XML.Event m ()
xmppTyping namespace mfrom mto x =
    let ns n = n { nameNamespace = Just namespace }
        st = case x of
            0 -> "{http://jabber.org/protocol/chatstates}active"
            1 -> "{http://jabber.org/protocol/chatstates}composing"
            -- tox-core supports only 0 and 1
            _ -> "{http://jabber.org/protocol/chatstates}paused"
    in mapM_ C.yield
        [ EventBeginElement (ns "message")
               (  maybe id (\t->(attr "from" t:)) mfrom
                $ maybe id (\t->(attr "to" t:)) mto
                $ [attr "type" "chat" ] )
        , EventBeginElement st []
        , EventEndElement st
        , EventEndElement (ns "message")
        ]

xmppInstantMessage :: Monad m => Text
                              -> Maybe Text
                              -> Maybe Text
                              -> [(Name, [Content])]
                              -> Text
                              -> ConduitM i XML.Event m ()
xmppInstantMessage namespace mfrom mto style text = do
    let ns n = n { nameNamespace = Just namespace }
    C.yield $ EventBeginElement (ns "message")
               (  maybe id (\t->(attr "from" t:)) mfrom
                $ maybe id (\t->(attr "to" t:)) mto
                $ [attr "type" "normal" ] )
    C.yield $   EventBeginElement (ns "body") []
    C.yield $     EventContent $ ContentText text
    C.yield $   EventEndElement (ns "body")
    C.yield $   EventBeginElement "{http://jabber.org/protocol/xhtml-im}html" []
    C.yield $     EventBeginElement "{http://www.w3.org/1999/xhtml}body" []
    C.yield $        EventBeginElement "{http://www.w3.org/1999/xhtml}p" style
    C.yield $          EventContent $ ContentText text
    C.yield $        EventEndElement "{http://www.w3.org/1999/xhtml}p"
    C.yield $     EventEndElement "{http://www.w3.org/1999/xhtml}body"
    C.yield $   EventEndElement "{http://jabber.org/protocol/xhtml-im}html"
    C.yield $ EventEndElement (ns "message")