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

Merge pull request #2 from Philonous/master 

incremental update
master
Jon Kristensen 14 years ago
parent
0cfad3e2ea cd86478023
commit
970572d436
15 changed files with 184 additions and 142 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. 3
      .gitmodules
  2. 8
      build.sh
  3. 29
      pontarius.cabal
  4. 2
      src/Network/XMPP.hs
  5. 2
      src/Network/XMPP/Bind.hs
  6. 4
      src/Network/XMPP/Concurrent/Monad.hs
  7. 7
      src/Network/XMPP/Concurrent/Threads.hs
  8. 34
      src/Network/XMPP/Monad.hs
  9. 7
      src/Network/XMPP/Pickle.hs
  10. 39
      src/Network/XMPP/SASL.hs
  11. 59
      src/Network/XMPP/Stream.hs
  12. 44
      src/Network/XMPP/TLS.hs
  13. 25
      src/Network/XMPP/Types.hs
  14. 10
      src/Tests.hs
  15. 1
      stringprep-hs

3
.gitmodules vendored
Unescape View File

@ -1,3 +1,6 @@
[submodule "xml-types-pickle"] [submodule "xml-types-pickle"]
path = xml-types-pickle path = xml-types-pickle
url = git@github.com:Philonous/xml-types-pickle.git url = git@github.com:Philonous/xml-types-pickle.git
[submodule "stringprep-hs"]
path = stringprep-hs
url = git@github.com:Philonous/stringprep-hs.git

8
build.sh
Unescape View File

@ -0,0 +1,8 @@
#!/bin/sh
git submodule init
git submodule update
cabal-dev install ./xml-types-pickle
cabal-dev install ./stringprep-hs
cabal-dev install-deps
cabal-dev configure
cabal-dev build

29
pontarius.cabal
Unescape View File

@ -26,6 +26,7 @@ Library
Exposed: True Exposed: True
Build-Depends: base >4 && <5 Build-Depends: base >4 && <5
, conduit -any , conduit -any
, void -any
, resourcet -any , resourcet -any
, containers -any , containers -any
, random -any , random -any
@ -48,20 +49,20 @@ Library
, xml-conduit -any , xml-conduit -any
, xml-types-pickle -any , xml-types-pickle -any
, data-default -any , data-default -any
Exposed-modules: Network.XMPP.Types , stringprep >= 0.1.5
-- Network.XMPP Exposed-modules: Network.XMPP
, Network.XMPP.Types
-- , Network.XMPP.SASL , Network.XMPP.SASL
-- , Network.XMPP.Stream , Network.XMPP.Stream
-- , Network.XMPP.Pickle , Network.XMPP.Pickle
-- , Network.XMPP.Marshal , Network.XMPP.Marshal
-- , Network.XMPP.Monad , Network.XMPP.Monad
-- , Network.XMPP.Concurrent , Network.XMPP.Concurrent
-- , Network.XMPP.TLS , Network.XMPP.TLS
-- , Network.XMPP.Bind , Network.XMPP.Bind
-- , Network.XMPP.Session , Network.XMPP.Session
-- , Text.XML.Stream.Elements , Text.XML.Stream.Elements
-- , Data.Conduit.TLS , Data.Conduit.TLS
GHC-Options: -Wall GHC-Options: -Wall

2
src/Network/XMPP.hs
Unescape View File

@ -58,7 +58,7 @@ import Network.XMPP.Stream
import Network.XMPP.TLS import Network.XMPP.TLS
import Network.XMPP.Types import Network.XMPP.Types
xmppConnect :: HostName -> Text -> XMPPConMonad () xmppConnect :: HostName -> Text -> XMPPConMonad (Either StreamError ())
xmppConnect address hostname = xmppRawConnect address hostname >> xmppStartStream xmppConnect address hostname = xmppRawConnect address hostname >> xmppStartStream
xmppNewSession :: XMPPThread a -> IO (a, XMPPConState) xmppNewSession :: XMPPThread a -> IO (a, XMPPConState)

2
src/Network/XMPP/Bind.hs
Unescape View File

