From ac3702dd365691cc9abf37248633f00f1e06cb12 Mon Sep 17 00:00:00 2001 From: joe Date: Wed, 19 Feb 2014 16:35:24 -0500 Subject: more type signatures --- Presence/XMPPServer.hs | 157 +++++++++++++++++++++++++++---------------------- 1 file changed, 86 insertions(+), 71 deletions(-) (limited to 'Presence/XMPPServer.hs') 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 C->Unrecognized -} +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 + -- cgit v1.2.3