~singpolyma/network-protocol-xmpp

ref: 2969f4f954b2f89766c3614cb8ae157b11392e44 network-protocol-xmpp/Network/Protocol/XMPP/Monad.hs -rw-r--r-- 3.1 KiB
2969f4f9 — John Millikin Expose enough of the 'XMPP' monad internals for clients to interleave it with other IO. 13 years ago
                                                                                
92b4b6e3 John Millikin
2969f4f9 John Millikin
92b4b6e3 John Millikin
2969f4f9 John Millikin
92b4b6e3 John Millikin
2969f4f9 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
-- 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
	
	, putTree
	, getTree
	
	, putStanza
	, getStanza
	) where
import Control.Monad.Trans (MonadIO, liftIO)
import qualified Control.Monad.Error as E
import qualified Control.Monad.Reader as R
import Data.Text (Text)
import Text.XML.HXT.DOM.Interface (XmlTree)
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 XmlTree
	| InvalidBindResult S.ReceivedStanza
	| AuthenticationFailure
	| AuthenticationError 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

putTree :: XmlTree -> XMPP ()
putTree t = do
	h <- getHandle
	liftIO $ X.putTree h t

getTree :: XMPP XmlTree
getTree = do
	Context h _ sax <- getContext
	liftIO $ X.getTree h sax

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

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