bind

src/Network/TLSConduit.hs

@@ -10,7 +10,7 @@ import Control.Monad.Trans
 
 import Crypto.Random
 
-import Data.ByteString
+import Data.ByteString as BS
 import qualified Data.ByteString.Lazy as BL
 import Data.Conduit
 
@@ -20,6 +20,8 @@ import Network.TLS.Extra as TLSExtra
 import System.IO(Handle)
 import System.Random
 
+import System.IO
+
 tlsinit
   :: (MonadIO m, ResourceIO m1) =>
      TLSParams -> Handle
@@ -37,4 +39,16 @@ tlsinit tlsParams handle = do
                 (\_ -> return ())
                 (\ctx dt -> sendData ctx (BL.fromChunks [dt]) >> return IOProcessing)
                 (\_ -> 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 [])

src/Network/XMPP/Bind.hs

@@ -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})
+
+

src/Network/XMPP/Marshal.hs

@@ -13,6 +13,18 @@ import Data.XML.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
 matr _ Nothing = []
@@ -54,23 +66,23 @@ elementToMessage e@(Element "message" _ _) =
       -- Oh dear, this is HORRIBLE. TODO: come up with something sane
       in grabFrom (elementChildren e) $ do
         -- TODO multiple bodies (different languages)
-        body <- maybeGrabNamed "body"
-        -- TODO multiple subjects (different languages)
-        subject <-  maybeGrabNamed "subject"
-        thread <- maybeGrabNamed "thread"
-        ext <- grabRest
-        return $ Message
-                   from
-                   to
-                   ident
-                   tp
-                   (elementToText <$>subject)
-                   (elementToText <$> body)
-                   (elementToText <$> thread)
-                   ext
-
-presenceTOXML (Presence from to id tp stp stat pri exts) =
-  Element "message"
+          body <- maybeGrabNamed "body"
+          -- TODO multiple subjects (different languages)
+          subject <-  maybeGrabNamed "subject"
+          thread <- maybeGrabNamed "thread"
+          ext <- grabRest
+          return $ Message
+                     from
+                     to
+                     ident
+                     tp
+                     (elementToText <$>subject)
+                     (elementToText <$> body)
+                     (elementToText <$> thread)
+                     ext
+
+presenceToElement (Presence from to id tp stp stat pri exts) =
+  Element "presence"
     (map contentify . concat $
       [ matr "from" (toText <$> from)
       , matr "to"  (toText <$> to)
@@ -85,7 +97,7 @@ presenceTOXML (Presence from to id tp stp stat pri exts) =
       ])
 
 -- Marshal XML element to message
-elementToPresence e@(Element "message" _ _) =
+elementToPresence e@(Element (Name "message" _ _) _ _) =
   let from    = fromText <$> attributeText "from" e
       to      = fromText <$> attributeText "to"   e
       ident   = attributeText "id"   e
@@ -108,7 +120,7 @@ elementToPresence e@(Element "message" _ _) =
 
 
 iqToElement (IQ from to id tp body) =
-  Element "message"
+  Element "iq"
     (map contentify . concat $
       [ matr "from" (toText <$> from)
       , matr "to"   (toText <$> to  )
@@ -117,7 +129,7 @@ iqToElement (IQ from to id tp body) =
       ])
     [ NodeElement body ]
 
-elementToIQ e@(Element "iq" _ _) =
+elementToIQ e@(Element (Name "iq" _ _) _ _ ) =
   let from      = fromText <$> attributeText "from" e
       to        = fromText <$> attributeText "to"   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)
 
 -- 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
 grabAll p = do
@@ -167,4 +179,6 @@ grabRest = do
 
 hasName x e = x == elementName e
 
-elementToText = Text.concat . elementText
+elementToText = Text.concat . elementText
+
+textToNode t = NodeContent (ContentText t)

src/Network/XMPP/Monad.hs

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

src/Network/XMPP/SASL.hs

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

src/Network/XMPP/TLS.hs

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

src/Network/XMPPConduit.hs

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