-- | Module:      $Header$
--   Description: A minimalistic and easy-to-use XMPP library
--   Copyright:   Copyright © 2010-2011 Jon Kristensen
--   License:     BSD-3
--   
--   Maintainer:  info@pontarius.org
--   Stability:   unstable
--   Portability: portable
--   
--   Pontarius XMPP aims to be a secure, concurrent/event-based and easy-to-use
--   XMPP library for Haskell. It is being actively developed.
--   
--   Note that we are not recommending anyone to use Pontarius XMPP at this time
--   as it's still in an experimental stage and will have its API and data types
--   modified frequently. See the project's web site at
--   <http://www.pontarius.org/projects/pontarius-xmpp/> for more information.
--   
--   This module will be thoroughly documented soon.

module Network.XMPP.PontariusXMPP ( -- JID:
                                    JID -- TODO: No external construction
                                  , jid
                                  , jidIsFull
                                  , jidIsBare
                                  , stringToJID
                                  , jidToString
                                  
                                    -- ID Generation:
                                  , getID
                                  
                                    -- Client API:
                                  , ClientInEvent (..)
                                  , ClientOutEvent (..)
                                  , createPresence
                                  , StanzaID
                                  , PresenceStatus
                                  , PresenceType (Available, Away, Chat, DoNotDisturb, ExtendedAway, Unavailable, Subscribe, Unsubscribe, Subscribed, Unsubscribed)
                                  , StanzaErrorCondition (BadRequest, Conflict,
                                                          FeatureNotImplemented, Forbidden, Gone,
                                                          InternalServerError, ItemNotFound,
                                                          JIDMalformed, NotAcceptable, NotAllowed,
                                                          NotAuthorized, PaymentRequired,
                                                          RecipientUnavailable, Redirect,
                                                          RegistrationRequired, RemoteServerNotFound,
                                                          RemoteServerTimeout, ResourceConstraint,
                                                          ServiceUnavailable, SubscriptionRequired,
                                                          UndefinedCondition, UnexpectedRequest)
                                  , StanzaErrorType (Cancel, Continue, Modify, Auth, Wait)
                                  , connect
                                  , presenceStatus
                                  , presenceEvent
                                  -- , subscriptionEvent
                                  , iqGetEvent
                                  , iqSetEvent
                                  , iqResultEvent
                                  , iqErrorEvent
                                  , disconnectEvent ) where


import qualified Data.ByteString as DB
import Data.Int
import Data.XML.Types
import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)

import Text.Regex.Posix ((=~))
import Codec.Binary.UTF8.String
import Control.Concurrent (forkIO, threadDelay)
import Control.Monad.IO.Class (liftIO, MonadIO)
import Data.Enumerator (($$), Iteratee, continue, joinI,
                        run_, yield)
import Data.Enumerator.Binary (enumHandle, enumFile )
import qualified Data.Text as DT
import qualified Data.Text.Lazy as DTL
import Data.XML.Types -- (Event)
import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput)
import System.Log.HLogger
import System.Log.SimpleHLogger
import Network
import System.IO (BufferMode, BufferMode(NoBuffering))
import Text.XML.Enumerator.Parse (parseBytes, decodeEntities)
import Text.XML.Enumerator.Document (fromEvents)
import qualified Data.Enumerator.List as EL
import qualified Data.List as DL
-- import Data.Text.Lazy.Internal
import Data.Digest.Pure.MD5

import qualified Text.XML.Enumerator.Document as D
import qualified Data.Enumerator as E

import qualified Data.List as DL

import qualified Codec.Binary.Base64.String as CBBS

import Data.Word (Word8)

import System.Crypto.Random
import Data.Word
import System.Random

-- import qualified Data.ByteString as DBy
import qualified Data.ByteString.Lazy as DBL (ByteString, append, pack, fromChunks, toChunks, null)
import qualified Data.ByteString.Lazy.Char8 as DBLC (append, pack, unpack)
import qualified Data.ByteString.Char8 as DBC (pack, unpack)
import Data.ByteString.Internal (c2w)

import qualified Data.Binary as DBi (Binary, encode)

import Data.Char (isLatin1)
import GHC.IO.Handle (hClose)
import Network.TLS
import Data.String
import Data.Maybe
import qualified Data.Map as DM


-- =============================================================================
--  JID
-- =============================================================================


-- TODO: Make the regular expression only match valid JIDs.
-- TODO: Use Perl regular expressions to use non-capturing groups with "(?:"?
-- TODO: Validate the input in the jid and stringToJID functions.

-- | JIDs are written in the format of `node@server/resource'.
--   
--   The node identifier is the part before the `@' character in Jabber IDs.
--   Node names are optional.
--   
--   The server identifier is the part after the `@' character in Jabber IDs
--   (and before the `/' character). It is the only required field of a JID. It
--   MAY be an IP address but SHOULD be a fully qualified domain name.
--   
--   The resource identifier is the part after the `/' character in Jabber IDs.
--   Like with node names, the resource identifier is optional.
--   
--   A JID without a resource identifier (i.e. a JID in the form of
--   `node@server') is called `bare JID'. A JID with a resource identifier is
--   called `full JID'.

-- Node identifiers MUST be formatted in such a way so that the Nodeprep profile
-- (see RFC 3920: XMPP Core, Appendix A) of RFC 3454: Preparation of
-- Internationalized Strings (`stringprep') can be applied without failing.
-- Servers MUST and clients SHOULD apply the Nodeprep profile to node names
-- prior to comparing them. Node identifiers MUST NOT be more than 1023 bytes in
-- length.
--
-- If it is a domain name it MUST be an `internationalized domain name' as
-- defined in RFC 3490: Internationalizing Domain Names in Applications (IDNA),
-- to which RFC 3491: Nameprep: A Stringprep Profile for Internationalized
-- Domain Names (IDN) can be applied without failing. Servers MUST and clients
-- SHOULD first apply the Nameprep profile to the domain names prior to
-- comparing them. Like with node names, server identifiers MUST NOT be more
-- than 1023 bytes in length.
--
-- A resource identifier has to be formatted in such a way so that the
-- Resourceprep profile of RFC 3454: Preparation of Internationalized Strings
-- (`stringprep') can be applied without failing. Servers MUST and clients
-- SHOULD first apply the Resourceprep profile (see RFC 3920: XMPP Core,
-- Appendix B) to resource names prior to comparing them. The resource
-- identifier MUST MOT be more than 1023 bytes in length.
--
-- Given the length of the `@' and `/' characters as well as the restrictions
-- imposed on the node, server and resource identifiers, a JID will never be
-- longer than 3071 bytes.


-- JID is a data type that has to be constructed in this module using either jid
-- or stringToJID.

data JID = JID { jidNode :: Maybe String
               , jidServer :: String
               , jidResource :: Maybe String } deriving (Eq, Show)