@ -44,5 +44,5 @@ xmppThreadedBind :: Maybe Text -> XMPPThread Text
xmppThreadedBind rsrc = do xmppThreadedBind rsrc = do
answer <- sendIQ' Nothing Set Nothing (bindBody rsrc) answer <- sendIQ' 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
let (JID _n _d (Just r)) = unpickleElem jidP b let Right (JID _n _d (Just r)) = unpickleElem jidP b
return r return r

4
src/Network/XMPP/Concurrent/Monad.hs
Unescape View File

@ -6,8 +6,8 @@ import Control.Concurrent
import Control.Concurrent.STM import Control.Concurrent.STM
import qualified Control.Exception.Lifted as Ex import qualified Control.Exception.Lifted as Ex
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Reader import Control.Monad.Reader
import Control.Monad.Trans.State import Control.Monad.State.Strict
import Data.IORef import Data.IORef
import qualified Data.Map as Map import qualified Data.Map as Map

7
src/Network/XMPP/Concurrent/Threads.hs
Unescape View File

@ -10,10 +10,9 @@ import Control.Concurrent.STM
import qualified Control.Exception.Lifted as Ex import qualified Control.Exception.Lifted as Ex
import Control.Monad import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Class import Control.Monad.Trans
import Control.Monad.Trans.Reader import Control.Monad.Reader
import Control.Monad.Trans.Resource import Control.Monad.State.Strict
import Control.Monad.Trans.State
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.Conduit import Data.Conduit

34
src/Network/XMPP/Monad.hs
Unescape View File

@ -8,7 +8,7 @@ import Control.Monad.IO.Class
import Control.Monad.Trans.Class import Control.Monad.Trans.Class
--import Control.Monad.Trans.Resource --import Control.Monad.Trans.Resource
import Control.Concurrent import Control.Concurrent
import Control.Monad.Trans.State import Control.Monad.State.Strict
import Data.ByteString as BS import Data.ByteString as BS
import Data.Conduit import Data.Conduit
@ -55,7 +55,7 @@ pullE :: XMPPConMonad Element
pullE = pulls elementFromEvents pullE = pulls elementFromEvents
pullPickle :: PU [Node] a -> XMPPConMonad a pullPickle :: PU [Node] a -> XMPPConMonad a
pullPickle p = unpickleElem p <$> pullE pullPickle p = unpickleElem' p <$> pullE
pull :: XMPPConMonad Stanza pull :: XMPPConMonad Stanza
pull = pullPickle stanzaP pull = pullPickle stanzaP
@ -68,7 +68,7 @@ xmppFromHandle :: Handle
-> IO (a, XMPPConState) -> IO (a, XMPPConState)
xmppFromHandle handle hostname username res f = do xmppFromHandle handle hostname username res f = do
liftIO $ hSetBuffering handle NoBuffering liftIO $ hSetBuffering handle NoBuffering
let raw = sourceHandle' handle let raw = sourceHandle handle
let src = raw $= XP.parseBytes def let src = raw $= XP.parseBytes def
let st = XMPPConState let st = XMPPConState
src src
@ -82,32 +82,6 @@ xmppFromHandle handle hostname username res f = do
res res
runStateT f st runStateT f st
-- TODO: Once pullrequest has been merged, switch back to upstream
sourceHandle' :: MonadIO m => Handle -> Source m BS.ByteString
sourceHandle' h =
src
where
src = PipeM pull close
pull = do
bs <- liftIO (BS.hGetSome h 4096)
if BS.null bs
then return $ Done Nothing ()
else return $ HaveOutput src close bs
close = return ()
sinkHandle' :: MonadIO m
=> Handle
-> Sink BS.ByteString m ()
sinkHandle' h =
NeedInput push close
where
push input = PipeM
(liftIO (BS.hPut h input) >> return (NeedInput push close))
(return ())
close = return ()
zeroSource :: Source IO output zeroSource :: Source IO output
zeroSource = sourceState () (\_ -> forever $ threadDelay 10000000) zeroSource = sourceState () (\_ -> forever $ threadDelay 10000000)
@ -131,7 +105,7 @@ xmppRawConnect host hostname = do
con <- connectTo host (PortNumber 5222) con <- connectTo host (PortNumber 5222)
hSetBuffering con NoBuffering hSetBuffering con NoBuffering
return con return con
let raw = sourceHandle' con let raw = sourceHandle con
let src = raw $= XP.parseBytes def let src = raw $= XP.parseBytes def
let st = XMPPConState let st = XMPPConState
src src

