1 files changed, 86 insertions, 71 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 7eb0fbc5..d41e06cb 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
 module XMPPServer
     ( xmppServer
     , ConnectionKey(..)
@@ -18,6 +19,7 @@ module XMPPServer
     , sendModifiedStanzaToPeer
     , sendModifiedStanzaToClient
     ) where
+
 import Debug.Trace
 import Control.Monad.Trans.Resource (runResourceT)
 import Control.Monad.Trans (lift)
@@ -28,7 +30,6 @@ import Control.Concurrent (forkIO)
 import Control.Concurrent.STM
 -- import Control.Concurrent.STM.TChan
 import Network.Socket
-import XMPPTypes (withPort)
 import Text.Printf
 import System.Posix.Signals
 import Data.ByteString (ByteString)
@@ -55,17 +56,26 @@ import Data.Set (Set, (\\) )
 import qualified Data.Set as Set
 import qualified System.Random 
 import qualified Network.BSD as BSD
+import Data.Void (Void)
 
 import GetHostByAddr (getHostByAddr)
 import qualified Control.Concurrent.STM.UpdateStream as Slotted
-import ControlMaybe
 import Nesting
-import EventUtil
 import Server
+import EventUtil
+import ControlMaybe
 
+withPort :: SockAddr -> Int -> SockAddr
+withPort (SockAddrInet _ a)      port = SockAddrInet (toEnum port) a
+withPort (SockAddrInet6 _ a b c) port = SockAddrInet6 (toEnum port) a b c
+
+
+peerport :: PortNumber
 peerport = 5269
+clientport :: PortNumber
 clientport = 5222
 
+my_uuid :: Text
 my_uuid = "154ae29f-98f2-4af4-826d-a40c8a188574"
 
 data ConnectionKey
@@ -164,6 +174,7 @@ data XMPPServerParameters =
     , xmppInformClientPresence :: ConnectionKey -> Stanza -> IO ()
     }
 
+
 -- TODO: http://xmpp.org/rfcs/rfc6120.html#rules-remote-error
 -- client connection
 -- socat script to send stanza fragment
@@ -252,6 +263,7 @@ copyToChannel f chan closer_stack = awaitForever copy
         yield x
 
 
+prettyPrint :: ByteString -> ConduitM Event Void IO ()
 prettyPrint prefix = 
         XML.renderBytes (XML.def { XML.rsPretty=True })
         =$= CB.lines 
@@ -279,6 +291,44 @@ fixHeaders Stanza { stanzaTo=mto, stanzaFrom=mfrom } = do
         as' = maybe as (\to->attr "to" to:as) mto
         as'' = maybe as' (\from->attr "from" from:as') mfrom
     
+conduitToChan
+  :: Conduit () IO Event
+     -> IO (TChan Event, TVar (Maybe [Event]), TMVar a)
+conduitToChan c = do
+    chan <- atomically newTChan
+    clsrs <- atomically $ newTVar (Just [])
+    quitvar <- atomically $ newEmptyTMVar
+    forkIO $ do
+        c =$= copyToChannel id chan clsrs $$ awaitForever (const $ return ())
+        atomically $ writeTVar clsrs Nothing
+    return (chan,clsrs,quitvar)
+
+ioWriteChan :: MonadIO m => TChan a -> a -> m ()
+ioWriteChan c v = liftIO . atomically $ writeTChan c v
+
+stanzaToConduit :: MonadIO m => Stanza -> ConduitM i Event m ()
+stanzaToConduit stanza = do
+    let xchan = stanzaChan stanza
+        xfin = stanzaClosers stanza
+        rdone = stanzaInterrupt stanza
+        loop = return ()
+    fix $ \inner -> do
+        what <- liftIO . atomically $ foldr1 orElse
+            [readTChan xchan >>= \xml -> return $ do
+                yield xml -- atomically $ Slotted.push slots Nothing xml
+                inner
+            ,do mb <- readTVar xfin
+                cempty <- isEmptyTChan xchan
+                if isNothing mb
+                    then if cempty then return loop else retry
+                    else do done <- tryReadTMVar rdone
+                            check (isJust done)
+                            trace "todo: send closers" retry
+            ,do isEmptyTChan xchan >>= check
+                readTMVar rdone
+                return (return ())]
+        what
+
 
 sendModifiedStanzaToPeer :: Stanza -> TChan Stanza -> IO ()
 sendModifiedStanzaToPeer stanza chan = do
@@ -374,9 +424,19 @@ C->Unrecognized   xmlns="jabber:client">
 C->Unrecognized     <bind xmlns="urn:ietf:params:xml:ns:xmpp-bind"/>
 C->Unrecognized </iq>
 -}
+chanContents :: TChan x -> IO [x]
+chanContents ch = do
+        x  <- atomically $ do
+            bempty <- isEmptyTChan ch
+            if bempty
+                then return Nothing
+                else fmap Just $ readTChan ch
+        maybe (return [])
+              (\x -> do
+                xs <- chanContents ch
+                return (x:xs))
+              x
 
