Use XMPPServerParameters instead of ResourcePolicy.

Also: some presence status parsing.

1 files changed, 120 insertions, 40 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index ccdffabe..10928892 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -1,6 +1,12 @@
 {-# LANGUAGE OverloadedStrings #-}
 module XMPPServer
     ( xmppServer
+    , ConnectionKey(..)
+    , XMPPServerParameters(..)
+    , Stanza(..)
+    , StanzaType(..)
+    , StanzaOrigin(..)
+    , dupStanza
     ) where
 import Control.Monad.Trans.Resource (runResourceT)
 import Control.Monad.Trans (lift)
@@ -17,6 +23,7 @@ import System.Posix.Signals
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as Strict8
 -- import qualified Data.ByteString.Lazy.Char8 as Lazy8
+import Data.Int (Int8)
 
 import Data.Conduit
 import qualified Data.Conduit.List as CL
@@ -29,7 +36,7 @@ import Data.XML.Types as XML
 import Data.Maybe (catMaybes,fromJust,isNothing)
 import Data.Monoid ( (<>) )
 import Data.Text (Text)
-import qualified Data.Text as Text (pack)
+import qualified Data.Text as Text (pack,unpack)
 import Data.Char (toUpper)
 
 import qualified Control.Concurrent.STM.UpdateStream as Slotted
@@ -37,13 +44,71 @@ import ControlMaybe
 import Nesting
 import EventUtil
 import Server
-import ResourcePolicy (getResourceName)
 
 peerport = 5269
 clientport = 5222
 
 my_uuid = "154ae29f-98f2-4af4-826d-a40c8a188574"
 
+data ConnectionKey
+       = PeerKey { callBackAddress :: SockAddr }
+       | ClientKey { localAddress :: SockAddr }
+ deriving (Show, Ord, Eq)
+
+data JabberShow = Offline
+                | ExtendedAway
+                | Away
+                | DoNotDisturb
+                | Available
+                | Chatty
+ deriving (Show,Enum,Ord,Eq,Read)
+
+data MessageThread = MessageThread { 
+        msgThreadParent  :: Maybe Text,
+        msgThreadContent :: Text
+    }
+  deriving (Show,Eq)
+
+data LangSpecificMessage =
+    LangSpecificMessage { msgBody :: Maybe Text
+                        , msgSubject :: Maybe Text
+                        }
+  deriving (Show,Eq)
+
+data StanzaType = Unrecognized | Ping | Pong | RequestResource (Maybe Text) | SetResource
+                  | SessionRequest | UnrecognizedQuery Name | Error
+    | PresenceStatus { presenceShow :: JabberShow
+                     , presencePriority :: Maybe Int8
+                     , presenceStatus :: [(Lang,Text)]
+                     }
+    | PresenceInformError
+    | PresenceInformSubscription Bool
+    | PresenceRequestStatus
+    | PresenceRequestSubscription Bool
+    | Message { msgThread :: Maybe MessageThread
+              , msgLangMap :: [(Lang,LangSpecificMessage)]
+              }
+ deriving Show
+
+data StanzaOrigin = LocalPeer | NetworkOrigin ConnectionKey (TChan Stanza)
+
+data Stanza = Stanza
+    { stanzaType :: StanzaType
+    , stanzaId :: Maybe Text
+    , stanzaTo :: Maybe Text
+    , stanzaFrom :: Maybe Text
+    , stanzaChan :: TChan XML.Event
+    , stanzaClosers ::  TVar (Maybe [XML.Event])
+    , stanzaInterrupt :: TMVar ()
+    , stanzaOrigin :: StanzaOrigin
+    }
+
+data XMPPServerParameters =
+    XMPPServerParameters
+    { xmppChooseResourceName :: ConnectionKey -> Socket -> Maybe Text -> IO Text
+    , xmppNewConnection :: ConnectionKey -> TChan Stanza -> IO ()
+    , xmppEOF :: ConnectionKey -> IO ()
+    }
 
 -- TODO: http://xmpp.org/rfcs/rfc6120.html#rules-remote-error
 -- client connection
@@ -93,31 +158,6 @@ type FlagCommand = STM Bool
 type ReadCommand = IO (Maybe ByteString)
 type WriteCommand = ByteString -> IO Bool
 
-{-
-data Stanza
-    = UnrecognizedStanza { stanzaChan :: TChan (Maybe XML.Event) }
-    | PingStanza { stanzaId :: Maybe Text
-                 , stanzaChan :: TChan (Maybe XML.Event) }
-    | PongStanza { -- stanzaId :: Maybe Text
-                   stanzaChan :: TChan (Maybe XML.Event) }
--}
-
-data StanzaType = Unrecognized | Ping | Pong | RequestResource (Maybe Text) | SetResource
-                  | SessionRequest | UnrecognizedQuery Name | Error
- deriving Show
-
-data StanzaOrigin = LocalPeer | NetworkOrigin ConnectionKey (TChan Stanza)
-
-data Stanza = Stanza
-    { stanzaType :: StanzaType
-    , stanzaId :: Maybe Text
-    , stanzaTo :: Maybe Text
-    , stanzaFrom :: Maybe Text
-    , stanzaChan :: TChan XML.Event
-    , stanzaClosers ::  TVar (Maybe [XML.Event])
-    , stanzaInterrupt :: TMVar ()
-    , stanzaOrigin :: StanzaOrigin
-    }
 dupStanza stanza = do
     dupped <- dupTChan (stanzaChan stanza)
     return stanza { stanzaChan = dupped }
@@ -212,6 +252,47 @@ C->Unrecognized </iq>
 
 ioWriteChan c v = liftIO . atomically $ writeTChan c v
 
+parsePresenceStatus ns = do
+
+    let toStat "away" = Away
+        toStat "xa"   = ExtendedAway
+        toStat "dnd"  = DoNotDisturb
+        toStat "chat" = Chatty
+
+    showv <- liftIO . atomically $ newTVar Available
+    priov <- liftIO . atomically $ newTVar Nothing
+    statusv <- liftIO . atomically $ newTChan
+    fix $ \loop -> do
+        mtag <- nextElement
+        flip (maybe $ return ()) mtag $ \tag -> do
+        when (nameNamespace (tagName tag) == Just ns) $ do
+            case nameLocalName (tagName tag) of
+                "show" -> do t <- XML.content
+                             liftIO . atomically $ writeTVar showv (toStat t)
+                "priority" -> do t <- XML.content
+                                 liftIO . handleIO_ (return ()) $ do
+                                 prio <- readIO (Text.unpack t)
+                                 atomically $ writeTVar priov (Just prio)
+                "status" -> do t <- XML.content
+                               lang <- xmlLang
+                               ioWriteChan statusv (maybe "" id lang,t)
+                _ -> return ()
+        loop
+    show <- liftIO . atomically $ readTVar showv
+    prio <- liftIO . atomically $ readTVar priov
+    status <- liftIO $ chanContents statusv -- Could use unsafeInterleaveIO to
+                                            -- avoid multiple passes, but whatever.
+    return . Just $ PresenceStatus { presenceShow = show
+                                   , presencePriority = prio
+                                   , presenceStatus = status
+                                   }
+grokPresence stanzaTag = do
+    let typ = lookupAttrib "type" (tagAttrs stanzaTag)
+    case typ of
+        Nothing -> parsePresenceStatus "jabber:client"
+        Just "unavailable" -> fmap (fmap (\p -> p {presenceShow=Offline}))
+                                   $ parsePresenceStatus "jabber:client"
+        _ -> return Nothing -- todo
 
 grokStanza "jabber:server" stanzaTag = 
             case () of
@@ -224,6 +305,7 @@ grokStanza "jabber:client" stanzaTag =
                 _ | stanzaTag `isClientIQOf` "get" -> grokStanzaIQGet stanzaTag
                 _ | stanzaTag `isClientIQOf` "set" -> grokStanzaIQSet stanzaTag
                 _ | stanzaTag `isClientIQOf` "result" -> grokStanzaIQResult stanzaTag
+                _ | tagName stanzaTag == "{jabber:client}presence" -> grokPresence stanzaTag
                 _ -> return $ Just Unrecognized
 
 xmppInbound :: Server ConnectionKey
@@ -524,11 +606,6 @@ forkConnection sv k pingflag src snk stanzas = do
         wlog $ "end reader fork: " ++ show k
     return output
 
-data ConnectionKey
-       = PeerKey { callBackAddress :: SockAddr }
-       | ClientKey { localAddress :: SockAddr }
- deriving (Show, Ord, Eq)
-
 {-
 data Peer = Peer
     { peerWanted :: TVar Bool -- ^ False when this peer is on a you-call-me basis
@@ -574,7 +651,7 @@ socketFromKey :: Server k -> k -> IO Socket
 socketFromKey sv k = do
     return todo
 
-monitor sv params = do
+monitor sv params xmpp = do
     chan <- return $ serverEvent sv
     stanzas <- atomically newTChan
     quitVar <- atomically newEmptyTMVar
@@ -585,10 +662,12 @@ monitor sv params = do
             Connection pingflag conread conwrite -> do
                  wlog $ tomsg k "Connection"
                  let (xsrc,xsnk) = xmlStream conread conwrite
-                 forkConnection sv k pingflag xsrc xsnk stanzas
+                 outs <- forkConnection sv k pingflag xsrc xsnk stanzas
+                 xmppNewConnection xmpp k outs
                  return ()
             ConnectFailure addr -> return () -- wlog $ tomsg k "ConnectFailure"
-            EOF        -> wlog $ tomsg k "EOF"
+            EOF        -> do wlog $ tomsg k "EOF"
+                             xmppEOF xmpp k
             HalfConnection In -> do
                 wlog $ tomsg k "ReadOnly"
                 control sv (Connect (callBackAddress k) params)
@@ -602,7 +681,7 @@ monitor sv params = do
                     case stanzaType stanza of
                         RequestResource wanted -> do
                             sock <- socketFromKey sv k
-                            rsc <- getResourceName sock wanted
+                            rsc <- xmppChooseResourceName xmpp k sock wanted
                             let reply = iq_bind_reply (stanzaId stanza) rsc
                             sendReply quitVar SetResource reply replyto
                         SessionRequest -> do
@@ -629,9 +708,10 @@ monitor sv params = do
         where
             _ = str :: String
 
-
-xmppServer :: (MonadResource m, MonadIO m) => m (Server ConnectionKey,ConnectionParameters ConnectionKey)
-xmppServer = do
+xmppServer :: ( MonadResource m
+              , MonadIO m
+              ) => XMPPServerParameters -> m (Server ConnectionKey,ConnectionParameters ConnectionKey)
+xmppServer xmpp = do
     sv <- server
     let peer_params = (connectionDefaults peerKey)
                           { pingInterval = 15000
@@ -642,7 +722,7 @@ xmppServer = do
                           , timeout = 0
                           }
     liftIO $ do
-        forkIO $ monitor sv peer_params
+        forkIO $ monitor sv peer_params xmpp
         control sv (Listen peerport peer_params)
         control sv (Listen clientport client_params)
     return (sv,peer_params)