~singpolyma/network-protocol-xmpp

ref: 670340a40cd642d35f9f3fc0033fa7f539ab3c54 network-protocol-xmpp/Network/Protocol/XMPP/Monad.hs -rw-r--r-- 4.9 KiB
670340a4 — John Millikin Documentation updates 12 years ago
                                                                                
92b4b6e3 John Millikin
fa4477d2 John Millikin
92b4b6e3 John Millikin
2969f4f9 John Millikin
92b4b6e3 John Millikin
d0f194da John Millikin
fa4477d2 John Millikin
d0f194da John Millikin
92b4b6e3 John Millikin
d0f194da John Millikin
fa4477d2 John Millikin
92b4b6e3 John Millikin
761236be John Millikin
92b4b6e3 John Millikin
d4a781fd John Millikin
99f5f447 John Millikin
fa4477d2 John Millikin
92b4b6e3 John Millikin
d0f194da John Millikin
92b4b6e3 John Millikin
670340a4 John Millikin
92b4b6e3 John Millikin
670340a4 John Millikin
d0f194da John Millikin
670340a4 John Millikin
92b4b6e3 John Millikin
761236be John Millikin
2969f4f9 John Millikin
92b4b6e3 John Millikin
2969f4f9 John Millikin
fa4477d2 John Millikin
2969f4f9 John Millikin
92b4b6e3 John Millikin
fa4477d2 John Millikin
92b4b6e3 John Millikin
d0f194da John Millikin
92b4b6e3 John Millikin
d0f194da John Millikin
92b4b6e3 John Millikin
fa4477d2 John Millikin
92b4b6e3 John Millikin
fa4477d2 John Millikin
92b4b6e3 John Millikin
d0f194da John Millikin
fa4477d2 John Millikin
670340a4 John Millikin
fa4477d2 John Millikin
670340a4 John Millikin
fa4477d2 John Millikin
d0f194da John Millikin
92b4b6e3 John Millikin
fa4477d2 John Millikin
92b4b6e3 John Millikin
fa4477d2 John Millikin
92b4b6e3 John Millikin
fa4477d2 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
-- Copyright (C) 2010 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/>.

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.Protocol.XMPP.Monad
	( XMPP (..)
	, Error (..)
	, Context (..)
	, runXMPP
	, startXMPP
	, restartXMPP
	
	, getHandle
	, getContext
	
	, readEvents
	, getElement
	, getStanza
	
	, putBytes
	, putElement
	, putStanza
	) where
import qualified Control.Applicative as A
import Control.Monad (ap)
import Control.Monad.Fix (MonadFix, mfix)
import Control.Monad.Trans (MonadIO, liftIO)
import qualified Control.Monad.Error as E
import qualified Control.Monad.Reader as R
import qualified Data.ByteString.Lazy.Char8 as B
import Data.Text.Lazy (Text)
import Data.Text.Lazy.Encoding (encodeUtf8)
import qualified Data.FailableList as FL
import qualified Text.XML.LibXML.SAX as SAX

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 Context = Context H.Handle Text SAX.Parser

newtype XMPP a = XMPP { unXMPP :: ErrorT Error (R.ReaderT Context 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 E.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 :: Context -> XMPP a -> IO (Either Error a)
runXMPP ctx xmpp = R.runReaderT (runErrorT (unXMPP xmpp)) ctx

startXMPP :: H.Handle -> Text -> XMPP a -> IO (Either Error a)
startXMPP h ns xmpp = do
	sax <- SAX.newParser
	runXMPP (Context h ns sax) xmpp

restartXMPP :: Maybe H.Handle -> XMPP a -> XMPP a
restartXMPP newH xmpp = do
	Context oldH ns _ <- getContext
	sax <- liftIO SAX.newParser
	let ctx = Context (maybe oldH id newH) ns sax
	XMPP $ R.local (const ctx) (unXMPP xmpp)

getContext :: XMPP Context
getContext = XMPP R.ask

getHandle :: XMPP H.Handle
getHandle = do
	Context h _ _ <- getContext
	return 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 :: B.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 = putElement . S.stanzaToElement

readEvents :: (Integer -> SAX.Event -> Bool) -> XMPP [SAX.Event]
readEvents done = xmpp where
	xmpp = do
		Context h _ p <- getContext
		let nextEvents = do
			-- TODO: read in larger increments
			bytes <- liftTLS $ H.hGetBytes h 1
			failable <- liftIO $ SAX.parse p bytes False
			failableToList failable
		X.readEvents done nextEvents
	
	failableToList f = case f of
		FL.Fail (SAX.Error e) -> E.throwError $ TransportError e
		FL.Done -> return []
		FL.Next e es -> do
			es' <- failableToList es
			return $ e : es'

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 (SAX.EndElement _) = True
	endOfTree _ _ = False

getStanza :: XMPP S.ReceivedStanza
getStanza = do
	elemt <- getElement
	Context _ ns _ <- getContext
	case S.elementToStanza ns elemt of
		Just x -> return x
		Nothing -> E.throwError $ InvalidStanza elemt