7
src/Network/XMPP/Pickle.hs
Unescape View File

@ -52,11 +52,14 @@ right :: Either [Char] t -> t
right (Left l) = error l right (Left l) = error l
right (Right r) = r 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 unpickle (xpNodeElem p) x of
Left l -> error $ l ++ "\n saw: " ++ ppElement x Left l -> error $ l ++ "\n saw: " ++ ppElement x
Right r -> r Right r -> r
unpickleElem :: PU [Node] a -> Element -> Either String a
unpickleElem p x = unpickle (xpNodeElem p) x
pickleElem :: PU [Node] a -> a -> Element pickleElem :: PU [Node] a -> a -> Element
pickleElem p = pickle $ xpNodeElem p pickleElem p = pickle $ xpNodeElem p

39
src/Network/XMPP/SASL.hs
Unescape View File

@ -4,7 +4,7 @@ module Network.XMPP.SASL where
import Control.Applicative import Control.Applicative
import Control.Monad import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.State import Control.Monad.State.Strict
import qualified Crypto.Classes as CC import qualified Crypto.Classes as CC
@ -68,7 +68,8 @@ xmppStartSASL realm username passwd = do
pushN $ saslInitE "DIGEST-MD5" pushN $ saslInitE "DIGEST-MD5"
Right challenge <- B64.decode . Text.encodeUtf8<$> pullPickle challengePickle Right challenge <- B64.decode . Text.encodeUtf8<$> pullPickle challengePickle
let Right pairs = toPairs challenge let Right pairs = toPairs challenge
pushN . saslResponseE =<< createResponse realm username passwd pairs g <- liftIO $ Random.newStdGen
pushN . saslResponseE $ createResponse g realm username passwd pairs
challenge2 <- pullPickle (xpEither failurePickle challengePickle) challenge2 <- pullPickle (xpEither failurePickle challengePickle)
case challenge2 of case challenge2 of
Left x -> error $ show x Left x -> error $ show x
@ -78,23 +79,24 @@ xmppStartSASL realm username passwd = do
xmppRestartStream xmppRestartStream
return () return ()
createResponse :: Text createResponse :: Random.RandomGen g
=> g
-> Text
-> Text -> Text
-> Text -> Text
-> [(BS8.ByteString, BS8.ByteString)] -> [(BS8.ByteString, BS8.ByteString)]
-> XMPPConMonad Text -> Text
createResponse hostname username passwd' pairs = do createResponse g hostname username passwd' pairs = let
let Just qop = L.lookup "qop" pairs Just qop = L.lookup "qop" pairs
let Just nonce = L.lookup "nonce" pairs Just nonce = L.lookup "nonce" pairs
let uname = Text.encodeUtf8 username uname = Text.encodeUtf8 username
let passwd = Text.encodeUtf8 passwd' passwd = Text.encodeUtf8 passwd'
let realm = Text.encodeUtf8 hostname realm = Text.encodeUtf8 hostname
g <- liftIO $ Random.newStdGen cnonce = BS.tail . BS.init .
let cnonce = BS.tail . BS.init .
B64.encode . BS.pack . take 8 $ Random.randoms g B64.encode . BS.pack . take 8 $ Random.randoms g
let nc = "00000001" nc = "00000001"
let digestURI = ("xmpp/" `BS.append` realm) digestURI = ("xmpp/" `BS.append` realm)
let digest = md5Digest digest = md5Digest
uname uname
realm realm
passwd passwd
@ -103,7 +105,7 @@ createResponse hostname username passwd' pairs = do
qop qop
nonce nonce
cnonce cnonce
let response = BS.intercalate"," . map (BS.intercalate "=") $ response = BS.intercalate"," . map (BS.intercalate "=") $
[["username" , quote uname ] [["username" , quote uname ]
,["realm" , quote realm ] ,["realm" , quote realm ]
,["nonce" , quote nonce ] ,["nonce" , quote nonce ]
@ -114,8 +116,9 @@ createResponse hostname username passwd' pairs = do
,["response" , digest ] ,["response" , digest ]
,["charset" , "utf-8" ] ,["charset" , "utf-8" ]
] ]
return . Text.decodeUtf8 $ B64.encode response in Text.decodeUtf8 $ B64.encode response
where quote x = BS.concat ["\"",x,"\""] where
quote x = BS.concat ["\"",x,"\""]
toPairs :: BS.ByteString -> Either String [(BS.ByteString, BS.ByteString)] toPairs :: BS.ByteString -> Either String [(BS.ByteString, BS.ByteString)]
toPairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do toPairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do

