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

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

toxToXmpp :: Monad m => SockAddr -> PublicKey -> Text -> Conduit Tox.CryptoMessage m XML.Event
toxToXmpp laddr me theirhost = do
    CL.sourceList $ XMPP.greet' "jabber:server" theirhost
    let me_u = T.pack $ show (key2id me)
    awaitForever $ \case

        UpToN { msgID    = MESSAGE
              , msgBytes = bs      }
               -> do
            xmppInstantMessage "jabber:server"
                (Just $ "root@" <> theirhost)      -- /from/
                (Just $ unsplitJID (Just me_u,T.pack (show laddr),Nothing)) -- /to/ should match local address of this node.
                []
                (T.decodeUtf8 bs)

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

        toxmsg -> do
            xmppInstantMessage "jabber:server"
                (Just theirhost)      -- /from/
                (Just $ unsplitJID (Just me_u,T.pack (show laddr),Nothing)) -- /to/ should match local address of this node.
                [ attr "style" "font-weight:bold; color:red" ]
                (T.pack $ show $ msgID toxmsg)

xmppInstantMessage :: Monad m => Text
                              -> Maybe Text
                              -> Maybe Text
                              -> [(Name, [Content])]
                              -> Text
                              -> ConduitM i 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")