asakul
/
pontarius-xmpp
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

rename JID to Jid 

remove sUsername, aAuthzid, sResource from XmppConnection
add sJid to XmppConnection
master
Philipp Balzarek 14 years ago
parent
ff4358c3a4
commit
1d54682baa
9 changed files with 64 additions and 70 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 4
      source/Network/Xmpp.hs
  2. 4
      source/Network/Xmpp/Bind.hs
  3. 4
      source/Network/Xmpp/Concurrent/IQ.hs
  4. 6
      source/Network/Xmpp/IM/Presence.hs
  5. 24
      source/Network/Xmpp/Jid.hs
  6. 39
      source/Network/Xmpp/Monad.hs
  7. 2
      source/Network/Xmpp/Presence.hs
  8. 42
      source/Network/Xmpp/Types.hs
  9. 9
      tests/Tests.hs

4
source/Network/Xmpp.hs
Unescape View File

@ -43,7 +43,7 @@ module Network.Xmpp
-- | A JID (historically: Jabber ID) is XMPPs native format -- | A JID (historically: Jabber ID) is XMPPs native format
-- for addressing entities in the network. It is somewhat similar to an e-mail -- for addressing entities in the network. It is somewhat similar to an e-mail
-- address but contains three parts instead of two: -- address but contains three parts instead of two:
, JID(..) , Jid(..)
, isBare , isBare
, isFull , isFull
-- * Stanzas -- * Stanzas
@ -177,7 +177,7 @@ auth :: Text.Text -- ^ The username
-> Text.Text -- ^ The password -> Text.Text -- ^ The password
-> Maybe Text -- ^ The desired resource or 'Nothing' to let the server -> Maybe Text -- ^ The desired resource or 'Nothing' to let the server
-- assign one -- assign one
-> XmppConMonad (Either AuthError JID) -> XmppConMonad (Either AuthError Jid)
auth username passwd resource = runErrorT $ do auth username passwd resource = runErrorT $ do
ErrorT $ xmppSasl [scramSha1 username Nothing passwd] ErrorT $ xmppSasl [scramSha1 username Nothing passwd]
res <- lift $ xmppBind resource res <- lift $ xmppBind resource

4
source/Network/Xmpp/Bind.hs
Unescape View File

