~singpolyma/network-protocol-xmpp

ref: 3f30f380adb4c6eedf3c919590359c9746f5d8b3 network-protocol-xmpp/lib/Network/Protocol/XMPP/Monad.hs -rw-r--r-- 5.8 KiB
3f30f380Stephen Paul Weber Call TLS.getBytes again on EAGAIN 2 years ago
                                                                                
6ac34f1c John Millikin
92b4b6e3 John Millikin
e5a8ce04 John Millikin
92b4b6e3 John Millikin
2969f4f9 John Millikin
92b4b6e3 John Millikin
92b4b6e3 John Millikin
e5a8ce04 John Millikin
3b3d4a2d John Millikin
d0f194da John Millikin
fa4477d2 John Millikin
d0f194da John Millikin
d0f194da John Millikin
fa4477d2 John Millikin
92b4b6e3 John Millikin
6ac34f1c John Millikin
761236be John Millikin
902c60fb John Millikin
6ac34f1c John Millikin
92b4b6e3 John Millikin
787d509a John Millikin
92b4b6e3 John Millikin
1eb63b40 John Millikin
d0f194da John Millikin
6ac34f1c John Millikin
92b4b6e3 John Millikin
92b4b6e3 John Millikin
670340a4 John Millikin
905f1032 John Millikin
670340a4 John Millikin
92b4b6e3 John Millikin
670340a4 John Millikin
670340a4 John Millikin
670340a4 John Millikin
d0f194da John Millikin
670340a4 John Millikin
92b4b6e3 John Millikin
902c60fb John Millikin
bb4dfca0 John Millikin
902c60fb John Millikin
92b4b6e3 John Millikin
e5a8ce04 John Millikin
92b4b6e3 John Millikin
f804d361 John Millikin
92b4b6e3 John Millikin
787d509a John Millikin
92b4b6e3 John Millikin
f804d361 John Millikin
92b4b6e3 John Millikin
761236be John Millikin
f804d361 John Millikin
761236be John Millikin
e5a8ce04 John Millikin
92b4b6e3 John Millikin
2969f4f9 John Millikin
bb4dfca0 John Millikin
902c60fb John Millikin
92b4b6e3 John Millikin
902c60fb John Millikin
f804d361 John Millikin
92b4b6e3 John Millikin
902c60fb John Millikin
902c60fb John Millikin
e5a8ce04 John Millikin
92b4b6e3 John Millikin
902c60fb John Millikin
92b4b6e3 John Millikin
3b3d4a2d John Millikin
3b3d4a2d John Millikin
d0f194da John Millikin
f804d361 John Millikin
d0f194da John Millikin
f804d361 John Millikin
d0f194da John Millikin
1eb63b40 John Millikin
d0f194da John Millikin
92b4b6e3 John Millikin
f804d361 John Millikin
92b4b6e3 John Millikin
fa4477d2 John Millikin
92b4b6e3 John Millikin
902c60fb John Millikin
92b4b6e3 John Millikin
3a40e58a John Millikin
fa4477d2 John Millikin
902c60fb John Millikin
fa4477d2 John Millikin
f804d361 John Millikin
bb4dfca0 John Millikin
f804d361 John Millikin
bb4dfca0 John Millikin
fa4477d2 John Millikin
3a40e58a John Millikin
d0f194da John Millikin
92b4b6e3 John Millikin
902c60fb John Millikin
fa4477d2 John Millikin
902c60fb John Millikin
fa4477d2 John Millikin
92b4b6e3 John Millikin
f804d361 John Millikin
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
199
200
201
{-# LANGUAGE TypeFamilies #-}

-- 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           Data.Maybe (fromMaybe)
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
import           Network.Protocol.XMPP.String (s)

data Error
	-- | The remote host refused the specified authentication credentials.
	--
	-- The included XML element is the error value that the server
	-- provided. It may contain additional information about why
	-- authentication failed.
	= AuthenticationFailure X.Element

	-- | 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 session xmpp = R.runReaderT (runErrorT (unXMPP xmpp)) session

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 session = Session (fromMaybe oldH newH) ns sax readLock writeLock
	XMPP (R.local (const session) (unXMPP xmpp))

withLock :: (Session -> M.MVar ()) -> XMPP a -> XMPP a
withLock getLock xmpp = do
	session <- getSession
	let mvar = getLock session
	res <- liftIO (M.withMVar mvar (const $ runXMPP session 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 = H.handleIsSecure <$> getHandle

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 $ s"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)