From 0651bcd18f15b13337049cd380dea90c9db86c9b Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 19 Mar 2012 17:21:36 +0100 Subject: [PATCH] first stab at types and marshaling --- src/Network/XMPP/Marshal.hs | 170 +++++++++++++++++++++++++++++++++ src/Network/XMPP/SASL.hs | 6 +- src/Network/XMPP/Stream.hs | 5 +- src/Network/XMPP/Types.hs | 181 ++++++++++++++++++++++++++++++++++++ src/Network/XMPPConduit.hs | 2 + 5 files changed, 360 insertions(+), 4 deletions(-) create mode 100644 src/Network/XMPP/Marshal.hs create mode 100644 src/Network/XMPP/Types.hs diff --git a/src/Network/XMPP/Marshal.hs b/src/Network/XMPP/Marshal.hs new file mode 100644 index 0000000..ea9bbf1 --- /dev/null +++ b/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 \ No newline at end of file diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index 396a6e1..886cb83 100644 --- a/src/Network/XMPP/SASL.hs +++ b/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,"\""] diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index c38be19..70ea683 100644 --- a/src/Network/XMPP/Stream.hs +++ b/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 () diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs new file mode 100644 index 0000000..5dc6d13 --- /dev/null +++ b/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 value" + diff --git a/src/Network/XMPPConduit.hs b/src/Network/XMPPConduit.hs index eef010c..b99135a 100644 --- a/src/Network/XMPPConduit.hs +++ b/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 ()