@ -24,7 +24,7 @@ bindBody = pickleElem $
-- Sends a (synchronous) IQ set request for a (`Just') given or server-generated -- Sends a (synchronous) IQ set request for a (`Just') given or server-generated
-- resource and extract the JID from the non-error response. -- resource and extract the JID from the non-error response.
xmppBind :: Maybe Text -> XmppConMonad JID xmppBind :: Maybe Text -> XmppConMonad Jid
xmppBind rsrc = do xmppBind rsrc = do
answer <- xmppSendIQ' "bind" Nothing Set Nothing (bindBody rsrc) answer <- xmppSendIQ' "bind" Nothing Set Nothing (bindBody rsrc)
let Right IQResult{iqResultPayload = Just b} = answer -- TODO: Error handling let Right IQResult{iqResultPayload = Just b} = answer -- TODO: Error handling
@ -32,7 +32,7 @@ xmppBind rsrc = do
return jid return jid
where where
-- Extracts the character data in the `jid' element. -- Extracts the character data in the `jid' element.
jidP :: PU [Node] JID jidP :: PU [Node] Jid
jidP = xpBind $ xpElemNodes "jid" (xpContent xpPrim) jidP = xpBind $ xpElemNodes "jid" (xpContent xpPrim)
-- A `bind' element pickler. -- A `bind' element pickler.

4
source/Network/Xmpp/Concurrent/IQ.hs
Unescape View File

@ -13,7 +13,7 @@ import Network.Xmpp.Types
-- | Sends an IQ, returns a 'TMVar' that will be filled with the first inbound -- | Sends an IQ, returns a 'TMVar' that will be filled with the first inbound
-- IQ with a matching ID that has type @result@ or @error@. -- IQ with a matching ID that has type @result@ or @error@.
sendIQ :: Maybe JID -- ^ Recipient (to) sendIQ :: Maybe Jid -- ^ Recipient (to)
-> IQRequestType -- ^ IQ type (@Get@ or @Set@) -> IQRequestType -- ^ IQ type (@Get@ or @Set@)
-> Maybe LangTag -- ^ Language tag of the payload (@Nothing@ for -> Maybe LangTag -- ^ Language tag of the payload (@Nothing@ for
-- default) -- default)
@ -32,7 +32,7 @@ sendIQ to tp lang body = do -- TODO: Add timeout
return ref return ref
-- | Like 'sendIQ', but waits for the answer IQ. -- | Like 'sendIQ', but waits for the answer IQ.
sendIQ' :: Maybe JID sendIQ' :: Maybe Jid
-> IQRequestType -> IQRequestType
-> Maybe LangTag -> Maybe LangTag
-> Element -> Element

6
source/Network/Xmpp/IM/Presence.hs
Unescape View File

@ -14,7 +14,7 @@ presence = Presence { presenceID = Nothing
} }
-- | Request subscription with an entity. -- | Request subscription with an entity.
presenceSubscribe :: JID -> Presence presenceSubscribe :: Jid -> Presence
presenceSubscribe to = presence { presenceTo = Just to presenceSubscribe to = presence { presenceTo = Just to
, presenceType = Just Subscribe , presenceType = Just Subscribe
} }
@ -24,7 +24,7 @@ isPresenceSubscribe :: Presence -> Bool
isPresenceSubscribe pres = presenceType pres == (Just Subscribe) isPresenceSubscribe pres = presenceType pres == (Just Subscribe)
-- | Approve a subscripton of an entity. -- | Approve a subscripton of an entity.
presenceSubscribed :: JID -> Presence presenceSubscribed :: Jid -> Presence
presenceSubscribed to = presence { presenceTo = Just to presenceSubscribed to = presence { presenceTo = Just to
, presenceType = Just Subscribed , presenceType = Just Subscribed
} }
@ -34,7 +34,7 @@ isPresenceSubscribed :: Presence -> Bool
isPresenceSubscribed pres = presenceType pres == (Just Subscribed) isPresenceSubscribed pres = presenceType pres == (Just Subscribed)
-- | End a subscription with an entity. -- | End a subscription with an entity.
presenceUnsubscribe :: JID -> Presence presenceUnsubscribe :: Jid -> Presence
presenceUnsubscribe to = presence { presenceTo = Just to presenceUnsubscribe to = presence { presenceTo = Just to
, presenceType = Just Unsubscribed , presenceType = Just Unsubscribed
} }

24
source/Network/Xmpp/JID.hs → source/Network/Xmpp/Jid.hs
Unescape View File

