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

bind

master
Philipp Balzarek 14 years ago
parent
0651bcd18f
commit
cebc468852
7 changed files with 129 additions and 56 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. 18
      src/Network/TLSConduit.hs
  2. 30
      src/Network/XMPP/Bind.hs
  3. 58
      src/Network/XMPP/Marshal.hs
  4. 40
      src/Network/XMPP/Monad.hs
  5. 14
      src/Network/XMPP/SASL.hs
  6. 14
      src/Network/XMPP/TLS.hs
  7. 11
      src/Network/XMPPConduit.hs

18
src/Network/TLSConduit.hs
Unescape View File

@ -10,7 +10,7 @@ import Control.Monad.Trans
import Crypto.Random import Crypto.Random
import Data.ByteString import Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import Data.Conduit import Data.Conduit
@ -20,6 +20,8 @@ import Network.TLS.Extra as TLSExtra
import System.IO(Handle) import System.IO(Handle)
import System.Random import System.Random
import System.IO
tlsinit tlsinit
:: (MonadIO m, ResourceIO m1) => :: (MonadIO m, ResourceIO m1) =>
TLSParams -> Handle TLSParams -> Handle
@ -37,4 +39,16 @@ tlsinit tlsParams handle = do
(\_ -> return ()) (\_ -> return ())
(\ctx dt -> sendData ctx (BL.fromChunks [dt]) >> return IOProcessing) (\ctx dt -> sendData ctx (BL.fromChunks [dt]) >> return IOProcessing)
(\_ -> return ()) (\_ -> return ())
return (src, snk) return (src $= conduitStdout , snk)
-- TODO: remove
conduitStdout :: ResourceIO m
=> Conduit BS.ByteString m BS.ByteString
conduitStdout = conduitIO
(return ())
(\_ -> return ())
(\_ bs -> do
liftIO $ BS.hPut stdout bs
return $ IOProducing [bs])
(const $ return [])

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

@ -0,0 +1,30 @@
module Network.XMPP.Bind where
import Control.Monad.Trans.State
import Data.Text as Text
import Data.XML.Types
import Network.XMPP.Monad
import Network.XMPP.Types
import Network.XMPP.Marshal
bindSt resource= SIQ $ IQ Nothing Nothing "bind" Set
(Element "{urn:ietf:params:xml:ns:xmpp-bind}bind"
[]
(maybe [] (return . textToNode) resource))
xmppBind = do
res <- gets sResource
push $ bindSt res
SIQ (IQ Nothing Nothing _ Result r) <- pull
(JID n d (Just r)) <- case r of
Element "{urn:ietf:params:xml:ns:xmpp-bind}bind" []
[NodeElement
jid@(Element "{urn:ietf:params:xml:ns:xmpp-bind}jid" [] _)] ->
return . fromText . Text.concat . elementText $ jid
_ -> error $ "bind failed:" ++ show r
modify (\s -> s{sResource = Just r})

58
src/Network/XMPP/Marshal.hs
Unescape View File

