module TCPConnection ( TCPConnection
                     , openConnection
                     , sendStanza
                     , getStanzas
                     , closeConnection
                     )
    where

import XMLParse

import Prelude hiding(read)
import Network
import Network.GnuTLS
import Data.IORef
import Control.Monad
import System.Posix.Temp
import System.IO
import System.Random
import Control.Concurrent
import qualified Codec.Binary.Base64 as B64
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC

-- |An XMPP connection over TCP.
-- The args are: tls session, network handle, unparsed incoming message, log handle, mutex.
data TCPConnection = TCPConnection (Session Client) Handle (IORef String) Handle (MVar ())

-- |Open a TCP connection to the named server, port 5222, and send a
-- stream header.  Get the stream header that the server sent. This should really check SRV records.
-- Finally, authenticate using SASL PLAIN mechanism.
openConnection :: (String, String, String) -> IO TCPConnection
openConnection (username, server, password) =
    let rawWrite h f s = (hPutStrLn f $ ">> " ++ s) >> (hPutStr h s)
        rawRead h f = do
          hWaitForInput h (-1)
          s <- getEverything
          hPutStrLn f $ "<< " ++ s
          return s
            where getEverything = do
                    r <- hReady h
                    if r then liftM2 (:) (hGetChar h) getEverything
                       else return []
    in
    do
      -- Initialization
      (logfile, logH) <- mkstemp "/tmp/log/XXXXXX"
      putStrLn $ "Log is " ++ logfile
      hSetBuffering logH LineBuffering
      h <- connectTo server (PortNumber 5222)
      hSetBuffering h NoBuffering
      buffer <- newIORef ""
      v <- newEmptyMVar

      -- Start the stream
      rawWrite h logH $ xmlToString False $ 
              XML "stream:stream"
                      [("to",server),
                       ("xmlns","jabber:client"),
                       ("xmlns:stream","http://etherx.jabber.org/streams"),
                       ("version", "1.0")]
                      []
      -- TODO: check the response, which would specify if tls is required and what sasl mechanisms are supported
      rawRead h logH

      -- jabber.org now requires use of tls, maybe for a week only?
      rawWrite h logH $ xmlToString True $
            XML "starttls" [("xmlns","urn:ietf:params:xml:ns:xmpp-tls")] []
      -- TODO: check the response is <proceed xmlns='urn:ietf:params:xml:ns:xmpp-tls'/>
      rawRead h logH

      -- attempt TLS negotiation. Unfortunately hsgnutls is poorly documented :(
      s <- tlsClient [handle := h,
                      -- Anonymous authentication KxAnonDh would not work. CrtOpenpgp is not supported yet.
                      priorities  := [CrtX509],
                      -- anonymousClientCredentials would not work
                      credentials := certificateCredentials
                     ]
      handshake s
      let c = TCPConnection s h buffer logH v

      -- attempt SASL negotiation
      write c $ xmlToString False $ 
                    XML "stream:stream"
                      [("to",server),
                       ("xmlns","jabber:client"),
                       ("xmlns:stream","http://etherx.jabber.org/streams"),
                       ("version", "1.0")]
                      []
      -- TODO: check the response, which would specify what sasl mechanisms are supported
      read c

      -- TODO: assume plain mechanism is supported, coz there's no SASL lib for use
      -- the correct format is
      -- <auth xmlns="urn:ietf:params:xml:ns:xmpp-sasl"
      --       mechanism="PLAIN">{base64 data here}</auth>,
      -- where the payload is |optional authzid <null> authcid <null> passwd|
      let auth = xmlToString True $
                    XML "auth"
                      [("xmlns", "urn:ietf:params:xml:ns:xmpp-sasl"),
                       ("mechanism", "PLAIN")
                      ]
                      [CData payload]
          payload = B64.encode $ concat [nul, authcid, nul, passwd]
          nul = [toEnum 0]
          authcid = B.unpack $ BC.pack username
          passwd = B.unpack $ BC.pack password
      write c auth
      
      [(XML response' _ _)] <- getStanzas c
      if "success" == response' then putStrLn "Authentication succeeded"
         else error "Authentication failed"

      -- Attempt resource binding
      write c $ xmlToString False $ 
                    XML "stream:stream"
                      [("to",server),
                       ("xmlns","jabber:client"),
                       ("xmlns:stream","http://etherx.jabber.org/streams"),
                       ("version", "1.0")]
                      []
      -- TODO: check if the resource binding feature is required
      read c
      
      sendIq c server "set" [XML "bind"
                                 [("xmlns","urn:ietf:params:xml:ns:xmpp-bind")]
                                 []]
      -- TODO: check the result of resource binding
      read c

      -- Attempt session establishment
      sendIq c server "set" [XML "session"
                                 [("xmlns","urn:ietf:params:xml:ns:xmpp-session")]
                                 []]
      -- TODO: check the result
      read c
      sendStanza c $ XML "presence" [] []
      return c

write :: TCPConnection -> String -> IO ()
write (TCPConnection h _ _ f v) s = do
  putMVar v ()
  tlsSendString h s
  hPutStrLn f $ ">> " ++ s
  takeMVar v

read :: TCPConnection -> IO String
read (TCPConnection h network _ f _) = do
  hWaitForInput network (-1)
  s <- getEverything
  hPutStrLn f $ "<< " ++ s
  return s
    where
      getEverything = do
            r <- hReady network
            if r then liftM2 (++) (tlsRecvString h) getEverything
               else return []

-- |Get incoming stanzas from the connection.
getStanzas :: TCPConnection -> IO [XMLElem]
getStanzas c = parseBuffered c deepTags

-- |Send a stanza on the connection.
sendStanza :: TCPConnection -> XMLElem -> IO ()
sendStanza c x =
    let str = xmlToString True x in
    write c str

-- |Close the connection.
closeConnection :: TCPConnection -> IO ()
closeConnection (TCPConnection h network _ f _) = bye h ShutRdwr >> hClose network >> hClose f

parseBuffered :: TCPConnection -> Parser a -> IO a
parseBuffered c@(TCPConnection h _ bufvar f _) parser = do
  buffer <- readIORef bufvar
  input <- read c
  case parse (getRest parser) "" (buffer++input) of
    Right (result, rest) ->
        do
          writeIORef bufvar rest
          return result
    Left e ->
        do
          putStrLn $ "An error?  Hopefully doesn't matter.\n"++(show e)
          parseBuffered c parser

sendIq ::  TCPConnection
           -> String            -- ^JID of recipient
           -> String            -- ^Type of IQ, either \"get\" or \"set\"
           -> [XMLElem]         -- ^Payload elements
           -> IO ()
sendIq c to iqtype payload =
    do
      iqid <- randomIO :: IO Int
      sendStanza c $ XML "iq"
                     [("to", to),
                      ("type", iqtype),
                      ("id", show iqid)]
                     payload