@ -3,8 +3,8 @@
-- This module deals with JIDs, also known as XMPP addresses. For more -- This module deals with JIDs, also known as XMPP addresses. For more
-- information on JIDs, see RFC 6122: XMPP: Address Format. -- information on JIDs, see RFC 6122: XMPP: Address Format.
module Network.Xmpp.JID module Network.Xmpp.Jid
( JID(..) ( Jid(..)
, fromText , fromText
, fromStrings , fromStrings
, isBare , isBare
@ -23,7 +23,7 @@ import qualified Data.Text as Text
import qualified Text.NamePrep as SP import qualified Text.NamePrep as SP
import qualified Text.StringPrep as SP import qualified Text.StringPrep as SP
data JID = JID { -- | The @localpart@ of a JID is an optional identifier placed data Jid = Jid { -- | The @localpart@ of a JID is an optional identifier placed
-- before the domainpart and separated from the latter by a -- before the domainpart and separated from the latter by a
-- \'\@\' character. Typically a localpart uniquely identifies -- \'\@\' character. Typically a localpart uniquely identifies
-- the entity requesting and using network access provided by a -- the entity requesting and using network access provided by a
@ -56,21 +56,21 @@ data JID = JID { -- | The @localpart@ of a JID is an optional identifier placed
, resourcepart :: !(Maybe Text) , resourcepart :: !(Maybe Text)
} deriving Eq } deriving Eq
instance Show JID where instance Show Jid where
show (JID nd dmn res) = show (Jid nd dmn res) =
maybe "" ((++ "@") . Text.unpack) nd ++ Text.unpack dmn ++ maybe "" ((++ "@") . Text.unpack) nd ++ Text.unpack dmn ++
maybe "" (('/' :) . Text.unpack) res maybe "" (('/' :) . Text.unpack) res
instance Read JID where instance Read Jid where
readsPrec _ x = case fromText (Text.pack x) of readsPrec _ x = case fromText (Text.pack x) of
Nothing -> [] Nothing -> []
Just j -> [(j,"")] Just j -> [(j,"")]
instance IsString JID where instance IsString Jid where
fromString = fromJust . fromText . Text.pack fromString = fromJust . fromText . Text.pack
-- | Converts a Text to a JID. -- | Converts a Text to a JID.
fromText :: Text -> Maybe JID fromText :: Text -> Maybe Jid
fromText t = do fromText t = do
(l, d, r) <- eitherToMaybe $ AP.parseOnly jidParts t (l, d, r) <- eitherToMaybe $ AP.parseOnly jidParts t
fromStrings l d r fromStrings l d r
@ -79,7 +79,7 @@ fromText t = do
-- | Converts localpart, domainpart, and resourcepart strings to a JID. Runs the -- | Converts localpart, domainpart, and resourcepart strings to a JID. Runs the
-- appropriate stringprep profiles and validates the parts. -- appropriate stringprep profiles and validates the parts.
fromStrings :: Maybe Text -> Text -> Maybe Text -> Maybe JID fromStrings :: Maybe Text -> Text -> Maybe Text -> Maybe Jid
fromStrings l d r = do fromStrings l d r = do
localPart <- case l of localPart <- case l of
Nothing -> return Nothing Nothing -> return Nothing
@ -97,7 +97,7 @@ fromStrings l d r = do
r'' <- SP.runStringPrep resourceprepProfile r' r'' <- SP.runStringPrep resourceprepProfile r'
guard $ validPartLength r'' guard $ validPartLength r''
return $ Just r'' return $ Just r''
return $ JID localPart domainPart resourcePart return $ Jid localPart domainPart resourcePart
where where
validDomainPart :: Text -> Bool validDomainPart :: Text -> Bool
validDomainPart _s = True -- TODO validDomainPart _s = True -- TODO
@ -106,12 +106,12 @@ fromStrings l d r = do
validPartLength p = Text.length p > 0 && Text.length p < 1024 validPartLength p = Text.length p > 0 && Text.length p < 1024
-- | Returns True if the JID is /bare/, and False otherwise. -- | Returns True if the JID is /bare/, and False otherwise.
isBare :: JID -> Bool isBare :: Jid -> Bool
isBare j | resourcepart j == Nothing = True isBare j | resourcepart j == Nothing = True
| otherwise = False | otherwise = False
-- | Returns True if the JID is 'full', and False otherwise. -- | Returns True if the JID is 'full', and False otherwise.
isFull :: JID -> Bool isFull :: Jid -> Bool
isFull = not . isBare isFull = not . isBare
-- Parses an JID string and returns its three parts. It performs no validation -- Parses an JID string and returns its three parts. It performs no validation

39
source/Network/Xmpp/Monad.hs
Unescape View File

@ -92,16 +92,14 @@ catchPush p = Ex.catch
-- XmppConnection state used when there is no connection. -- XmppConnection state used when there is no connection.
xmppNoConnection :: XmppConnection xmppNoConnection :: XmppConnection
xmppNoConnection = XmppConnection xmppNoConnection = XmppConnection
{ sConSrc = zeroSource { sConSrc = zeroSource
, sRawSrc = zeroSource , sRawSrc = zeroSource
, sConPushBS = \_ -> return False -- Nothing has been sent. , sConPushBS = \_ -> return False -- Nothing has been sent.
, sConHandle = Nothing , sConHandle = Nothing
, sFeatures = SF Nothing [] [] , sFeatures = SF Nothing [] []
, sConnectionState = XmppConnectionClosed , sConnectionState = XmppConnectionClosed
, sHostname = Nothing , sHostname = Nothing
, sAuthzid = Nothing , sJid = Nothing
, sUsername = Nothing
, sResource = Nothing
, sCloseConnection = return () , sCloseConnection = return ()
} }
where where
@ -119,17 +117,16 @@ xmppRawConnect host hostname = do
let raw = sourceHandle con let raw = sourceHandle con
src <- liftIO . bufferSource $ raw $= XP.parseBytes def src <- liftIO . bufferSource $ raw $= XP.parseBytes def
let st = XmppConnection let st = XmppConnection
src { sConSrc = src
raw , sRawSrc = raw
(catchPush . BS.hPut con) , sConPushBS = (catchPush . BS.hPut con)
(Just con) , sConHandle = (Just con)
(SF Nothing [] []) , sFeatures = (SF Nothing [] [])
XmppConnectionPlain , sConnectionState = XmppConnectionPlain
(Just hostname) , sHostname = (Just hostname)
Nothing , sJid = Nothing
Nothing , sCloseConnection = (hClose con)
Nothing }
(hClose con)
put st put st
-- Execute a XmppConMonad computation. -- Execute a XmppConMonad computation.
@ -146,7 +143,7 @@ xmppKillConnection = 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.
xmppSendIQ' :: StanzaId xmppSendIQ' :: StanzaId
-> Maybe JID -> Maybe Jid
-> IQRequestType -> IQRequestType
-> Maybe LangTag -> Maybe LangTag
-> Element -> Element

2
source/Network/Xmpp/Presence.hs
Unescape View File

@ -6,5 +6,5 @@ import Data.Text(Text)
import Network.Xmpp.Types import Network.Xmpp.Types
-- | Add a recipient to a presence notification. -- | Add a recipient to a presence notification.
presTo :: Presence -> JID -> Presence presTo :: Presence -> Jid -> Presence
presTo pres to = pres{presenceTo = Just to} presTo pres to = pres{presenceTo = Just to}

42
source/Network/Xmpp/Types.hs
Unescape View File

@ -38,7 +38,7 @@ module Network.Xmpp.Types
, XmppT(..) , XmppT(..)
, XmppStreamError(..) , XmppStreamError(..)
, parseLangTag , parseLangTag
, module Network.Xmpp.JID , module Network.Xmpp.Jid
) )
where where
@ -60,7 +60,7 @@ import Data.XML.Types
import qualified Network as N import qualified Network as N
import Network.Xmpp.JID import Network.Xmpp.Jid
import System.IO import System.IO
@ -93,8 +93,8 @@ 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. They are guaranteed to always contain a payload. -- type. They are guaranteed to always contain a 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
, iqRequestType :: IQRequestType , iqRequestType :: IQRequestType
, iqRequestPayload :: Element , iqRequestPayload :: Element
@ -118,16 +118,16 @@ type IQResponse = Either IQError IQResult
-- | 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
, iqResultPayload :: Maybe Element , iqResultPayload :: Maybe Element
} 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
, iqErrorStanzaError :: StanzaError , iqErrorStanzaError :: StanzaError
, iqErrorPayload :: Maybe Element -- should this be []? , iqErrorPayload :: Maybe Element -- should this be []?
@ -135,8 +135,8 @@ data IQError = IQError { iqErrorID :: StanzaId
-- | 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
, messageType :: MessageType , messageType :: MessageType
, messagePayload :: [Element] , messagePayload :: [Element]
@ -144,8 +144,8 @@ data Message = Message { messageID :: Maybe StanzaId
-- | 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
, messageErrorStanzaError :: StanzaError , messageErrorStanzaError :: StanzaError
, messageErrorPayload :: [Element] , messageErrorPayload :: [Element]
@ -204,8 +204,8 @@ instance Read MessageType where
-- | 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
, presenceType :: Maybe PresenceType , presenceType :: Maybe PresenceType
, presencePayload :: [Element] , presencePayload :: [Element]
@ -214,8 +214,8 @@ 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
, presenceErrorStanzaError :: StanzaError , presenceErrorStanzaError :: StanzaError
, presenceErrorPayload :: [Element] , presenceErrorPayload :: [Element]
@ -324,7 +324,7 @@ data StanzaErrorCondition = BadRequest -- ^ Malformed XML.
-- address. -- address.
| InternalServerError | InternalServerError
| ItemNotFound | ItemNotFound
| JIDMalformed | JidMalformed
| NotAcceptable -- ^ Does not meet policy | NotAcceptable -- ^ Does not meet policy
-- criteria. -- criteria.
| NotAllowed -- ^ No entity may perform | NotAllowed -- ^ No entity may perform
@ -357,7 +357,7 @@ instance Show StanzaErrorCondition where
show Gone = "gone" show Gone = "gone"
show InternalServerError = "internal-server-error" show InternalServerError = "internal-server-error"
show ItemNotFound = "item-not-found" show ItemNotFound = "item-not-found"
show JIDMalformed = "jid-malformed" show JidMalformed = "jid-malformed"
show NotAcceptable = "not-acceptable" show NotAcceptable = "not-acceptable"
show NotAllowed = "not-allowed" show NotAllowed = "not-allowed"
show NotAuthorized = "not-authorized" show NotAuthorized = "not-authorized"
@ -381,7 +381,7 @@ instance Read StanzaErrorCondition where
readsPrec _ "gone" = [(Gone , "")] readsPrec _ "gone" = [(Gone , "")]
readsPrec _ "internal-server-error" = [(InternalServerError , "")] readsPrec _ "internal-server-error" = [(InternalServerError , "")]
readsPrec _ "item-not-found" = [(ItemNotFound , "")] readsPrec _ "item-not-found" = [(ItemNotFound , "")]
readsPrec _ "jid-malformed" = [(JIDMalformed , "")] readsPrec _ "jid-malformed" = [(JidMalformed , "")]
readsPrec _ "not-acceptable" = [(NotAcceptable , "")] readsPrec _ "not-acceptable" = [(NotAcceptable , "")]
readsPrec _ "not-allowed" = [(NotAllowed , "")] readsPrec _ "not-allowed" = [(NotAllowed , "")]
readsPrec _ "not-authorized" = [(NotAuthorized , "")] readsPrec _ "not-authorized" = [(NotAuthorized , "")]
@ -654,9 +654,7 @@ data XmppConnection = XmppConnection
, sFeatures :: ServerFeatures , sFeatures :: ServerFeatures
, sConnectionState :: XmppConnectionState , sConnectionState :: XmppConnectionState
, sHostname :: Maybe Text , sHostname :: Maybe Text
, sUsername :: Maybe Text , sJid :: Maybe Jid
, sAuthzid :: Maybe Text
, sResource :: Maybe Text
, sCloseConnection :: IO () , sCloseConnection :: IO ()
-- TODO: add default Language -- TODO: add default Language
} }

