{-# LANGUAGE CPP                      #-}
{-# LANGUAGE GADTs                    #-}
{-# 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.Dependent.Sum
import Data.Function
import Data.Functor.Identity
import Data.Monoid
import qualified Data.Text          as T
         ;import Data.Text          (Text)
import Data.Text.Encoding           as T
import Data.Tox.Msg                 as Tox
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 :: UserStatus -> JabberShow
toxUserStatus Online   = Available
toxUserStatus Tox.Away = XMPP.Away
toxUserStatus Busy     = DoNotDisturb
toxUserStatus _        = XMPP.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

        Pkt MESSAGE :=> Identity bs ->
            xmppInstantMessage "jabber:server" im_from im_to [] bs

        Pkt TYPING :=> Identity st  -> xmppTyping "jabber:server" im_from im_to st

        Pkt NICKNAME :=> Identity bs ->
            xmppInstantMessage "jabber:server" im_from im_to
                [ attr "style" "font-weight:bold; color:red" ]
                ("NICKNAME(todo) " <> bs)

        toxmsg | msgID toxmsg == M 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 (Pkt USERSTATUS :=> Identity st) = do
                let status' = status { presenceShow = toxUserStatus st }
                xmppPresence "jabber:server" im_from status'
                loop status'

            go (Pkt STATUSMESSAGE :=> Identity bs) = do
                let status' = status { presenceStatus = [("",bs)] }
                xmppPresence "jabber:server" im_from status'
                loop status'

            go (Pkt 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 XMPP.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
                              -> Bool
                              -> ConduitM i XML.Event m ()
xmppTyping namespace mfrom mto x =
    let ns n = n { nameNamespace = Just namespace }
        st = case x of
            False -> "{http://jabber.org/protocol/chatstates}active"
            True  -> "{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")