@ -13,6 +13,18 @@ import Data.XML.Types
import Network.XMPP.Types import Network.XMPP.Types
stanzaToElement (SMessage m) = messageToElement m
stanzaToElement (SPresence m) = presenceToElement m
stanzaToElement (SIQ m) = iqToElement m
elementToStanza e@(Element (Name n ns Nothing) _ _) =
if (ns `elem` [Nothing, Just "jabber:client"]) then
case n of
"message" -> SMessage $ elementToMessage e
"presence" -> SPresence $ elementToPresence e
"iq" -> SIQ $ elementToIQ e
s -> error $ "unknown stanza type :" ++ show e
else error $ "unknown namespace: " ++ show ns
-- create attribute from Just -- create attribute from Just
matr _ Nothing = [] matr _ Nothing = []
@ -54,23 +66,23 @@ elementToMessage e@(Element "message" _ _) =
-- Oh dear, this is HORRIBLE. TODO: come up with something sane -- Oh dear, this is HORRIBLE. TODO: come up with something sane
in grabFrom (elementChildren e) $ do in grabFrom (elementChildren e) $ do
-- TODO multiple bodies (different languages) -- TODO multiple bodies (different languages)
body <- maybeGrabNamed "body" body <- maybeGrabNamed "body"
-- TODO multiple subjects (different languages) -- TODO multiple subjects (different languages)
subject <- maybeGrabNamed "subject" subject <- maybeGrabNamed "subject"
thread <- maybeGrabNamed "thread" thread <- maybeGrabNamed "thread"
ext <- grabRest ext <- grabRest
return $ Message return $ Message
from from
to to
ident ident
tp tp
(elementToText <$>subject) (elementToText <$>subject)
(elementToText <$> body) (elementToText <$> body)
(elementToText <$> thread) (elementToText <$> thread)
ext ext
presenceTOXML (Presence from to id tp stp stat pri exts) = presenceToElement (Presence from to id tp stp stat pri exts) =
Element "message" Element "presence"
(map contentify . concat $ (map contentify . concat $
[ matr "from" (toText <$> from) [ matr "from" (toText <$> from)
, matr "to" (toText <$> to) , matr "to" (toText <$> to)
@ -85,7 +97,7 @@ presenceTOXML (Presence from to id tp stp stat pri exts) =
]) ])
-- Marshal XML element to message -- Marshal XML element to message
elementToPresence e@(Element "message" _ _) = elementToPresence e@(Element (Name "message" _ _) _ _) =
let from = fromText <$> attributeText "from" e let from = fromText <$> attributeText "from" e
to = fromText <$> attributeText "to" e to = fromText <$> attributeText "to" e
ident = attributeText "id" e ident = attributeText "id" e
@ -108,7 +120,7 @@ elementToPresence e@(Element "message" _ _) =
iqToElement (IQ from to id tp body) = iqToElement (IQ from to id tp body) =
Element "message" Element "iq"
(map contentify . concat $ (map contentify . concat $
[ matr "from" (toText <$> from) [ matr "from" (toText <$> from)
, matr "to" (toText <$> to ) , matr "to" (toText <$> to )
@ -117,7 +129,7 @@ iqToElement (IQ from to id tp body) =
]) ])
[ NodeElement body ] [ NodeElement body ]
elementToIQ e@(Element "iq" _ _) = elementToIQ e@(Element (Name "iq" _ _) _ _ ) =
let from = fromText <$> attributeText "from" e let from = fromText <$> attributeText "from" e
to = fromText <$> attributeText "to" e to = fromText <$> attributeText "to" e
Just ident= attributeText "id" e Just ident= attributeText "id" e
@ -143,7 +155,7 @@ takeAllFromList pred l = let (l', xs) = go pred [] l in (reverse l', xs)
-- elements from a "pool" (list) -- elements from a "pool" (list)
-- Put a list of elements into the pool and start grabbing -- Put a list of elements into the pool and start grabbing
grabFrom l = flip runState l grabFrom l = fst . flip runState l
-- grab all elements matching predicate out of the pool -- grab all elements matching predicate out of the pool
grabAll p = do grabAll p = do
@ -167,4 +179,6 @@ grabRest = do
hasName x e = x == elementName e hasName x e = x == elementName e
elementToText = Text.concat . elementText elementToText = Text.concat . elementText
textToNode t = NodeContent (ContentText t)

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

