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)
|
