4 files changed, 114 insertions, 72 deletions

diff --git a/Presence/ControlMaybe.hs b/Presence/ControlMaybe.hs
index 69a38f71..659dab74 100644
--- a/Presence/ControlMaybe.hs
+++ b/Presence/ControlMaybe.hs
@@ -4,9 +4,12 @@ module ControlMaybe where
 -- import GHC.IO.Exception (IOException(..))
 import Control.Exception as Exception (IOException(..),catch)
 
+
+withJust :: Monad m => Maybe x -> (x -> m ()) -> m ()
 withJust (Just x) f = f x
 withJust Nothing  f = return ()
 
+whenJust :: Monad m => m (Maybe x) -> (x -> m ()) -> m ()
 whenJust acn f = do
     x <- acn
     withJust x f
@@ -18,6 +21,9 @@ catchIO_ a h = Exception.catch a (\(_ :: IOException) -> h)
 catchIO :: IO a -> (IOException -> IO a)  -> IO a
 catchIO body handler = Exception.catch body handler
 
+handleIO_ :: IO a -> IO a -> IO a
 handleIO_ = flip catchIO_
-handleIO = flip catchIO
 
+
+handleIO :: (IOException -> IO a) -> IO a -> IO a
+handleIO = flip catchIO
diff --git a/Presence/EventUtil.hs b/Presence/EventUtil.hs
index 02a37472..908e09e0 100644
--- a/Presence/EventUtil.hs
+++ b/Presence/EventUtil.hs
@@ -4,49 +4,62 @@ module EventUtil where
 import Control.Monad
 import Data.XML.Types as XML
 import qualified Data.List as List
+import Data.Text (Text)
 
 -- getStreamName (EventBeginElement name _) = name
 
+isEventBeginElement :: Event -> Bool
 isEventBeginElement (EventBeginElement {}) = True
 isEventBeginElement _ = False
 
+isEventEndElement :: Event -> Bool
 isEventEndElement (EventEndElement {}) = True
 isEventEndElement _ = False
 
 -- Note: This function ignores name space qualification
+elementAttrs ::
+  MonadPlus m =>
+  Text -> Event -> m [(Name, [Content])]
 elementAttrs expected (EventBeginElement name attrs)
     | nameLocalName name==expected 
     = return attrs
 elementAttrs _ _ = mzero
 
+streamP :: Text -> Name
 streamP name = Name name (Just "http://etherx.jabber.org/streams") (Just "stream")
 
+attr :: Name -> Text -> (Name,[Content])
 attr   name value = (name,[ContentText value])
 
+isServerIQOf :: Event -> Text -> Bool
 isServerIQOf (EventBeginElement name attrs) testType 
     | name=="{jabber:server}iq" 
     && matchAttrib "type" testType attrs
     = True
 isServerIQOf _ _ = False
 
+isClientIQOf :: Event -> Text -> Bool
 isClientIQOf (EventBeginElement name attrs) testType 
     | name=="{jabber:client}iq" 
     && matchAttrib "type" testType attrs
     = True
 isClientIQOf _ _ = False
 
+matchAttrib :: Name -> Text -> [(Name, [Content])] -> Bool
 matchAttrib name value attrs = 
     case List.find ( (==name) . fst) attrs of
         Just (_,[ContentText x])   | x==value -> True
         Just (_,[ContentEntity x]) | x==value -> True
         _                                     -> False
 
+lookupAttrib :: Name -> [(Name, [Content])] -> Maybe Text
 lookupAttrib name attrs =
     case List.find ( (==name) . fst) attrs of
         Just (_,[ContentText x])   -> Just x
         Just (_,[ContentEntity x]) -> Just x
         _                          -> Nothing
 
+tagAttrs :: Event -> [(Name, [Content])]
 tagAttrs (EventBeginElement _ xs) = xs
 tagAttrs _                        = []
 
@@ -59,8 +72,12 @@ iqTypeError  = "error"
 -}
 
 
+tagName :: Event -> Name
 tagName (EventBeginElement n _) = n
 tagName _                       = ""
 
+closerFor :: Event -> Event
 closerFor (EventBeginElement n _) = EventEndElement n
 closerFor _ = error "closerFor: unsupported event"
+
+
diff --git a/Presence/Nesting.hs b/Presence/Nesting.hs
index 850cb8c0..dd0e4113 100644
--- a/Presence/Nesting.hs
+++ b/Presence/Nesting.hs
@@ -52,6 +52,7 @@ trackNesting = awaitForever doit
     yield xml
 
 
+lookupLang :: [(Name, [Content])] -> Maybe S.Text
 lookupLang attrs =
     case List.find ( (=="xml:lang") . fst) attrs of
         Just (_,[ContentText x])   -> Just x
@@ -67,6 +68,9 @@ awaitCloser lvl = do
         xml <- await
         maybe (return ()) (const loop) xml
 
+withXML ::
+    Monad m =>
+    (i -> ConduitM i o m ()) -> ConduitM i o m ()
 withXML f = await >>= maybe (return ()) f
 
 nextElement :: Monad m => NestingXML o m (Maybe Event)
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
+