Browse Source

rename StanzaID to StanzaId

cleanups
master
Philipp Balzarek 13 years ago
parent
commit
82e398fddd
  1. 2
      examples/EchoClient.hs
  2. 9
      pontarius-xmpp.cabal
  3. 2
      source/Network/Xmpp/Concurrent/Channels/Types.hs
  4. 2
      source/Network/Xmpp/Concurrent/Types.hs
  5. 22
      source/Network/Xmpp/Connection.hs
  6. 2
      source/Network/Xmpp/Errors.hs
  7. 2
      source/Network/Xmpp/IM/Message.hs
  8. 22
      source/Network/Xmpp/Marshal.hs
  9. 53
      source/Network/Xmpp/Pickle.hs
  10. 11
      source/Network/Xmpp/Session.hs
  11. 13
      source/Network/Xmpp/Stream.hs
  12. 2
      source/Network/Xmpp/TLS.hs
  13. 24
      source/Network/Xmpp/Types.hs
  14. 66
      source/Network/Xmpp/Xep/InbandRegistration.hs

2
examples/EchoClient.hs

@ -26,7 +26,7 @@ import Network.Xmpp.IM
-- Server and authentication details. -- Server and authentication details.
host = "localhost" host = "localhost"
port = PortNumber 5222 port = PortNumber 5222
realm = "server.com" realm = "species64739.dyndns.org"
username = "echo" username = "echo"
password = "pwd" password = "pwd"
resource = Just "bot" resource = Just "bot"

9
pontarius-xmpp.cabal

@ -49,14 +49,15 @@ Library
, stm >=2.1.2.1 , stm >=2.1.2.1
, xml-types >=0.3.1 , xml-types >=0.3.1
, xml-conduit >=1.0 , xml-conduit >=1.0
, xml-picklers >=0.2.2 , xml-picklers >=0.3
, data-default >=0.2 , data-default >=0.2
, stringprep >=0.1.3 , stringprep >=0.1.3
Exposed-modules: Network.Xmpp Exposed-modules: Network.Xmpp
, Network.Xmpp.IM , Network.Xmpp.IM
, Network.Xmpp.Basic , Network.Xmpp.Basic
Other-modules: , Network.Xmpp.Lens
Network.Xmpp.Bind -- Undocumented modules
, Network.Xmpp.Bind
, Network.Xmpp.Concurrent , Network.Xmpp.Concurrent
, Network.Xmpp.IM.Message , Network.Xmpp.IM.Message
, Network.Xmpp.IM.Presence , Network.Xmpp.IM.Presence
@ -79,6 +80,8 @@ Library
, Network.Xmpp.Jid , Network.Xmpp.Jid
, Network.Xmpp.Concurrent.Types , Network.Xmpp.Concurrent.Types
, Network.Xmpp.Concurrent.Channels.IQ , Network.Xmpp.Concurrent.Channels.IQ
, Network.Xmpp.Concurrent.Channels
, Network.Xmpp.Concurrent.Channels.Types
, Network.Xmpp.Concurrent.Threads , Network.Xmpp.Concurrent.Threads
, Network.Xmpp.Concurrent.Monad , Network.Xmpp.Concurrent.Monad
, Text.XML.Stream.Elements , Text.XML.Stream.Elements

2
source/Network/Xmpp/Concurrent/Channels/Types.hs

@ -21,7 +21,7 @@ data Session = Session
-- | IQHandlers holds the registered channels for incomming IQ requests and -- | IQHandlers holds the registered channels for incomming IQ requests and
-- TMVars of and TMVars for expected IQ responses -- TMVars of and TMVars for expected IQ responses
type IQHandlers = (Map.Map (IQRequestType, Text) (TChan IQRequestTicket) type IQHandlers = (Map.Map (IQRequestType, Text) (TChan IQRequestTicket)
, Map.Map StanzaId (TMVar IQResponse) , Map.Map StanzaID (TMVar IQResponse)
) )
-- | Contains whether or not a reply has been sent, and the IQ request body to -- | Contains whether or not a reply has been sent, and the IQ request body to

2
source/Network/Xmpp/Concurrent/Types.hs

