-----------------------------------------------------------------------------
-- |
-- Module      :  Network.XMPP.Stanza
-- Copyright   :  (c) pierre, 2007
-- License     :  BSD-style (see the file libraries/base/LICENSE)
-- 
-- Maintainer  :  k.pierre.k@gmail.com
-- Stability   :  experimental
-- Portability :  portable
--
-- XMPP stanzas parsing 
--
-----------------------------------------------------------------------------

module Network.XMPP.Stanza
  (
    parse
  , parseM
  , outStanza
  ) where 

import Text.XML.HaXml.Xtract.Parse (xtract)

import Network.XMPP.Types
import Network.XMPP.Print
import Network.XMPP.Stream
import Network.XMPP.Utils

import Data.Maybe

-- | Parses XML element producing Stanza
parse :: XmppMessage -> Stanza
parse m | xtractp id "/message" m  = parseMessage m
        | xtractp id "/presence" m = parsePresence m
        | xtractp id "/iq" m       = parseIQ m
        | otherwise               = error "Can't read stanza"
 where
  xtractp f p m = not . null $ xtract f p m

-- | Gets next message from stream and parses it
parseM :: XmppStateT Stanza
parseM = do
  m <- nextM
  let pm = parse m in do
    debug $ "parseM: Got element: " ++ show pm
    return pm

parseMessage :: XmppMessage -> Stanza
parseMessage m = Message from to id' messageType subject body thread x
  where
    from = mread $ txt "/message/@from" m
    to = read $ getText_ $ xtract id "/message/@to" m
    id' = getText_ $ xtract id "/message/@id" m
    messageType = read $ getText_ $ xtract id "/message/@type" m
    subject = getText_ $ xtract id "/message/subject/-" m
    body = getText_ $ xtract id "/message/body/-" m
    thread = getText_ $ xtract id "/message/thread/-" m
    x = xtract id "/message/*" m

parsePresence :: XmppMessage -> Stanza
parsePresence m = Presence from to id' presenceType showType status priority x
  where
    from = mread $ txt "/presence/@from" m
    to = mread $ txt "/presence/@to" m
    id' = txt "/presence/@id" m
    presenceType = read $ txt "/presence/@type" m          
    showType = read $ txt "/presence/show/-" m
    status = txt "/presence/status/-" m
    priority = mread $ txt "/presence/priority/-" m
    x = xtract id "/presence/*" m

parseIQ :: XmppMessage -> Stanza
parseIQ m = IQ from to id' iqType body
  where
    from = mread $ txt "/iq/@from" m
    to = mread $ txt "/iq/@to" m
    id' = txt "/iq/@id" m
    iqType = read $ txt "/iq/@type" m
    body = [m]

-- | Extract text from `XmppMessage' with supplied pattern
txt :: String      -- ^ xtract-like pattern to match
    -> XmppMessage -- ^ message being processed
    -> String      -- ^ result of extraction
txt p m = getText_ $ xtract id p m

-- | Converts stanza to XML and outputs it 
outStanza :: Stanza -> XmppStateT ()
outStanza s = case s of
                a@(Message{}) -> outMessage a
                a@(Presence{}) -> outPresence a
                a@(IQ{}) -> outIQ a

outMessage :: Stanza -> XmppStateT ()
outMessage (Message from' to' id' mtype' subject' body' thread' x') =
    out $ toContent $ 
        ptag "message"
                ( (mattr "from" from') ++ 
                [ strAttr "to" (show to'),
                  strAttr "id" id',
                  strAttr "type" (show mtype'),
                  xmllang "en" ] )
                ([ ptag "body" [] [literal body'] ] ++
                 (if subject' /= "" then [ ptag "subject" [] [literal subject'] ] else []) ++                      
                 (if thread' /= "" then [ ptag "thread" [] [literal thread'] ] else []) ++
                 (map toFilter x'))
outMessage _ = error "Stanza isn't message"

outPresence :: Stanza -> XmppStateT ()
outPresence (Presence from' to' id' ptype' stype' status' priority' x') =
  out $ toContent $
      ptag "presence"
              ((mattr "from" from') ++
               (mattr "to" to') ++
               (if id' /= "" then [strAttr "id" id'] else []) ++
               (if ptype' /= Default then [strAttr "type" (show ptype')] else []) ++
               [xmllang "en" ])              
              ((if stype' /= Available then [ ptag "show" [] [literal $ show stype'] ] else []) ++
               (if status' /= "" then [ ptag "status" [] [ literal status' ] ]  else []) ++
               (if isJust priority' then [ ptag "priority" [] [ literal $ show (fromJust priority') ] ] else []) ++
               (map toFilter x'))
outPresence _ = error "Stanza isn't presence"

outIQ :: Stanza -> XmppStateT ()
outIQ (IQ from' to' id' itype' body') =
  out $ toContent $
      ptag "iq"
               ((mattr "from" from') ++
                (mattr "to" to') ++       
                [ strAttr "id" id',
                  sattr "type" (show itype'),
                  xmllang "en" ])
               (map toFilter body')               
outIQ _ = error "Stanza isn't IQ"