~singpolyma/network-protocol-xmpp

ref: network-protocol-xmpp_0.4.5 network-protocol-xmpp/examples/echo.hs -rw-r--r-- 5.6 KiB
905f1032 — John Millikin If auth fails, include the error element in AuthenticationFailure. 7 years ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
-- Copyright (c) 2010 John Millikin
--
-- Permission is hereby granted, free of charge, to any person
-- obtaining a copy of this software and associated documentation
-- files (the "Software"), to deal in the Software without
-- restriction, including without limitation the rights to use,
-- copy, modify, merge, publish, distribute, sublicense, and/or sell
-- copies of the Software, and to permit persons to whom the
-- Software is furnished to do so, subject to the following
-- conditions:
--
-- The above copyright notice and this permission notice shall be
-- included in all copies or substantial portions of the Software.
--
-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
-- OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
-- HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
-- WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-- FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
-- OTHER DEALINGS IN THE SOFTWARE.

{-# LANGUAGE OverloadedStrings #-}
module Main where

-- XMPP imports
import Network
import Network.Protocol.XMPP
import Data.XML.Types

-- other imports
import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import qualified Data.Text as T
import System.Environment

runEcho :: String -> T.Text -> T.Text -> IO ()
runEcho hostname user password = do
	-- Verify that the user provided a valid JID, and that it contains a username
	-- (AKA a "node").
	jid <- case parseJID user of
		Just x -> return x
		Nothing -> error $ "Invalid JID: " ++ show user
	username <- case strNode `fmap` jidNode jid of
		Just x -> return x
		Nothing -> error $ "JID must include a username"
	
	-- 'Server' values record what host the connection will be opened to. Normally
	-- the hostname and JID will be the same; however, in some cases the hostname is
	-- something special (like "jabber.domain.com" or "localhost").
	-- 
	-- The port number is hardcoded to 5222 in this example, but in the wild there
	-- might be servers with a jabberd running on alternative ports.
	let server = Server
		{ serverHostname = hostname
		, serverJID = JID Nothing (jidDomain jid) Nothing
		, serverPort = PortNumber 5222
		}
	
	-- 'runClient' and 'runComponent' open a connection to the remote server and
	-- establish an XMPP session.
	-- 
	-- It is possible to run an XMPP session over multiple IO chunks using the
	-- 'getSession' computation. The returned session value can be used to run
	-- 'runXMPP'.
	-- 
	-- Unusual conditions like socket errors or async exceptions might cause this
	-- computation to raise an exception, but in normal operation all XMPP errors
	-- are returned via a 'Left' value.
	-- 
	-- 'XMPP' is an instance of 'MonadError', so you can use the standard
	-- 'throwError' and 'catchError' computations to handle errors within an XMPP
	-- session.
	res <- runClient server jid username password $ do
		
		-- Some servers will close the XMPP connection after some period
		-- of inactivity. For this example, we'll simply send a "ping" every
		-- 60 seconds
		getSession >>= liftIO . forkIO . sendPings 60
		
		-- When running a client session, most servers require the user to
		-- "bind" their JID before sending any stanzas.
		boundJID <- bindJID jid
		
		-- 'XMPP' is an instance of 'MonadIO', so any IO may be performed
		-- within.
		liftIO $ putStrLn $ "Server bound our session to: " ++ show boundJID
		
		-- This is a simple loop which will echo received messages back to the
		-- sender; additionally, it prints *all* received stanzas to the console.
		forever $ do
			stanza <- getStanza
			liftIO $ putStr "\n" >> print stanza >> putStrLn "\n"
			case stanza of
				ReceivedMessage msg -> if messageType msg == MessageError
					then return ()
					else putStanza $ echo msg
				ReceivedPresence msg -> if presenceType msg == PresenceSubscribe
					then putStanza (subscribe msg)
					else return ()
				_ -> return ()
	
	-- If 'runClient' terminated due to an XMPP error, propagate it as an exception.
	-- In non-example code, you might want to show this error to the user.
	case res of
		Left err -> error $ show err
		Right _ -> return ()

-- Copy a 'Message' into another message, setting the 'messageTo' field to the
-- original sender's address.
echo :: Message -> Message
echo msg = Message
	{ messageType = MessageNormal
	, messageTo = messageFrom msg
	
	-- Note: Conforming XMPP servers populate the "from" attribute on
	-- stanzas, to prevent clients from spoofing it. Therefore, the
	-- 'messageFrom' field's value is irrelevant when sending stanzas.
	, messageFrom = Nothing
	
	, messageID = Nothing
	, messageLang = Nothing
	, messagePayloads = messagePayloads msg
	}

subscribe :: Presence -> Presence
subscribe p = Presence
	{ presenceType = PresenceSubscribed
	, presenceTo = presenceFrom p
	, presenceFrom = Nothing
	, presenceID = Nothing
	, presenceLang = Nothing
	, presencePayloads = []
	}

-- Send a "ping" occasionally, to prevent server timeouts from
-- closing the connection.
sendPings :: Integer -> Session -> IO ()
sendPings seconds s = forever send where
	send = do
		-- Ignore errors
		runXMPP s $ putStanza ping
		threadDelay $ fromInteger $ 1000000 * seconds
	ping = (emptyIQ IQGet)
		{ iqPayload = Just (Element pingName [] [])
		}

pingName :: Name
pingName = Name "ping" (Just "urn:xmpp:ping") Nothing

main :: IO ()
main = do
	args <- getArgs
	case args of
		(server:user:pass:_) -> runEcho server (T.pack user) (T.pack pass)
		_ -> do
			name <- getProgName
			error $ "Use: " ++ name ++ " <server> <username> <password>"