path: root/Presence/XMPP.hs

{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE CPP                 #-}
module XMPP 
    ( module XMPPTypes
    , listenForXmppClients
    , listenForRemotePeers
    , seekRemotePeers
    , quitListening
    )  where

import ServerC
import XMPPTypes
import SocketLike
import ByteStringOperators

import Data.HList
import Network.Socket (Family)
import Network.BSD (PortNumber)
import Control.Concurrent.STM
import Data.Conduit
import qualified Data.Conduit.List as CL
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S (pack,putStr,putStrLn)
import qualified Data.ByteString.Lazy.Char8 as L
    ( putStrLn
    , fromChunks
    )
import Control.Concurrent (forkIO,killThread)
import Control.Concurrent.Async
import Control.Exception (handle,SomeException(..),finally)
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Todo
import Control.Monad as Monad
import Text.XML.Stream.Parse
import Text.XML.Stream.Render
import Data.XML.Types as XML
import Network.BSD (getHostName,hostName,hostAliases)
import Data.Text.Encoding      as S (decodeUtf8)
import Data.Text.Lazy.Encoding as L (decodeUtf8)
import Data.Text.Lazy (toStrict)
import GetHostByAddr
import Data.Monoid
import qualified Data.Sequence as Seq
import Data.Foldable (toList)
#ifdef RENDERFLUSH
import Data.Conduit.Blaze
#endif

data Commands = Send [XML.Event] | QuitThread
 deriving Prelude.Show

getNamesForPeer :: Peer -> IO [ByteString]
getNamesForPeer LocalHost = fmap ((:[]) . S.pack) getHostName
getNamesForPeer peer@(RemotePeer addr) = do
    ent <- getHostByAddr addr --  AF_UNSPEC addr
    let names = hostName ent : hostAliases ent
    return . map S.pack $ names


xmlifyPresenceForClient :: Presence -> IO [XML.Event]
xmlifyPresenceForClient (Presence jid stat) = do
    let n   = name jid
        rsc = resource jid
    names <- getNamesForPeer (peer jid)
    let tostr p = L.decodeUtf8 $ n <$++> "@" <?++> L.fromChunks [p] <++?>  "/" <++$> rsc
        jidstrs = fmap (toStrict . tostr) names
    return (concatMap presenceEvents jidstrs)
 where
    presenceEvents jidstr =
      [ EventBeginElement "presence" (("from",[ContentText jidstr]):typ stat)
      , EventBeginElement "show" []
      , EventContent (ContentText . shw $ stat)
      , EventEndElement "show"
      , EventEndElement "presence"
      ]
    typ Offline = [("type",[ContentText "unavailable"])]
    typ _       = []
    shw Available = "chat"
    shw Away      = "away"
    shw Offline   = "away" -- Is this right?

prefix ## name = Name name Nothing (Just prefix)

streamP name = Name name (Just "http://etherx.jabber.org/streams") (Just "stream")
    
greet host =
    [ EventBeginDocument
    , EventBeginElement (streamP "stream")
        [("from",[ContentText host])
        ,("id",[ContentText "someid"])
        ,("xmlns",[ContentText "jabber:client"])
        ,("xmlns:stream",[ContentText "http://etherx.jabber.org/streams"])
        ,("version",[ContentText "1.0"])
        ]
    , EventBeginElement (streamP "features") []
    , EventBeginElement "bind" [("xmlns",[ContentText "urn:ietf:params:xml:ns:xmpp-bind"])]
    , EventEndElement   "bind"

    {-
    -- , "  <session xmlns='urn:ietf:params:xml:ns:xmpp-session'/>"
    , " <mechanisms xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>"
    -- , " <mechanism>DIGEST-MD5</mechanism>"
    , " <mechanism>PLAIN</mechanism>"
    , " </mechanisms> "
    -}

    , EventEndElement (streamP "features")
    ]


-- type Consumer i m r = forall o. ConduitM i o m r
mawait :: Monad m => MaybeT (ConduitM i o m) i
mawait = MaybeT await

elementAttrs expected (EventBeginElement name attrs)
    | nameLocalName name==expected 
    = return attrs
elementAttrs _ _ = mzero
     
eventIsBeginElement (EventBeginElement _ _) = True
eventIsBeginElement _                       = False

eventIsEndElement (EventEndElement _) = True
eventIsEndElement _                   = False

gatherElement ::
  (Monad m, MonadPlus mp) =>
  Event -> mp Event -> MaybeT (ConduitM Event o m) (mp Event)
gatherElement opentag empty = gatherElement' (empty `mplus` return opentag) 1 
 where
    gatherElement' ts cnt = do
        tag <- mawait
        let ts' = ts `mplus` return tag
            cnt' = case () of
                     _ | eventIsEndElement tag -> cnt-1
                     _ | eventIsBeginElement tag -> cnt+1
                     _ -> cnt
        if (cnt'>0) then gatherElement' ts' cnt'
                   else return ts' 

voidMaybeT body = (>> return ()) . runMaybeT $ body
fixMaybeT f = (>> return ()) . runMaybeT . fix $ f

fromClient :: (MonadIO m, XMPPSession session) => 
    session -> TChan Commands -> Sink XML.Event m ()
fromClient session cmdChan = voidMaybeT $ do
    let log  = liftIO . L.putStrLn . ("client-in: " <++>)
        send = liftIO . atomically . writeTChan cmdChan . Send
    mawait >>= guard . (==EventBeginDocument)
    log "begin-doc"
    xml <- mawait
    stream_attrs <- elementAttrs "stream" xml
    log $ "stream " <++> bshow stream_attrs
    host <- liftIO $ do
        jid <- getJID session
        names <- getNamesForPeer (peer jid)
        return (S.decodeUtf8 . head $ names)
    send $ greet host
    
    fix $ \loop -> do
      xml <- mawait
      log $ bshow xml
      case xml of
        _ | eventIsEndElement xml -> return ()
        tag@(EventBeginElement _ _) -> do
             xs <- gatherElement tag Seq.empty
             prettyPrint "client-in: ignoring..." (toList xs)
             {-
             liftIO (putStrLn "client-in: ignoring\n{")
             liftIO (mapM_ print xs)
             liftIO (putStrLn "}")
             -}
             loop
        _ -> loop

    log $ "end of stream"
    xml <- mawait
    log $ "end-of-document: " <++> bshow xml

prettyPrint prefix xs = 
    liftIO $ do
        S.putStrLn prefix
        CL.sourceList xs $= renderBytes (def { rsPretty=True }) $$ CL.mapM_ S.putStr

toClient :: MonadIO m => TChan Presence -> TChan Commands -> Source m [XML.Event]
toClient pchan cmdChan = fix $ \loop -> do
    event <- liftIO . atomically $ 
              orElse (fmap Left  $ readTChan pchan)
                     (fmap Right $ readTChan cmdChan)
    case event of
      Right QuitThread -> return ()
      Right (Send xs)  -> yield xs >> loop -- prettyPrint "client-out: " xs >> loop
      Left  presence   -> do 
        xs <- liftIO $ xmlifyPresenceForClient presence
        yield xs
        loop

handleClient
  :: (SocketLike sock, HHead l (XMPPClass session),
      XMPPSession session) =>
     HCons sock (HCons t l) -> Source IO ByteString -> Sink ByteString IO () -> IO ()
handleClient st src snk = do
    let HCons sock (HCons _ st') = st
        session_factory = hHead st'
    pname <- getPeerName sock
    session <- newSession session_factory sock
    Prelude.putStrLn $ "PEER NAME: "++Prelude.show pname
    pchan <- subscribe session Nothing
    cmdChan <- atomically newTChan

#ifdef RENDERFLUSH
    writer <- async (   toClient pchan cmdChan 
                    $$  flushList
                    =$= renderBuilderFlush def 
                    =$= builderToByteStringFlush 
                    =$= discardFlush 
                     =$ snk )
#else
    writer <- async ( toClient pchan cmdChan $$ renderChunks =$ snk )
#endif
    finally         ( src $= parseBytes def $$ fromClient session cmdChan )
        $ do
            atomically $ writeTChan cmdChan QuitThread
            wait writer
            closeSession session

listenForXmppClients ::
  (HList l, HHead l (XMPPClass session), HExtend e1 l2 l1,
   HExtend e l1 (HCons PortNumber l), XMPPSession session) =>
  Family -> e1 -> e -> l2 -> IO ServerHandle
listenForXmppClients addr_family session_factory port st = do
    doServer (addr_family .*. port .*. session_factory .*. st) handleClient

listenForRemotePeers
  :: (HList t1, HExtend e l (HCons PortNumber t1), XMPPSession t) =>
     Family -> XMPPClass t -> e -> l -> IO ServerHandle
listenForRemotePeers addrfamily session_factory port st = do
    putStrLn "unimplemented: listenForRemotePeers"
    dummyServerHandle
    -- TODO

seekRemotePeers :: XMPPConfig config =>
     config -> TChan Presence -> IO ()
seekRemotePeers config chan = do
    putStrLn "unimplemented: seekRemotePeers"
    -- TODO
    return ()

#ifdef RENDERFLUSH
flushList :: Monad m => ConduitM [a] (Flush a) m ()
flushList = fixMaybeT $ \loop -> do
    xs <- mawait
    lift ( CL.sourceList xs $$ CL.mapM_ (yield . Chunk) )
    lift ( yield Flush )
    loop

discardFlush :: Monad m => ConduitM (Flush a) a m ()
discardFlush = fixMaybeT $ \loop -> do
    x <- mawait
    let unchunk (Chunk a) = a
        ischunk (Chunk _) = True
        ischunk _         = False
    lift . when (ischunk x) $ yield (unchunk x)
    loop
#else
renderChunks :: (MonadUnsafeIO m, MonadIO m) => ConduitM [Event] ByteString m ()
renderChunks = fixMaybeT $  \loop -> do
    xs <- mawait
    lift . when (not . null $ xs) $ ( CL.sourceList xs $= renderBytes def $$ CL.mapM_ yield )
    loop
#endif