diff options
-rw-r--r-- | Presence/XMPP.hs | 104 |
1 files changed, 89 insertions, 15 deletions
diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs index d0333f4a..8508c3b4 100644 --- a/Presence/XMPP.hs +++ b/Presence/XMPP.hs | |||
@@ -20,7 +20,7 @@ import Control.Concurrent.STM | |||
20 | import Data.Conduit | 20 | import Data.Conduit |
21 | import qualified Data.Conduit.List as CL | 21 | import qualified Data.Conduit.List as CL |
22 | import Data.ByteString (ByteString) | 22 | import Data.ByteString (ByteString) |
23 | import Data.ByteString.Char8 (pack) | 23 | import qualified Data.ByteString.Char8 as S (pack,putStr,putStrLn) |
24 | import qualified Data.ByteString.Lazy.Char8 as L | 24 | import qualified Data.ByteString.Lazy.Char8 as L |
25 | ( putStrLn | 25 | ( putStrLn |
26 | , fromChunks | 26 | , fromChunks |
@@ -36,19 +36,23 @@ import Text.XML.Stream.Parse | |||
36 | import Text.XML.Stream.Render | 36 | import Text.XML.Stream.Render |
37 | import Data.XML.Types as XML | 37 | import Data.XML.Types as XML |
38 | import Network.BSD (getHostName,hostName,hostAliases) | 38 | import Network.BSD (getHostName,hostName,hostAliases) |
39 | import Data.Text.Lazy.Encoding (decodeUtf8) | 39 | import Data.Text.Encoding as S (decodeUtf8) |
40 | import Data.Text.Lazy.Encoding as L (decodeUtf8) | ||
40 | import Data.Text.Lazy (toStrict) | 41 | import Data.Text.Lazy (toStrict) |
41 | import GetHostByAddr | 42 | import GetHostByAddr |
43 | import Data.Monoid | ||
44 | import qualified Data.Sequence as Seq | ||
45 | import Data.Foldable (toList) | ||
42 | 46 | ||
43 | data Commands = Send [XML.Event] | QuitThread | 47 | data Commands = Send [XML.Event] | QuitThread |
44 | deriving Prelude.Show | 48 | deriving Prelude.Show |
45 | 49 | ||
46 | getNamesForPeer :: Peer -> IO [ByteString] | 50 | getNamesForPeer :: Peer -> IO [ByteString] |
47 | getNamesForPeer LocalHost = fmap ((:[]) . pack) getHostName | 51 | getNamesForPeer LocalHost = fmap ((:[]) . S.pack) getHostName |
48 | getNamesForPeer peer@(RemotePeer addr) = do | 52 | getNamesForPeer peer@(RemotePeer addr) = do |
49 | ent <- getHostByAddr addr -- AF_UNSPEC addr | 53 | ent <- getHostByAddr addr -- AF_UNSPEC addr |
50 | let names = hostName ent : hostAliases ent | 54 | let names = hostName ent : hostAliases ent |
51 | return . map pack $ names | 55 | return . map S.pack $ names |
52 | 56 | ||
53 | 57 | ||
54 | xmlifyPresenceForClient :: Presence -> IO [XML.Event] | 58 | xmlifyPresenceForClient :: Presence -> IO [XML.Event] |
@@ -56,7 +60,7 @@ xmlifyPresenceForClient (Presence jid stat) = do | |||
56 | let n = name jid | 60 | let n = name jid |
57 | rsc = resource jid | 61 | rsc = resource jid |
58 | names <- getNamesForPeer (peer jid) | 62 | names <- getNamesForPeer (peer jid) |
59 | let tostr p = decodeUtf8 $ n <$++> "@" <?++> L.fromChunks [p] <++?> "/" <++$> rsc | 63 | let tostr p = L.decodeUtf8 $ n <$++> "@" <?++> L.fromChunks [p] <++?> "/" <++$> rsc |
60 | jidstrs = fmap (toStrict . tostr) names | 64 | jidstrs = fmap (toStrict . tostr) names |
61 | return (concatMap presenceEvents jidstrs) | 65 | return (concatMap presenceEvents jidstrs) |
62 | where | 66 | where |
@@ -73,6 +77,34 @@ xmlifyPresenceForClient (Presence jid stat) = do | |||
73 | shw Away = "away" | 77 | shw Away = "away" |
74 | shw Offline = "away" -- Is this right? | 78 | shw Offline = "away" -- Is this right? |
75 | 79 | ||
80 | prefix ## name = Name name Nothing (Just prefix) | ||
81 | |||
82 | streamP name = Name name (Just "http://etherx.jabber.org/streams") (Just "stream") | ||
83 | |||
84 | greet host = | ||
85 | [ EventBeginDocument | ||
86 | , EventBeginElement (streamP "stream") | ||
87 | [("from",[ContentText host]) | ||
88 | ,("id",[ContentText "someid"]) | ||
89 | ,("xmlns",[ContentText "jabber:client"]) | ||
90 | ,("xmlns:stream",[ContentText "http://etherx.jabber.org/streams"]) | ||
91 | ,("version",[ContentText "1.0"]) | ||
92 | ] | ||
93 | , EventBeginElement (streamP "features") [] | ||
94 | , EventBeginElement "bind" [("xmlns",[ContentText "urn:ietf:params:xml:ns:xmpp-bind"])] | ||
95 | , EventEndElement "bind" | ||
96 | |||
97 | {- | ||
98 | -- , " <session xmlns='urn:ietf:params:xml:ns:xmpp-session'/>" | ||
99 | , " <mechanisms xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>" | ||
100 | -- , " <mechanism>DIGEST-MD5</mechanism>" | ||
101 | , " <mechanism>PLAIN</mechanism>" | ||
102 | , " </mechanisms> " | ||
103 | -} | ||
104 | |||
105 | , EventEndElement (streamP "features") | ||
106 | ] | ||
107 | |||
76 | 108 | ||
77 | -- type Consumer i m r = forall o. ConduitM i o m r | 109 | -- type Consumer i m r = forall o. ConduitM i o m r |
78 | mawait :: Monad m => MaybeT (ConduitM i o m) i | 110 | mawait :: Monad m => MaybeT (ConduitM i o m) i |
@@ -83,19 +115,62 @@ elementAttrs expected (EventBeginElement name attrs) | |||
83 | = return attrs | 115 | = return attrs |
84 | elementAttrs _ _ = mzero | 116 | elementAttrs _ _ = mzero |
85 | 117 | ||
118 | eventIsBeginElement (EventBeginElement _ _) = True | ||
119 | eventIsBeginElement _ = False | ||
120 | |||
121 | eventIsEndElement (EventEndElement _) = True | ||
122 | eventIsEndElement _ = False | ||
86 | 123 | ||
87 | fromClient :: MonadIO m => TChan Commands -> Sink XML.Event m () | 124 | gatherElement :: |
88 | fromClient cmdChan = (>>return ()) . runMaybeT $ do | 125 | (Monad m, MonadPlus mp) => |
126 | Event -> mp Event -> MaybeT (ConduitM Event o m) (mp Event) | ||
127 | gatherElement opentag empty = gatherElement' (empty `mplus` return opentag) 1 | ||
128 | where | ||
129 | gatherElement' ts cnt = do | ||
130 | tag <- mawait | ||
131 | let ts' = ts `mplus` return tag | ||
132 | cnt' = case () of | ||
133 | _ | eventIsEndElement tag -> cnt-1 | ||
134 | _ | eventIsBeginElement tag -> cnt+1 | ||
135 | _ -> cnt | ||
136 | if (cnt>0) then gatherElement' ts' cnt' | ||
137 | else return ts' | ||
138 | |||
139 | fromClient :: (MonadIO m, XMPPSession session) => | ||
140 | session -> TChan Commands -> Sink XML.Event m () | ||
141 | fromClient session cmdChan = (>>return ()) . runMaybeT $ do | ||
142 | let log = liftIO . L.putStrLn . ("client-in: " <++>) | ||
143 | send = liftIO . atomically . writeTChan cmdChan . Send | ||
89 | mawait >>= guard . (==EventBeginDocument) | 144 | mawait >>= guard . (==EventBeginDocument) |
90 | liftIO . L.putStrLn $ "client-in: begin-doc " | 145 | log "begin-doc" |
91 | xml <- mawait | 146 | xml <- mawait |
92 | stream_attrs <- elementAttrs "stream" xml | 147 | stream_attrs <- elementAttrs "stream" xml |
93 | liftIO . L.putStrLn $ "client-in: stream " <++> bshow stream_attrs | 148 | log $ "stream " <++> bshow stream_attrs |
149 | host <- liftIO $ do | ||
150 | jid <- getJID session | ||
151 | names <- getNamesForPeer (peer jid) | ||
152 | return (S.decodeUtf8 . head $ names) | ||
153 | send $ greet host | ||
154 | |||
94 | fix $ \loop -> do | 155 | fix $ \loop -> do |
95 | xml <- mawait | 156 | xml <- mawait |
96 | liftIO (L.putStrLn $ "client-in: " <++> bshow xml) | 157 | log $ bshow xml |
97 | loop | 158 | case xml of |
159 | _ | eventIsEndElement xml -> return () | ||
160 | tag@(EventBeginElement _ _) -> do | ||
161 | xs <- gatherElement tag Seq.empty | ||
162 | prettyPrint "client-in: ignoring..." (toList xs) | ||
163 | loop | ||
164 | _ -> loop | ||
165 | |||
166 | log $ "end of stream" | ||
167 | xml <- mawait | ||
168 | log $ "end-of-document: " <++> bshow xml | ||
98 | 169 | ||
170 | prettyPrint prefix xs = | ||
171 | liftIO $ do | ||
172 | S.putStrLn prefix | ||
173 | CL.sourceList xs $= renderBytes (def { rsPretty=True }) $$ CL.mapM_ S.putStr | ||
99 | 174 | ||
100 | toClient :: MonadIO m => TChan Presence -> TChan Commands -> Source m XML.Event | 175 | toClient :: MonadIO m => TChan Presence -> TChan Commands -> Source m XML.Event |
101 | toClient pchan cmdChan = fix $ \loop -> do | 176 | toClient pchan cmdChan = fix $ \loop -> do |
@@ -103,13 +178,12 @@ toClient pchan cmdChan = fix $ \loop -> do | |||
103 | orElse (fmap Left $ readTChan pchan) | 178 | orElse (fmap Left $ readTChan pchan) |
104 | (fmap Right $ readTChan cmdChan) | 179 | (fmap Right $ readTChan cmdChan) |
105 | case event of | 180 | case event of |
106 | Right QuitThread -> | 181 | Right QuitThread -> return () |
107 | return () | 182 | Right (Send xs) -> mapM_ yield xs >> prettyPrint "client-out: " xs >> loop |
108 | Left presence -> do | 183 | Left presence -> do |
109 | xs <- liftIO $ xmlifyPresenceForClient presence | 184 | xs <- liftIO $ xmlifyPresenceForClient presence |
110 | Monad.mapM_ yield xs | 185 | Monad.mapM_ yield xs |
111 | loop | 186 | loop |
112 | |||
113 | 187 | ||
114 | handleClient | 188 | handleClient |
115 | :: (SocketLike sock, HHead l (XMPPClass session), | 189 | :: (SocketLike sock, HHead l (XMPPClass session), |
@@ -125,7 +199,7 @@ handleClient st src snk = do | |||
125 | cmdChan <- atomically newTChan | 199 | cmdChan <- atomically newTChan |
126 | 200 | ||
127 | writer <- async ( toClient pchan cmdChan $$ renderBytes def =$ snk ) | 201 | writer <- async ( toClient pchan cmdChan $$ renderBytes def =$ snk ) |
128 | finally ( src $= parseBytes def $$ fromClient cmdChan ) | 202 | finally ( src $= parseBytes def $$ fromClient session cmdChan ) |
129 | $ do | 203 | $ do |
130 | atomically $ writeTChan cmdChan QuitThread | 204 | atomically $ writeTChan cmdChan QuitThread |
131 | wait writer | 205 | wait writer |