-ioWriteChan :: MonadIO m => TChan a -> a -> m ()
-ioWriteChan c v = liftIO . atomically $ writeTChan c v
 
 parsePresenceStatus
   :: ( MonadThrow m
@@ -499,7 +559,7 @@ grokMessage ns stanzaTag = do
 
 grokStanza
   ::  Text -> XML.Event -> NestingXML o IO (Maybe StanzaType)
-ggrokStanza "jabber:server" stanzaTag = 
+grokStanza "jabber:server" stanzaTag = 
             case () of
                 _ | stanzaTag `isServerIQOf` "get" -> grokStanzaIQGet stanzaTag
                 _ | stanzaTag `isServerIQOf` "result" -> grokStanzaIQResult stanzaTag
@@ -516,6 +576,24 @@ grokStanza "jabber:client" stanzaTag =
                 _ | tagName stanzaTag == "{jabber:client}message" -> grokMessage "jabber:client" stanzaTag
                 _ -> return $ Just Unrecognized
 
+mkname :: Text -> Text -> XML.Name
+mkname namespace name = (Name name (Just namespace) Nothing)
+
+makePong :: Text -> Maybe Text -> Text -> Text -> [XML.Event]
+makePong namespace mid to from =
+       -- Note: similar to session reply
+       [ EventBeginElement (mkname namespace "iq")
+         $(case mid of
+               Just c -> (("id",[ContentText c]):)
+               _      -> id)
+               [ attr "type" "result"
+               , attr "to"   to
+               , attr "from" from
+               ]
+       , EventEndElement (mkname namespace "iq")
+       ]
+
+
 xmppInbound :: Server ConnectionKey SockAddr
                 -> XMPPServerParameters
                 -> ConnectionKey
@@ -609,19 +687,6 @@ xmppInbound sv xmpp k laddr pingflag src stanzas output donevar = doNestingXML $
         loop
     
 
-chanContents :: TChan x -> IO [x]
-chanContents ch = do
-        x  <- atomically $ do
-            bempty <- isEmptyTChan ch
-            if bempty
-                then return Nothing
-                else fmap Just $ readTChan ch
-        maybe (return [])
-              (\x -> do
-                xs <- chanContents ch
-                return (x:xs))
-              x
-
 while :: IO Bool -> IO a -> IO [a]
 while cond body = do
     b <- cond
@@ -639,6 +704,7 @@ readUntilNothing ch = do
                 return (x:xs))
               x
 
+
 streamFeatures :: Text -> [XML.Event]
 streamFeatures "jabber:client" =
     [ EventBeginElement (streamP "features") []
@@ -680,9 +746,6 @@ data XMPPState
     = PingSlot
  deriving (Eq,Ord)
 
-mkname :: Text -> Text -> XML.Name
-mkname namespace name = (Name name (Just namespace) Nothing)
-
 makePing :: Text -> Maybe Text -> Text -> Text -> [XML.Event]
 makePing namespace mid to from = 
        [ EventBeginElement (mkname namespace "iq")
@@ -697,20 +760,6 @@ makePing namespace mid to from =
        , EventEndElement "{urn:xmpp:ping}ping"
        , EventEndElement $ mkname namespace "iq"]
 
-makePong :: Text -> Maybe Text -> Text -> Text -> [XML.Event]
-makePong namespace mid to from =
-       -- Note: similar to session reply
-       [ EventBeginElement (mkname namespace "iq")
-         $(case mid of
-               Just c -> (("id",[ContentText c]):)
-               _      -> id)
-               [ attr "type" "result"
-               , attr "to"   to
-               , attr "from" from
-               ]
-       , EventEndElement (mkname namespace "iq")
-       ]
-
 iq_bind_reply :: Maybe Text -> Text -> [XML.Event]
 iq_bind_reply mid jid =
     [ EventBeginElement "{jabber:client}iq" (consid mid [("type",[ContentText "result"])])
@@ -944,29 +993,6 @@ clientKey (sock,addr) = do
     paddr <- getPeerName sock
     return $ (ClientKey addr,paddr)
 
-stanzaToConduit :: MonadIO m => Stanza -> ConduitM i Event m ()
-stanzaToConduit stanza = do
-    let xchan = stanzaChan stanza
-        xfin = stanzaClosers stanza
-        rdone = stanzaInterrupt stanza
-        loop = return ()
-    fix $ \inner -> do
-        what <- liftIO . atomically $ foldr1 orElse
-            [readTChan xchan >>= \xml -> return $ do
-                yield xml -- atomically $ Slotted.push slots Nothing xml
-                inner
-            ,do mb <- readTVar xfin
-                cempty <- isEmptyTChan xchan
-                if isNothing mb
-                    then if cempty then return loop else retry
-                    else do done <- tryReadTMVar rdone
-                            check (isJust done)
-                            trace "todo: send closers" retry
-            ,do isEmptyTChan xchan >>= check
-                readTMVar rdone
-                return (return ())]
-        what
-
 xmlifyRosterItems :: Monad m => Set Text -> Text -> Set Text -> ConduitM i Event m ()
 xmlifyRosterItems solicited stype set = mapM_ item (Set.toList set) 
  where
@@ -978,18 +1004,6 @@ xmlifyRosterItems solicited stype set = mapM_ item (Set.toList set)
                              else [] )
                 yield $ EventEndElement "{jabber:iq:roster}item"
 
-conduitToChan
-  :: Conduit () IO Event
-     -> IO (TChan Event, TVar (Maybe [Event]), TMVar a)
-conduitToChan c = do
-    chan <- atomically newTChan
-    clsrs <- atomically $ newTVar (Just [])
-    quitvar <- atomically $ newEmptyTMVar
-    forkIO $ do
-        c =$= copyToChannel id chan clsrs $$ awaitForever (const $ return ())
-        atomically $ writeTVar clsrs Nothing
-    return (chan,clsrs,quitvar)
-
 sendRoster ::
     StanzaWrap a
     -> XMPPServerParameters
@@ -1190,3 +1204,4 @@ cloneTChan chan = do
         xs <- chanContents' chan
         return (x:xs)
 #endif
+