~singpolyma/network-protocol-xmpp

ref: 23ef847262518ba35eb6b28e996b060c39cae2db network-protocol-xmpp/lib/Network/Protocol/XMPP/Monad.hs -rw-r--r-- 5.5 KiB
23ef8472 — John Millikin Update source repository locations. Bump version to 0.4.5. 9 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
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}

-- Copyright (C) 2010-2011 John Millikin <jmillikin@gmail.com>
-- 
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- any later version.
-- 
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
-- 
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

module Network.Protocol.XMPP.Monad
	( XMPP (..)
	, Error (..)
	, Session (..)
	, runXMPP
	, startXMPP
	, restartXMPP
	
	, getHandle
	, getSession
	, sessionIsSecure
	
	, readEvents
	, getElement
	, getStanza
	
	, putBytes
	, putElement
	, putStanza
	) where

import qualified Control.Applicative as A
import qualified Control.Concurrent.MVar as M
import           Control.Monad (ap)
import           Control.Monad.Fix (MonadFix, mfix)
import           Control.Monad.Trans (MonadIO, liftIO)
import qualified Control.Monad.Error as E
import           Control.Monad.Error (ErrorType)
import qualified Control.Monad.Reader as R
import qualified Data.ByteString
import           Data.ByteString (ByteString)
import           Data.Text (Text)
import           Data.Text.Encoding (encodeUtf8)

import           Network.Protocol.XMPP.ErrorT
import qualified Network.Protocol.XMPP.Handle as H
import qualified Network.Protocol.XMPP.Stanza as S
import qualified Network.Protocol.XMPP.XML as X

data Error
	-- | The remote host refused the specified authentication credentials.
	= AuthenticationFailure
	
	-- | There was an error while authenticating with the remote host.
	| AuthenticationError Text
	
	-- | An unrecognized or malformed 'S.Stanza' was received from the remote
	-- host.
	| InvalidStanza X.Element
	
	-- | The remote host sent an invalid reply to a resource bind request.
	| InvalidBindResult S.ReceivedStanza
	
	-- | There was an error with the underlying transport.
	| TransportError Text
	
	-- | The remote host did not send a stream ID when accepting a component
	-- connection.
	| NoComponentStreamID
	deriving (Show)

data Session = Session
	{ sessionHandle :: H.Handle
	, sessionNamespace :: Text
	, sessionParser :: X.Parser
	, sessionReadLock :: M.MVar ()
	, sessionWriteLock :: M.MVar ()
	}

newtype XMPP a = XMPP { unXMPP :: ErrorT Error (R.ReaderT Session IO) a }

instance Functor XMPP where
	fmap f = XMPP . fmap f . unXMPP

instance Monad XMPP where
	return = XMPP . return
	m >>= f = XMPP (unXMPP m >>= unXMPP . f)

instance MonadIO XMPP where
	liftIO = XMPP . liftIO

instance E.MonadError XMPP where
	type ErrorType XMPP = Error
	throwError = XMPP . E.throwError
	catchError m h = XMPP (E.catchError (unXMPP m) (unXMPP . h))

instance A.Applicative XMPP where
	pure = return
	(<*>) = ap

instance MonadFix XMPP where
	mfix f = XMPP (mfix (unXMPP . f))

runXMPP :: Session -> XMPP a -> IO (Either Error a)
runXMPP s xmpp = R.runReaderT (runErrorT (unXMPP xmpp)) s

startXMPP :: H.Handle -> Text -> XMPP a -> IO (Either Error a)
startXMPP h ns xmpp = do
	sax <- X.newParser
	readLock <- M.newMVar ()
	writeLock <- M.newMVar ()
	runXMPP (Session h ns sax readLock writeLock) xmpp

restartXMPP :: Maybe H.Handle -> XMPP a -> XMPP a
restartXMPP newH xmpp = do
	Session oldH ns _ readLock writeLock <- getSession
	sax <- liftIO X.newParser
	let s = Session (maybe oldH id newH) ns sax readLock writeLock
	XMPP (R.local (const s) (unXMPP xmpp))

withLock :: (Session -> M.MVar ()) -> XMPP a -> XMPP a
withLock getLock xmpp = do
	s <- getSession
	let mvar = getLock s
	res <- liftIO (M.withMVar mvar (\_ -> runXMPP s xmpp))
	case res of
		Left err -> E.throwError err
		Right x -> return x

getSession :: XMPP Session
getSession = XMPP R.ask

getHandle :: XMPP H.Handle
getHandle = fmap sessionHandle getSession

sessionIsSecure :: XMPP Bool
sessionIsSecure = do
	h <- getHandle
	return (H.handleIsSecure h)

liftTLS :: ErrorT Text IO a -> XMPP a
liftTLS io = do
	res <- liftIO (runErrorT io)
	case res of
		Left err -> E.throwError (TransportError err)
		Right x -> return x

putBytes :: ByteString -> XMPP ()
putBytes bytes = do
	h <- getHandle
	liftTLS (H.hPutBytes h bytes)

putElement :: X.Element -> XMPP ()
putElement = putBytes . encodeUtf8 . X.serialiseElement

putStanza :: S.Stanza a => a -> XMPP ()
putStanza = withLock sessionWriteLock . putElement . S.stanzaToElement

readEvents :: (Integer -> X.Event -> Bool) -> XMPP [X.Event]
readEvents done = xmpp where
	xmpp = do
		Session h _ p _ _ <- getSession
		let nextEvents = do
			-- TODO: read in larger increments
			bytes <- liftTLS (H.hGetBytes h 1)
			let eof = Data.ByteString.null bytes
			parsed <- liftIO (X.parse p bytes eof)
			case parsed of
				Left err -> E.throwError (TransportError err)
				Right events -> return events
		X.readEvents done nextEvents

getElement :: XMPP X.Element
getElement = xmpp where
	xmpp = do
		events <- readEvents endOfTree
		case X.eventsToElement events of
			Just x -> return x
			Nothing -> E.throwError (TransportError "getElement: invalid event list")
	
	endOfTree 0 (X.EventEndElement _) = True
	endOfTree _ _ = False

getStanza :: XMPP S.ReceivedStanza
getStanza = withLock sessionReadLock $ do
	elemt <- getElement
	Session _ ns _ _ _ <- getSession
	case S.elementToStanza ns elemt of
		Just x -> return x
		Nothing -> E.throwError (InvalidStanza elemt)