59
src/Network/XMPP/Stream.hs
Unescape View File

@ -4,14 +4,17 @@
module Network.XMPP.Stream where module Network.XMPP.Stream where
import Control.Applicative((<$>)) import Control.Applicative((<$>))
import Control.Exception(throwIO)
import Control.Monad(unless) import Control.Monad(unless)
import Control.Monad.Trans.State import Control.Monad.Error
import Control.Monad.State.Strict
import Data.Conduit import Data.Conduit
import Data.Conduit.List as CL import Data.Conduit.List as CL
import Data.Text as T import Data.Text as T
import Data.XML.Pickle import Data.XML.Pickle
import Data.XML.Types import Data.XML.Types
import Data.Void(Void)
import Network.XMPP.Monad import Network.XMPP.Monad
import Network.XMPP.Pickle import Network.XMPP.Pickle
@ -22,6 +25,16 @@ import Text.XML.Stream.Parse as XP
-- import Text.XML.Stream.Elements -- import Text.XML.Stream.Elements
streamUnpickleElem :: PU [Node] a
-> Element
-> ErrorT StreamError (Pipe Event Void IO) a
streamUnpickleElem p x = do
case unpickleElem p x of
Left l -> throwError $ StreamUnpickleError l
Right r -> return r
type StreamSink a = ErrorT StreamError (Pipe Event Void IO) a
throwOutJunk :: Monad m => Sink Event m () throwOutJunk :: Monad m => Sink Event m ()
throwOutJunk = do throwOutJunk = do
next <- CL.peek next <- CL.peek
@ -30,22 +43,26 @@ throwOutJunk = do
Just (EventBeginElement _ _) -> return () Just (EventBeginElement _ _) -> return ()
_ -> CL.drop 1 >> throwOutJunk _ -> CL.drop 1 >> throwOutJunk
openElementFromEvents :: Monad m => Sink Event m Element openElementFromEvents :: StreamSink Element
openElementFromEvents = do openElementFromEvents = do
throwOutJunk lift throwOutJunk
Just (EventBeginElement name attrs) <- CL.head hd <- lift CL.head
return $ Element name attrs [] case hd of
Just (EventBeginElement name attrs) -> return $ Element name attrs []
_ -> throwError $ StreamConnectionError
xmppStartStream :: XMPPConMonad ()
xmppStartStream = do xmppStartStream :: XMPPConMonad (Either StreamError ())
hostname <- gets sHostname xmppStartStream = runErrorT $ do
pushOpen $ pickleElem pickleStream ("1.0",Nothing, hostname) hostname' <- gets sHostname
features <- pulls xmppStream case hostname' of
Nothing -> throwError StreamConnectionError
Just hostname -> lift . pushOpen $
pickleElem pickleStream ("1.0",Nothing, Just hostname)
features <- ErrorT . pulls $ runErrorT xmppStream
modify (\s -> s {sFeatures = features}) modify (\s -> s {sFeatures = features})
return () return ()
xmppRestartStream :: XMPPConMonad () xmppRestartStream :: XMPPConMonad (Either StreamError ())
xmppRestartStream = do xmppRestartStream = do
raw <- gets sRawSrc raw <- gets sRawSrc
let newsrc = raw $= XP.parseBytes def let newsrc = raw $= XP.parseBytes def
@ -53,22 +70,22 @@ xmppRestartStream = do
xmppStartStream xmppStartStream
xmppStream :: Sink Event IO ServerFeatures xmppStream :: StreamSink ServerFeatures
xmppStream = do xmppStream = do
xmppStreamHeader xmppStreamHeader
xmppStreamFeatures xmppStreamFeatures
xmppStreamHeader :: Sink Event IO () xmppStreamHeader :: StreamSink ()
xmppStreamHeader = do xmppStreamHeader = do
throwOutJunk lift $ throwOutJunk
(ver, _, _) <- unpickleElem pickleStream <$> openElementFromEvents (ver, _, _) <- streamUnpickleElem pickleStream =<< openElementFromEvents
unless (ver == "1.0") $ error "Not XMPP version 1.0 " unless (ver == "1.0") . throwError $ StreamWrongVersion ver
return() return()
xmppStreamFeatures :: Sink Event IO ServerFeatures xmppStreamFeatures :: StreamSink ServerFeatures
xmppStreamFeatures = unpickleElem pickleStreamFeatures <$> elementFromEvents xmppStreamFeatures = streamUnpickleElem pickleStreamFeatures
=<< lift elementFromEvents
-- Pickling -- Pickling

