~singpolyma/network-protocol-xmpp

ref: d0f194da32afc3a5fbf63d543721ff59786bdafb network-protocol-xmpp/Network/Protocol/XMPP/Monad.hs -rw-r--r-- 4.0 KiB
d0f194da — John Millikin Add error handling hooks to 'Handle' computation signatures, to simplify the migration to a better GNU TLS binding. 13 years ago
                                                                                
92b4b6e3 John Millikin
2969f4f9 John Millikin
92b4b6e3 John Millikin
d0f194da John Millikin
92b4b6e3 John Millikin
d0f194da John Millikin
92b4b6e3 John Millikin
d0f194da John Millikin
92b4b6e3 John Millikin
d0f194da John Millikin
92b4b6e3 John Millikin
d0f194da John Millikin
92b4b6e3 John Millikin
d0f194da John Millikin
92b4b6e3 John Millikin
d0f194da John Millikin
92b4b6e3 John Millikin
d0f194da John Millikin
92b4b6e3 John Millikin
d0f194da John Millikin
92b4b6e3 John Millikin
2969f4f9 John Millikin
92b4b6e3 John Millikin
2969f4f9 John Millikin
92b4b6e3 John Millikin
d0f194da John Millikin
92b4b6e3 John Millikin
d0f194da John Millikin
92b4b6e3 John Millikin
d0f194da John Millikin
92b4b6e3 John Millikin
d0f194da John Millikin
92b4b6e3 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
-- 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 #-}
module Network.Protocol.XMPP.Monad
	( XMPP (..)
	, Error (..)
	, Context (..)
	, runXMPP
	, startXMPP
	, restartXMPP
	
	, getHandle
	, getContext
	
	, readEvents
	, getChar
	, getTree
	, getStanza
	
	, putBytes
	, putTree
	, putStanza
	) where
import Prelude hiding (getChar)
import Control.Monad.Trans (MonadIO, liftIO)
import qualified Control.Monad.Error as E
import qualified Control.Monad.Reader as R
import qualified Data.ByteString.Char8 as B
import Data.Text (Text)

import Text.XML.HXT.Arrow ((>>>))
import qualified Text.XML.HXT.Arrow as A
import qualified Text.XML.HXT.DOM.Interface as DOM
import qualified Text.XML.HXT.DOM.XmlNode as XN
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
	= InvalidStanza DOM.XmlTree
	| InvalidBindResult S.ReceivedStanza
	| AuthenticationFailure
	| AuthenticationError Text
	| TransportError Text
	| NoComponentStreamID
	| ComponentHandshakeFailed
	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)

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.mkParser
	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.mkParser
	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

getChar :: XMPP Char
getChar = do
	h <- getHandle
	liftTLS $ H.hGetChar h

putTree :: DOM.XmlTree -> XMPP ()
putTree t = do
	let root = XN.mkRoot [] [t]
	[text] <- liftIO $ A.runX (A.constA root >>> A.writeDocumentToString [
		(A.a_no_xml_pi, "1")
		])
	h <- getHandle
	liftTLS $ H.hPutBytes h $ B.pack text

putStanza :: S.Stanza a => a -> XMPP ()
putStanza = putTree . S.stanzaToTree

readEvents :: (Integer -> SAX.Event -> Bool) -> XMPP [SAX.Event]
readEvents done = do
	Context h _ p <- getContext
	X.readEvents done (liftTLS $ H.hGetChar h) p

getTree :: XMPP DOM.XmlTree
getTree = X.eventsToTree `fmap` readEvents endOfTree where
	endOfTree 0 (SAX.EndElement _) = True
	endOfTree _ _ = False

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