-- | Simple function to construct a JID. We will add validation to this function
--   in a later release.

jid :: Maybe String -> String -> Maybe String -> JID
jid n s r = JID { jidNode = n, jidServer = s, jidResource = r }


-- | Converts a (JID) String to a JID record.

stringToJID :: String -> Maybe JID

stringToJID string = matchToJID $ string =~ "^(([^@]+)@)?([^/]+)(/(.+))?$"
  where
    matchToJID [[_, _, "", server, _, ""]] =
      Just JID { jidNode = Nothing, jidServer = server, jidResource = Nothing }
    matchToJID [[_, _, node, server, _, ""]] =
      Just JID { jidNode = Just node
               , jidServer = server
               , jidResource = Nothing }
    matchToJID [[_, _, "", server, _, resource]] =
      Just JID { jidNode = Nothing
               , jidServer = server
               , jidResource = Just resource }
    matchToJID [[_, _, node, server, _, resource]] =
      Just JID { jidNode = Just node
               , jidServer = server
               , jidResource = Just resource }
    matchToJID _ = Nothing


-- | Converts a JID to a String.

jidToString :: JID -> String

jidToString JID { jidNode = n, jidServer = s, jidResource = r }
  | n == Nothing && r == Nothing = s
  | r == Nothing                 = let Just n' = n in n' ++ "@" ++ s
  | n == Nothing                 = let Just r' = r in s ++ "/" ++ r'
  | otherwise                    = let Just n' = n; Just r' = r
                                   in n' ++ "@" ++ s ++ "/" ++ r'


-- | JIDs are written in the format of `node@server/resource'. A JID without a
--   resource identifier (i.e. a JID in the form of `server' or `node@server')
--   is called a `bare JID'. A JID with a resource identifier is called `full
--   JID'. This function returns True if the JID is `bare' and False otherwise.

jidIsBare :: JID -> Bool
jidIsBare j | jidResource j == Nothing = True
            | otherwise                = False


-- | JIDs are written in the format of `node@server/resource'. A JID without a
--   resource identifier (i.e. a JID in the form of `server' or `node@server')
--   is called a `bare JID'. A JID with a resource identifier is called `full
--   JID'. This function returns True if the JID is `full' and False otherwise.

-- This function is defined in terms of (not) jidIsBare.

jidIsFull :: JID -> Bool
jidIsFull jid = not $ jidIsBare jid



-- =============================================================================
--  ID Generation
-- =============================================================================


-- TODO: This is a bit rushed as we are pressed for time.

characters :: String
characters = "abcdefghijklmnopqrstuvwxyz0123456789"

getID :: IO String
getID =
  do se <- getSeed
     let st = mkStdGen se
     return $ take 8 (idSequence st)
    where
      idSequence :: StdGen -> String
      idSequence st = [characters !! (fst $ rand st)] ++ idSequence (snd $ rand st)
      rand :: StdGen -> (Int, StdGen)
      rand st = randomR (0, length characters - 1) st

getSeed :: IO Int
getSeed =
  do h <- openHandle
     b <- hGetEntropy h 8
     let w = DB.unpack b
     let s = seed w
     closeHandle h
     return s
    where seed :: [Word8] -> Int
          seed []     = 1
          seed (x:xs) = ((fromIntegral x) + 1) * (seed xs)



-- =============================================================================
--  Client API
-- =============================================================================


-- TODO: "IQGet i f t e" instead of "IQGet (i, f, t, e)"?
-- TODO: Messages, see http://www.ietf.org/rfc/rfc3921.txt, section 2.1.1.


-- | A StanzaID is a eight character string which you can either generate
--   yourself or have Pontarius XMPP generate for you.

data StanzaID = SID String deriving (Eq, Show)


-- | All stanzas (IQ, message, presence) can cause errors, which looks like
--   <stanza-kind to='sender' type='error'>. These errors are of one of the
--   types listed below.

data StanzaErrorType = Cancel   | -- ^ Error is unrecoverable - do not retry
                       Continue | -- ^ Conditition was a warning - proceed
                       Modify   | -- ^ Change the data and retry
                       Auth     | -- ^ Provide credentials and retry
                       Wait       -- ^ Error is temporary - wait and retry
                       deriving (Eq, Show)


-- | The stanza errors are accommodated with one of the error conditions listed
--   below. The ones that are not self-explainatory should be documented below.

data StanzaErrorCondition = BadRequest            | -- ^ Malformed XML
                            Conflict              | -- ^ Resource or session
                                                    --   with name already
                                                    --   exists
                            FeatureNotImplemented |
                            Forbidden             | -- ^ Insufficient
                                                    --   permissions
                            Gone                  | -- ^ Entity can no longer
                                                    --   be contacted at this
                                                    --   address
                            InternalServerError   |
                            ItemNotFound          |
                            JIDMalformed          |
                            NotAcceptable         | -- ^ Does not meet policy
                                                    --   criteria
                            NotAllowed            | -- ^ No entity may perform
                                                    --   this action
                            NotAuthorized         | -- ^ Must provide proper
                                                    --   credentials
                            PaymentRequired       |
                            RecipientUnavailable  | -- ^ Temporarily
                                                    --   unavailable
                            Redirect              | -- ^ Redirecting to other
                                                    --   entity, usually
                                                    --   temporarily
                            RegistrationRequired  |
                            RemoteServerNotFound  |
                            RemoteServerTimeout   |
                            ResourceConstraint    | -- ^ Entity lacks the
                                                    --   necessary system
                                                    --   resources
                            ServiceUnavailable    |
                            SubscriptionRequired  |
                            UndefinedCondition    | -- ^ Application-specific
                                                    --   condition
                            UnexpectedRequest       -- ^ Badly timed request
                            deriving (Eq, Show)


-- | Presence stanzas are used to express an entity's network availability.

data PresenceType = Subscribe    | -- ^ Sender wants to subscribe to presence
                     Subscribed   | -- ^ Sender has approved the subscription
                     Unsubscribe  | -- ^ Sender is unsubscribing from presence
                     Unsubscribed | -- ^ Sender has denied or cancelled a
                                    --   subscription
                     Probe        | -- ^ Sender requests current presence;
                                    --   should only be used by servers
                     Error        | -- ^ Processing or delivery of previously
                                    --   sent presence stanza failed
                     Available    |
                     Away         |
                     Chat         |
                     DoNotDisturb |
                     ExtendedAway |
                     Unavailable
                     deriving (Eq, Show)


data PresenceStatus = PS String deriving (Eq, Show)


-- TODO: Validate input.

presenceStatus :: String -> Maybe PresenceStatus
presenceStatus s = Just (PS s)


-- TODO: Is the payload type below correct?
-- TODO: Include presence type='error' information.