44
src/Network/XMPP/TLS.hs
Unescape View File

@ -1,15 +1,21 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Network.XMPP.TLS where module Network.XMPP.TLS where
import Control.Applicative((<$>))
import Control.Arrow(left)
import qualified Control.Exception.Lifted as Ex
import Control.Monad import Control.Monad
import Control.Monad.Trans.Class import Control.Monad.Error
import Control.Monad.Trans.State import Control.Monad.State.Strict
import Control.Monad.Trans
import Data.Conduit import Data.Conduit
import Data.Conduit.List as CL import Data.Conduit.List as CL
import Data.Conduit.TLS as TLS import Data.Conduit.TLS as TLS
import Data.Default import Data.Default
import Data.Typeable
import Data.XML.Types import Data.XML.Types
import qualified Network.TLS as TLS import qualified Network.TLS as TLS
@ -39,21 +45,37 @@ exampleParams = TLS.defaultParams
return TLS.CertificateUsageAccept return TLS.CertificateUsageAccept
} }
xmppStartTLS :: TLS.TLSParams -> XMPPConMonad () data XMPPTLSError = TLSError TLSError
xmppStartTLS params = do | TLSNoServerSupport
features <- gets sFeatures | TLSNoConnection
unless (stls features == Nothing) $ do | TLSStreamError StreamError
pushN starttlsE deriving (Show, Eq, Typeable)
Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] <- pullE
Just handle <- gets sConHandle instance Error XMPPTLSError where
noMsg = TLSNoConnection -- TODO: What should we choose here?
instance Ex.Exception XMPPTLSError
xmppStartTLS :: TLS.TLSParams -> XMPPConMonad (Either XMPPTLSError ())
xmppStartTLS params = Ex.handle (return . Left . TLSError)
. runErrorT $ do
features <- lift $ gets sFeatures
handle' <- lift $ gets sConHandle
handle <- maybe (throwError TLSNoConnection) return handle'
when (stls features == Nothing) $ throwError TLSNoServerSupport
lift $ pushN starttlsE
answer <- lift $ pullE
case answer of
Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] -> return ()
_ -> throwError $ TLSStreamError StreamXMLError
(raw, snk, psh) <- lift $ TLS.tlsinit params handle (raw, snk, psh) <- lift $ TLS.tlsinit params handle
modify (\x -> x lift $ modify (\x -> x
{ sRawSrc = raw { sRawSrc = raw
-- , sConSrc = -- Note: this momentarily leaves us in an -- , sConSrc = -- Note: this momentarily leaves us in an
-- inconsistent state -- inconsistent state
, sConPushBS = psh , sConPushBS = psh
}) })
xmppRestartStream ErrorT $ (left TLSStreamError) <$> xmppRestartStream
modify (\s -> s{sHaveTLS = True}) modify (\s -> s{sHaveTLS = True})
return () return ()

25
src/Network/XMPP/Types.hs
Unescape View File

