From 82e398fdddfe7aa988ae1580504bced95692bb67 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Tue, 29 Jan 2013 14:34:13 +0100 Subject: [PATCH] rename StanzaID to StanzaId cleanups --- examples/EchoClient.hs | 2 +- pontarius-xmpp.cabal | 9 ++- .../Network/Xmpp/Concurrent/Channels/Types.hs | 2 +- source/Network/Xmpp/Concurrent/Types.hs | 2 +- source/Network/Xmpp/Connection.hs | 22 +++++- source/Network/Xmpp/Errors.hs | 4 +- source/Network/Xmpp/IM/Message.hs | 2 +- source/Network/Xmpp/Marshal.hs | 22 +++--- source/Network/Xmpp/Pickle.hs | 53 +++------------ source/Network/Xmpp/Session.hs | 11 +++ source/Network/Xmpp/Stream.hs | 13 +++- source/Network/Xmpp/TLS.hs | 2 +- source/Network/Xmpp/Types.hs | 24 +++---- source/Network/Xmpp/Xep/InbandRegistration.hs | 68 +++++++++++-------- 14 files changed, 127 insertions(+), 109 deletions(-) diff --git a/examples/EchoClient.hs b/examples/EchoClient.hs index 953cc2b..24c04a1 100644 --- a/examples/EchoClient.hs +++ b/examples/EchoClient.hs @@ -26,7 +26,7 @@ import Network.Xmpp.IM -- Server and authentication details. host = "localhost" port = PortNumber 5222 -realm = "server.com" +realm = "species64739.dyndns.org" username = "echo" password = "pwd" resource = Just "bot" diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index c54a7f3..fd823af 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -49,14 +49,15 @@ Library , stm >=2.1.2.1 , xml-types >=0.3.1 , xml-conduit >=1.0 - , xml-picklers >=0.2.2 + , xml-picklers >=0.3 , data-default >=0.2 , stringprep >=0.1.3 Exposed-modules: Network.Xmpp , Network.Xmpp.IM , Network.Xmpp.Basic - Other-modules: - Network.Xmpp.Bind + , Network.Xmpp.Lens +-- Undocumented modules + , Network.Xmpp.Bind , Network.Xmpp.Concurrent , Network.Xmpp.IM.Message , Network.Xmpp.IM.Presence @@ -79,6 +80,8 @@ Library , Network.Xmpp.Jid , Network.Xmpp.Concurrent.Types , Network.Xmpp.Concurrent.Channels.IQ + , Network.Xmpp.Concurrent.Channels + , Network.Xmpp.Concurrent.Channels.Types , Network.Xmpp.Concurrent.Threads , Network.Xmpp.Concurrent.Monad , Text.XML.Stream.Elements diff --git a/source/Network/Xmpp/Concurrent/Channels/Types.hs b/source/Network/Xmpp/Concurrent/Channels/Types.hs index 8de98f1..1be179e 100644 --- a/source/Network/Xmpp/Concurrent/Channels/Types.hs +++ b/source/Network/Xmpp/Concurrent/Channels/Types.hs @@ -21,7 +21,7 @@ data Session = Session -- | IQHandlers holds the registered channels for incomming IQ requests and -- TMVars of and TMVars for expected IQ responses 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 diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs index 962dbd1..e862e11 100644 --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -22,7 +22,7 @@ data EventHandlers = EventHandlers data Context = Context { writeRef :: TMVar (BS.ByteString -> IO Bool) , readerThread :: ThreadId - , idGenerator :: IO StanzaId + , idGenerator :: IO StanzaID -- | Lock (used by withConnection) to make sure that a maximum of one -- XmppConMonad action is executed at any given time. , conRef :: TMVar Connection diff --git a/source/Network/Xmpp/Connection.hs b/source/Network/Xmpp/Connection.hs index 2269d8b..a5244d8 100644 --- a/source/Network/Xmpp/Connection.hs +++ b/source/Network/Xmpp/Connection.hs @@ -147,7 +147,13 @@ connectTcpRaw :: HostName -> PortID -> Text -> IO Connection connectTcpRaw host port hostname = do h <- connectTo host port 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 ()) let hand = Hand { cSend = if debug then \d -> do @@ -157,6 +163,7 @@ connectTcpRaw host port hostname = do , cRecv = if debug then \n -> do bs <- BS.hGetSome h n + Prelude.putStr "in: " BS.putStrLn bs return bs else BS.hGetSome h @@ -178,7 +185,16 @@ connectTcpRaw host port hostname = do , sFrom = Nothing } 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. 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 -- match the outgoing ID, an error is thrown. -pushIQ' :: StanzaId +pushIQ' :: StanzaID -> Maybe Jid -> IQRequestType -> Maybe LangTag diff --git a/source/Network/Xmpp/Errors.hs b/source/Network/Xmpp/Errors.hs index 0172b6d..9dbecb3 100644 --- a/source/Network/Xmpp/Errors.hs +++ b/source/Network/Xmpp/Errors.hs @@ -36,7 +36,7 @@ findStreamErrors (Element name attrs children) -> StreamUnknownError safeRead x = case reads $ Text.unpack x of [] -> Nothing - [(y,_),_] -> Just y + ((y,_):_) -> Just y flattenAttrs :: [(Name, [Content])] -> [(Name, Text.Text)] flattenAttrs attrs = map (\(name, content) -> @@ -46,4 +46,4 @@ flattenAttrs attrs = map (\(name, content) -> attrs where uncontentify (ContentText t) = t - uncontentify _ = "" \ No newline at end of file + uncontentify _ = "" diff --git a/source/Network/Xmpp/IM/Message.hs b/source/Network/Xmpp/IM/Message.hs index fe43744..505a27e 100644 --- a/source/Network/Xmpp/IM/Message.hs +++ b/source/Network/Xmpp/IM/Message.hs @@ -80,7 +80,7 @@ body m = bodyContent <$> listToMaybe (bodies m) -- | Generate a new instant message newIM :: Jid - -> Maybe StanzaId + -> Maybe StanzaID -> Maybe LangTag -> MessageType -> Maybe MessageSubject diff --git a/source/Network/Xmpp/Marshal.hs b/source/Network/Xmpp/Marshal.hs index 4de88c4..6738bb4 100644 --- a/source/Network/Xmpp/Marshal.hs +++ b/source/Network/Xmpp/Marshal.hs @@ -18,7 +18,7 @@ xpStreamStanza :: PU [Node] (Either XmppStreamError Stanza) xpStreamStanza = xpEither xpStreamError xpStanza xpStanza :: PU [Node] Stanza -xpStanza = xpAlt stanzaSel +xpStanza = ("xpStanza" , "") xpAlt stanzaSel [ xpWrap IQRequestS (\(IQRequestS x) -> x) xpIQRequest , xpWrap IQResultS (\(IQResultS x) -> x) xpIQResult , xpWrap IQErrorS (\(IQErrorS x) -> x) xpIQError @@ -39,7 +39,7 @@ xpStanza = xpAlt stanzaSel stanzaSel (PresenceErrorS _) = 6 xpMessage :: PU [Node] (Message) -xpMessage = xpWrap +xpMessage = ("xpMessage" , "") xpWrap (\((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)) (xpElem "{jabber:client}message" @@ -55,7 +55,7 @@ xpMessage = xpWrap ) xpPresence :: PU [Node] Presence -xpPresence = xpWrap +xpPresence = ("xpPresence" , "") xpWrap (\((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)) (xpElem "{jabber:client}presence" @@ -70,7 +70,7 @@ xpPresence = xpWrap ) xpIQRequest :: PU [Node] IQRequest -xpIQRequest = xpWrap +xpIQRequest = ("xpIQRequest" , "") xpWrap (\((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)) (xpElem "{jabber:client}iq" @@ -85,7 +85,7 @@ xpIQRequest = xpWrap ) xpIQResult :: PU [Node] IQResult -xpIQResult = xpWrap +xpIQResult = ("xpIQResult" , "") xpWrap (\((qid, from, to, lang, _tp),body) -> IQResult qid from to lang body) (\(IQResult qid from to lang body) -> ((qid, from, to, lang, ()), body)) (xpElem "{jabber:client}iq" @@ -104,7 +104,7 @@ xpIQResult = xpWrap ---------------------------------------------------------- xpErrorCondition :: PU [Node] StanzaErrorCondition -xpErrorCondition = xpWrap +xpErrorCondition = ("xpErrorCondition" , "") xpWrap (\(cond, (), ()) -> cond) (\cond -> (cond, (), ())) (xpElemByNamespace @@ -115,7 +115,7 @@ xpErrorCondition = xpWrap ) xpStanzaError :: PU [Node] StanzaError -xpStanzaError = xpWrap +xpStanzaError = ("xpStanzaError" , "") xpWrap (\(tp, (cond, txt, ext)) -> StanzaError tp cond txt ext) (\(StanzaError tp cond txt ext) -> (tp, (cond, txt, ext))) (xpElem "{jabber:client}error" @@ -131,7 +131,7 @@ xpStanzaError = xpWrap ) xpMessageError :: PU [Node] (MessageError) -xpMessageError = xpWrap +xpMessageError = ("xpMessageError" , "") xpWrap (\((_, 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 = xpWrap +xpPresenceError = ("xpPresenceError" , "") xpWrap (\((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 = xpWrap +xpIQError = ("xpIQError" , "") xpWrap (\((qid, from, to, lang, _tp),(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 = xpWrap +xpStreamError = ("xpStreamError" , "") xpWrap (\((cond,() ,()), txt, el) -> XmppStreamError cond txt el) (\(XmppStreamError cond txt el) ->((cond,() ,()), txt, el)) (xpElemNodes diff --git a/source/Network/Xmpp/Pickle.hs b/source/Network/Xmpp/Pickle.hs index e00e190..3cda8d3 100644 --- a/source/Network/Xmpp/Pickle.hs +++ b/source/Network/Xmpp/Pickle.hs @@ -8,19 +8,13 @@ module Network.Xmpp.Pickle - ( mbToBool - , xmlLang + ( xmlLang , xpLangTag - , xpNodeElem - , ignoreAttrs - , mbl - , lmb - , right , unpickleElem' , unpickleElem , pickleElem - , ppElement - ) where + ) + where import Data.XML.Types import Data.XML.Pickle @@ -29,50 +23,23 @@ import Network.Xmpp.Types import Text.XML.Stream.Elements -mbToBool :: Maybe t -> Bool -mbToBool (Just _) = True -mbToBool _ = False - xmlLang :: Name xmlLang = Name "lang" (Just "http://www.w3.org/XML/1998/namespace") (Just "xml") xpLangTag :: PU [Attribute] (Maybe LangTag) xpLangTag = xpAttrImplied xmlLang xpPrim -xpNodeElem :: PU [Node] a -> PU Element a -xpNodeElem xp = PU { pickleTree = \x -> head $ (pickleTree xp x) >>= \y -> - case y of - 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 +-- Given a pickler and an element, produces an object. +unpickleElem :: PU [Node] a -> Element -> Either UnpickleError a +unpickleElem p x = unpickle p [NodeElement x] 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 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. pickleElem :: PU [Node] a -> a -> Element -pickleElem p = pickle $ xpNodeElem p \ No newline at end of file +pickleElem p x = case pickle p x of + [NodeElement e] -> e + _ -> error "pickleElem: Pickler didn't return a single element." diff --git a/source/Network/Xmpp/Session.hs b/source/Network/Xmpp/Session.hs index 28be338..cbfda71 100644 --- a/source/Network/Xmpp/Session.hs +++ b/source/Network/Xmpp/Session.hs @@ -87,6 +87,17 @@ connectTcp address port hostname = do XmppStreamError StreamInvalidXml Nothing Nothing toError StreamUnknownError = 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 diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 9af9a5c..35cd848 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -30,6 +30,14 @@ import Text.XML.Stream.Parse as XP -- 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. streamUnpickleElem :: PU [Node] a -> Element @@ -125,6 +133,7 @@ streamS expectedTo = do -- Get the stream:stream element (or whatever it is) from the server, -- and validate what we get. el <- openElementFromEvents + liftIO . print $ unpickleElem xpStream el case unpickleElem xpStream el of Left _ -> throwError $ findStreamErrors el Right r -> validateData r @@ -144,7 +153,7 @@ streamS expectedTo = do 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")) (xp5Tuple (xpAttr "version" xpId) @@ -156,7 +165,7 @@ xpStream = xpElemAttrs -- Pickler/Unpickler for the stream features - TLS, SASL, and the rest. xpStreamFeatures :: PU [Node] ServerFeatures -xpStreamFeatures = xpWrap +xpStreamFeatures = ("xpStreamFeatures", "") xpWrap (\(tls, sasl, rest) -> SF tls (mbl sasl) rest) (\(SF tls sasl rest) -> (tls, lmb sasl, rest)) (xpElemNodes diff --git a/source/Network/Xmpp/TLS.hs b/source/Network/Xmpp/TLS.hs index 13742c7..e9f3225 100644 --- a/source/Network/Xmpp/TLS.hs +++ b/source/Network/Xmpp/TLS.hs @@ -18,7 +18,7 @@ import Data.Typeable import Data.XML.Types import Network.Xmpp.Connection -import Network.Xmpp.Pickle(ppElement) +import Text.XML.Stream.Elements(ppElement) import Network.Xmpp.Stream import Network.Xmpp.Types diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 63e139a..bb2c033 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -27,7 +27,7 @@ module Network.Xmpp.Types , StanzaError(..) , StanzaErrorCondition(..) , StanzaErrorType(..) - , StanzaId(..) + , StanzaID(..) , StreamError(..) , StreamErrorCondition(..) , Version(..) @@ -73,15 +73,15 @@ import System.IO -- Wraps a string of random characters that, when using an appropriate -- @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 -instance Read StanzaId where +instance Read StanzaID where readsPrec _ x = [(SI $ Text.pack x, "")] -instance IsString StanzaId where +instance IsString StanzaID where fromString = SI . Text.pack -- | 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 -- type. It always contains an xml payload. -data IQRequest = IQRequest { iqRequestID :: !StanzaId +data IQRequest = IQRequest { iqRequestID :: !StanzaID , iqRequestFrom :: !(Maybe Jid) , iqRequestTo :: !(Maybe Jid) , iqRequestLangTag :: !(Maybe LangTag) @@ -125,7 +125,7 @@ data IQResponse = IQResponseError IQError deriving Show -- | The (non-error) answer to an IQ request. -data IQResult = IQResult { iqResultID :: !StanzaId +data IQResult = IQResult { iqResultID :: !StanzaID , iqResultFrom :: !(Maybe Jid) , iqResultTo :: !(Maybe Jid) , iqResultLangTag :: !(Maybe LangTag) @@ -133,7 +133,7 @@ data IQResult = IQResult { iqResultID :: !StanzaId } deriving Show -- | The answer to an IQ request that generated an error. -data IQError = IQError { iqErrorID :: !StanzaId +data IQError = IQError { iqErrorID :: !StanzaID , iqErrorFrom :: !(Maybe Jid) , iqErrorTo :: !(Maybe Jid) , iqErrorLangTag :: !(Maybe LangTag) @@ -142,7 +142,7 @@ data IQError = IQError { iqErrorID :: !StanzaId } deriving Show -- | The message stanza. Used for /push/ type communication. -data Message = Message { messageID :: !(Maybe StanzaId) +data Message = Message { messageID :: !(Maybe StanzaID) , messageFrom :: !(Maybe Jid) , messageTo :: !(Maybe Jid) , messageLangTag :: !(Maybe LangTag) @@ -151,7 +151,7 @@ data Message = Message { messageID :: !(Maybe StanzaId) } deriving Show -- | An error stanza generated in response to a 'Message'. -data MessageError = MessageError { messageErrorID :: !(Maybe StanzaId) +data MessageError = MessageError { messageErrorID :: !(Maybe StanzaID) , messageErrorFrom :: !(Maybe Jid) , messageErrorTo :: !(Maybe Jid) , messageErrorLangTag :: !(Maybe LangTag) @@ -211,7 +211,7 @@ instance Read MessageType where readsPrec _ _ = [(Normal, "")] -- | The presence stanza. Used for communicating status updates. -data Presence = Presence { presenceID :: !(Maybe StanzaId) +data Presence = Presence { presenceID :: !(Maybe StanzaID) , presenceFrom :: !(Maybe Jid) , presenceTo :: !(Maybe Jid) , presenceLangTag :: !(Maybe LangTag) @@ -221,7 +221,7 @@ data Presence = Presence { presenceID :: !(Maybe StanzaId) -- | An error stanza generated in response to a 'Presence'. -data PresenceError = PresenceError { presenceErrorID :: !(Maybe StanzaId) +data PresenceError = PresenceError { presenceErrorID :: !(Maybe StanzaID) , presenceErrorFrom :: !(Maybe Jid) , presenceErrorTo :: !(Maybe Jid) , presenceErrorLangTag :: !(Maybe LangTag) diff --git a/source/Network/Xmpp/Xep/InbandRegistration.hs b/source/Network/Xmpp/Xep/InbandRegistration.hs index 7f433ef..4f68b60 100644 --- a/source/Network/Xmpp/Xep/InbandRegistration.hs +++ b/source/Network/Xmpp/Xep/InbandRegistration.hs @@ -22,6 +22,8 @@ import qualified Data.XML.Types as XML import Network.Xmpp.Connection import Network.Xmpp.Pickle import Network.Xmpp.Types +import Network.Xmpp.Basic +import Network.Xmpp import Network.Xmpp.Xep.ServiceDiscovery @@ -34,6 +36,7 @@ ibrName x = (XML.Name x (Just ibrns) Nothing) data IbrError = IbrNotSupported | IbrNoConnection | IbrIQError IQError + | IbrTimeout deriving (Show) instance Error IbrError @@ -47,30 +50,6 @@ data Query = Query { instructions :: Maybe Text.Text 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 queryType x con = do 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 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 | MissingFields [Field] | AlreadyRegistered @@ -95,10 +91,10 @@ instance Error RegisterError mapError f = mapErrorT (liftM $ left f) -- | Retrieve the necessary fields and fill them in to register an account with --- the server +-- the server. registerWith :: [(Field, Text.Text)] -> Connection - -> IO (Either RegisterError Query) + -> IO (Either RegisterError Query) registerWith givenFields con = runErrorT $ do fs <- mapError IbrError . ErrorT $ requestFields con when (registered fs) . throwError $ AlreadyRegistered @@ -112,14 +108,30 @@ registerWith givenFields con = runErrorT $ do result <- mapError IbrError . ErrorT $ query Set (emptyQuery {fields}) con 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 -- work. You connection will most likely be terminated after unregistering. unregister :: Connection -> IO (Either IbrError Query) unregister = query Set $ emptyQuery {remove = True} +unregister' :: Session -> IO (Either IbrError Query) +unregister' = query' Set $ emptyQuery {remove = True} + requestFields con = runErrorT $ do --- supp <- ErrorT supported --- unless supp $ throwError $ IbrNotSupported qr <- ErrorT $ query Get emptyQuery con return $ qr