@ -22,7 +22,7 @@ data EventHandlers = EventHandlers
data Context = Context data Context = Context
{ writeRef :: TMVar (BS.ByteString -> IO Bool) { writeRef :: TMVar (BS.ByteString -> IO Bool)
, readerThread :: ThreadId , readerThread :: ThreadId
, idGenerator :: IO StanzaId , idGenerator :: IO StanzaID
-- | Lock (used by withConnection) to make sure that a maximum of one -- | Lock (used by withConnection) to make sure that a maximum of one
-- XmppConMonad action is executed at any given time. -- XmppConMonad action is executed at any given time.
, conRef :: TMVar Connection , conRef :: TMVar Connection

22
source/Network/Xmpp/Connection.hs

@ -147,7 +147,13 @@ connectTcpRaw :: HostName -> PortID -> Text -> IO Connection
connectTcpRaw host port hostname = do connectTcpRaw host port hostname = do
h <- connectTo host port h <- connectTo host port
hSetBuffering h NoBuffering hSetBuffering h NoBuffering
let eSource = DCI.ResumableSource (sourceHandle h $= XP.parseBytes def) let eSource = if debug then
DCI.ResumableSource (sourceHandle h
$= debugOut
$= XP.parseBytes def)
(return ())
else DCI.ResumableSource (sourceHandle h
$= XP.parseBytes def)
(return ()) (return ())
let hand = Hand { cSend = if debug let hand = Hand { cSend = if debug
then \d -> do then \d -> do
@ -157,6 +163,7 @@ connectTcpRaw host port hostname = do
, cRecv = if debug then , cRecv = if debug then
\n -> do \n -> do
bs <- BS.hGetSome h n bs <- BS.hGetSome h n
Prelude.putStr "in: "
BS.putStrLn bs BS.putStrLn bs
return bs return bs
else BS.hGetSome h else BS.hGetSome h
@ -178,7 +185,16 @@ connectTcpRaw host port hostname = do
, sFrom = Nothing , sFrom = Nothing
} }
mkConnection con mkConnection con
where
debugOut = do
d <- await
case d of
Nothing -> return ()
Just bs -> do
liftIO $ BS.putStr "in: "
liftIO $ BS.putStrLn bs
yield bs
debugOut
-- Closes the connection and updates the XmppConMonad Connection_ state. -- Closes the connection and updates the XmppConMonad Connection_ state.
killConnection :: Connection -> IO (Either Ex.SomeException ()) killConnection :: Connection -> IO (Either Ex.SomeException ())
@ -190,7 +206,7 @@ killConnection = withConnection $ do
-- Sends an IQ request and waits for the response. If the response ID does not -- Sends an IQ request and waits for the response. If the response ID does not
-- match the outgoing ID, an error is thrown. -- match the outgoing ID, an error is thrown.
pushIQ' :: StanzaId pushIQ' :: StanzaID
-> Maybe Jid -> Maybe Jid
-> IQRequestType -> IQRequestType
-> Maybe LangTag -> Maybe LangTag

2
source/Network/Xmpp/Errors.hs

@ -36,7 +36,7 @@ findStreamErrors (Element name attrs children)
-> StreamUnknownError -> StreamUnknownError
safeRead x = case reads $ Text.unpack x of safeRead x = case reads $ Text.unpack x of
[] -> Nothing [] -> Nothing
[(y,_),_] -> Just y ((y,_):_) -> Just y
flattenAttrs :: [(Name, [Content])] -> [(Name, Text.Text)] flattenAttrs :: [(Name, [Content])] -> [(Name, Text.Text)]
flattenAttrs attrs = map (\(name, content) -> flattenAttrs attrs = map (\(name, content) ->

2
source/Network/Xmpp/IM/Message.hs

@ -80,7 +80,7 @@ body m = bodyContent <$> listToMaybe (bodies m)
-- | Generate a new instant message -- | Generate a new instant message
newIM newIM
:: Jid :: Jid
-> Maybe StanzaId -> Maybe StanzaID
-> Maybe LangTag -> Maybe LangTag
-> MessageType -> MessageType
-> Maybe MessageSubject -> Maybe MessageSubject

22
source/Network/Xmpp/Marshal.hs

@ -18,7 +18,7 @@ xpStreamStanza :: PU [Node] (Either XmppStreamError Stanza)
xpStreamStanza = xpEither xpStreamError xpStanza xpStreamStanza = xpEither xpStreamError xpStanza
xpStanza :: PU [Node] Stanza xpStanza :: PU [Node] Stanza
xpStanza = xpAlt stanzaSel xpStanza = ("xpStanza" , "") <?+> xpAlt stanzaSel
[ xpWrap IQRequestS (\(IQRequestS x) -> x) xpIQRequest [ xpWrap IQRequestS (\(IQRequestS x) -> x) xpIQRequest
, xpWrap IQResultS (\(IQResultS x) -> x) xpIQResult , xpWrap IQResultS (\(IQResultS x) -> x) xpIQResult
, xpWrap IQErrorS (\(IQErrorS x) -> x) xpIQError , xpWrap IQErrorS (\(IQErrorS x) -> x) xpIQError
@ -39,7 +39,7 @@ xpStanza = xpAlt stanzaSel
stanzaSel (PresenceErrorS _) = 6 stanzaSel (PresenceErrorS _) = 6
xpMessage :: PU [Node] (Message) xpMessage :: PU [Node] (Message)
xpMessage = xpWrap xpMessage = ("xpMessage" , "") <?+> xpWrap
(\((tp, qid, from, to, lang), ext) -> Message qid from to lang tp ext) (\((tp, qid, from, to, lang), ext) -> Message qid from to lang tp ext)
(\(Message qid from to lang tp ext) -> ((tp, qid, from, to, lang), ext)) (\(Message qid from to lang tp ext) -> ((tp, qid, from, to, lang), ext))
(xpElem "{jabber:client}message" (xpElem "{jabber:client}message"
@ -55,7 +55,7 @@ xpMessage = xpWrap
) )
xpPresence :: PU [Node] Presence xpPresence :: PU [Node] Presence
xpPresence = xpWrap xpPresence = ("xpPresence" , "") <?+> xpWrap
(\((qid, from, to, lang, tp), ext) -> Presence qid from to lang tp ext) (\((qid, from, to, lang, tp), ext) -> Presence qid from to lang tp ext)
(\(Presence qid from to lang tp ext) -> ((qid, from, to, lang, tp), ext)) (\(Presence qid from to lang tp ext) -> ((qid, from, to, lang, tp), ext))
(xpElem "{jabber:client}presence" (xpElem "{jabber:client}presence"
@ -70,7 +70,7 @@ xpPresence = xpWrap
) )
xpIQRequest :: PU [Node] IQRequest xpIQRequest :: PU [Node] IQRequest
xpIQRequest = xpWrap xpIQRequest = ("xpIQRequest" , "") <?+> xpWrap
(\((qid, from, to, lang, tp),body) -> IQRequest qid from to lang tp body) (\((qid, from, to, lang, tp),body) -> IQRequest qid from to lang tp body)
(\(IQRequest qid from to lang tp body) -> ((qid, from, to, lang, tp), body)) (\(IQRequest qid from to lang tp body) -> ((qid, from, to, lang, tp), body))
(xpElem "{jabber:client}iq" (xpElem "{jabber:client}iq"
@ -85,7 +85,7 @@ xpIQRequest = xpWrap
) )
xpIQResult :: PU [Node] IQResult xpIQResult :: PU [Node] IQResult
xpIQResult = xpWrap xpIQResult = ("xpIQResult" , "") <?+> xpWrap
(\((qid, from, to, lang, _tp),body) -> IQResult qid from to lang body) (\((qid, from, to, lang, _tp),body) -> IQResult qid from to lang body)
(\(IQResult qid from to lang body) -> ((qid, from, to, lang, ()), body)) (\(IQResult qid from to lang body) -> ((qid, from, to, lang, ()), body))
(xpElem "{jabber:client}iq" (xpElem "{jabber:client}iq"
@ -104,7 +104,7 @@ xpIQResult = xpWrap
---------------------------------------------------------- ----------------------------------------------------------
xpErrorCondition :: PU [Node] StanzaErrorCondition xpErrorCondition :: PU [Node] StanzaErrorCondition
xpErrorCondition = xpWrap xpErrorCondition = ("xpErrorCondition" , "") <?+> xpWrap
(\(cond, (), ()) -> cond) (\(cond, (), ()) -> cond)
(\cond -> (cond, (), ())) (\cond -> (cond, (), ()))
(xpElemByNamespace (xpElemByNamespace
@ -115,7 +115,7 @@ xpErrorCondition = xpWrap
) )
xpStanzaError :: PU [Node] StanzaError xpStanzaError :: PU [Node] StanzaError
xpStanzaError = xpWrap xpStanzaError = ("xpStanzaError" , "") <?+> xpWrap
(\(tp, (cond, txt, ext)) -> StanzaError tp cond txt ext) (\(tp, (cond, txt, ext)) -> StanzaError tp cond txt ext)
(\(StanzaError tp cond txt ext) -> (tp, (cond, txt, ext))) (\(StanzaError tp cond txt ext) -> (tp, (cond, txt, ext)))
(xpElem "{jabber:client}error" (xpElem "{jabber:client}error"
@ -131,7 +131,7 @@ xpStanzaError = xpWrap
) )
xpMessageError :: PU [Node] (MessageError) xpMessageError :: PU [Node] (MessageError)
xpMessageError = xpWrap xpMessageError = ("xpMessageError" , "") <?+> xpWrap
(\((_, qid, from, to, lang), (err, ext)) -> (\((_, qid, from, to, lang), (err, ext)) ->
MessageError qid from to lang err ext) MessageError qid from to lang err ext)
(\(MessageError qid from to lang err ext) -> (\(MessageError qid from to lang err ext) ->
@ -149,7 +149,7 @@ xpMessageError = xpWrap
) )
xpPresenceError :: PU [Node] PresenceError xpPresenceError :: PU [Node] PresenceError
xpPresenceError = xpWrap xpPresenceError = ("xpPresenceError" , "") <?+> xpWrap
(\((qid, from, to, lang, _),(err, ext)) -> (\((qid, from, to, lang, _),(err, ext)) ->
PresenceError qid from to lang err ext) PresenceError qid from to lang err ext)
(\(PresenceError qid from to lang err ext) -> (\(PresenceError qid from to lang err ext) ->
@ -166,7 +166,7 @@ xpPresenceError = xpWrap
) )
xpIQError :: PU [Node] IQError xpIQError :: PU [Node] IQError
xpIQError = xpWrap xpIQError = ("xpIQError" , "") <?+> xpWrap
(\((qid, from, to, lang, _tp),(err, body)) -> (\((qid, from, to, lang, _tp),(err, body)) ->
IQError qid from to lang err body) IQError qid from to lang err body)
(\(IQError qid from to lang err body) -> (\(IQError qid from to lang err body) ->
@ -183,7 +183,7 @@ xpIQError = xpWrap
) )
xpStreamError :: PU [Node] XmppStreamError xpStreamError :: PU [Node] XmppStreamError
xpStreamError = xpWrap xpStreamError = ("xpStreamError" , "") <?+> xpWrap
(\((cond,() ,()), txt, el) -> XmppStreamError cond txt el) (\((cond,() ,()), txt, el) -> XmppStreamError cond txt el)
(\(XmppStreamError cond txt el) ->((cond,() ,()), txt, el)) (\(XmppStreamError cond txt el) ->((cond,() ,()), txt, el))
(xpElemNodes (xpElemNodes

53
source/Network/Xmpp/Pickle.hs

@ -8,19 +8,13 @@
module Network.Xmpp.Pickle module Network.Xmpp.Pickle
( mbToBool ( xmlLang
, xmlLang
, xpLangTag , xpLangTag
, xpNodeElem
, ignoreAttrs
, mbl
, lmb
, right
, unpickleElem' , unpickleElem'
, unpickleElem , unpickleElem
, pickleElem , pickleElem
, ppElement )
) where where
import Data.XML.Types import Data.XML.Types
import Data.XML.Pickle import Data.XML.Pickle
@ -29,50 +23,23 @@ import Network.Xmpp.Types
import Text.XML.Stream.Elements import Text.XML.Stream.Elements
mbToBool :: Maybe t -> Bool
mbToBool (Just _) = True
mbToBool _ = False
xmlLang :: Name xmlLang :: Name
xmlLang = Name "lang" (Just "http://www.w3.org/XML/1998/namespace") (Just "xml") xmlLang = Name "lang" (Just "http://www.w3.org/XML/1998/namespace") (Just "xml")
xpLangTag :: PU [Attribute] (Maybe LangTag) xpLangTag :: PU [Attribute] (Maybe LangTag)
xpLangTag = xpAttrImplied xmlLang xpPrim xpLangTag = xpAttrImplied xmlLang xpPrim
xpNodeElem :: PU [Node] a -> PU Element a -- Given a pickler and an element, produces an object.
xpNodeElem xp = PU { pickleTree = \x -> head $ (pickleTree xp x) >>= \y -> unpickleElem :: PU [Node] a -> Element -> Either UnpickleError a
case y of unpickleElem p x = unpickle p [NodeElement x]
NodeElement e -> [e]
_ -> []
, unpickleTree = \x -> case unpickleTree xp $ [NodeElement x] of
Left l -> Left l
Right (a,(_,c)) -> Right (a,(Nothing,c))
}
ignoreAttrs :: PU t ((), b) -> PU t b
ignoreAttrs = xpWrap snd ((),)
mbl :: Maybe [a] -> [a]
mbl (Just l) = l
mbl Nothing = []
lmb :: [t] -> Maybe [t]
lmb [] = Nothing
lmb x = Just x
right :: Either [Char] t -> t
right (Left l) = error l
right (Right r) = r
unpickleElem' :: PU [Node] c -> Element -> c unpickleElem' :: PU [Node] c -> Element -> c
unpickleElem' p x = case unpickle (xpNodeElem p) x of unpickleElem' p x = case unpickleElem p x of
Left l -> error $ (show l) ++ "\n saw: " ++ ppElement x Left l -> error $ (show l) ++ "\n saw: " ++ ppElement x
Right r -> r Right r -> r
-- Given a pickler and an element, produces an object.
unpickleElem :: PU [Node] a -> Element -> Either UnpickleError a
unpickleElem p x = unpickle (xpNodeElem p) x
-- Given a pickler and an object, produces an Element. -- Given a pickler and an object, produces an Element.
pickleElem :: PU [Node] a -> a -> Element pickleElem :: PU [Node] a -> a -> Element
pickleElem p = pickle $ xpNodeElem p pickleElem p x = case pickle p x of
[NodeElement e] -> e
_ -> error "pickleElem: Pickler didn't return a single element."

11
source/Network/Xmpp/Session.hs

@ -87,6 +87,17 @@ connectTcp address port hostname = do
XmppStreamError StreamInvalidXml Nothing Nothing XmppStreamError StreamInvalidXml Nothing Nothing
toError StreamUnknownError = toError StreamUnknownError =
XmppStreamError StreamBadFormat Nothing Nothing XmppStreamError StreamBadFormat Nothing Nothing
toError (StreamWrongTo _) =
XmppStreamError StreamBadFormat Nothing Nothing
toError (StreamXMLError _) =
XmppStreamError StreamInvalidXml Nothing Nothing
toError StreamStreamEnd =
XmppStreamError StreamBadFormat Nothing Nothing
toError StreamConnectionError =
XmppStreamError StreamRemoteConnectionFailed Nothing Nothing
toError (StreamError _) =
XmppStreamError StreamUndefinedCondition Nothing Nothing
sessionXML :: Element sessionXML :: Element

13
source/Network/Xmpp/Stream.hs

@ -30,6 +30,14 @@ import Text.XML.Stream.Parse as XP
-- import Text.XML.Stream.Elements -- import Text.XML.Stream.Elements
mbl :: Maybe [a] -> [a]
mbl (Just l) = l
mbl Nothing = []
lmb :: [t] -> Maybe [t]
lmb [] = Nothing
lmb x = Just x
-- Unpickles and returns a stream element. Throws a StreamXMLError on failure. -- Unpickles and returns a stream element. Throws a StreamXMLError on failure.
streamUnpickleElem :: PU [Node] a streamUnpickleElem :: PU [Node] a
-> Element -> Element
@ -125,6 +133,7 @@ streamS expectedTo = do
-- Get the stream:stream element (or whatever it is) from the server, -- Get the stream:stream element (or whatever it is) from the server,
-- and validate what we get. -- and validate what we get.
el <- openElementFromEvents el <- openElementFromEvents
liftIO . print $ unpickleElem xpStream el
case unpickleElem xpStream el of case unpickleElem xpStream el of
Left _ -> throwError $ findStreamErrors el Left _ -> throwError $ findStreamErrors el
Right r -> validateData r Right r -> validateData r
@ -144,7 +153,7 @@ streamS expectedTo = do
xpStream :: PU [Node] (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag) xpStream :: PU [Node] (Text, Maybe Jid, Maybe Jid, Maybe Text, Maybe LangTag)
xpStream = xpElemAttrs xpStream = ("xpStream","") <?+> xpElemAttrs
(Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream"))
(xp5Tuple (xp5Tuple
(xpAttr "version" xpId) (xpAttr "version" xpId)
@ -156,7 +165,7 @@ xpStream = xpElemAttrs
-- Pickler/Unpickler for the stream features - TLS, SASL, and the rest. -- Pickler/Unpickler for the stream features - TLS, SASL, and the rest.
xpStreamFeatures :: PU [Node] ServerFeatures xpStreamFeatures :: PU [Node] ServerFeatures
xpStreamFeatures = xpWrap xpStreamFeatures = ("xpStreamFeatures", "") <?+> xpWrap
(\(tls, sasl, rest) -> SF tls (mbl sasl) rest) (\(tls, sasl, rest) -> SF tls (mbl sasl) rest)
(\(SF tls sasl rest) -> (tls, lmb sasl, rest)) (\(SF tls sasl rest) -> (tls, lmb sasl, rest))
(xpElemNodes (xpElemNodes

2
source/Network/Xmpp/TLS.hs

@ -18,7 +18,7 @@ import Data.Typeable
import Data.XML.Types import Data.XML.Types
import Network.Xmpp.Connection import Network.Xmpp.Connection
import Network.Xmpp.Pickle(ppElement) import Text.XML.Stream.Elements(ppElement)
import Network.Xmpp.Stream import Network.Xmpp.Stream
import Network.Xmpp.Types import Network.Xmpp.Types

24
source/Network/Xmpp/Types.hs

@ -27,7 +27,7 @@ module Network.Xmpp.Types
, StanzaError(..) , StanzaError(..)
, StanzaErrorCondition(..) , StanzaErrorCondition(..)
, StanzaErrorType(..) , StanzaErrorType(..)
, StanzaId(..) , StanzaID(..)
, StreamError(..) , StreamError(..)
, StreamErrorCondition(..) , StreamErrorCondition(..)
, Version(..) , Version(..)
@ -73,15 +73,15 @@ import System.IO
-- Wraps a string of random characters that, when using an appropriate -- Wraps a string of random characters that, when using an appropriate
-- @IDGenerator@, is guaranteed to be unique for the Xmpp session. -- @IDGenerator@, is guaranteed to be unique for the Xmpp session.
data StanzaId = SI !Text deriving (Eq, Ord) data StanzaID = SI !Text deriving (Eq, Ord)
instance Show StanzaId where instance Show StanzaID where
show (SI s) = Text.unpack s show (SI s) = Text.unpack s
instance Read StanzaId where instance Read StanzaID where
readsPrec _ x = [(SI $ Text.pack x, "")] readsPrec _ x = [(SI $ Text.pack x, "")]
instance IsString StanzaId where instance IsString StanzaID where
fromString = SI . Text.pack fromString = SI . Text.pack
-- | The Xmpp communication primities (Message, Presence and Info/Query) are -- | The Xmpp communication primities (Message, Presence and Info/Query) are
@ -97,7 +97,7 @@ data Stanza = IQRequestS !IQRequest
-- | A "request" Info/Query (IQ) stanza is one with either "get" or "set" as -- | A "request" Info/Query (IQ) stanza is one with either "get" or "set" as
-- type. It always contains an xml payload. -- type. It always contains an xml payload.
data IQRequest = IQRequest { iqRequestID :: !StanzaId data IQRequest = IQRequest { iqRequestID :: !StanzaID
, iqRequestFrom :: !(Maybe Jid) , iqRequestFrom :: !(Maybe Jid)
, iqRequestTo :: !(Maybe Jid) , iqRequestTo :: !(Maybe Jid)
, iqRequestLangTag :: !(Maybe LangTag) , iqRequestLangTag :: !(Maybe LangTag)
@ -125,7 +125,7 @@ data IQResponse = IQResponseError IQError
deriving Show deriving Show
-- | The (non-error) answer to an IQ request. -- | The (non-error) answer to an IQ request.
data IQResult = IQResult { iqResultID :: !StanzaId data IQResult = IQResult { iqResultID :: !StanzaID
, iqResultFrom :: !(Maybe Jid) , iqResultFrom :: !(Maybe Jid)
, iqResultTo :: !(Maybe Jid) , iqResultTo :: !(Maybe Jid)
, iqResultLangTag :: !(Maybe LangTag) , iqResultLangTag :: !(Maybe LangTag)
@ -133,7 +133,7 @@ data IQResult = IQResult { iqResultID :: !StanzaId
} deriving Show } deriving Show
-- | The answer to an IQ request that generated an error. -- | The answer to an IQ request that generated an error.
data IQError = IQError { iqErrorID :: !StanzaId data IQError = IQError { iqErrorID :: !StanzaID
, iqErrorFrom :: !(Maybe Jid) , iqErrorFrom :: !(Maybe Jid)
, iqErrorTo :: !(Maybe Jid) , iqErrorTo :: !(Maybe Jid)
, iqErrorLangTag :: !(Maybe LangTag) , iqErrorLangTag :: !(Maybe LangTag)
@ -142,7 +142,7 @@ data IQError = IQError { iqErrorID :: !StanzaId
} deriving Show } deriving Show
-- | The message stanza. Used for /push/ type communication. -- | The message stanza. Used for /push/ type communication.
data Message = Message { messageID :: !(Maybe StanzaId) data Message = Message { messageID :: !(Maybe StanzaID)
, messageFrom :: !(Maybe Jid) , messageFrom :: !(Maybe Jid)
, messageTo :: !(Maybe Jid) , messageTo :: !(Maybe Jid)
, messageLangTag :: !(Maybe LangTag) , messageLangTag :: !(Maybe LangTag)
@ -151,7 +151,7 @@ data Message = Message { messageID :: !(Maybe StanzaId)
} deriving Show } deriving Show
-- | An error stanza generated in response to a 'Message'. -- | An error stanza generated in response to a 'Message'.
data MessageError = MessageError { messageErrorID :: !(Maybe StanzaId) data MessageError = MessageError { messageErrorID :: !(Maybe StanzaID)
, messageErrorFrom :: !(Maybe Jid) , messageErrorFrom :: !(Maybe Jid)
, messageErrorTo :: !(Maybe Jid) , messageErrorTo :: !(Maybe Jid)
, messageErrorLangTag :: !(Maybe LangTag) , messageErrorLangTag :: !(Maybe LangTag)
@ -211,7 +211,7 @@ instance Read MessageType where
readsPrec _ _ = [(Normal, "")] readsPrec _ _ = [(Normal, "")]
-- | The presence stanza. Used for communicating status updates. -- | The presence stanza. Used for communicating status updates.
data Presence = Presence { presenceID :: !(Maybe StanzaId) data Presence = Presence { presenceID :: !(Maybe StanzaID)
, presenceFrom :: !(Maybe Jid) , presenceFrom :: !(Maybe Jid)
, presenceTo :: !(Maybe Jid) , presenceTo :: !(Maybe Jid)
, presenceLangTag :: !(Maybe LangTag) , presenceLangTag :: !(Maybe LangTag)
@ -221,7 +221,7 @@ data Presence = Presence { presenceID :: !(Maybe StanzaId)
-- | An error stanza generated in response to a 'Presence'. -- | An error stanza generated in response to a 'Presence'.
data PresenceError = PresenceError { presenceErrorID :: !(Maybe StanzaId) data PresenceError = PresenceError { presenceErrorID :: !(Maybe StanzaID)
, presenceErrorFrom :: !(Maybe Jid) , presenceErrorFrom :: !(Maybe Jid)
, presenceErrorTo :: !(Maybe Jid) , presenceErrorTo :: !(Maybe Jid)
, presenceErrorLangTag :: !(Maybe LangTag) , presenceErrorLangTag :: !(Maybe LangTag)

66
source/Network/Xmpp/Xep/InbandRegistration.hs

@ -22,6 +22,8 @@ import qualified Data.XML.Types as XML
import Network.Xmpp.Connection import Network.Xmpp.Connection
import Network.Xmpp.Pickle import Network.Xmpp.Pickle
import Network.Xmpp.Types import Network.Xmpp.Types
import Network.Xmpp.Basic
import Network.Xmpp
import Network.Xmpp.Xep.ServiceDiscovery import Network.Xmpp.Xep.ServiceDiscovery
@ -34,6 +36,7 @@ ibrName x = (XML.Name x (Just ibrns) Nothing)
data IbrError = IbrNotSupported data IbrError = IbrNotSupported
| IbrNoConnection | IbrNoConnection
| IbrIQError IQError | IbrIQError IQError
| IbrTimeout
deriving (Show) deriving (Show)
instance Error IbrError instance Error IbrError
@ -47,30 +50,6 @@ data Query = Query { instructions :: Maybe Text.Text
emptyQuery = Query Nothing False False [] emptyQuery = Query Nothing False False []
-- supported :: XmppConMonad (Either IbrError Bool)
-- supported = runErrorT $ fromFeatures <+> fromDisco
-- where
-- fromFeatures = do
-- fs <- other <$> gets sFeatures
-- let fe = XML.Element
-- "{http://jabber.org/features/iq-register}register"
-- []
-- []
-- return $ fe `elem` fs
-- fromDisco = do
-- hn' <- gets sHostname
-- hn <- case hn' of
-- Just h -> return (Jid Nothing h Nothing)
-- Nothing -> throwError IbrNoConnection
-- qi <- lift $ xmppQueryInfo Nothing Nothing
-- case qi of
-- Left e -> return False
-- Right qir -> return $ "jabber:iq:register" `elem` qiFeatures qir
-- f <+> g = do
-- r <- f
-- if r then return True else g
query :: IQRequestType -> Query -> Connection -> IO (Either IbrError Query) query :: IQRequestType -> Query -> Connection -> IO (Either IbrError Query)
query queryType x con = do query queryType x con = do
answer <- pushIQ' "ibr" Nothing queryType Nothing (pickleElem xpQuery x) con answer <- pushIQ' "ibr" Nothing queryType Nothing (pickleElem xpQuery x) con
@ -85,6 +64,23 @@ query queryType x con = do
Right _ -> return $ Right emptyQuery -- TODO: That doesn't seem right Right _ -> return $ Right emptyQuery -- TODO: That doesn't seem right
Left e -> return . Left $ IbrIQError e Left e -> return . Left $ IbrIQError e
query' :: IQRequestType -> Query -> Session -> IO (Either IbrError Query)
query' queryType x con = do
answer <- sendIQ' Nothing queryType Nothing (pickleElem xpQuery x) con
case answer of
IQResponseResult IQResult{iqResultPayload = Just b} ->
case unpickleElem xpQuery b of
Right query -> return $ Right query
Left e -> throw . StreamXMLError $
"RequestField: unpickle failed, got "
++ Text.unpack (ppUnpickleError e)
++ " saw " ++ ppElement b
IQResponseResult _ -> return $ Right emptyQuery -- TODO: That doesn't
-- seem right
IQResponseError e -> return . Left $ IbrIQError e
IQResponseTimeout -> return . Left $ IbrTimeout
data RegisterError = IbrError IbrError data RegisterError = IbrError IbrError
| MissingFields [Field] | MissingFields [Field]
| AlreadyRegistered | AlreadyRegistered
@ -95,7 +91,7 @@ instance Error RegisterError
mapError f = mapErrorT (liftM $ left f) mapError f = mapErrorT (liftM $ left f)
-- | Retrieve the necessary fields and fill them in to register an account with -- | Retrieve the necessary fields and fill them in to register an account with
-- the server -- the server.
registerWith :: [(Field, Text.Text)] registerWith :: [(Field, Text.Text)]
-> Connection -> Connection
-> IO (Either RegisterError Query) -> IO (Either RegisterError Query)
@ -112,14 +108,30 @@ registerWith givenFields con = runErrorT $ do
result <- mapError IbrError . ErrorT $ query Set (emptyQuery {fields}) con result <- mapError IbrError . ErrorT $ query Set (emptyQuery {fields}) con
return result return result
createAccountWith host hostname port fields = runErrorT $ do
con' <- liftIO $ connectTcp host port hostname
con <- case con' of
Left e -> throwError $ IbrError IbrNoConnection
Right r -> return r
lift $ startTLS exampleParams con
ErrorT $ registerWith fields con
deleteAccount host hostname port username password = do
con <- simpleConnect host port hostname username password Nothing
unregister' con
-- endsession con
-- | Terminate your account on the server. You have to be logged in for this to -- | Terminate your account on the server. You have to be logged in for this to
-- work. You connection will most likely be terminated after unregistering. -- work. You connection will most likely be terminated after unregistering.
unregister :: Connection -> IO (Either IbrError Query) unregister :: Connection -> IO (Either IbrError Query)
unregister = query Set $ emptyQuery {remove = True} unregister = query Set $ emptyQuery {remove = True}
unregister' :: Session -> IO (Either IbrError Query)
unregister' = query' Set $ emptyQuery {remove = True}
requestFields con = runErrorT $ do requestFields con = runErrorT $ do
-- supp <- ErrorT supported
-- unless supp $ throwError $ IbrNotSupported
qr <- ErrorT $ query Get emptyQuery con qr <- ErrorT $ query Get emptyQuery con
return $ qr return $ qr

Loading…
Cancel
Save