@ -1,3 +1,4 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
-- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the -- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the
-- Pontarius distribution for more details. -- Pontarius distribution for more details.
@ -15,8 +16,11 @@ module Network.XMPP.Types where
-- import Network.XMPP.Utilities (idGenerator) -- import Network.XMPP.Utilities (idGenerator)
import Control.Applicative((<$>)) import Control.Applicative((<$>))
import Control.Exception
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.State import Control.Monad.State.Strict
import Control.Monad.Error
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.Conduit import Data.Conduit
@ -24,6 +28,7 @@ import Data.List.Split as L
import Data.String(IsString(..)) import Data.String(IsString(..))
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.Typeable(Typeable)
import Data.XML.Types import Data.XML.Types
import qualified Network as N import qualified Network as N
@ -58,7 +63,7 @@ data SessionSettings =
-- @IDGenerator@, is guaranteed to be unique for the XMPP session. -- @IDGenerator@, is guaranteed to be unique for the XMPP session.
-- Stanza identifiers are generated by Pontarius. -- Stanza identifiers are generated by Pontarius.
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
@ -73,11 +78,11 @@ instance IsString StanzaId where
-- @From@ is a readability type synonym for @Address@. -- @From@ is a readability type synonym for @Address@.
-- | Jabber ID (JID) datatype -- | Jabber ID (JID) datatype
data JID = JID { node :: Maybe Text data JID = JID { localpart :: !(Maybe Text)
-- ^ Account name -- ^ Account name
, domain :: Text , domainpart :: !Text
-- ^ Server adress -- ^ Server adress
, resource :: Maybe Text , resourcepart :: !(Maybe Text)
-- ^ Resource name -- ^ Resource name
} }
@ -533,8 +538,14 @@ data ServerAddress = ServerAddress N.HostName N.PortNumber deriving (Eq)
type Timeout = Int type Timeout = Int
data StreamError = StreamError data StreamError = StreamError String
| StreamWrongVersion Text
| StreamXMLError
| StreamUnpickleError String
| StreamConnectionError
deriving (Show, Eq, Typeable)
instance Exception StreamError
instance Error StreamError where strMsg = StreamError
-- ============================================================================= -- =============================================================================
-- XML TYPES -- XML TYPES

10
src/Tests.hs
Unescape View File

@ -54,7 +54,7 @@ iqResponder = do
>> error "hanging up" >> error "hanging up"
forever $ do forever $ do
next@(iq,_) <- liftIO . atomically $ readTChan chan next@(iq,_) <- liftIO . atomically $ readTChan chan
let payload = unpickleElem payloadP $ iqRequestPayload iq let Right payload = unpickleElem payloadP $ iqRequestPayload iq
let answerPayload = invertPayload payload let answerPayload = invertPayload payload
let answerBody = pickleElem payloadP answerPayload let answerBody = pickleElem payloadP answerPayload
answerIQ next (Right $ Just answerBody) answerIQ next (Right $ Just answerBody)
@ -89,11 +89,11 @@ runMain debug number = do
withConnection $ do withConnection $ do
xmppConnect "localhost" "species64739.dyndns.org" xmppConnect "localhost" "species64739.dyndns.org"
xmppStartTLS exampleParams xmppStartTLS exampleParams
saslResponse <- xmppSASL (fromJust $ node we) "pwd" saslResponse <- xmppSASL (fromJust $ localpart we) "pwd"
case saslResponse of case saslResponse of
Right _ -> return () Right _ -> return ()
Left e -> error e Left e -> error e
xmppThreadedBind (resource we) xmppThreadedBind (resourcepart we)
withConnection $ xmppSession withConnection $ xmppSession
debug' "session standing" debug' "session standing"
sendPresence presenceOnline sendPresence presenceOnline
@ -101,11 +101,11 @@ runMain debug number = do
forkXMPP iqResponder forkXMPP iqResponder
when active . void . forkXMPP $ do when active . void . forkXMPP $ do
forM [1..10] $ \count -> do forM [1..10] $ \count -> do
let message = Text.pack . show $ node we let message = Text.pack . show $ localpart we
let payload = Payload count (even count) (Text.pack $ show count) let payload = Payload count (even count) (Text.pack $ show count)
let body = pickleElem payloadP payload let body = pickleElem payloadP payload
Right answer <- sendIQ' (Just them) Get Nothing body Right answer <- sendIQ' (Just them) Get Nothing body
let answerPayload = unpickleElem payloadP let Right answerPayload = unpickleElem payloadP
(fromJust $ iqResultPayload answer) (fromJust $ iqResultPayload answer)
expect debug' (invertPayload payload) answerPayload expect debug' (invertPayload payload) answerPayload
liftIO $ threadDelay 100000 liftIO $ threadDelay 100000

1
stringprep-hs

@ -0,0 +1 @@
Subproject commit 7a6ca463b5e6d6636abf266bc9a782ede4e76b06
Write Preview
Loading…
Cancel
Save