-- data Presence = Presence { presenceID :: Maybe StanzaID
--                          , presenceFrom :: JID
--                          , presenceTo :: Maybe JID
--                          , payload :: Either SubscribeType (PresenceType
--                                                            , PresenceStatus) }


-- | Connects to the given server and port using the provided user name and
--   password. It returns a pair of channels, one channel used for delivering
--   client events to Pontarius XMPP, and one to receive events from Pontarius
--   XMPP.

-- TODO: stopLogger logger
-- TODO: Catch errors

connect :: String -> Integer -> JID -> String ->
           IO (Chan ClientOutEvent, Chan ClientInEvent)

connect s po JID { jidNode = Just u, jidResource = r } pa =
  do logger <- simpleLogger "PontariusXMPP"
     logNotice logger "Pontarius XMPP has started"
     
     logInfo logger $ "Connecting to " ++ s ++ ":" ++ (show po) ++ "..."
     -- Connect to the server, open stream
     handle <- connectTo s (PortNumber $ fromInteger po)
     hSetBuffering handle NoBuffering
     hPutStr' handle s
     
     -- Create client "in" and "out" channels (naming from the perspective of
     -- the client) as well as the internal event channel
     inChan <- newChan
     outChan <- newChan
     internalChan <- newChan
     
     -- Start XML enumerator, which will read from the handle to generate the
     -- relevant internal events
     forkIO $ xmlEnumerator internalChan handle s logger
     
     -- Start to listen to client "out" events (client actions)
     forkIO $ clientListener outChan internalChan logger
     
     -- Start the state loop, the main loop of Pontarius XMPP
     forkIO $ stateLoop (defaultState s po u r pa handle) internalChan
       inChan logger
     
     return (outChan, inChan)


-- both presenceEvent and subscriptionEvent are presence stanzas
presenceEvent :: PresenceType -> Maybe PresenceStatus -> ClientOutEvent
presenceEvent t s = COESimplePresence (t, s)

-- subscriptionEvent :: Maybe StanzaID -> JID -> SubscribeType -> ClientOutEvent
-- subscriptionEvent i t j = COESubscription (i, t, j)

-- id, to, payload
iqGetEvent :: Maybe StanzaID -> Maybe JID -> Element -> ClientOutEvent
iqGetEvent i j p = COEIQGet (i, j, p)

iqSetEvent :: Maybe StanzaID -> Maybe JID -> Element -> ClientOutEvent
iqSetEvent i j p = COEIQSet (i, j, p)

iqResultEvent :: Maybe StanzaID -> JID -> Maybe Element -> ClientOutEvent
iqResultEvent i j p = COEIQResult (i, j, p)

iqErrorEvent :: Maybe StanzaID -> JID -> Element -> Maybe Element ->
                StanzaErrorType -> StanzaErrorCondition -> ClientOutEvent
iqErrorEvent i j p a t c = COEIQError (i, j, p, a, t, c)

disconnectEvent :: ClientOutEvent
disconnectEvent = COEDisconnect

createPresence :: Maybe JID -> Maybe PresenceType -> Maybe Element -> ClientOutEvent
createPresence j p e = COEComplexPresence (j, p, e)

data ClientOutEvent = COESimplePresence (PresenceType, Maybe PresenceStatus) |
                      COEComplexPresence (Maybe JID, Maybe PresenceType, Maybe Element) |
                      COEIQGet (Maybe StanzaID, Maybe JID, Element)            |
                      COEIQSet (Maybe StanzaID, Maybe JID, Element)            |
                      COEIQResult (Maybe StanzaID, JID, Maybe Element)         |
                      COEIQError (Maybe StanzaID, JID, Element, Maybe Element,
                                  StanzaErrorType, StanzaErrorCondition)       |
                      COEDisconnect deriving (Eq, Show)


data ClientInEvent = CIEConnected                                                |
                     CIEPresence (Maybe StanzaID, Maybe JID, Maybe JID,
                                  Maybe PresenceType, [Element])                       |
                     CIEIQGet (StanzaID, Maybe JID, Maybe JID, Element)    |
                     CIEIQSet (StanzaID, Maybe JID, Maybe JID, Element)          |
                     CIEIQResult (StanzaID, Maybe JID, Maybe JID, Maybe Element) |
                     -- CIEIQError (StanzaID, JID, Element, Maybe Element,
                     --            StanzaErrorType, StanzaErrorCondition)        | -- TODO
                     CIEDisconnected deriving (Eq, Show)


-- =============================================================================
--  Internal Functions
-- =============================================================================


