diff options
Diffstat (limited to 'Presence')
-rw-r--r-- | Presence/XMPPServer.hs | 20 |
1 files changed, 9 insertions, 11 deletions
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs index 42425c5e..3327b523 100644 --- a/Presence/XMPPServer.hs +++ b/Presence/XMPPServer.hs | |||
@@ -57,8 +57,6 @@ import qualified Connection | |||
57 | import Util | 57 | import Util |
58 | import Network.Address (getBindAddress, sockAddrPort) | 58 | import Network.Address (getBindAddress, sockAddrPort) |
59 | 59 | ||
60 | import Data.Bits | ||
61 | import Data.Word | ||
62 | import Debug.Trace | 60 | import Debug.Trace |
63 | import Control.Monad.Trans (lift) | 61 | import Control.Monad.Trans (lift) |
64 | import Control.Monad.IO.Class (MonadIO, liftIO) | 62 | import Control.Monad.IO.Class (MonadIO, liftIO) |
@@ -281,7 +279,7 @@ cacheMessageId id' replyto = do | |||
281 | 279 | ||
282 | addrToText :: SockAddr -> Text | 280 | addrToText :: SockAddr -> Text |
283 | addrToText (addr@(SockAddrInet _ _)) = Text.pack $ stripColon (show addr) | 281 | addrToText (addr@(SockAddrInet _ _)) = Text.pack $ stripColon (show addr) |
284 | where stripColon s = pre where (pre,port) = break (==':') s | 282 | where stripColon s = pre where (pre,_) = break (==':') s |
285 | addrToText (addr@(SockAddrInet6 _ _ _ _)) = Text.pack $ stripColon (show addr) | 283 | addrToText (addr@(SockAddrInet6 _ _ _ _)) = Text.pack $ stripColon (show addr) |
286 | where stripColon s = if null bracket then pre else pre ++ "]" | 284 | where stripColon s = if null bracket then pre else pre ++ "]" |
287 | where | 285 | where |
@@ -911,8 +909,6 @@ makePong namespace mid to from = | |||
911 | , EventEndElement (mkname namespace "iq") | 909 | , EventEndElement (mkname namespace "iq") |
912 | ] | 910 | ] |
913 | 911 | ||
914 | data ClientOrPeer = IsClient | IsPeer | ||
915 | |||
916 | xmppInbound :: ConnectionData | 912 | xmppInbound :: ConnectionData |
917 | -> XMPPServerParameters -- ^ XXX: unused | 913 | -> XMPPServerParameters -- ^ XXX: unused |
918 | -> (Text, IO Text, IO Text, TChan Stanza -> StanzaOrigin) | 914 | -> (Text, IO Text, IO Text, TChan Stanza -> StanzaOrigin) |
@@ -1008,6 +1004,7 @@ while cond body = do | |||
1008 | return (x:xs) | 1004 | return (x:xs) |
1009 | else return [] | 1005 | else return [] |
1010 | 1006 | ||
1007 | {- | ||
1011 | readUntilNothing :: TChan (Maybe x) -> IO [x] | 1008 | readUntilNothing :: TChan (Maybe x) -> IO [x] |
1012 | readUntilNothing ch = do | 1009 | readUntilNothing ch = do |
1013 | x <- atomically $ readTChan ch | 1010 | x <- atomically $ readTChan ch |
@@ -1016,7 +1013,7 @@ readUntilNothing ch = do | |||
1016 | xs <- readUntilNothing ch | 1013 | xs <- readUntilNothing ch |
1017 | return (x:xs)) | 1014 | return (x:xs)) |
1018 | x | 1015 | x |
1019 | 1016 | -} | |
1020 | 1017 | ||
1021 | streamFeatures :: Text -> [XML.Event] | 1018 | streamFeatures :: Text -> [XML.Event] |
1022 | streamFeatures "jabber:client" = | 1019 | streamFeatures "jabber:client" = |
@@ -1167,11 +1164,13 @@ greet namespace = | |||
1167 | ] | 1164 | ] |
1168 | -} | 1165 | -} |
1169 | 1166 | ||
1167 | {- | ||
1170 | goodbye :: [XML.Event] | 1168 | goodbye :: [XML.Event] |
1171 | goodbye = | 1169 | goodbye = |
1172 | [ EventEndElement (streamP "stream") | 1170 | [ EventEndElement (streamP "stream") |
1173 | , EventEndDocument | 1171 | , EventEndDocument |
1174 | ] | 1172 | ] |
1173 | -} | ||
1175 | 1174 | ||
1176 | simulateChatError :: StanzaError -> Maybe Text -> [Event] | 1175 | simulateChatError :: StanzaError -> Maybe Text -> [Event] |
1177 | simulateChatError err mfrom = | 1176 | simulateChatError err mfrom = |
@@ -1586,8 +1585,7 @@ data StanzaError | |||
1586 | | UnexpectedRequest | 1585 | | UnexpectedRequest |
1587 | deriving (Show,Enum,Ord,Eq) | 1586 | deriving (Show,Enum,Ord,Eq) |
1588 | 1587 | ||
1589 | xep0086 :: | 1588 | xep0086 :: StanzaError -> (Text, Int) |
1590 | forall t t1. (Num t1, IsString t) => StanzaError -> (t, t1) | ||
1591 | xep0086 e = | 1589 | xep0086 e = |
1592 | case e of | 1590 | case e of |
1593 | BadRequest -> ("modify", 400) | 1591 | BadRequest -> ("modify", 400) |
@@ -1660,7 +1658,7 @@ makeErrorStanza stanza = do | |||
1660 | mto = Map.lookup "to" amap0 | 1658 | mto = Map.lookup "to" amap0 |
1661 | mfrom = Map.lookup "from" amap0 | 1659 | mfrom = Map.lookup "from" amap0 |
1662 | mtype = Map.lookup "type" amap0 | 1660 | mtype = Map.lookup "type" amap0 |
1663 | mid = Map.lookup "id" amap0 | 1661 | -- mid = Map.lookup "id" amap0 |
1664 | amap1 = Map.alter (const mto) "from" amap0 | 1662 | amap1 = Map.alter (const mto) "from" amap0 |
1665 | -- amap2 = Map.alter (const $ Just $ [ContentText "blackbird"]) {-mfrom)-} "to" amap1 | 1663 | -- amap2 = Map.alter (const $ Just $ [ContentText "blackbird"]) {-mfrom)-} "to" amap1 |
1666 | amap2 = Map.alter (const mfrom) "to" amap1 | 1664 | amap2 = Map.alter (const mfrom) "to" amap1 |
@@ -1679,9 +1677,9 @@ makeErrorStanza stanza = do | |||
1679 | , nameLocalName = errorTagLocalName err | 1677 | , nameLocalName = errorTagLocalName err |
1680 | , namePrefix = Nothing } | 1678 | , namePrefix = Nothing } |
1681 | errattrs = errorAttribs err [] | 1679 | errattrs = errorAttribs err [] |
1680 | {- | ||
1682 | let wlogd v s = do | 1681 | let wlogd v s = do |
1683 | wlog $ "error "++show (lookupAttrib "id" $ tagAttrs startTag)++" " ++ v ++ " = " ++ show s | 1682 | wlog $ "error "++show (lookupAttrib "id" $ tagAttrs startTag)++" " ++ v ++ " = " ++ show s |
1684 | {- | ||
1685 | wlogd "amap0" amap0 | 1683 | wlogd "amap0" amap0 |
1686 | wlogd "mto" mto | 1684 | wlogd "mto" mto |
1687 | wlogd "mfrom" mfrom | 1685 | wlogd "mfrom" mfrom |
@@ -1941,7 +1939,7 @@ xmppServer allocate bind_addr = do | |||
1941 | liftIO $ do | 1939 | liftIO $ do |
1942 | gen <- System.Random.getStdGen | 1940 | gen <- System.Random.getStdGen |
1943 | peer_bind <- maybe (getBindAddress "5269" True) return bind_addr | 1941 | peer_bind <- maybe (getBindAddress "5269" True) return bind_addr |
1944 | let (r,gen') = System.Random.next gen | 1942 | let (r, _) = System.Random.next gen |
1945 | fuzz = r `mod` 2000 -- maximum 2 seconds of ping fuzz | 1943 | fuzz = r `mod` 2000 -- maximum 2 seconds of ping fuzz |
1946 | peer_params :: ConnectionParameters PeerAddress ConnectionData | 1944 | peer_params :: ConnectionParameters PeerAddress ConnectionData |
1947 | peer_params = (connectionDefaults $ peerKey $ Just peer_bind) | 1945 | peer_params = (connectionDefaults $ peerKey $ Just peer_bind) |