@ -1,5 +1,7 @@
module Network.XMPP.Monad where module Network.XMPP.Monad where
import Control.Applicative((<$>))
import Control.Monad.Trans import Control.Monad.Trans
import Control.Monad.Trans.State import Control.Monad.Trans.State
@ -12,6 +14,9 @@ import Data.XML.Types
import Data.Default import Data.Default
import Data.Text import Data.Text
import Network.XMPP.Types
import Network.XMPP.Marshal
import System.IO import System.IO
import Text.XML.Stream.Elements import Text.XML.Stream.Elements
@ -21,14 +26,14 @@ import Text.XML.Stream.Parse
type XMPPMonad a = StateT XMPPState (ResourceT IO) a type XMPPMonad a = StateT XMPPState (ResourceT IO) a
data XMPPState = XMPPState data XMPPState = XMPPState
{ conSrc :: BufferedSource IO Event { sConSrc :: BufferedSource IO Event
, conSink :: Sink Event IO () , sConSink :: Sink Event IO ()
, conHandle :: Maybe Handle , sConHandle :: Maybe Handle
, sFeatures :: ServerFeatures , sFeatures :: ServerFeatures
, haveTLS :: Bool , sHaveTLS :: Bool
, sHostname :: Text , sHostname :: Text
, username :: Text , sUsername :: Text
, resource :: Text , sResource :: Maybe Text
} }
data ServerFeatures = SF data ServerFeatures = SF
@ -46,27 +51,34 @@ instance Default ServerFeatures where
, other = [] , other = []
} }
push :: Element -> XMPPMonad ()
push x = do pushE :: Element -> XMPPMonad ()
sink <- gets conSink pushE x = do
sink <- gets sConSink
lift $ CL.sourceList (elementToEvents x) $$ sink lift $ CL.sourceList (elementToEvents x) $$ sink
push :: Stanza -> XMPPMonad ()
push = pushE . stanzaToElement
pushOpen :: Element -> XMPPMonad () pushOpen :: Element -> XMPPMonad ()
pushOpen x = do pushOpen x = do
sink <- gets conSink sink <- gets sConSink
lift $ CL.sourceList (elementToEvents' x) $$ sink lift $ CL.sourceList (elementToEvents' x) $$ sink
pulls :: Sink Event IO a -> XMPPMonad a pulls :: Sink Event IO a -> XMPPMonad a
pulls snk = do pulls snk = do
source <- gets conSrc source <- gets sConSrc
lift $ source $$ snk lift $ source $$ snk
pull :: XMPPMonad Element pullE :: XMPPMonad Element
pull = do pullE = do
source <- gets conSrc source <- gets sConSrc
pulls elementFromEvents pulls elementFromEvents
pull :: XMPPMonad Stanza
pull = elementToStanza <$> pullE
xmppFromHandle handle hostname username resource f = runResourceT $ do xmppFromHandle handle hostname username resource f = runResourceT $ do
liftIO $ hSetBuffering handle NoBuffering liftIO $ hSetBuffering handle NoBuffering
src <- bufferSource $ CB.sourceHandle handle $= CT.decode CT.utf8 $= parseText def src <- bufferSource $ CB.sourceHandle handle $= CT.decode CT.utf8 $= parseText def

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

@ -48,24 +48,24 @@ saslResponse2E =
xmppSASL passwd = do xmppSASL passwd = do
mechanisms <- gets $ saslMechanisms . sFeatures mechanisms <- gets $ saslMechanisms . sFeatures
unless ("DIGEST-MD5" `elem` mechanisms) $ error "No usable auth mechanism" unless ("DIGEST-MD5" `elem` mechanisms) $ error "No usable auth mechanism"
push $ saslInitE "DIGEST-MD5" pushE $ saslInitE "DIGEST-MD5"
Element "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" [] Element "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" []
[NodeContent (ContentText content)] <- pull [NodeContent (ContentText content)] <- pullE
let (Right challenge) = B64.decode . Text.encodeUtf8 $ content let (Right challenge) = B64.decode . Text.encodeUtf8 $ content
let Right pairs = toPairs challenge let Right pairs = toPairs challenge
push . saslResponseE =<< createResponse passwd pairs pushE . saslResponseE =<< createResponse passwd pairs
Element name attrs content <- pull Element name attrs content <- pullE
when (name == "{urn:ietf:params:xml:ns:xmpp-sasl}failure") $ when (name == "{urn:ietf:params:xml:ns:xmpp-sasl}failure") $
(error $ show content) (error $ show content)
push saslResponse2E pushE saslResponse2E
Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] <- pull Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] <- pullE
xmppStartStream xmppStartStream
return () return ()
createResponse passwd' pairs = do createResponse passwd' pairs = do
let Just qop = L.lookup "qop" pairs let Just qop = L.lookup "qop" pairs
let Just nonce = L.lookup "nonce" pairs let Just nonce = L.lookup "nonce" pairs
uname <- Text.encodeUtf8 <$> gets username uname <- Text.encodeUtf8 <$> gets sUsername
let passwd = Text.encodeUtf8 passwd' let passwd = Text.encodeUtf8 passwd'
realm <- Text.encodeUtf8 <$> gets sHostname realm <- Text.encodeUtf8 <$> gets sHostname
g <- liftIO $ Random.newStdGen g <- liftIO $ Random.newStdGen

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

