-- | Module:      $Header$
--   Description: XMPP client session management module
--   Copyright:   Copyright © 2010-2011 Jon Kristensen
--   License:     BSD-3
--   
--   Maintainer:  info@pontarius.org
--   Stability:   unstable
--   Portability: portable
--   
--   This module will be documented soon.

-- TODO: Send white-space characters with regular intervals to keep the
--       connection alive.
-- TODO: Add namespace support for stream/features?
-- TODO: Add support for `ver optional' support for features?
-- TODO: Presence priority?
-- TODO: Stop the logger
-- TODO: Catch errors

module Network.XMPP.Session ( XMPPInEvent (..)
                            , XMPPOutEvent (..)
                            , createSession ) where


import Network.XMPP.JID
import Network.XMPP.SASL
import Network.XMPP.Stanza
import Network.XMPP.Utilities

import Codec.Binary.UTF8.String
import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
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 Data.Maybe
import Data.String
import Data.XML.Types
import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput)
import Network
import Network.TLS
import Network.TLS.Cipher
import System.IO (BufferMode, BufferMode(NoBuffering))
import System.Log.HLogger
import System.Log.SimpleHLogger
import Text.XML.Enumerator.Parse (parseBytes, decodeEntities)
import Text.XML.Enumerator.Document (fromEvents)
import qualified Codec.Binary.Base64.String as CBBS
import qualified Data.ByteString as DB
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.Enumerator as E
import qualified Data.Enumerator.List as EL
import qualified Data.List as DL
import qualified Data.Text as DT
import qualified Data.Text.Lazy as DTL


type Server = String
type Port = Integer

type UserName = String
type Password = String
type Resource = String


data XMPPInEvent = XIEConnectionSucceeded |
                   XIEConnectionFailed |
                   XIEAuthenticationSucceeded |
                   XIEAuthenticationFailed |
                   XIEMessage Message |
                   XIEPresence Presence |
                   XIEIQ IQ |
                   -- XIEIQJingle | -- Added for Jingle sessions
                   -- XIEIQXTLS |   -- Added for XTLS connection
                   XIEDisconnect deriving (Eq, Show)

data XMPPOutEvent = XOEConnect Server Port |
                    XOEAuthenticate UserName Password Resource |
                    XOEMessage Message |
                    XOEPresence Presence |
                    XOEIQ IQ |
                    -- XOEIQJingle | -- Added for Jingle sessions
                    -- XOEIQXTLS |   -- Added for XTLS connection
                    XOEDisconnect deriving (Eq, Show)


data SecurityEvent = TLSSucceeded TLSCtx | TLSFailed


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


data ConnectionState = Disconnected               |
                       ConnectedNotTLSSecured     |
                       ConnectedTLSSecured TLSCtx

instance Eq ConnectionState where
  (==) Disconnected Disconnected = True
  (==) ConnectedNotTLSSecured ConnectedNotTLSSecured = True
  (==) (ConnectedTLSSecured _) (ConnectedTLSSecured _) = True
  (==) _ _ = False

data AuthenticationState = AuthNotRequested    |
                           AuthRequested       |
                           Challenge1Processed |
                           Authenticated deriving (Eq)

data State = State { stateConnectionState :: ConnectionState
                   , stateAuthenticationState :: AuthenticationState
                   , stateHandle :: Maybe Handle
                   , stateServer :: Maybe (Server, Port)
                   , stateUserName :: Maybe String
                   , statePassword :: Maybe String
                   , stateResource :: Maybe String
                   , stateStreamID :: Maybe String }

defaultState = State { stateConnectionState = Disconnected
                     , stateAuthenticationState = AuthNotRequested
                     , stateHandle = Nothing
                     , stateServer = Nothing
                     , stateUserName = Nothing
                     , statePassword = Nothing
                     , stateResource = Nothing
                     , stateStreamID = Nothing }


-- 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 |
                XEMessage Message | 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 InternalEvent = IEX XMLEvent |
                     IEO XMPPOutEvent |
                     IES SecurityEvent deriving (Show)


-- | Creates a Pontarius XMPP session by setting up internal processes and state
--   and creates the two (in and out) event channels that the XMPP client uses
--   for communicating with Pontarius XMPP.

createSession :: IO (Chan XMPPInEvent, Chan XMPPOutEvent)

createSession = do
  logger <- simpleLogger "PontariusXMPP"
  loggerLog logger (Just ("Session", "createSession")) Info "Pontarius XMPP has started"
  
  -- Create client "in" and "out" channels (naming from the perspective of the
  -- XMPP client) as well as the internal event channel used by the state loop
  inChan <- newChan
  outChan <- newChan
  internalChan <- newChan
  
  -- 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 internalChan inChan logger
  
  return (inChan, outChan)


-- Receives events from the XMPP client and forwards them to the state loop by
-- using the internal event channel.

clientListener :: Chan XMPPOutEvent -> Chan InternalEvent -> Logger -> IO ()

clientListener c c_ l =
  do event <- readChan c
     loggerLog l (Just ("Session", "clientListener")) Debug $ "clientListener: Forwarding received client event: " ++ show (event)
     writeChan c_ (IEO event)
     clientListener c c_ l


-- Processes internal events to possibly perform actions and update the session
-- state. Note that the InternalEvent type wraps the external client events.

stateLoop :: State -> Chan InternalEvent -> Chan XMPPInEvent -> 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
      connectionState = stateConnectionState s
      authenticationState = stateAuthenticationState s
      handle = stateHandle s
      server = stateServer s
      userName = stateUserName s
      password = statePassword s
      resource = stateResource s
      streamID = stateStreamID s
      Just (serverHost, serverPort) = stateServer s
      tlsCtx = let ConnectedTLSSecured x = connectionState in x
      
      -- let xml = clientOutEventToXML clientEvent
      -- logDebug l $ "processEvent: Sending XML: " ++ xml
      -- sendData (fromJust tlsCtx) $ DBLC.pack $ encodeString $ xml
      
      processEvent (IEO clientOutEvent) = do
        loggerLog l (Just ("Session", "processEvent")) Debug $ "Processing client out event " ++ (show clientOutEvent)
        case clientOutEvent of
          XOEConnect serverHost_ serverPort_ -> do
            handle <- connectTo serverHost_ (PortNumber $ fromInteger serverPort_)
            hSetBuffering handle NoBuffering
            hPutStr handle $ encodeString $
              "<?xml version='1.0'?><stream:stream to='" ++ serverHost_ ++
              "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.or" ++
              "g/streams' version='1.0'>"
            hFlush handle
            
            -- Start XML enumerator, which will read from the handle to generate the
            -- relevant internal events
            forkIO $ xmlEnumerator c handle serverHost_ l
            
            return s { stateConnectionState = ConnectedNotTLSSecured
                     , stateHandle = Just handle
                     , stateServer = Just (serverHost_, serverPort_) }
          
          -- TODO: Function to verify certificate?
          XOEAuthenticate userName_ password_ resource_ -> do
            sendData tlsCtx $ DBLC.pack $ encodeString
              "<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl' mechanism='DIGEST-MD5'/>"
            return s { stateAuthenticationState = AuthRequested
                     , stateUserName = Just userName_
                     , statePassword = Just password_
                     , stateResource = Just resource_ }
          
          XOEPresence presence -> do
            presence' <- case stanzaID $ presenceStanza presence of
              Nothing -> do
                id <- getID
                return $ presence { presenceStanza = (presenceStanza presence) { stanzaID = Just (SID id) } }
              _ -> return presence
            
            let xml = presenceToXML presence'
            loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Will send presence XML: " ++ xml
            sendData tlsCtx $ DBLC.pack $ encodeString $ xml
            return s
          
          XOEMessage message -> do
            message' <- case stanzaID $ messageStanza message of
              Nothing -> do
                id <- getID
                return $ message { messageStanza = (messageStanza message) { stanzaID = Just (SID id) } }
              _ -> return message
            
            let xml = messageToXML message'
            loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Will send message XML: " ++ xml
            sendData tlsCtx $ DBLC.pack $ encodeString $ xml
            return s
          
          XOEIQ iq -> do
            iq' <- case stanzaID $ iqStanza iq of
              Nothing -> do
                id <- getID
                return $ case iq of
                  IQGet {} -> do
                    iq { iqGetStanza = (iqStanza iq) { stanzaID = Just (SID id) } }
                  IQSet {} -> do
                    iq { iqSetStanza = (iqStanza iq) { stanzaID = Just (SID id) } }
                  IQResult {} -> do
                    iq { iqResultStanza = (iqStanza iq) { stanzaID = Just (SID id) } }
              _ -> return iq
            
            let xml = iqToXML iq'
            loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Will send IQ XML: " ++ xml
            sendData tlsCtx $ DBLC.pack $ encodeString $ xml
            return s
          
          XOEDisconnect -> do
            -- TODO: Close stream
            return s
      
      -- TODO: processEvent (IES TLSFailed) =
      
      processEvent (IES (TLSSucceeded receivedTLSCtx)) =
        return (s { stateConnectionState = ConnectedTLSSecured receivedTLSCtx })
      
      -- A <stream:stream> element has begun
      -- TODO: Parse the XEStreamBegin object
      processEvent (IEX (XEBeginStream _)) = do
        loggerLog l (Just ("Session", "processEvent")) Debug "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 _))
        | connectionState == ConnectedNotTLSSecured = do
          loggerLog l (Just ("Session", "processEvent")) Debug $
            "processEvent: Received features ([...]) on insecure stream; req" ++
            "uesting \"starttls\""
          hPutStr (fromJust handle) $
            "<starttls xmlns='urn:ietf:params:xml:ns:xmpp-tls'/>"
          hFlush (fromJust handle)
          return s
      
      -- We have received <features> on a secure and non-authenticated stream
      processEvent (IEX (XEFeatures _))
        | connectionState == ConnectedTLSSecured tlsCtx &&
          authenticationState /= Authenticated = do
            loggerLog l (Just ("Session", "processEvent")) Debug $
              "processEvent: Received features ([...]) on an unauthenticated" ++
              " secure stream"
            writeChan c_ $ XIEConnectionSucceeded
            return s
      
      -- We have received <features> on an authenticated secure stream; we are
      -- now ready to start processing client events
      processEvent (IEX (XEFeatures _))
        | connectionState == ConnectedTLSSecured tlsCtx = do
          loggerLog l (Just ("Session", "processEvent")) Debug $
            "processEvent: Received features ([...]) on an authenticated sec" ++
            "ure stream"
          loggerLog l (Just ("Session", "processEvent")) Info $ "processEvent: User has successfully logged in"
          case resource of
            Nothing -> do
              sendData tlsCtx $ DBLC.pack $ encodeString
                "<iq type=\"set\" id=\"bind_1\"><bind xmlns=\"urn:ietf:param" ++
                "s:xml:ns:xmpp-bind\"></bind></iq>"
              return ()
            _ -> do
              loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Setting resource: " ++
                (fromJust resource)
              sendData tlsCtx $ DBLC.pack $ encodeString
                "<iq type=\"set\" id=\"bind_1\"><bind xmlns=\"urn:ietf:param" ++
                "s:xml:ns:xmpp-bind\"><resource>" ++ fromJust resource ++
                "</resource></bind></iq>"
              return ()
          r <- getID
          sendData tlsCtx $ DBLC.pack $ encodeString $
            "<iq type=\"set\" id=\"" ++ r ++
            "\"><session xmlns=\"urn:ietf:params:xml:ns:xmpp-session\"/>" ++
            "</iq>"
          writeChan c_ $ XIEAuthenticationSucceeded
          return (s { stateAuthenticationState = Authenticated })
      
      -- We have received a SASL challenge on a secure stream
      processEvent (IEX (XEChallenge (Chal challenge)))
        | connectionState == ConnectedTLSSecured tlsCtx = do
          let challenge' = CBBS.decode challenge
          case authenticationState of
            AuthRequested -> do
              -- This is the first challenge - we need to calculate the reply
              loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Received initial challenge: " ++
                challenge ++ " (or " ++ challenge' ++ ")"
              random <- getID -- TODO: Length and content.
              case replyToChallenge1 challenge' serverHost (fromJust userName)
                   (fromJust password) random of
                Left reply -> do
                  let reply' = (filter (/= '\n') (CBBS.encode reply))
                  loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Sending challenge response: " ++
                    reply'
                  sendData tlsCtx $ DBLC.pack $ encodeString $
                    "<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>" ++
                    reply' ++ "</response>"
                  return (s { stateAuthenticationState = Challenge1Processed } )
                Right error -> do
                  putStrLn $ show error
                  return s
            Challenge1Processed  -> do
              -- This is not the first challenge; [...]
              -- TODO: Can we assume "rspauth"?
              loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Received non-initial challenge: " ++
                challenge ++ " (or " ++ challenge' ++ ")"
              liftIO $ sendData 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 _)))
        | connectionState == ConnectedTLSSecured tlsCtx = do
          loggerLog l (Just ("Session", "processEvent")) Debug $
            "processEvent: Received authentication success: [...]; restartin" ++
            "g stream" -- TODO
          sendData tlsCtx $ DBLC.pack $
            encodeString "<?xml version='1.0'?><stream:stream to='" ++
            serverHost ++
            "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/" ++
            "streams' version='1.0'>"
          return s { stateAuthenticationState = Authenticated }
      
      -- Ignore id="bind_1" and session IQ result, otherwise create client event
      processEvent (IEX (XEIQ iqEvent))
        | authenticationState == Authenticated = do
          case shouldIgnoreIQ iqEvent of
            True ->
              return s
            False -> do
              loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Got IQ for client: " ++
                (show iqEvent)
              writeChan c_ $ XIEIQ iqEvent
              return s
      
      processEvent (IEX (XEPresence presenceEvent))
        | authenticationState == Authenticated = do
          loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Got presence for client: " ++
            (show presenceEvent)
          writeChan c_ $ XIEPresence presenceEvent
          return s
      
      processEvent (IEX (XEMessage messageEvent)) = do
        loggerLog l (Just ("Session", "processEvent")) Debug $ "processEvent: Got message for client: " ++
          (show messageEvent)
        writeChan c_ $ XIEMessage messageEvent
        return s
      
      -- We received an XML element that we didn't parse
      processEvent (IEX xmlEvent) = do
        loggerLog l (Just ("Session", "processEvent")) Warning $ "processEvent: XML event slipped through: " ++
          (show xmlEvent)
        return s

      shouldIgnoreIQ :: IQ -> Bool
      shouldIgnoreIQ i = case iqPayload i of
        Nothing -> False
        Just e -> case nameNamespace $ elementName e of
          Just x | x == DT.pack "urn:ietf:params:xml:ns:xmpp-bind" -> True
          Just x | x == DT.pack "urn:ietf:params:xml:ns:xmpp-session" -> True
          Just _ -> False
          Nothing -> False
        
parseIQ :: Element -> IQ
parseIQ e | typeAttr == "get" = let (Just payloadMust) = payload
                                in iqGet idAttr fromAttr toAttr Nothing
                                   payloadMust
          | typeAttr == "set" = let (Just payloadMust) = payload
                                in iqSet idAttr fromAttr toAttr Nothing
                                   payloadMust
          | typeAttr == "result" = iqResult idAttr fromAttr toAttr Nothing
                                   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"

-- TODO: Parse xml:lang

parsePresence :: Element -> Presence
parsePresence e = presence idAttr fromAttr toAttr Nothing typeAttr (elementChildren e)
  where
    -- TODO: Many duplicate functions from parseIQ.
    
    typeAttr :: PresenceType
    typeAttr = case attributeText typeName e of
      Just t -> stringToPresenceType $ DT.unpack t
      Nothing -> Available
    
    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"

parseMessage :: Element -> Message
parseMessage e = message idAttr fromAttr toAttr Nothing typeAttr (elementChildren e)
  where
    -- TODO: Many duplicate functions from parseIQ.
    
    typeAttr :: MessageType
    typeAttr = case attributeText typeName e of
      Just t -> stringToMessageType $ DT.unpack t
      Nothing -> Normal
    
    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"

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

stringToPresenceType "probe" = Probe
stringToPresenceType "error" = PresenceError

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

-- presenceTypeToString Available = "available"

-- presenceTypeToString Away = "away"
-- presenceTypeToString Chat = "chat"
-- presenceTypeToString DoNotDisturb = "dnd"
-- presenceTypeToString ExtendedAway = "xa"

presenceTypeToString Unavailable = "unavailable"

presenceTypeToString Probe = "probe"
presenceTypeToString PresenceError = "error"

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

stringToMessageType "chat" = Chat
stringToMessageType "error" = MessageError
stringToMessageType "groupchat" = Groupchat
stringToMessageType "headline" = Headline
stringToMessageType "normal" = Normal
stringToMessageType s = OtherMessageType s

messageTypeToString Chat = "chat"
messageTypeToString MessageError = "error"
messageTypeToString Groupchat = "groupchat"
messageTypeToString Headline = "headline"
messageTypeToString Normal = "normal"
messageTypeToString (OtherMessageType s) = s

xmlEnumerator :: Chan InternalEvent -> Handle -> String -> Logger -> IO ()
xmlEnumerator c h s l = do
  loggerLog l (Just ("Session", "processEvent")) Debug $ "xmlEnumerator: Starting to read insecure XML"
  run_ $ enumHandle 1 h $$ joinI $ parseBytes decodeEntities
    $$ xmlReader c [] 0
  loggerLog l (Just ("Session", "processEvent")) Debug $ "xmlEnumerator: Unsecure stream ended - performing TLS handshake"
  t <- handshake' h s
  case t of
    Just tlsctx -> do loggerLog l (Just ("Session", "processEvent")) Debug $ "xmlEnumerator: Handshake successful - st" ++
                        "arting to read secure XML"
                      writeChan c (IES (TLSSucceeded tlsctx))
                      run_ $ enumTLS tlsctx $$ joinI $ parseBytes decodeEntities
                        $$ xmlReader c [] 0
                      loggerLog l (Just ("Session", "processEvent")) Debug $
                        "xmlEnumerator: Secure stream ended, exiting"
                      return ()
    Nothing -> loggerLog l (Just ("Session", "processEvent")) Debug $ "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
  | nameLocalName name == DT.pack "message" = XEMessage $ parseMessage $ eventsToElement e
  | otherwise = XEOther $ elementToString $ Just (eventsToElement e)
      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

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

presenceToXML :: Presence -> String
presenceToXML p = "<presence" ++ from ++ id' ++ to ++ type' ++ ">" ++
                  (elementsToString $ presencePayload p) ++ "</presence>"
  where
    s = presenceStanza p
    
    from :: String
    from = case stanzaFrom $ presenceStanza p of
      -- TODO: Lower-case
      Just s -> " from='" ++ (jidToString s) ++ "'"
      Nothing -> ""
    
    id' :: String
    id' = case stanzaID s of
      Just (SID s) -> " id='" ++ s ++ "'"
      Nothing -> ""
    
    to :: String
    to = case stanzaTo $ presenceStanza p of
      -- TODO: Lower-case
      Just s -> " to='" ++ (jidToString s) ++ "'"
      Nothing -> ""
    
    type' :: String
    type' = case presenceType p of
      Available -> ""
      t -> " type='" ++ (presenceTypeToString t) ++ "'"

iqToXML :: IQ -> String
iqToXML IQGet { iqGetStanza = s, iqGetPayload = p } =
  let type' = " type='get'" in "<iq" ++ from ++ id' ++ to ++ type' ++ ">" ++ (elementToString (Just p)) ++ "</iq>"
  where
    from :: String
    from = case stanzaFrom s of
      -- TODO: Lower-case
      Just s -> " from='" ++ (jidToString s) ++ "'"
      Nothing -> ""
    
    id' :: String
    id' = case stanzaID s of
      Just (SID s) -> " id='" ++ s ++ "'"
      Nothing -> ""
    
    to :: String
    to = case stanzaTo s of
      -- TODO: Lower-case
      Just s -> " to='" ++ (jidToString s) ++ "'"
      Nothing -> ""

iqToXML IQSet { iqSetStanza = s, iqSetPayload = p } =
  let type' = " type='set'" in "<iq" ++ from ++ id' ++ to ++ type' ++ ">" ++ (elementToString (Just p)) ++ "</iq>"
  where
    from :: String
    from = case stanzaFrom s of
      -- TODO: Lower-case
      Just s -> " from='" ++ (jidToString s) ++ "'"
      Nothing -> ""
    
    id' :: String
    id' = case stanzaID s of
      Just (SID s) -> " id='" ++ s ++ "'"
      Nothing -> ""
    
    to :: String
    to = case stanzaTo s of
      -- TODO: Lower-case
      Just s -> " to='" ++ (jidToString s) ++ "'"
      Nothing -> ""

iqToXML IQResult { iqResultStanza = s, iqResultPayload = p } =
  let type' = " type='result'" in "<iq" ++ from ++ id' ++ to ++ type' ++ ">" ++ (elementToString p) ++ "</iq>"
  where
    from :: String
    from = case stanzaFrom s of
      -- TODO: Lower-case
      Just s -> " from='" ++ (jidToString s) ++ "'"
      Nothing -> ""
    
    id' :: String
    id' = case stanzaID s of
      Just (SID s) -> " id='" ++ s ++ "'"
      Nothing -> ""
    
    to :: String
    to = case stanzaTo s of
      -- TODO: Lower-case
      Just s -> " to='" ++ (jidToString s) ++ "'"
      Nothing -> ""

messageToXML :: Message -> String
messageToXML m = "<message" ++ from ++ id' ++ to ++ type' ++ ">" ++
                  (elementsToString $ messagePayload m) ++ "</message>"
  where
    s = messageStanza m
    
    from :: String
    from = case stanzaFrom $ messageStanza m of
      -- TODO: Lower-case
      Just s -> " from='" ++ (jidToString s) ++ "'"
      Nothing -> ""
    
    id' :: String
    id' = case stanzaID s of
      Just (SID s) -> " id='" ++ s ++ "'"
      Nothing -> ""
    
    to :: String
    to = case stanzaTo $ messageStanza m of
      -- TODO: Lower-case
      Just s -> " to='" ++ (jidToString s) ++ "'"
      Nothing -> ""
    
    type' :: String
    type' = case messageType m of
      Normal -> ""
      t -> " type='" ++ (messageTypeToString t) ++ "'"