first stab at types and marshaling

src/Network/XMPP/Marshal.hs

@@ -0,0 +1,170 @@
+{-# Language OverloadedStrings, ViewPatterns, NoMonomorphismRestriction #-}
+
+module Network.XMPP.Marshal where
+
+import Control.Applicative((<$>))
+
+import Control.Monad.State
+
+import Data.Maybe
+
+import qualified Data.Text as Text
+import Data.XML.Types
+
+import Network.XMPP.Types
+
+
+-- create attribute from Just
+matr _ Nothing = []
+matr n (Just x) = [(n,x)]
+
+-- Child if text is not empty
+nech _ "" = []
+nech n x  = [ NodeElement (Element n [] [NodeContent (ContentText x) ]) ]
+
+-- Child if text is not Nothing
+mnech _ Nothing = []
+mnech n (Just x) = [ NodeElement (Element n [] [NodeContent (ContentText x) ]) ]
+
+-- make Attributes from text
+contentify (x,y) = (x, [ContentText y])
+
+-- Marshal Message to XML Element
+messageToElement (Message from to ident tp sub body thread exts) =
+  Element "message"
+    (map contentify . concat $
+      [ matr "from" (toText <$> from)
+      , [("to", toText to)]
+      , matr "id"    ident
+      , [("type", toText tp)]
+      ])
+    (concat $
+      [ mnech "subject" sub
+      , mnech "body"    body
+      , mnech "thread"  thread
+      ,  map NodeElement exts
+      ])
+
+-- Marshal XML element to message
+elementToMessage e@(Element "message" _ _) =
+  let from    = fromText <$> attributeText "from" e
+      Just to = fromText <$> attributeText "to"   e
+      ident   = attributeText "id"   e
+      Just tp = fromText <$> attributeText "type" e
+      -- 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"
+    (map contentify . concat $
+      [ matr "from" (toText <$> from)
+      , matr "to"  (toText <$> to)
+      , matr "id" id
+      , matr "type" ( toText <$> tp)
+      ])
+    (concat $
+      [ mnech "show"    (toText <$> stp)
+      , mnech "status"  stat
+      , mnech "priority"  (Text.pack . show <$> pri)
+      , map NodeElement exts
+      ])
+
+-- Marshal XML element to message
+elementToPresence e@(Element "message" _ _) =
+  let from    = fromText <$> attributeText "from" e
+      to      = fromText <$> attributeText "to"   e
+      ident   = attributeText "id"   e
+      tp = fromText <$> attributeText "type" e
+      in grabFrom (elementChildren e) $ do
+        pshow <- maybeGrabNamed "show"
+        -- TODO multiple status (different languages)
+        stat  <-  maybeGrabNamed "status"
+        prio  <-  maybeGrabNamed "priority"
+        ext   <- grabRest
+        return $ Presence
+                   from
+                   to
+                   ident
+                   tp
+                   (fromText . elementToText <$> pshow)
+                   (elementToText <$> stat)
+                   (read . Text.unpack . elementToText <$> prio)
+                   ext
+
+
+iqToElement (IQ from to id tp body) =
+  Element "message"
+    (map contentify . concat $
+      [ matr "from" (toText <$> from)
+      , matr "to"   (toText <$> to  )
+      , [("id" , id)]
+      , [("type", toText tp)]
+      ])
+    [ NodeElement body ]
+
+elementToIQ e@(Element "iq" _ _) =
+  let from      = fromText <$> attributeText "from" e
+      to        = fromText <$> attributeText "to"   e
+      Just ident= attributeText "id"   e
+      Just tp = fromText <$> attributeText "type" e
+      [ext] = elementChildren e
+   in IQ
+        from
+        to
+        ident
+        tp
+        ext
+
+-- take and remove all elements matching a predicate from the list
+takeAllFromList pred l = let (l', xs) = go pred [] l in (reverse l', xs)
+  where
+  go pred ys  [] = (ys, [])
+  go pred ys (x:xs) =
+    case pred x of
+      True -> let (ys', rs) = go pred ys xs in (ys', x:rs)
+      False -> go pred (x:ys) xs
+
+-- The "Grab Monad" : sucessively take and remove ("grab")
+-- elements from a "pool" (list)
+
+-- Put a list of elements into the pool and start grabbing
+grabFrom l = flip runState l
+
+-- grab all elements matching predicate out of the pool
+grabAll p = do
+  l <- get
+  let (l', xs) = takeAllFromList p l
+  put l'
+  return xs
+
+-- grab XML-elements by exact name
+grabNamed = grabAll . hasName
+
+-- This throws away all elements after the first one
+-- TODO: Be more stricy here
+maybeGrabNamed = liftM listToMaybe . grabAll . hasName
+
+-- grab all remaining elements from the pool
+grabRest = do
+  l <- get
+  put []
+  return l
+
+hasName x e = x == elementName e
+
+elementToText = Text.concat . elementText

src/Network/XMPP/SASL.hs

@@ -24,6 +24,7 @@ import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 
 import Network.XMPP.Monad
+import Network.XMPP.Stream
 
 import Numeric --
 
@@ -52,13 +53,13 @@ xmppSASL passwd = do
     [NodeContent (ContentText content)] <- pull
   let (Right challenge) = B64.decode . Text.encodeUtf8 $ content
   let Right pairs = toPairs challenge
-  liftIO $ BS.putStrLn challenge
   push . saslResponseE =<< createResponse passwd pairs
   Element name attrs content <- pull
   when (name == "{urn:ietf:params:xml:ns:xmpp-sasl}failure") $
     (error $ show content)
   push saslResponse2E
-  Element "{urn:ietf:params:xml:ns:xmpp-sasl}sucess" <- pull
+  Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] <- pull
+  xmppStartStream
   return ()
 
 createResponse passwd' pairs = do
@@ -92,7 +93,6 @@ createResponse passwd' pairs = do
        ,["response"  ,       digest    ]
        ,["charset"   ,       "utf-8"   ]
        ]