@ -29,16 +29,16 @@ exampleParams = TLS.defaultParams {TLS.pCiphers = TLS.ciphersuite_strong}
xmppStartTLS params = do xmppStartTLS params = do
features <- gets sFeatures features <- gets sFeatures
when (stls features) $ do when (stls features) $ do
push starttlsE pushE starttlsE
Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] <- pull Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] <- pullE
Just handle <- gets conHandle Just handle <- gets sConHandle
(src', snk) <- lift $ TLS.tlsinit params handle (src', snk) <- lift $ TLS.tlsinit params handle
src <- lift . bufferSource $ src' $= CT.decode CT.utf8 $= parseText def src <- lift . bufferSource $ src' $= CT.decode CT.utf8 $= parseText def
modify (\x -> x modify (\x -> x
{ conSrc = src { sConSrc = src
, conSink = XR.renderBytes def =$ snk , sConSink = XR.renderBytes def =$ snk
}) })
xmppStartStream xmppStartStream
modify (\s -> s{haveTLS = True}) modify (\s -> s{sHaveTLS = True})
gets haveTLS gets sHaveTLS

11
src/Network/XMPPConduit.hs
Unescape View File

@ -13,27 +13,30 @@ import Network.XMPP.Monad
import Network.XMPP.TLS import Network.XMPP.TLS
import Network.XMPP.Stream import Network.XMPP.Stream
import Network.XMPP.SASL import Network.XMPP.SASL
import Network.XMPP.Bind
import System.IO import System.IO
fromHandle :: Handle -> Text -> Text -> Text -> IO ((), XMPPState) fromHandle :: Handle -> Text -> Text -> Text -> IO ((), XMPPState)
fromHandle handle hostname username password = fromHandle handle hostname username password =
xmppFromHandle handle hostname username "" $ do xmppFromHandle handle hostname username Nothing $ do
xmppStartStream xmppStartStream
-- this will check whether the server supports tls -- this will check whether the server supports tls
-- on it's own -- on it's own
xmppStartTLS exampleParams xmppStartTLS exampleParams
xmppSASL password xmppSASL password
gets haveTLS >>= liftIO . print xmppBind
forever $ pull >>= liftIO . print gets sResource >>= liftIO . print
gets sHaveTLS >>= liftIO . print
forever $ pullE >>= liftIO . print
return () return ()
main = do main = do
con <- connectTo "localhost" (PortNumber 5222) con <- connectTo "localhost" (PortNumber 5222)
hSetBuffering con NoBuffering hSetBuffering con NoBuffering
(fs,st) <- fromHandle con "species64739.dyndns.org" "bot" "pwd" (fs,st) <- fromHandle con "species64739.dyndns.org" "bot" "pwd"
print $ haveTLS st print $ sHaveTLS st
putStrLn "" putStrLn ""
hGetContents con >>= putStrLn hGetContents con >>= putStrLn

Write Preview
Loading…
Cancel
Save