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 @@ -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"

9
pontarius-xmpp.cabal

@ -49,14 +49,15 @@ Library @@ -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 @@ -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

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

@ -21,7 +21,7 @@ data Session = Session @@ -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

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

@ -22,7 +22,7 @@ data EventHandlers = EventHandlers @@ -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

22
source/Network/Xmpp/Connection.hs

@ -147,7 +147,13 @@ connectTcpRaw :: HostName -> PortID -> Text -> IO Connection @@ -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 @@ -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 @@ -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 @@ -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

2
source/Network/Xmpp/Errors.hs

@ -36,7 +36,7 @@ findStreamErrors (Element name attrs children) @@ -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) ->

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

@ -80,7 +80,7 @@ body m = bodyContent <$> listToMaybe (bodies m) @@ -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

22
source/Network/Xmpp/Marshal.hs

@ -18,7 +18,7 @@ xpStreamStanza :: PU [Node] (Either XmppStreamError Stanza) @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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

53
source/Network/Xmpp/Pickle.hs

@ -8,19 +8,13 @@ @@ -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 @@ -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
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 @@ -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

13
source/Network/Xmpp/Stream.hs

@ -30,6 +30,14 @@ import Text.XML.Stream.Parse as XP @@ -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 @@ -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 @@ -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 @@ -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

2
source/Network/Xmpp/TLS.hs

@ -18,7 +18,7 @@ import Data.Typeable @@ -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

24
source/Network/Xmpp/Types.hs

@ -27,7 +27,7 @@ module Network.Xmpp.Types @@ -27,7 +27,7 @@ module Network.Xmpp.Types
, StanzaError(..)
, StanzaErrorCondition(..)
, StanzaErrorType(..)
, StanzaId(..)
, StanzaID(..)
, StreamError(..)
, StreamErrorCondition(..)
, Version(..)
@ -73,15 +73,15 @@ import System.IO @@ -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 @@ -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 @@ -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 @@ -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 @@ -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) @@ -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 @@ -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) @@ -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)

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

@ -22,6 +22,8 @@ import qualified Data.XML.Types as XML @@ -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) @@ -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 @@ -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 @@ -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,7 +91,7 @@ instance Error RegisterError @@ -95,7 +91,7 @@ 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)
@ -112,14 +108,30 @@ registerWith givenFields con = runErrorT $ do @@ -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

Loading…
Cancel
Save