-  liftIO $ BS.putStrLn response
   return . Text.decodeUtf8 $ B64.encode response
   where quote x = BS.concat ["\"",x,"\""]
 

src/Network/XMPP/Stream.hs

@@ -31,7 +31,10 @@ xmppStream = do
 
 xmppStreamHeader :: Resource m => Sink Event m ()
 xmppStreamHeader = do
-  Just EventBeginDocument <- CL.head
+  hd <- CL.peek
+  case hd of
+    Just EventBeginDocument -> CL.drop 1
+    _ -> return ()
   Just (EventBeginElement "{http://etherx.jabber.org/streams}stream" streamAttrs) <- CL.head
   unless (checkVersion streamAttrs)  $ error  "Not XMPP version 1.0 "
   return ()

src/Network/XMPP/Types.hs

@@ -0,0 +1,181 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Network.XMPP.Types where
+-- proudly "borrowed" from haskell-xmpp
+
+import Control.Applicative((<$>))
+import Control.Monad
+
+import Data.Maybe
+import Data.Text as Text
+import Data.String as Str
+import Data.XML.Types
+
+class ToText a where
+  toText :: a -> Text
+
+class FromText a where
+  fromText :: Text -> a
+
+-- | Jabber ID (JID) datatype
+data JID = JID { node :: Maybe Text
+               -- ^ Account name
+               , domain :: Text
+               -- ^ Server adress
+               , resource :: Maybe Text
+               -- ^ Resource name
+               }
+instance ToText JID where
+  toText (JID n d r) =
+    let n' = maybe "" (`append` "@" ) n
+        r' = maybe "" ("/" `append` ) r
+    in Text.concat [n', d, r']
+
+instance FromText JID where
+  fromText = parseJID
+
+instance Show JID where
+  show = Text.unpack . toText
+
+-- Ugh, that smells a bit.
+parseJID jid =
+  let (jid', rst) = case Text.splitOn "@" jid of
+                      [rest] -> (JID Nothing, rest)
+                      [node,rest] -> (JID (Just node), rest)
+                      _ -> error $  "Couldn't parse JID: \"" ++ Text.unpack jid ++ "\""
+  in case Text.splitOn "/" rst of
+      [domain] -> jid' domain Nothing
+      [domain, resource] -> jid' domain (Just resource)
+      _ -> error $ "Couldn't parse JID: \"" ++ Text.unpack jid ++ "\""
+
+instance IsString JID where
+  fromString = parseJID . Text.pack
+
+
+-- should we factor from, to and id out, even though they are
+-- sometimes mandatory?
+data Message = Message
+    { mFrom :: Maybe JID
+    , mTo :: JID
+    , mId :: Maybe Text
+             -- ^ Message 'from', 'to', 'id' attributes
+    , mType :: MessageType
+               -- ^ Message type (2.1.1)
+    , mSubject :: Maybe Text
+                  -- ^ Subject element (2.1.2.1)
+    , mBody :: Maybe Text
+               -- ^ Body element (2.1.2.2)
+    , mThread :: Maybe Text
+                 -- ^ Thread element (2.1.2.3)
+    , mExt :: [Element]
+              -- ^ Additional contents, used for extensions
+    } deriving Show
+
+data Presence =  Presence
+    { pFrom :: Maybe JID
+    , pTo :: Maybe JID
+    , pId :: Maybe Text
+             -- ^ Presence 'from', 'to', 'id' attributes
+    , pType :: Maybe PresenceType
+               -- ^ Presence type (2.2.1)
+    , pShowType :: Maybe ShowType
+                   -- ^ Show element (2.2.2.1)
+    , pStatus :: Maybe Text
+                 -- ^ Status element (2.2.2.2)
+    , pPriority :: Maybe Int
+                   -- ^ Presence priority (2.2.2.3)
+    , pExt :: [Element]
+              -- ^ Additional contents, used for extensions
+    }
+
+data IQ = IQ
+    { iqFrom :: Maybe JID
+    , iqTo :: Maybe JID
+    , iqId :: Text
+      -- ^ IQ id (Core-9.2.3)
+    , iqType :: IQType
+      -- ^ IQ type (Core-9.2.3)
+    , iqBody :: Element
+      -- ^ Child element (Core-9.2.3)
+    }
+
+data Stanza = SMessage Message | SPresence Presence | SIQ IQ --  deriving Show
+
+data MessageType = Chat | GroupChat | Headline | Normal | MessageError deriving (Eq, Show)
+
+data PresenceType = Default | Unavailable | Subscribe | Subscribed | Unsubscribe | Unsubscribed | Probe | PresenceError deriving Eq
+
+data IQType = Get | Result | Set | IQError deriving Eq
+
+data ShowType = Available | Away | FreeChat | DND | XAway deriving Eq
+
+instance ToText MessageType where
+  toText Chat = "chat"
+  toText GroupChat = "groupchat"
+  toText Headline = "headline"
+  toText Normal = "normal"
+  toText MessageError = "error"
+
+instance ToText PresenceType where
+  toText Default = ""
+  toText Unavailable = "unavailable"
+  toText Subscribe = "subscribe"
+  toText Subscribed = "subscribed"
+  toText Unsubscribe = "unsubscribe"
+  toText Unsubscribed = "unsubscribed"
+  toText Probe = "probe"
+  toText PresenceError = "error"
+
+instance ToText IQType where
+  toText Get = "get"
+  toText Result = "result"
+  toText Set = "set"
+  toText IQError = "error"
+
+instance ToText ShowType where
+  toText Available = ""
+  toText Away = "away"
+  toText FreeChat = "chat"
+  toText DND = "dnd"
+  toText XAway = "xa"
+
+
+instance FromText MessageType where
+  fromText "chat" = Chat
+  fromText "groupchat" = GroupChat
+  fromText "headline" = Headline
+  fromText "normal" = Normal
+  fromText "error" = MessageError
+  fromText "" = Chat
+  fromText _ = error "incorrect message type"
+
+instance FromText PresenceType where
+  fromText "" = Default
+  fromText "available" = Default
+  fromText "unavailable" = Unavailable
+  fromText "subscribe" = Subscribe
+  fromText "subscribed" = Subscribed
+  fromText "unsubscribe" = Unsubscribe
+  fromText "unsubscribed" = Unsubscribed
+  fromText "probe" = Probe
+  fromText "error" = PresenceError
+  fromText _ = error "incorrect presence type"
+
+instance FromText IQType where
+  fromText "get" = Get
+  fromText "result" = Result
+  fromText "set" = Set
+  fromText "error" = IQError
+  fromText "" = Get
+  fromText _ = error "incorrect iq type"
+
+instance FromText ShowType where
+  fromText "" = Available
+  fromText "available" = Available
+  fromText "away" = Away
+  fromText "chat" = FreeChat
+  fromText "dnd" = DND
+  fromText "xa" = XAway
+  fromText "invisible" = Available
+  fromText _ = error "incorrect <show> value"
+

src/Network/XMPPConduit.hs

@@ -3,6 +3,7 @@ module Network.XMPPConduit where
 
 import Control.Monad
 import Control.Monad.Trans
+import Control.Monad.Trans.State
 
 import qualified Data.ByteString as BS
 import Data.Text as Text
@@ -24,6 +25,7 @@ fromHandle handle hostname username password =
       -- on it's own
       xmppStartTLS exampleParams
       xmppSASL password
+      gets haveTLS >>= liftIO . print
       forever $ pull >>= liftIO . print
       return ()