Session.hs

{-

Copyright © 2010-2011 Jon Kristensen.

This file is part of Pontarius XMPP.

Pontarius XMPP is free software: you can redistribute it and/or modify it under
the terms of the GNU Lesser General Public License as published by the Free
Software Foundation, either version 3 of the License, or (at your option) any
later version.

Pontarius XMPP is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more
details.

You should have received a copy of the GNU Lesser General Public License along
with Pontarius XMPP. If not, see <http://www.gnu.org/licenses/>.

-}

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


-- I believe we need to use the MultiParamTypeClasses extension to be able to
-- work with arbitrary client states (solving the problem that the ClientState
-- type class is solving). However, I would be happy if someone proved me wrong.

{-# LANGUAGE MultiParamTypeClasses #-}

-- TODO: Better functions and events for stanzas, IncomingIQ, OutgoingIQ, etc. (ClientSession, ClientStanza)

-- TODO: IO function to do everything related to the handle, instead of just connecting.

-- TODO: Enumerate in the same thread? Enumerate one element at the time, non-blocking?


-- | This module provides the functions used by XMPP clients to manage their
--   XMPP sessions.
--   
--   Working with Pontarius XMPP is mostly done asynchronously with callbacks;
--   Pontarius XMPP "owns" the XMPP thread and carries the client state with it.
--   A client consists of a list of client handlers to handle XMPP events. This
--   is all set up through a @Session@ object, which a client can create by
--   calling the (blocking) function @createSession@.
--   
--   The Pontarius XMPP functions operate in an arbitrary MonadIO monad.
--   Typically, clients will use the IO monad.
--   
--   For more information, see the Pontarius XMPP Manual.

module Network.XMPP.Session ( Certificate
                            , ClientHandler (..)
                            , ClientState (..)
                            , ConnectResult (..)
                            , HostName
                            , Password
                            , PortNumber
                            , Resource
                            , Session
                            , TerminationReason
                            , UserName
                            , OpenStreamResult (..)
                            , SecureWithTLSResult (..)
                            , AuthenticateResult (..)
                            , sendPresence
                            , sendIQ
                            , sendMessage
                            , connect
                            , openStream
                            , secureWithTLS
                            , authenticate
                            , createSession ) where

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

import qualified Control.Exception as CE
import qualified Control.Exception.Base as CEB -- ?
import qualified Control.Monad.Error as CME
import qualified Control.Monad.State as CMS
import qualified Network as N

-------------

import Control.Concurrent.MVar

import Codec.Binary.UTF8.String
import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
import Control.Concurrent (ThreadId, forkIO, killThread, threadDelay)
import Control.Monad.IO.Class (liftIO, MonadIO)
import Control.Monad.State hiding (State)
import Data.Enumerator (($$), Iteratee, continue, joinI,
                        run, 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.TLS
import Network.TLS.Cipher
import System.IO (BufferMode, BufferMode(NoBuffering))
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



-- =============================================================================
--  EXPORTED TYPES AND FUNCTIONS
-- =============================================================================


-- | The @Session@ object is used by clients when interacting with Pontarius
--   XMPP. It holds information needed by Pontarius XMPP; its content is not
--   accessible from the client.

data Session s m = Session { sessionChannel :: Chan (InternalEvent s m) }


-- | A client typically needs one or more @ClientHandler@ objects to interact
--   with Pontarius XMPP. Each client handler may provide four callback
--   functions; the first three callbacks deals with received stanzas, and the
--   last one is used when the session is terminated.
--   
--   These stanza functions takes the current client state and an object
--   containing the details of the stanza in question. The boolean returned
--   along with the possibly updated state signals whether or not the message
--   should be blocked to client handlerss further down the stack. For example,
--   an XEP-0030: Service Discovery handler may choose to hide disco\#info
--   requests to handlers above it in the stack.
--   
--   The 'sessionTerminated' callback function takes a 'TerminationReason' value
--   along with the state and will be sent to all client handlers.

data MonadIO m => ClientHandler s m =
  ClientHandler { messageReceived :: Maybe (Message -> StateT s m Bool)
                , presenceReceived :: Maybe (Presence -> StateT s m Bool)
                , iqReceived :: Maybe (IQ -> StateT s m Bool)
                , sessionTerminated :: Maybe (TerminationReason ->
                                              StateT s m ()) }


-- | Readability type for host name Strings.

type HostName = String -- This is defined in Network as well


-- | Readability type for port number Integers.

type PortNumber = Integer -- We use N(etwork).PortID (PortNumber) internally


-- | Readability type for user name Strings.

type UserName = String


-- | Readability type for password Strings.

type Password = String


-- | Readability type for (JID) resource identifier Strings.

type Resource = String


-- | @TerminationReason@ contains information on why the XMPP session was
--   terminated.

data TerminationReason = WhateverReason -- TODO


type Certificate = String -- TODO

data ConnectResult = ConnectSuccess StreamProperties StreamFeatures (Maybe Resource) |
                     ConnectOpenStreamFailure |
                     ConnectSecureWithTLSFailure |
                     ConnectAuthenticateFailure

data OpenStreamResult = OpenStreamSuccess StreamProperties StreamFeatures |
                        OpenStreamFailure

data SecureWithTLSResult = SecureWithTLSSuccess StreamProperties StreamFeatures | SecureWithTLSFailure

data AuthenticateResult = AuthenticateSuccess StreamProperties StreamFeatures Resource | AuthenticateFailure

type StreamProperties = Float
type StreamFeatures = String


-- | Creates an XMPP session. Blocks the current thread. The first parameter,
--   @s@, is an arbitrary state that is defined by the client. This is the
--   initial state, and it will be passed to the client (handlers) as XMPP
--   events are emitted. The second parameter is the list of @ClientHandler@s;
--   this is a way to provide a "layered" system of XMPP event handlers. For
--   example, a client may have a dedicated handler to manage messages,
--   implement a spam protection system, etc. Messages are piped through these
--   handlers one by one, and any handler may block the message from being sent
--   to the next handler(s) above in the stack. The third argument is a callback
--   function that will be called when the session has been initialized, and
--   this function should be used by the client to store the Session object in
--   its state.

-- Creates the internal event channel, injects the Pontarius XMPP session object
-- into the ClientState object, runs the "session created" client callback (in
-- the new state context), and stores the updated client state in s''. Finally,
-- we launch the (main) state loop of Pontarius XMPP.

createSession :: (MonadIO m, ClientState s m) => s -> [ClientHandler s m] ->
                 (CMS.StateT s m ()) -> m ()

createSession s h c = do
  threadID <- liftIO $ newEmptyMVar
  chan <- liftIO $ newChan
  ((), clientState) <- runStateT c (putSession s $ session chan)
  (result, _) <- runStateT (stateLoop chan)
                 (defaultState chan threadID h clientState)
  case result of
    Just (CE.SomeException e) -> do
      liftIO $ putStrLn "Got an exception!"
      threadID' <- liftIO $ tryTakeMVar threadID
      case threadID' of
        Nothing -> do
          liftIO $ putStrLn "No thread ID to kill"
        Just t -> do
          liftIO $ putStrLn "Killing thread"
          liftIO $ killThread t
      CE.throw e
    Nothing ->
      return ()
  where
    -- session :: Chan (InternalEvent m s) -> Session m s -- TODO
    session c = Session { sessionChannel = c }


defaultState :: (MonadIO m, ClientState s m) => Chan (InternalEvent s m) -> MVar ThreadId ->
                [ClientHandler s m] -> s -> State s m

defaultState c t h s = State { stateClientHandlers = h
                             , stateClientState = s
                             , stateChannel = c
                             , stateConnectionState = Disconnected
                             , stateStreamState = PreStream
                             , stateTLSState = NoTLS
                             , stateOpenStreamCallback = Nothing
                             , stateSecureWithTLSCallback = Nothing
                             , stateAuthenticateCallback = Nothing
                             , stateAuthenticationState = NoAuthentication
                             , stateResource = Nothing
                             , stateShouldExit = False
                             , stateThreadID = t
                             , stateIQCallbacks = [] }


connect :: MonadIO m => Session s m -> HostName -> PortNumber ->
           Maybe (Certificate, (Certificate -> Bool)) ->
           Maybe (UserName, Password, Maybe Resource) ->
           (ConnectResult -> StateT s m ()) -> StateT s m ()

-- data ConnectResult = ConnectSuccess StreamProperties StreamFeatures Resource |
--                      ConnectOpenStreamFailure |
--                      ConnectTLSSecureStreamFailure |
--                      ConnectAuthenticateFailure

-- data OpenStreamResult = OpenStreamSuccess StreamProperties StreamFeatures |
--                         OpenStreamFailure

-- data SecureWithTLSResult = SecureWithTLSSuccess StreamProperties StreamFeatures | SecureWithTLSFailure

-- data AuthenticateResult = AuthenticateSuccess Resource | AuthenticateFailure


connect s h p t a c = openStream s h p connect'
  where
    connect' r = case r of
      OpenStreamSuccess _ _ -> case t of -- TODO: Check for TLS support?
        Just (certificate, certificateValidator) ->
          secureWithTLS s certificate certificateValidator connect''
        Nothing -> connect'' (SecureWithTLSSuccess 1.0 "") -- TODO
      OpenStreamFailure -> c ConnectOpenStreamFailure
    connect'' r = case r of
      SecureWithTLSSuccess _ _ -> case a of
        Just (userName, password, resource) ->
          authenticate s userName password resource connect'''
        Nothing -> connect''' (AuthenticateSuccess 1.0 "" "todo") -- TODO
      SecureWithTLSFailure -> c ConnectSecureWithTLSFailure
    connect''' r = case r of
      AuthenticateSuccess streamProperties streamFeatures resource ->
        c (ConnectSuccess streamProperties streamFeatures (Just resource))
      AuthenticateFailure -> c ConnectAuthenticateFailure


openStream :: MonadIO m => Session s m -> HostName -> PortNumber ->
              (OpenStreamResult -> StateT s m ()) -> StateT s m ()

openStream s h p c = CMS.get >>=
                     (\ state -> lift $ liftIO $ writeChan (sessionChannel s)
                                 (IEC (CEOpenStream state h p c)))


secureWithTLS :: MonadIO m => Session s m -> Certificate ->
                 (Certificate -> Bool) ->
                 (SecureWithTLSResult -> StateT s m ()) -> StateT s m ()

secureWithTLS s c a c_ = CMS.get >>=
                         (\ state -> lift $ liftIO $
                                     writeChan (sessionChannel s)
                                     (IEC (CESecureWithTLS state c a c_)))


-- |

authenticate :: MonadIO m => Session s m -> UserName -> Password ->
                Maybe Resource -> (AuthenticateResult -> StateT s m ()) ->
                StateT s m ()

authenticate s u p r c = CMS.get >>=
                         (\ state -> lift $ liftIO $
                                     writeChan (sessionChannel s)
                                     (IEC (CEAuthenticate state u p r c)))


sendMessage :: MonadIO m => Session s m -> Message -> StateT s m ()
sendMessage s m = CMS.get >>=
                  (\ state -> lift $ liftIO $
                              writeChan (sessionChannel s)
                              (IEC (CEMessage state m)))

sendPresence :: MonadIO m => Session s m -> Presence -> StateT s m ()
sendPresence s p = CMS.get >>=
                   (\ state -> lift $ liftIO $
                               writeChan (sessionChannel s)
                               (IEC (CEPresence state p)))

sendIQ :: MonadIO m => Session s m -> IQ -> Maybe (IQ -> StateT s m Bool) -> StateT s m ()
sendIQ s i c = CMS.get >>=
               (\ state -> lift $ liftIO $
                           writeChan (sessionChannel s)
                           (IEC (CEIQ state i c)))

-- xmppDisconnect :: MonadIO m => Session s m -> Maybe (s -> (Bool, s)) -> m ()
-- xmppDisconnect s c = xmppDisconnect s c

class ClientState s m where
  putSession :: s -> Session s m -> s


-- =============================================================================
--  INTERNAL TYPES AND FUNCTIONS
-- =============================================================================


data XMPPError = UncaughtEvent deriving (Eq, Show)

instance CME.Error XMPPError where
  strMsg "UncaughtEvent" = UncaughtEvent

type StreamID = String


-- Client actions that needs to be performed in the (main) state loop are
-- converted to ClientEvents and sent through the internal event channel.

data ClientEvent s m = CEOpenStream s N.HostName PortNumber
                       (OpenStreamResult -> StateT s m ()) |
                       CESecureWithTLS s Certificate (Certificate -> Bool)
                       (SecureWithTLSResult -> StateT s m ()) |
                       CEAuthenticate s UserName Password (Maybe Resource)
                       (AuthenticateResult -> StateT s m ()) |
                       CEMessage s Message |
                       CEPresence s Presence |
                       CEIQ s IQ (Maybe (IQ -> StateT s m Bool))

instance Show (ClientEvent s m) where
  show (CEOpenStream _ h p _) = "CEOpenStream " ++ h ++ " " ++ (show p)
  show (CESecureWithTLS _ c _ _) = "CESecureWithTLS " ++ c
  show (CEAuthenticate _ u p r _) = "CEAuthenticate " ++ u ++ " " ++ p ++ " " ++
                                    (show r)
  show (CEIQ _ i (Just _)) = "CEIQ " ++ (show i) ++ " (with callback)"
  show (CEIQ _ i Nothing) = "CEIQ " ++ (show i) ++ " (without callback)"
  show (CEMessage _ m) = "CEMessage " ++ (show m)
  show (CEPresence _ p) = "CEPresence " ++ (show p)


-- An XMLEvent is triggered by an XML stanza or some other XML event, and is
-- sent through the internal event channel, just like client action events.

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


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


data EnumeratorEvent = EnumeratorDone |
                       EnumeratorXML XMLEvent |
                       EnumeratorException CE.SomeException
                       deriving (Show)


-- Type to contain the internal events.

data InternalEvent s m = IEC (ClientEvent s m) | IEE EnumeratorEvent deriving (Show)


data Challenge = Chal String deriving (Show)

data Success = Succ String deriving (Show)


data ConnectionState s m = Disconnected | Connected ServerAddress Handle


type OpenStreamCallback s m = Maybe (OpenStreamResult -> CMS.StateT s m ())

type SecureWithTLSCallback s m = Maybe (SecureWithTLSResult -> CMS.StateT s m ())

type AuthenticateCallback s m = Maybe (AuthenticateResult -> CMS.StateT s m ())


data StreamState s m = PreStream |
                       PreFeatures StreamProperties |
                       PostFeatures StreamProperties StreamFeatures



data TLSState = NoTLS | PreProceed | PreHandshake | PostHandshake TLSCtx


isTLSSecured :: TLSState -> Bool
isTLSSecured (PostHandshake _) = True
isTLSSecured _ = False

data AuthenticationState s m = NoAuthentication | AuthenticatingPreChallenge1 String String (Maybe Resource) | AuthenticatingPreChallenge2 String String (Maybe Resource) | AuthenticatingPreSuccess String String (Maybe Resource) | AuthenticatedUnbound String (Maybe Resource) | AuthenticatedBound String Resource


isConnected :: ConnectionState s m -> Bool
isConnected Disconnected = True
isConnected (Connected _ _) = True

instance Eq (ConnectionState s m) where
  Disconnected == Disconnected = True
  (Connected p h) == (Connected p_ h_) = p == p_ && h == h_
  -- (ConnectedPostFeatures s p h t) == (ConnectedPostFeatures s p h t) = True
  -- (ConnectedAuthenticated s p h t) == (ConnectedAuthenticated s p h t) = True
  _ == _ = False

data ServerAddress = ServerAddress N.HostName N.PortNumber deriving (Eq)

data MonadIO m => State s m =
  State { stateClientHandlers :: [ClientHandler s m]
        , stateClientState :: s
        , stateChannel :: Chan (InternalEvent s m)
        , stateConnectionState :: ConnectionState s m
        , stateTLSState :: TLSState
        , stateStreamState :: StreamState s m
        , stateOpenStreamCallback :: OpenStreamCallback s m
        , stateSecureWithTLSCallback :: SecureWithTLSCallback s m
        , stateAuthenticateCallback :: AuthenticateCallback s m
        , stateAuthenticationState :: AuthenticationState s m
        , stateResource :: Maybe Resource
        , stateShouldExit :: Bool
        , stateThreadID :: MVar ThreadId
        , stateIQCallbacks :: [(StanzaID, (IQ -> StateT s m Bool))]
        }


-- Repeatedly reads internal events from the channel and processes them. This is
-- the main loop of the XMPP session process.

-- The main loop of the XMPP library runs in the following monads:
--
-- m, m => MonadIO (from the client)
-- StateT
-- ErrorT

-- TODO: Will >> carry the updated state?
-- TODO: Should InternalState be in both places?

stateLoop :: (MonadIO m, ClientState s m) => Chan (InternalEvent s m) ->
             StateT (State s m) m (Maybe CE.SomeException)

stateLoop c = do
  event <- lift $ liftIO $ readChan c
  lift $ liftIO $ putStrLn $ "Processing event " ++ (show event) ++ "."
  result <- (processEvent event)
  state <- get
  case result of
    Nothing -> do
      case stateShouldExit state of
        True ->
          return $ Nothing
        False ->
          stateLoop c
    Just e ->
      return $ Just e


-- Process an InternalEvent and performs the necessary IO and updates the state
-- accordingly.

processEvent :: (MonadIO m, ClientState s m) => (InternalEvent s m) ->
                (StateT (State s m) m) (Maybe CE.SomeException)

processEvent e = get >>= \ state ->
  let handleOrTLSCtx = case stateTLSState state of
        PostHandshake tlsCtx ->
          Right tlsCtx
        _ ->
          let Connected _ handle = stateConnectionState state in Left handle
  in case e of
  
  -- ---------------------------------------------------------------------------
  --  CLIENT EVENTS
  -- ---------------------------------------------------------------------------
  -- 
  IEC (CEOpenStream clientState hostName portNumber callback) -> do
    
    CEB.assert (stateConnectionState state == Disconnected) (return ())
    
    let portNumber' = fromIntegral portNumber
    
    connectResult <- liftIO $ CE.try $ N.connectTo hostName
                     (N.PortNumber portNumber')
    
    case connectResult of
      Right handle -> do
        put $ state { stateConnectionState = Connected (ServerAddress hostName portNumber') handle
                    , stateStreamState = PreStream
                    , stateOpenStreamCallback = Just callback }
        lift $ liftIO $ hSetBuffering handle NoBuffering
        lift $ liftIO $ send ("<?xml version='1.0'?><stream:stream to='" ++ hostName ++
          "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.or" ++
          "g/streams' version='1.0'>") (Left handle)
        threadID <- lift $ liftIO $ forkIO $ xmlEnumerator (stateChannel state) (Left handle)
        lift $ liftIO $ putMVar (stateThreadID state) threadID
        return Nothing
      Left e -> do
        ((), clientState') <- lift $ runStateT (callback OpenStreamFailure) clientState
        put $ state { stateShouldExit = True }
        return $ Just e
  
  IEC (CESecureWithTLS clientState certificate verifyCertificate callback) -> do
    -- CEB.assert (not $ isTLSSecured (stateStreamState state)) (return ())
    let Connected _ handle = stateConnectionState state
    lift $ liftIO $ send "<starttls xmlns='urn:ietf:params:xml:ns:xmpp-tls'/>" (Left handle)
    put $ state { stateStreamState = PreStream
                , stateSecureWithTLSCallback = Just callback }
    return Nothing
  
-- TODO: Save callback in state.
  IEC (CEAuthenticate clientState userName password resource callback) -> do
    -- CEB.assert (or [ stateConnectionState state == Connected
    --                , stateConnectionState state == TLSSecured ]) (return ())
    -- CEB.assert (stateHandle state /= Nothing) (return ())
    put $ state { stateAuthenticationState = AuthenticatingPreChallenge1 userName password resource
                , stateAuthenticateCallback = Just callback }
    lift $ liftIO $ send "<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl' mechanism='DIGEST-MD5'/>" handleOrTLSCtx
    return Nothing
  
  IEE (EnumeratorXML (XEBeginStream stream)) -> do
    put $ state { stateStreamState = PreFeatures (1.0) }
    return Nothing
  
  IEE (EnumeratorXML (XEFeatures features)) -> do
    let PreFeatures streamProperties = stateStreamState state
    case stateTLSState state of
      NoTLS -> let callback = fromJust $ stateOpenStreamCallback state in do
        ((), clientState) <- lift $ runStateT (callback $ OpenStreamSuccess streamProperties "TODO") (stateClientState state)
        put $ state { stateClientState = clientState
                    , stateStreamState = PostFeatures streamProperties "TODO" }
        return Nothing
      _ -> case stateAuthenticationState state of
        AuthenticatedUnbound _ resource -> do -- TODO: resource
          case resource of
            Nothing -> do
              lift $ liftIO $ send ("<iq type=\"set\" id=\"bind_1\"><bind xmlns=\"urn:ietf:param" ++ "s:xml:ns:xmpp-bind\"></bind></iq>") handleOrTLSCtx
              return ()
            _ -> do
              lift $ liftIO $ send ("<iq type=\"set\" id=\"bind_1\"><bind xmlns=\"urn:ietf:param" ++ "s:xml:ns:xmpp-bind\"><resource>" ++ fromJust resource ++ "</resource></bind></iq>") handleOrTLSCtx
              return ()
          r <- lift $ liftIO $ getID
          lift $ liftIO $ send ("<iq type=\"set\" id=\"" ++ r ++ "\"><session xmlns=\"urn:ietf:params:xml:ns:xmpp-session\"/>" ++ "</iq>") handleOrTLSCtx
          
          -- TODO: Execute callback on iq result
          
          let callback = fromJust $ stateAuthenticateCallback state in do -- TODO: streamProperties "TODO" after success
            ((), clientState) <- lift $ runStateT (callback $ AuthenticateSuccess streamProperties "TODO" "todo") (stateClientState state) -- get proper resource value when moving to iq result
            put $ state { stateClientState = clientState
                        , stateStreamState = PostFeatures streamProperties "TODO" }
          return Nothing
        _ -> do
          let callback = fromJust $ stateSecureWithTLSCallback state in do
          ((), clientState) <- lift $ runStateT (callback $ SecureWithTLSSuccess streamProperties "TODO") (stateClientState state)
          put $ state { stateClientState = clientState
                      , stateStreamState = PostFeatures streamProperties "TODO" }
          return Nothing
  
  -- TODO: Can we assume that it's safe to start to enumerate on handle when it
  -- might not have exited?
  IEE (EnumeratorXML XEProceed) -> do
    let Connected (ServerAddress hostName _) handle = stateConnectionState state
    tlsCtx <- lift $ liftIO $ handshake' handle hostName
    let tlsCtx_ = fromJust tlsCtx
    put $ (defaultState (stateChannel state) (stateThreadID state) (stateClientHandlers state) (stateClientState state)) { stateTLSState = PostHandshake tlsCtx_, stateConnectionState = (stateConnectionState state), stateSecureWithTLSCallback = (stateSecureWithTLSCallback state) }
    threadID <- lift $ liftIO $ forkIO $ xmlEnumerator (stateChannel state) (Right tlsCtx_) -- double code
    lift $ liftIO $ putStrLn "00000000000000000000000000000000"
    lift $ liftIO $ swapMVar (stateThreadID state) threadID -- return value not used
    lift $ liftIO $ putStrLn "00000000000000000000000000000000"
    lift $ liftIO $ threadDelay 1000000
    lift $ liftIO $ putStrLn "00000000000000000000000000000000"
    lift $ liftIO $ send ("<?xml version='1.0'?><stream:stream to='" ++
      hostName ++ "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/" ++
      "streams' version='1.0'>") (Right tlsCtx_)
    lift $ liftIO $ putStrLn "00000000000000000000000000000000"
    return Nothing
  
  IEE (EnumeratorXML (XEChallenge (Chal challenge))) -> do
    let serverHost = "jonkristensen.com"
    let challenge' = CBBS.decode challenge
    case stateAuthenticationState state of
      AuthenticatingPreChallenge1 userName password resource -> do
        -- This is the first challenge - we need to calculate the reply
        random <- lift $ liftIO $ getID -- TODO: Length and content.
        case replyToChallenge1 challenge' serverHost userName password random of
          Left reply -> do
            let reply' = (filter (/= '\n') (CBBS.encode reply))
            lift $ liftIO $ send ("<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>" ++ reply' ++ "</response>") handleOrTLSCtx
            put $ state { stateAuthenticationState = AuthenticatingPreChallenge2 userName password resource }
            return ()
          Right error -> do
            lift $ liftIO $ putStrLn $ show error
            return ()
      AuthenticatingPreChallenge2 userName password resource -> do
        -- This is not the first challenge; [...]
        -- TODO: Can we assume "rspauth"?
        lift $ liftIO $ send "<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'/>" handleOrTLSCtx
        put $ state { stateAuthenticationState = AuthenticatingPreSuccess userName password resource }
        return ()
    return Nothing
  
  -- We have received a SASL "success" message over a secured connection
  -- TODO: Parse the success message?
  -- TODO: <?xml version='1.0'?>?
  IEE (EnumeratorXML (XESuccess (Succ _))) -> do
    let serverHost = "jonkristensen.com"
    let AuthenticatingPreSuccess userName _ resource = stateAuthenticationState state in do
      lift $ liftIO $ send ("<?xml version='1.0'?><stream:stream to='" ++ serverHost ++ "' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/" ++ "streams' version='1.0'>") handleOrTLSCtx
      put $ state { stateAuthenticationState = AuthenticatedUnbound userName resource }
    return Nothing
  
  IEE EnumeratorDone ->
    -- TODO: Exit?
    return Nothing
  
  -- ---------------------------------------------------------------------------
  --  XML EVENTS
  -- ---------------------------------------------------------------------------
  
  -- Ignore id="bind_1" and session IQ result, otherwise create client event
  IEE (EnumeratorXML (XEIQ iqEvent)) -> do
    case shouldIgnoreIQ iqEvent of
      True ->
        return Nothing
      False -> do
        let iqReceivedFunctions = map (\ x -> iqReceived x) (stateClientHandlers state)
        let functions = map (\ x -> case x of
                                Just f -> Just (f iqEvent)
                                Nothing -> Nothing) iqReceivedFunctions
        let functions' = case lookup (fromJust $ stanzaID $ iqStanza $ iqEvent) (stateIQCallbacks state) of
              Just f -> (Just (f iqEvent)):functions
              Nothing -> functions
        let clientState = stateClientState state -- ClientState s m
        clientState' <- sendToClient functions' clientState
        put $ state { stateClientState = clientState' }
        return Nothing
  
  IEE (EnumeratorXML (XEPresence presenceEvent)) -> do
    let presenceReceivedFunctions = map (\ x -> presenceReceived x) (stateClientHandlers state)
    let functions = map (\ x -> case x of
                            Just f -> Just (f presenceEvent)
                            Nothing -> Nothing) presenceReceivedFunctions
    let clientState = stateClientState state -- ClientState s m
    clientState' <- sendToClient functions clientState
    put $ state { stateClientState = clientState' }
    return Nothing
  
  IEE (EnumeratorXML (XEMessage messageEvent)) -> do
    let messageReceivedFunctions = map (\ x -> messageReceived x) (stateClientHandlers state)
    let functions = map (\ x -> case x of
                            Just f -> Just (f messageEvent)
                            Nothing -> Nothing) messageReceivedFunctions
    let clientState = stateClientState state -- ClientState s m
    clientState' <- sendToClient functions clientState
    put $ state { stateClientState = clientState' }
    return Nothing
  
  IEC (CEPresence clientState presence) -> do
    presence' <- case stanzaID $ presenceStanza presence of
      Nothing -> do
        id <- lift $ liftIO $ getID
        return $ presence { presenceStanza = (presenceStanza presence) { stanzaID = Just (SID id) } }
      _ -> return presence
    let xml = presenceToXML presence'
    lift $ liftIO $ send xml handleOrTLSCtx
    return Nothing

  IEC (CEMessage clientState message) -> do
    message' <- case stanzaID $ messageStanza message of
      Nothing -> do
        id <- lift $ liftIO $ getID
        return $ message { messageStanza = (messageStanza message) { stanzaID = Just (SID id) } }
      _ -> return message
    let xml = messageToXML message'
    lift $ liftIO $ send xml handleOrTLSCtx
    return Nothing
  
  IEC (CEIQ clientState iq callback) -> do
    iq' <- case stanzaID $ iqStanza iq of
      Nothing -> do
        id <- lift $ liftIO $ 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
    case callback of
      Just callback' -> case iq of
        IQGet {} -> put $ state { stateIQCallbacks = (fromJust $ stanzaID $ iqStanza iq', callback'):(stateIQCallbacks state) }
        IQSet {} -> put $ state { stateIQCallbacks = (fromJust $ stanzaID $ iqStanza iq', callback'):(stateIQCallbacks state) }
        _ -> return ()
      Nothing -> return ()
    -- TODO: Bind ID to callback
    let xml = iqToXML iq'
    lift $ liftIO $ send xml handleOrTLSCtx
    return Nothing
  
  -- XOEDisconnect -> do
  --   -- TODO: Close stream
  --   return ()
  
  e -> do
    return Nothing
    -- lift $ liftIO $ putStrLn $ "UNCAUGHT EVENT: " ++ (show e)
    -- return $ Just (CE.SomeException $ CE.PatternMatchFail "processEvent")
  where
    -- Assumes handle is set
    send :: String -> Either Handle TLSCtx -> IO ()
    send s o = case o of
      Left handle -> do
        liftIO $ hPutStr handle $ encodeString $ s
        liftIO $ hFlush handle
        return ()
      Right tlsCtx -> do
        liftIO $ sendData tlsCtx $ DBLC.pack $ encodeString s
        return ()
    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


sendToClient :: (MonadIO m, ClientState s m) => [Maybe (StateT s m Bool)] -> s -> (StateT (State s m) m) s
sendToClient [] s = return s
sendToClient (Nothing:fs) s = sendToClient fs s
sendToClient ((Just f):fs) s = do
  (b, s') <- lift $ runStateT f s
  case b of
    True -> return s'
    False -> sendToClient fs s'


-- Reads from the provided handle or TLS context and sends the events to the
-- internal event channel.

xmlEnumerator :: Chan (InternalEvent s m) -> Either Handle TLSCtx -> IO ()
xmlEnumerator c s = do
  enumeratorResult <- case s of
    Left handle -> run $ enumHandle 1 handle $$ joinI $
                   parseBytes decodeEntities $$ xmlReader c
    Right tlsCtx -> run $ enumTLS tlsCtx $$ joinI $
                    parseBytes decodeEntities $$ xmlReader c
  case enumeratorResult of
    Right _ ->
      writeChan c $ IEE EnumeratorDone
    Left e ->
      writeChan c $ IEE (EnumeratorException e)
  where
    -- Behaves like enumHandle, but reads from the TLS context instead
    enumTLS :: TLSCtx -> E.Enumerator DB.ByteString IO b
    enumTLS c s = loop c s
    
    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


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
      putStrLn ">>>>TLS data sended<<<<"
      return (Just c)
    Left ge -> do
      putStrLn $ show ge
      return Nothing


xmlReader :: Chan (InternalEvent s m) -> Iteratee Event IO (Maybe Event)

xmlReader c = xmlReader_ c [] 0


xmlReader_ :: Chan (InternalEvent s m) -> [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 $ IEE $ EnumeratorXML $ XEBeginStream $ "StreamTODO"
      xmlReader_ ch [] 1

xmlReader_ ch [EventEndElement name] 1
  | namePrefix name == Just (DT.pack "stream") &&
    nameLocalName name == DT.pack "stream" = do
      liftIO $ writeChan ch $ IEE $ EnumeratorXML $ 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" = do
    liftIO $ writeChan ch $ IEE $ EnumeratorXML $ XEProceed
    E.yield Nothing (E.Chunks [])
  | otherwise = do
    -- liftIO $ putStrLn "Got an IEX Event..."
    liftIO $ writeChan ch $ IEE $ EnumeratorXML $ (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 "FeaturesTODO"
  | 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) ++ "'"


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