9
tests/Tests.hs
Unescape View File

@ -19,13 +19,13 @@ import Network.Xmpp.Pickle
import System.Environment import System.Environment
import Text.XML.Stream.Elements import Text.XML.Stream.Elements
testUser1 :: JID testUser1 :: Jid
testUser1 = read "testuser1@species64739.dyndns.org/bot1" testUser1 = read "testuser1@species64739.dyndns.org/bot1"
testUser2 :: JID testUser2 :: Jid
testUser2 = read "testuser2@species64739.dyndns.org/bot2" testUser2 = read "testuser2@species64739.dyndns.org/bot2"
supervisor :: JID supervisor :: Jid
supervisor = read "uart14@species64739.dyndns.org" supervisor = read "uart14@species64739.dyndns.org"
@ -75,7 +75,7 @@ autoAccept = forever $ do
st <- waitForPresence isPresenceSubscribe st <- waitForPresence isPresenceSubscribe
sendPresence $ presenceSubscribed (fromJust $ presenceFrom st) sendPresence $ presenceSubscribed (fromJust $ presenceFrom st)
simpleMessage :: JID -> Text -> Message simpleMessage :: Jid -> Text -> Message
simpleMessage to txt = message simpleMessage to txt = message
{ messageTo = Just to { messageTo = Just to
, messagePayload = [Element "body" , messagePayload = [Element "body"
@ -161,4 +161,3 @@ run i = do
runMain debugOut (2 + i) runMain debugOut (2 + i)
main = run 0 main = run 0

Write Preview
Loading…
Cancel
Save