-- TODO: Add namespace support for stream/features?
-- TODO: Add support for `ver optional' support for features?
-- TODO: Presence priority?


-- We use the InternalEvent data type for the channel to our internal enumerator
-- (which processes the events that are fed into our state-modifying iteratee).
-- An internal event is (so far) either a "XML event" (captured at depth level
-- 1, such as a stanza) or a ClientOutEvent generated by the XMPP client.

data InternalEvent = IEX XMLEvent | IEC ClientOutEvent | IES SecurityEvent deriving (Show) -- WhiteSpaceEvent?


data SecurityEvent = TLSSucceeded TLSCtx | TLSFailed

instance Show SecurityEvent where
  show (TLSSucceeded _) = "TLSSucceeded Ctx"
  show TLSFailed        = "TLSFailed"


-- An XMLEvent is a high-level XMPP event generated by our XML parsing code.

data XMLEvent = XEBeginStream Stream | XEFeatures Features |
                XEChallenge Challenge | XESuccess Success |
                XEEndStream | XEIQ IQ | XEPresence Presence | XEOther String deriving (Show)


-- Represents the top-level "<stream>" element.

data Stream = Stream { streamNamespace :: StreamNamespace
                     , streamID :: String
                     , streamVersion :: Float } deriving (Show)


-- TODO: Do not make this assumption, but parse the element instead.

defaultStream id = Stream { streamNamespace = Client
                          , streamID = id
                          , streamVersion = 1.0 }


-- The "<stream:features>" element.

data Features = Features { featuresStartTLS :: Bool
                         , featuresMechanisms :: [FeaturesMechanism]
                         , featuresCompressionMethods :: [CompressionMethod] } deriving (Show)


-- TODO: Do not make this assumption, but parse the element instead.

featuresDefault = Features { featuresStartTLS = True,
                             featuresMechanisms = [DigestMD5],
                             featuresCompressionMethods = [] }


-- TODO: Necessary?

data StreamNamespace = Client | Server deriving (Show)


-- Authentication mechanisms. We only support DigestMD5 at this point.

data FeaturesMechanism = DigestMD5 | CramMD5 | Login | Plain | UnknownMechanism deriving (Show)

data UnknownMechanism = UM String deriving (Show)


data CompressionMethod = Zlib deriving (Show)


-- Containers for information from SASL challenges and successes.

data Challenge = Chal String deriving (Show)

data Success = Succ String deriving (Show)


data SecurityState = NotTLSSecured | TLSSecured | SASLSecured deriving (Show, Eq)



xmlEnumerator :: Chan InternalEvent -> Handle -> String -> Logger -> IO ()
xmlEnumerator c h s l = do
  logDebug l "xmlEnumerator: Starting to read insecure XML"
  run_ $ enumHandle 1 h $$ joinI $ parseBytes decodeEntities
    $$ xmlReader c [] 0
  logDebug l "xmlEnumerator: Unsecure stream ended - performing TLS handshake"
  t <- handshake' h s
  case t of
    Just tlsctx -> do logDebug l $ "xmlEnumerator: Handshake successful - st" ++
                        "arting to read secure XML"
                      writeChan c (IES (TLSSucceeded tlsctx))
                      run_ $ enumTLS tlsctx $$ joinI $ parseBytes decodeEntities
                        $$ xmlReader c [] 0
                      logDebug l $
                        "xmlEnumerator: Secure stream ended, exiting"
                      return ()
    Nothing -> logDebug l $ "xmlEnumerator: TLS handshake failed" -- TODO: Event
  return ()

enumTLS :: TLSCtx -> E.Enumerator DB.ByteString IO b
enumTLS c s = loop c s where
  loop :: TLSCtx -> E.Step DB.ByteString IO b -> E.Iteratee DB.ByteString IO b
  loop c (E.Continue k) =
    do d <- recvData c
       case DBL.null d of
         True  -> loop c (E.Continue k)
         False -> k (E.Chunks $ DBL.toChunks d) E.>>== loop c
  loop _ step = E.returnI step

hPutStr' :: Handle -> String -> IO ()
hPutStr' h s = do
  hPutStr h $ encodeString "<?xml version='1.0'?><stream:stream to='" ++
       s ++ "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/" ++
       "streams' version='1.0'>"
  hFlush h

getTLSParams :: TLSParams
getTLSParams = TLSParams { pConnectVersion    = TLS10
                    , pAllowedVersions   = [TLS10,TLS11]
                    , pCiphers           = [cipher_AES256_SHA1] -- Check the rest
                    , pCompressions      = [nullCompression]
                    , pWantClientCert    = False
                    , pCertificates      = []
                    , onCertificatesRecv = \_ -> return True } -- Verify cert chain

handshake' :: Handle -> String -> IO (Maybe TLSCtx)
handshake' h s = do
  let t = getTLSParams
  r <- makeSRandomGen
  case r of
    Right sr -> do
      putStrLn $ show sr
      c <- client t sr h
      handshake c
      sendData c $ DBLC.pack $ encodeString "<?xml version='1.0'?><stream:stream to='" ++
       s ++ "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/" ++
       "streams' version='1.0'>"
      putStrLn ">>>>TLS data sended<<<<"
      return (Just c)
    Left ge -> do
      putStrLn $ show ge
      return Nothing


-- TODO: Add logger

xmlReader :: Chan InternalEvent -> [Event] -> Int ->
             Iteratee Event IO (Maybe Event)

xmlReader ch [EventBeginDocument] 0 = xmlReader ch [] 0

-- TODO: Safe to start change level here? We are doing this since the stream can
-- restart.
-- TODO: l < 2?
xmlReader ch [EventBeginElement name attribs] l
  | l < 3 && nameLocalName name == DT.pack "stream" &&
    namePrefix name == Just (DT.pack "stream") = do
      liftIO $ writeChan ch $ IEX $ XEBeginStream $ defaultStream "TODO"
      xmlReader ch [] 1

xmlReader ch [EventEndElement name] 1
  | namePrefix name == Just (DT.pack "stream") &&
    nameLocalName name == DT.pack "stream" = do
      liftIO $ writeChan ch $ IEX XEEndStream
      return Nothing

-- Check if counter is one to forward it to related function.
-- Should replace "reverse ((EventEndElement n):es)" with es
-- ...
xmlReader ch ((EventEndElement n):es) 1
  | nameLocalName n == DT.pack "proceed" = E.yield Nothing (E.Chunks [])
  | otherwise = do
    -- liftIO $ putStrLn "Got an IEX Event..."
    liftIO $ writeChan ch $ IEX (processEventList (DL.reverse ((EventEndElement n):es)))
    xmlReader ch [] 1

-- Normal condition, buffer the event to events list.
xmlReader ch es co = do
  head <- EL.head
  let co' = counter co head
  liftIO $ putStrLn $ show co' ++ "\t" ++ show head    -- for test
  case head of
    Just e -> xmlReader ch (e:es) co'
    Nothing -> xmlReader ch es co'


-- TODO: Generate real event.
processEventList :: [Event] -> XMLEvent
processEventList e
  | namePrefix name == Just (DT.pack "stream") &&
    nameLocalName name == DT.pack "features" = XEFeatures featuresDefault
  | nameLocalName name == DT.pack "challenge" =
    let EventContent (ContentText c) = head es in XEChallenge $ Chal $ DT.unpack c
  | nameLocalName name == DT.pack "success" =
    let EventContent (ContentText c) = head es in XESuccess $ Succ $ DT.unpack c
  | nameLocalName name == DT.pack "iq" = XEIQ $ parseIQ $ eventsToElement e
  | nameLocalName name == DT.pack "presence" = XEPresence $ parsePresence $ eventsToElement e
  | otherwise = XEOther $ show $ nameLocalName name
      where
        (EventBeginElement name attribs) = head e
        es = tail e

eventsToElement :: [Event] -> Element
eventsToElement e = do
  documentRoot $ fromJust (run_ $ enum e $$ fromEvents)
    where
      enum :: [Event] -> E.Enumerator Event Maybe Document
      enum e_ (E.Continue k) = k $ E.Chunks e_
      enum e_ step = E.returnI step

clientListener :: Chan ClientOutEvent -> Chan InternalEvent -> Logger -> IO ()
clientListener c i l =
  do event <- readChan c
     logDebug l $ "clientListener: Forwarding received client event: " ++
       show (event)
     writeChan i (IEC event)
     clientListener c i l


-- TODO: Process the events that we are getting.

stateLoop :: State -> Chan InternalEvent -> Chan ClientInEvent -> Logger ->
             IO ()
stateLoop s c c_ l =
  do event <- readChan c
     -- logDebug l $ "stateLoop: Received event: " ++ (show event)
     -- TODO: Debug with state?
     s' <- processEvent event
     stateLoop s' c c_ l
    where
      -- Some readability variables.
      server = stateServer s
      username = stateUsername s
      resource = stateResource s
      password = statePassword s
      handle = stateHandle s
      securityState = stateSecurityState s
      tlsCtx = stateTLSCtx s
      isChallenge1 = stateIsChallenge1 s
      isReady = stateIsReady s
      
      -- We are receiving a client event but are not authenticated
      processEvent (IEC clientEvent) | isReady == False = do
        -- As we cannot process it, we put it back in the queue
        -- TODO: Ugly? Log?
        writeChan c $ IEC clientEvent
        return s
      
      -- We are receiving a client event that we should act on
      processEvent (IEC clientEvent) | isReady == True = do
        logDebug l $ "processEvent: Processing client event " ++
          (show clientEvent)
        case clientEvent of
          COEDisconnect ->
            -- TODO: Disconnect
            return s
          _ -> do
            logDebug l $ "processEvent: Received Client Out Event: " ++ (show clientEvent)
            let xml = clientOutEventToXML clientEvent
            logDebug l $ "processEvent: Sending XML: " ++ xml
            sendData (fromJust tlsCtx) $ DBLC.pack $ encodeString $ xml
            return s
      
      -- TLS negotiation has suceeded
      processEvent (IES (TLSSucceeded receivedTLSCtx)) =
        return (s { stateSecurityState = TLSSecured
                  , stateTLSCtx = Just receivedTLSCtx } )
      
      -- We failed to match a security event
      processEvent (IES securityEvent) = do
        logWarning l $ "processEvent: Security event slipped through: " ++
          (show securityEvent)
        return s
      
      -- A <stream:stream> element has begun
      -- TODO: Parse the XEStreamBegin object
      processEvent (IEX (XEBeginStream _)) = do
        logDebug l "processEvent: A new stream has been opened"
        return s
      
      -- We have received <features> on an insecure stream
      -- TODO: Parse the XEFeatures object
      processEvent (IEX (XEFeatures _)) | securityState == NotTLSSecured = do
        logDebug l $
          "processEvent: Received features ([...]) on insecure stream; reque" ++
          "sting \"starttls\""
        hPutStr handle "<starttls xmlns='urn:ietf:params:xml:ns:xmpp-tls'/>"
        hFlush handle
        return s
      
      -- We have received <features> on an unauthenticated secure stream
      processEvent (IEX (XEFeatures _)) | securityState == TLSSecured = do
        logDebug l $
          "processEvent: Received features ([...]) on an unauthenticated sec" ++
          "ure stream; requesting to authenticate"
        do sendData (fromJust tlsCtx) $ DBLC.pack $ encodeString $ getAuth
           return s
      
      -- We have received <features> on an authenticated secure stream; we are
      -- now ready to start processing client events
      processEvent (IEX (XEFeatures _)) | securityState == SASLSecured = do
        logDebug l $
          "processEvent: Received features ([...]) on an authenticated secur" ++
          "e stream"
        logInfo l "processEvent: User has successfully logged in"
        case resource of
          Nothing -> do
            return ()
          _ -> do
            logDebug l $ "processEvent: Setting resource: " ++
              (fromJust resource)
            sendData (fromJust tlsCtx) $ DBLC.pack $ encodeString
              "<iq type=\"set\" id=\"bind_1\"><bind xmlns=\"urn:ietf:params:" ++
              "xml:ns:xmpp-bind\"><resource>" ++ fromJust resource ++
              "</resource></bind></iq>"
            r <- getID
            sendData (fromJust tlsCtx) $ DBLC.pack $ encodeString $
              "<iq type=\"set\" id=\"" ++ r ++
              "\"><session xmlns=\"urn:ietf:params:xml:ns:xmpp-session\"/></iq>"
        return (s { stateIsReady = True })
      
      -- We have received a SASL challenge on a secure stream
      processEvent (IEX (XEChallenge (Chal challenge)))
        | securityState == TLSSecured = do
          let challenge' = CBBS.decode challenge
          case isChallenge1 of
            True -> do
              -- This is the first challenge - we need to calculate the reply
              logDebug l $ "processEvent: Received initial challenge: " ++
                challenge ++ " (or " ++ challenge' ++ ")"
              random <- getID -- TODO: Length and content.
              case replyToChallenge1 challenge' server username password random of
                Left reply -> do
                  let reply' = (filter (/= '\n') (CBBS.encode reply))
                  logDebug l $ "processEvent: Sending challenge response: " ++
                    reply'
                  sendData (fromJust tlsCtx) $ DBLC.pack $ encodeString $
                    "<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>" ++
                    reply' ++ "</response>"
                  return (s { stateIsChallenge1 = False } )
                Right error -> do
                  putStrLn $ show error
                  return s
            False  -> do
              -- This is not the first challenge; [...]
              -- TODO: Can we assume "rspauth"?
              logDebug l $ "processEvent: Received non-initial challenge: " ++
                challenge ++ " (or " ++ challenge' ++ ")"
              liftIO $ sendData (fromJust tlsCtx) $ DBLC.pack $ encodeString $
                "<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/>"
              return s
      
      -- We have received a SASL "success" message over a secured connection
      -- TODO: Parse the success message?
      -- TODO: <?xml version='1.0'?>?
      processEvent (IEX (XESuccess (Succ _))) | securityState == TLSSecured = do
        logDebug l $
          "processEvent: Received authentication success: [...]; restarting " ++
          "stream" -- TODO
        sendData (fromJust tlsCtx) $ DBLC.pack $
          encodeString "<?xml version='1.0'?><stream:stream to='" ++ server ++
          "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/st" ++
          "reams' version='1.0'>"
        return s { stateSecurityState = SASLSecured }
      
      -- CIEIQGet (Maybe StanzaID, Maybe JID, Maybe JID, Element)    |
      -- CIEIQSet (StanzaID, Maybe JID, Maybe JID, Element)          |
      -- CIEIQResult (StanzaID, Maybe JID, Maybe JID, Maybe Element) |
      processEvent (IEX (XEIQ iqEvent))
        | isReady == True = do
            case iqTo iqEvent of
              Nothing -> do
                logDebug l $ "processEvent: Got IQ for library: " ++
                  (show iqEvent)
              _ -> do
                logDebug l $ "processEvent: Got IQ for client: " ++
                  (show iqEvent)
                writeChan c_ $ iqToClientInEvent iqEvent
                putStrLn $ "!!! - " ++ (show $ iqToClientInEvent iqEvent)
            return s
      
      processEvent (IEX (XEPresence presenceEvent)) | isReady == True = do
        let Pres (_, from, _, _, _) = presenceEvent in
          case from of
            Nothing -> do
              logDebug l $ "processEvent: Got presence for library: " ++
                (show presenceEvent)
            _ -> do
              logDebug l $ "processEvent: Got presence for client: " ++
                (show presenceEvent)
              writeChan c_ $ presenceToClientInEvent presenceEvent
        return s
      
      -- We received an XML element that we didn't parse
      processEvent (IEX xmlEvent) = do
        logWarning l $ "processEvent: XML event slipped through: " ++
          (show xmlEvent)
        return s

iqToClientInEvent :: IQ -> ClientInEvent
iqToClientInEvent iq = case iq of
  IQGet (i, f, t, e) -> CIEIQGet (fromJust i, f, t, e)
  IQSet (i, f, t, e) -> CIEIQSet (fromJust i, f, t, e)
  IQResult (i, f, t, e) -> CIEIQResult (fromJust i, f, t, e)

presenceToClientInEvent :: Presence -> ClientInEvent
presenceToClientInEvent (Pres (i, f, t, p, e)) = CIEPresence (i, f, t, p, e)

iqTo :: IQ -> Maybe JID
iqTo (IQGet (_, j, _, _)) = j
iqTo (IQSet (_, j, _, _)) = j
iqTo (IQResult (_, j, _, _)) = j



-- =============================================================================
--  SASL Authentication
-- =============================================================================


data Challenge1Error = C1MultipleCriticalAttributes       |
                       C1NotAllParametersPresent          |
                       C1SomeParamtersPresentMoreThanOnce |
                       C1WrongRealm                       |
                       C1UnsupportedAlgorithm             |
                       C1UnsupportedCharset               |
                       C1UnsupportedQOP
                       deriving Show


-- Will produce a list of key-value pairs given a string in the format of
-- realm="somerealm",nonce="OA6MG9tEQGm2hh",qop="auth",charset=utf-8...
stringToList :: String -> [(String, String)]
stringToList "" = []
stringToList s' = let (next, rest) = break' s' ','
                  in break' next '=' : stringToList rest
  where
    -- Like break, but will remove the first char of the continuation, if
    -- present.
    break' :: String -> Char -> (String, String)
    break' s' c = let (first, second) = break ((==) c) s'
                  in (first, removeCharIfPresent second c)
    
    -- Removes the first character, if present; "=hello" with '=' becomes
    -- "hello".
    removeCharIfPresent :: String -> Char -> String
    removeCharIfPresent [] _               = []
    removeCharIfPresent (c:t) c' | c == c' = t
    removeCharIfPresent s' c               = s'

-- Counts the number of directives in the pair list.
countDirectives :: String -> [(String, String)] -> Int
countDirectives v l = DL.length $ filter (isEntry v) l
  where
    isEntry :: String -> (String, String) -> Bool
    isEntry name (name', _) | name == name' = True
                            | otherwise     = False


-- Returns the given directive in the list of pairs, or Nothing.
lookupDirective :: String -> [(String, String)] -> Maybe String
lookupDirective d []                      = Nothing
lookupDirective d ((d', v):t) | d == d'   = Just v
                              | otherwise = lookupDirective d t


-- Returns the given directive in the list of pairs, or the default value
-- otherwise.
lookupDirectiveWithDefault :: String -> [(String, String)] -> String -> String
lookupDirectiveWithDefault di l de
  | lookup == Nothing = de
  | otherwise         = let Just r = lookup in r
  where
    lookup = lookupDirective di l


-- TODO: Make appropriate response.
-- TODO: Can it contain newline characters?

-- Takes a challenge string (which is not Base64-encoded), the host name of the
-- Jabber server, the Jabber user name (JID), the password and a random and
-- unique "cnonce" value and generates either an error or a response to that
-- challenge.
--
-- TODO: Host is assumed to be ISO 8859-1; make list of assumptions.

-- We have broken replyToChallenge1 for non-TLS authentication. In order to
-- change it back, just uncomment the lines relevant to the realm and match it
-- in the C1NotAllParametersSet case.

replyToChallenge1 :: String -> String -> String -> String -> String ->
                     Either String Challenge1Error
replyToChallenge1 s h u p c =
  -- Remove all new line characters.
  let list = stringToList $ filter (/= '\n') s
  in -- Count that there are no more than one nonce or algorithm directives.
     case countDirectives "nonce"     list <= 1 &&
          countDirectives "algorithm" list <= 1 of
       True ->
         let -- realm     = lookupDirective "realm" list
             nonce     = lookupDirective "nonce" list
             qop       = lookupDirectiveWithDefault "qop" list "auth"
             charset   = lookupDirectiveWithDefault "charset" list "utf-8"
             algorithm = lookupDirective "algorithm" list
         
         -- Verify that all necessary directives has been set.
         in case (nonce, qop, charset, algorithm) of
              (Just nonce', qop', charset', Just algorithm') ->
                
                -- Strip quotations of the directives that need it.
                let -- realm'' = stripQuotations realm'
                    nonce'' = stripQuotations nonce'
                    qop'' = stripQuotations qop' -- It seems ejabberd gives us an errorous "auth" instead of auth
                in
                -- -- Verify that the realm is the same as the Jabber host.
                -- case realm'' == h of
                --      True ->
                       
                       -- Verify that QOP is "auth", charset is "utf-8" and that
                       -- the algorithm is "md5-sess".
                       case qop'' == "auth" of
                         True ->
                           case charset' == "utf-8" of
                             True ->
                               case algorithm' == "md5-sess" of
                                 True ->
                                 
                                   -- All data is valid; generate the reply.
                                   Left (reply nonce'' qop'')
                                 
                                 -- Errors are caught and reported below.
                                 False -> Right C1UnsupportedAlgorithm
                             False -> Right C1UnsupportedCharset
                         False -> Right C1UnsupportedQOP
                     -- False -> Right C1WrongRealm
              _ -> Right C1NotAllParametersPresent
  where
    reply n q =
      let -- We start with what's in RFC 2831 is referred to as "A1", a 16 octet
          -- MD5 hash.
          
          -- If the username or password values are in ISO-8859-1, we convert
          -- them to ISO-8859-1 strings.
          username = case all isLatin1 u of
            True -> DBL.pack $ map c2w u
            False -> DBLC.pack $ u
          password = case all isLatin1 p of
            True -> DBL.pack $ map c2w p
            False -> DBLC.pack p
          
          nc = "00000001"
          digestUri = "xmpp/" ++ h
          
          -- Build the "{ username-value, ":", realm-value, ":", passwd }"
          -- bytestring, the rest of the bytestring and then join them.
          a1a = DBi.encode $ md5 $ DBLC.append
                (DBLC.append username (DBLC.pack (":" ++ h ++ ":")))
                password
          a1aDebug = "DBi.encode $ md5 $ " ++ (DBLC.unpack $ DBLC.append
                (DBLC.append username (DBLC.pack (":" ++ h ++ ":")))
                password)
          a1b = DBLC.pack (":" ++ n ++ ":" ++ c)
          a1 = DBLC.append a1a a1b
          
          -- Generate the "A2" value.
          a2 = DBLC.pack ("AUTHENTICATE:" ++ digestUri)
          
          -- Produce the responseValue.
          k = DBLC.pack (show $ md5 a1)
          colon = DBLC.pack ":"
          s0 = DBLC.pack (n ++ ":" ++ nc ++ ":" ++ c ++ ":" ++
                          q ++ ":")
          s1 = DBLC.pack $ show $ md5 a2
          
          s_ = DBLC.append s0 s1
          -- append k:d and 16 octet hash it
          kd = md5 (DBLC.append k (DBLC.append colon s_))
          
          lol0 = DBLC.unpack s_
          lol1 = show kd
          
          response = show kd
      in "username=\"" ++ u ++ "\",realm=\"" ++ h ++ "\",nonce=\"" ++ n ++
         "\",cnonce=\"" ++ c ++ "\",nc=" ++ nc ++ ",digest-uri=\"" ++
         digestUri ++ "\",qop=auth,response=" ++ response ++ ",charset=utf-8"
         -- "\n\n" ++
         -- "a1aDebug: " ++ a1aDebug ++ "\n" ++
         -- "a1b: " ++ (DBLC.unpack a1b) ++ "\n" ++
         -- "a1: " ++ (DBLC.unpack a1) ++ "\n" ++
         -- "a2: " ++ (DBLC.unpack a2) ++ "\n" ++
         -- "k: " ++ (DBLC.unpack k) ++ "\n" ++
         -- "colon: " ++ (DBLC.unpack colon) ++ "\n" ++
         -- "s0: " ++ (DBLC.unpack s0) ++ "\n" ++
         -- "s1: " ++ (DBLC.unpack s1) ++ "\n" ++
         -- "s_: " ++ (DBLC.unpack s_) ++ "\n"


-- Stripts the quotations around a string, if any; "\"hello\"" becomes "hello".

stripQuotations :: String -> String
stripQuotations ""                                     = ""
stripQuotations s | (head s == '"') && (last s == '"') = tail $ init s
                  | otherwise                          = s



-- =============================================================================
--  Temporary
-- =============================================================================


-- either = from/to
data Subscription = SSubscribe    { subscribeSource    :: Either JID JID } |
                    SUnsubscribe  { unsubscribeSource  :: Either JID JID } |
                    SSubscribed   { subscribedSource   :: Either JID JID } |
                    SUnsubscribed { unsubscribedSource :: Either JID JID }

data IQ = IQGet (Maybe StanzaID, Maybe JID, Maybe JID, Element) |
          IQSet (Maybe StanzaID, Maybe JID, Maybe JID, Element) |
          IQResult (Maybe StanzaID, Maybe JID, Maybe JID, Maybe Element) deriving (Eq, Show)

data Presence = Pres (Maybe StanzaID, Maybe JID, Maybe JID, Maybe PresenceType, [Element]) deriving (Eq, Show)

-- | The iqErrorAppPayload field is used in conjuction with
--   UndefinedCondition.

data IQError = IQError { iqErrorID         :: StanzaID
                       , iqErrorFrom       :: JID
                       -- , iqErrorTo         :: JID
                       , iqErrorPayload    :: Element
                       , iqErrorAppPayload :: Maybe Element
                       , iqErrorType       :: StanzaErrorType
                       , iqErrorCondition  :: StanzaErrorCondition } deriving (Eq, Show)

getAuth = "<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl' mechanism='DIGEST-MD5'/>"

-- ---------------------------------------------------------------------------
data ParsingContext = PreDocument     -- No xml stream received
                    | Authenticating  -- Received xml stream and negotiate for
                                      -- stream features
                    | Challenge       -- Send Challenge to server and recieve..
                    | Authenticated   -- Conected to Jabber server
                    | Disconnected    -- Disconected to Jabber server
                    deriving Eq

data State = State { stateServer :: String
                   , statePort :: Integer
                   , stateUsername :: String
                   , stateResource :: Maybe String
                   , statePassword :: String
                   , stateHandle :: Handle
                   , stateStreamID :: Maybe String
                   , stateSecurityState :: SecurityState
                   , stateTLSCtx :: (Maybe TLSCtx)
                   , stateIsChallenge1 :: Bool
                   , stateIsReady :: Bool } -- Ready for client events

defaultState s po u r pa h = State { stateServer = s
                                     , statePort = po
                                     , stateUsername = u
                                     , stateResource = r
                                     , statePassword = pa
                                     , stateHandle = h
                                     , stateStreamID = Nothing
                                     , stateSecurityState = NotTLSSecured
                                     , stateTLSCtx = Nothing
                                     , stateIsChallenge1 = True
                                     , stateIsReady = False }

myEnum :: (Monad m) => [Event] -> E.Enumerator Event m Document
myEnum es (E.Continue k) = k $ E.Chunks es
myEnum es step = E.returnI step

procDoc :: Iteratee Document IO ()
procDoc = do
  -- case h of
  --   Just e  -> liftIO $ putStrLn " Got an Element : " ++ show e
  --   Nothing -> liftIO $ putStrLn " Got no Element "
  procDoc

-- Return a list of Event or empty list
toList :: (Maybe Event) -> [Event]
toList (Just e) = [e]
toList Nothing  = []

counter :: Int -> Maybe Event -> Int
counter c (Just (EventBeginElement _ _)) = (c + 1)
counter c (Just (EventEndElement _) )    = (c - 1)
counter c _                       = c

-- Just prints the Events
callEvent :: [Event] -> IO ()
callEvent [] = putStrLn "End of the document...."
callEvent (x:xs) = do
  putStrLn $ show x             -- for test
  callEvent xs

printFeatures :: [Event] -> IO ()
printFeatures [] = do
  putStrLn "End of my Events *****************************"
  return ()
printFeatures (e:es) = do
  putStrLn "******************************************************************"
  putStrLn $ show e
  printFeatures es
  return ()
-- Try to authenticate bas on features list
authenticating :: Features -> Bool
authenticating f = True

getFeatures :: Features -> [Event] -> Features
getFeatures f [] = f
-- TODO: Check for the server offered features.
getFeatures f es = getFeatures (f { featuresStartTLS = True }) []


getFeatures' :: [Event] -> IO ()
getFeatures' es = do
   d <- eventsToDoc es
   let r =  documentRoot d
   putStrLn $ show r
   return ()

-- Convert a list of Events to a Document
eventsToDoc :: [Event] -> IO Document
eventsToDoc es = do
  run_ $ myEnum es $$ fromEvents

-- TODO: Actually parse the element.
getSF :: Element -> Features
getSF _ = Features { featuresStartTLS = False
                   , featuresMechanisms = [DigestMD5]
                   , featuresCompressionMethods = [Zlib] }

parseIQ :: Element -> IQ
parseIQ e | typeAttr == "get" = let (Just payloadMust) = payload
                                in (IQGet (idAttr,
                                           fromAttr,
                                           toAttr,
                                           payloadMust))
          | typeAttr == "set" = let (Just payloadMust) = payload
                                in (IQSet (idAttr,
                                           fromAttr,
                                           toAttr,
                                           payloadMust))
          | typeAttr == "result" = IQResult (idAttr,
                                             fromAttr,
                                             toAttr,
                                             payload)
  where
    -- TODO: Many duplicate functions from parsePresence.
    
    payload :: Maybe Element
    payload = case null (elementChildren e) of
      True -> Nothing
      False -> Just $ head $ elementChildren e
    
    typeAttr :: String
    typeAttr = case attributeText typeName e of
      -- Nothing -> Nothing
      Just a -> DT.unpack a
    
    fromAttr :: Maybe JID
    fromAttr = case attributeText fromName e of
      Nothing -> Nothing
      Just a -> stringToJID $ DT.unpack a
    
    toAttr :: Maybe JID
    toAttr = case attributeText toName e of
      Nothing -> Nothing
      Just a -> stringToJID $ DT.unpack a
    
    idAttr :: Maybe StanzaID
    idAttr = case attributeText idName e of
      Nothing -> Nothing
      Just a -> Just (SID (DT.unpack a))
    
    typeName :: Name
    typeName = fromString "type"
    
    fromName :: Name
    fromName = fromString "from"
    
    toName :: Name
    toName = fromString "to"
    
    idName :: Name
    idName = fromString "id"

parsePresence :: Element -> Presence
parsePresence e = Pres (idAttr, fromAttr, toAttr, typeAttr, elementChildren e)
  where
    -- TODO: Many duplicate functions from parseIQ.
    
    typeAttr :: Maybe PresenceType
    typeAttr = case attributeText typeName e of
      Just t -> Just (presence $ DT.unpack t)
      Nothing -> Nothing
    
    fromAttr :: Maybe JID
    fromAttr = case attributeText fromName e of
      Nothing -> Nothing
      Just a -> stringToJID $ DT.unpack a
    
    toAttr :: Maybe JID
    toAttr = case attributeText toName e of
      Nothing -> Nothing
      Just a -> stringToJID $ DT.unpack a
    
    idAttr :: Maybe StanzaID
    idAttr = case attributeText idName e of
      Nothing -> Nothing
      Just a -> Just (SID (DT.unpack a))
    
    fromName :: Name
    fromName = fromString "from"
    
    typeName :: Name
    typeName = fromString "type"
    
    toName :: Name
    toName = fromString "to"
    
    idName :: Name
    idName = fromString "id"

presence "available" = Available
presence "away" = Away
presence "chat" = Chat
presence "dnd" = DoNotDisturb
presence "xa" = ExtendedAway

presence "probe" = Probe

presence "unavailable" = Unavailable
presence "subscribe" = Subscribe
presence "subscribed" = Subscribed
presence "unsubscribe" = Unsubscribe
presence "unsubscribed" = Unsubscribed

presence_ Available = "available"
presence_ Away = "away"
presence_ Chat = "chat"
presence_ DoNotDisturb = "dnd"
presence_ ExtendedAway = "xa"
presence_ Unavailable = "unavailable"

presence_ Probe = "probe"

presence_ Subscribe = "subscribe"
presence_ Subscribed = "subscribed"
presence_ Unsubscribe = "unsubscribe"
presence_ Unsubscribed = "unsubscribed"

clientOutEventToXML :: ClientOutEvent -> String
clientOutEventToXML (COESimplePresence (presenceType, Nothing)) =
  "<presence><priority>5</priority><show>" ++ (presence_ presenceType) ++ "</show></presence>"
clientOutEventToXML (COESimplePresence (presenceType, Just (PS status))) =
  "<presence><priority>5</priority><show>" ++ (presence_ presenceType) ++ "</show><status>" ++ status ++ "</status></presence>"
clientOutEventToXML (COEComplexPresence (t, s, e)) =
  "<presence" ++ t' ++ s' ++ ">" ++ (e' e) ++ "</presence>"
  where
    e' :: Maybe Element -> String
    e' e = case e of
      Nothing -> ""
      Just e_ -> DT.unpack $ head $ elementText e_ -- TODO
    s' :: String
    s' = case s of
      -- TODO: Lower-case
      Just s'' -> " type='" ++ (presence_ s'') ++ "'"
      Nothing -> ""
    t' :: String
    t' = case t of
      Just t'' -> " to='" ++ (jidToString t'') ++ "'"
clientOutEventToXML (COEIQGet (s, j, e)) = "<iq type='get'" ++ s' ++ j' ++ ">" ++ (elementToString $ Just e) ++ "</iq>"
  where
    s' = case s of
      Nothing -> ""
      Just (SID i) -> " id=\"" ++ i ++ "\""
    j' = case j of
      Nothing -> ""
      Just t -> " to=\"" ++ (jidToString t) ++ "\""

clientOutEventToXML (COEIQSet (s, j, e)) = "<iq type='set'" ++ s' ++ j' ++ ">" ++ (elementToString $ Just e) ++ "</iq>"
  where
    s' = case s of
      Nothing -> ""
      Just (SID i) -> " id=\"" ++ i ++ "\""
    j' = case j of
      Nothing -> ""
      Just t -> " to=\"" ++ (jidToString t) ++ "\""

clientOutEventToXML (COEIQResult (s, j, e)) = "<iq type='result'" ++ s' ++ j' ++ ">" ++ (elementToString e) ++ "</iq>"
  where
    s' = case s of
      Nothing -> ""
      Just (SID i) -> " id=\"" ++  i ++ "\""
    j' = " to=\"" ++ (jidToString j) ++ "\""

elementToString :: Maybe Element -> String
elementToString Nothing = ""
elementToString (Just e) = "<" ++ nameToString (elementName e) ++ xmlns ++
                           attributes (DM.toList (elementAttributes e)) ++ ">" ++
                           (nodesToString $ elementNodes e) ++ "</" ++
                           nameToString (elementName e) ++ ">"
  where
    xmlns :: String
    xmlns = case nameNamespace $ elementName e of
      Nothing -> ""
      Just t -> " xmlns='" ++ (DT.unpack t) ++ "'"
    
    nameToString :: Name -> String
    nameToString Name { nameLocalName = n, namePrefix = Nothing } = DT.unpack n
    nameToString Name { nameLocalName = n, namePrefix = Just p } = (DT.unpack p) ++ ":" ++ (DT.unpack n)

    contentToString :: Content -> String
    contentToString (ContentText t) = DT.unpack t
    contentToString (ContentEntity t) = DT.unpack t
    
    attributes :: [(Name, [Content])] -> String
    attributes [] = ""
    attributes ((n, c):t) = (" " ++ (nameToString n) ++ "='" ++
                             concat (map contentToString c) ++ "'") ++
                            attributes t
    
    nodesToString :: [Node] -> String
    nodesToString [] = ""
    nodesToString ((NodeElement e):ns) = (elementToString $ Just e) ++ (nodesToString ns)
    nodesToString ((NodeContent c):ns) = (contentToString c) ++ (nodesToString ns)