{-# LANGUAGE CPP #-}
module Stanza.Build where

import Control.Monad
import Control.Concurrent.STM
import Data.Maybe
import Data.Text (Text)
import Data.XML.Types as XML

#ifdef THREAD_DEBUG
import Control.Concurrent.Lifted.Instrument
#else
import Control.Concurrent
import GHC.Conc (labelThread)
#endif

import EventUtil
import LockedChan
import Stanza.Types

makeMessage :: Text -> Text -> Text -> Text -> IO Stanza
makeMessage namespace from to bod = makeMessageEx namespace from to NormalMsg bod

makeMessageEx :: Text -> Text -> Text -> MessageType -> Text -> IO Stanza
makeMessageEx namespace from to msgtyp bod =
    stanzaFromList typ
     $ [ EventBeginElement (mkname namespace "message")
            $ addMessageType msgtyp
                [ attr "from" from
                , attr "to" to
                ]
       , EventBeginElement (mkname namespace "body") []
       , EventContent (ContentText bod)
       , EventEndElement (mkname namespace "body")
       , EventEndElement (mkname namespace "message") ]
 where
    typ = Message { msgThread  = Nothing
                  , msgLangMap = [("", lsm)]
                  , msgType    = msgtyp
                  }
    lsm = LangSpecificMessage
            { msgBody    = Just bod
            , msgSubject = Nothing }

addMessageType ChatMsg      attrs = ("type",[ContentText "chat"]) : attrs
addMessageType GroupChatMsg attrs = ("type",[ContentText "groupchat"]) : attrs
addMessageType HeadlineMsg  attrs = ("type",[ContentText "headline"]) : attrs
addMessageType _            attrs = attrs

makeInformSubscription :: Text -> Text -> Text -> Bool -> IO Stanza
makeInformSubscription namespace from to approved =
    stanzaFromList (PresenceInformSubscription approved)
      $ [ EventBeginElement (mkname namespace "presence")
            [ attr "from" from
            , attr "to" to
            , attr "type" $ if approved then "subscribed"
                                        else "unsubscribed" ]
        , EventEndElement (mkname namespace "presence")]

makePresenceStanza :: Text -> Maybe Text -> JabberShow -> IO Stanza
makePresenceStanza ns mjid pstat = makePresenceStanzaEx ns mjid pstat []

makePresenceStanzaEx :: Text -> Maybe Text -> JabberShow -> [XML.Event]-> IO Stanza
makePresenceStanzaEx namespace mjid pstat es = do
    stanzaFromList PresenceStatus { presenceShow = pstat
                                  , presencePriority = Nothing
                                  , presenceStatus = []
                                  , presenceWhiteList = []
                                  }
      $ [ EventBeginElement (mkname namespace "presence")
            (setFrom $ typ pstat) ]
        ++ (shw pstat >>= jabberShow) ++ es ++
        [ EventEndElement (mkname namespace "presence")]
 where
    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" ]

makeRosterUpdate :: Text -> Text -> [(Name, Text)] -> IO Stanza
makeRosterUpdate tojid contact as = do
    let attrs = map (uncurry attr) as
    stanzaFromList Unrecognized
      [ EventBeginElement "{jabber:client}iq"
            [ attr "to"   tojid
            , attr "id"   "someid"
            , attr "type" "set"
            ]
      , EventBeginElement "{jabber:iq:roster}query" []
      , EventBeginElement "{jabber:iq:roster}item" (attr "jid" contact : attrs)
      , EventEndElement   "{jabber:iq:roster}item"
      , EventEndElement   "{jabber:iq:roster}query"
      , EventEndElement "{jabber:client}iq"
      ]

makePong :: Text -> Maybe Text -> Text -> Text -> [XML.Event]
makePong namespace mid to from =
       -- Note: similar to session reply
       [ EventBeginElement (mkname namespace "iq")
         $(case mid of
               Just c -> (("id",[ContentText c]):)
               _      -> id)
               [ attr "type" "result"
               , attr "to"   to
               , attr "from" from
               ]
       , EventEndElement (mkname namespace "iq")
       ]


mkname :: Text -> Text -> XML.Name
mkname namespace name = (Name name (Just namespace) Nothing)


stanzaFromList :: StanzaType -> [Event] -> IO Stanza
stanzaFromList stype reply = do
    let stanzaTag = listToMaybe reply
        mid   = stanzaTag >>= lookupAttrib "id" . tagAttrs
        mfrom = stanzaTag >>= lookupAttrib "from" . tagAttrs
        mto = stanzaTag >>= lookupAttrib "to" . tagAttrs
        {-
        isInternal (InternalEnableHack {}) = True
        isInternal (InternalCacheId {})    = True
        isInternal _                       = False
        -}
    (donevar,replyChan,replyClsrs) <- atomically $ do
        donevar <- newEmptyTMVar -- TMVar ()
        replyChan <- newLockedChan
        replyClsrs <- newTVar (Just [])
        return (donevar,replyChan, replyClsrs)
    t <- forkIO $ do
        forM_ reply $ atomically . writeLChan replyChan
        atomically $ do putTMVar donevar ()
                        writeTVar replyClsrs Nothing
    labelThread t $ concat $ "stanza." : take 1 (words $ show stype)
    return Stanza { stanzaType      = stype
                  , stanzaId        = mid
                  , stanzaTo        = mto   -- as-is from reply list
                  , stanzaFrom      = mfrom -- as-is from reply list
                  , stanzaChan      = replyChan
                  , stanzaClosers   = replyClsrs
                  , stanzaInterrupt = donevar
                  , stanzaOrigin    = LocalPeer
                  }