From 58e611385f38e3b32c171e56557ab163d1f1c014 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Fri, 27 Jul 2012 17:55:15 +0200 Subject: [PATCH] Initial work on Data Forms, IBR --- .gitignore | 4 - examples/EchoClient.hs | 17 +- pontarius-xmpp.cabal | 3 + source/Network/Xmpp.hs | 7 +- source/Network/Xmpp/Pickle.hs | 6 - source/Network/Xmpp/Xep/DataForms.hs | 85 +++++++++ source/Network/Xmpp/Xep/InbandRegistration.hs | 172 ++++++++++++++++++ tests/Tests.hs | 121 ++++++------ 8 files changed, 334 insertions(+), 81 deletions(-) create mode 100644 source/Network/Xmpp/Xep/DataForms.hs create mode 100644 source/Network/Xmpp/Xep/InbandRegistration.hs diff --git a/.gitignore b/.gitignore index f684ca1..d64bd06 100644 --- a/.gitignore +++ b/.gitignore @@ -3,7 +3,3 @@ cabal-dev/ wiki/ *.o *.hi -*~ -*# -*.#* -*_flymake.hs \ No newline at end of file diff --git a/examples/EchoClient.hs b/examples/EchoClient.hs index d60ebba..aeb6a22 100644 --- a/examples/EchoClient.hs +++ b/examples/EchoClient.hs @@ -25,26 +25,21 @@ import Network.Xmpp.IM -- Server and authentication details. -hostname = "nejla.com" -hostname_ = "xmpp.nejla.com" -- TODO +hostname = "localhost" + -- portNumber = 5222 -- TODO -userName = "" +username = "" password = "" +resource = Nothing -- TODO: Incomplete code, needs documentation, etc. main :: IO () main = do withNewSession $ do - withConnection $ do - connect hostname_ hostname - -- startTLS exampleParams - saslResponse <- simpleAuth userName password (Just "echo-client") - case saslResponse of - Right _ -> return () - Left e -> error $ show e + withConnection $ simpleConnect hostname username password resource sendPresence presenceOnline - fork echo + echo return () return () diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index 81e168f..eeedc69 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -80,6 +80,9 @@ Library , Text.XML.Stream.Elements , Data.Conduit.BufferedSource , Data.Conduit.TLS + , Network.Xmpp.Sasl.Common + , Network.Xmpp.Sasl.StringPrep + , Network.Xmpp.Errors GHC-Options: -Wall Executable pontarius-xmpp-echoclient diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index 315059a..8a10bfe 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -34,6 +34,7 @@ module Network.Xmpp , newSession , withConnection , connect + , simpleConnect , startTLS , simpleAuth , auth @@ -236,6 +237,7 @@ simpleAuth username passwd resource = flip auth resource $ -- * authenticate to the server using either SCRAM-SHA1 (preferred) or -- Digest-MD5 -- * bind a resource +-- * return the full JID you have been assigned -- -- Note that the server might assign a different resource even when we send -- a preference. @@ -244,12 +246,11 @@ simpleConnect :: HostName -- ^ Target host name -> Text -- ^ Password -> Maybe Text -- ^ Desired resource (or Nothing to let the server -- decide) - -> XmppConMonad () + -> XmppConMonad Jid simpleConnect host username password resource = do connect host username startTLS exampleParams saslResponse <- simpleAuth username password resource case saslResponse of - Right _ -> return () + Right jid -> return jid Left e -> error $ show e - return () diff --git a/source/Network/Xmpp/Pickle.hs b/source/Network/Xmpp/Pickle.hs index 04d5eee..2286fea 100644 --- a/source/Network/Xmpp/Pickle.hs +++ b/source/Network/Xmpp/Pickle.hs @@ -7,7 +7,6 @@ module Network.Xmpp.Pickle ( mbToBool - , xpElemEmpty , xmlLang , xpLangTag , xpNodeElem @@ -32,11 +31,6 @@ mbToBool :: Maybe t -> Bool mbToBool (Just _) = True mbToBool _ = False -xpElemEmpty :: Name -> PU [Node] () -xpElemEmpty name = xpWrap (\((),()) -> ()) - (\() -> ((),())) $ - xpElem name xpUnit xpUnit - xmlLang :: Name xmlLang = Name "lang" (Just "http://www.w3.org/XML/1998/namespace") (Just "xml") diff --git a/source/Network/Xmpp/Xep/DataForms.hs b/source/Network/Xmpp/Xep/DataForms.hs new file mode 100644 index 0000000..6172a1f --- /dev/null +++ b/source/Network/Xmpp/Xep/DataForms.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | XEP 0004: Data Forms (http://xmpp.org/extensions/xep-0004.html) + +module Network.Xmpp.Xep.DataForms where + +import qualified Data.Text as Text +import qualified Data.XML.Types as XML + +import Data.XML.Pickle +import qualified Data.Text as Text + +dataFormNs = "jabber:x:data" + +data FormType = FormF | SubmitF | CancelF | ResultF + +instance Show FormType where + show FormF = "form" + show SubmitF = "submit" + show CancelF = "cancel" + show ResultF = "result" + +instance Read FormType where + readsPrec _ "form" = [(FormF , "")] + readsPrec _ "submit" = [(SubmitF, "")] + readsPrec _ "cancel" = [(CancelF, "")] + readsPrec _ "result" = [(ResultF, "")] + readsPrec _ _ = [] + +data Option = Option { label :: Text.Text + , options :: [Text.Text] + } + +data Field = Field { fieldType :: FieldType + , desc :: Maybe Text.Text + , required :: Bool + , value :: [Text.Text] + , option :: [Option] + } + + +data Form = Form { formType :: FormType + , title :: Maybe Text.Text + , instructions :: Maybe Text.Text + , field :: [Field] + } + + + +data FieldType = Boolean + | Fixed + | Hidden + | JidMulti + | JidSingle + | ListMulti + | ListSingle + | TextMulti + | TextPrivate + | TextSingle + + +instance Show FieldType where + show Boolean = "boolean" + show Fixed = "fixed" + show Hidden = "hidden" + show JidMulti = "jid-multi" + show JidSingle = "jid-single" + show ListMulti = "list-multi" + show ListSingle = "list-single" + show TextMulti = "text-multi" + show TextPrivate = "text-private" + show TextSingle = "text-single" + +instance Read FieldType where + readsPrec _ "boolean" = [(Boolean ,"")] + readsPrec _ "fixed" = [(Fixed ,"")] + readsPrec _ "hidden" = [(Hidden ,"")] + readsPrec _ "jid-multi" = [(JidMulti ,"")] + readsPrec _ "jid-single" = [(JidSingle ,"")] + readsPrec _ "list-multi" = [(ListMulti ,"")] + readsPrec _ "list-single" = [(ListSingle ,"")] + readsPrec _ "text-multi" = [(TextMulti ,"")] + readsPrec _ "text-private" = [(TextPrivate ,"")] + readsPrec _ "text-single" = [(TextSingle ,"")] + readsPrec _ _ = [] diff --git a/source/Network/Xmpp/Xep/InbandRegistration.hs b/source/Network/Xmpp/Xep/InbandRegistration.hs new file mode 100644 index 0000000..001cc76 --- /dev/null +++ b/source/Network/Xmpp/Xep/InbandRegistration.hs @@ -0,0 +1,172 @@ +-- | XEP 0077: In-Band Registration +-- http://xmpp.org/extensions/xep-0077.html + +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.Xmpp.Xep.InbandRegistration where + +import Control.Applicative((<$>)) +import Control.Arrow(left) +import Control.Exception +import Control.Monad.Error +import Control.Monad.State + +import Data.Either (partitionEithers) +import qualified Data.Text as Text +import Data.XML.Pickle +import qualified Data.XML.Types as XML + +import Network.Xmpp.Monad +import Network.Xmpp.Pickle +import Network.Xmpp.Types + + +-- In-Band Registration name space +ibrns :: Text.Text +ibrns = "jabber:iq:register" + +ibrName x = (XML.Name x (Just ibrns) Nothing) + +data Query = Query { instructions :: Maybe Text.Text + , registered :: Bool + , fields ::[(Field, Maybe Text.Text)] + } deriving Show + +emptyQuery = Query Nothing False [] + +supported = do + fs <- other <$> gets sFeatures + let fe = XML.Element "{http://jabber.org/features/iq-register}register" [] [] + return $ fe `elem` fs + + +data IbrError = IbrNotSupported + | IbrIQError IQError + deriving (Show) +instance Error IbrError + +query :: Query -> XmppConMonad (Either IbrError Query) +query x = do + answer <- xmppSendIQ' "ibr" Nothing Get Nothing (pickleElem xpQuery x) + case answer of + Right IQResult{iqResultPayload = Just b} -> + case unpickleElem xpQuery b of + Right query -> return $ Right query + Left e -> throw . StreamXMLError $ + "RequestField: unpickle failed, got " + ++ Text.unpack (ppUnpickleError e) + ++ " saw " ++ ppElement b + Left e -> return . Left $ IbrIQError e + +data RegisterError = IbrError IbrError + | MissingFields [Field] + | AlreadyRegistered + deriving (Show) + +instance Error RegisterError + +mapError f = mapErrorT (liftM $ left f) + +registerWith :: [(Field, Text.Text)] -> XmppConMonad (Either RegisterError Query) +registerWith givenFields = runErrorT $ do + fs <- mapError IbrError $ ErrorT requestFields + when (registered fs) . throwError $ AlreadyRegistered + let res = flip map (fields fs) $ \(field,_) -> + case lookup field givenFields of + Just entry -> Right (field, Just entry) + Nothing -> Left field + fields <- case partitionEithers res of + ([],fs) -> return fs + (fs,_) -> throwError $ MissingFields fs + result <- mapError IbrError . ErrorT . query $ emptyQuery {fields} + return result + +requestFields = runErrorT $ do + supp <- supported + unless supp $ throwError $ IbrNotSupported + qr <- ErrorT $ query emptyQuery + return $ qr + +xpQuery :: PU [XML.Node] Query +xpQuery = xpWrap + (\(is, r, fs) -> Query is r fs) + (\(Query is r fs) -> (is, r, fs)) $ + xpElemNodes (ibrName "query") $ + xp3Tuple + (xpOption $ + xpElemNodes (ibrName "instructions") (xpContent $ xpText)) + (xpElemExists (ibrName "registered")) + (xpAllByNamespace ibrns ( xpWrap + (\(name,_,c) -> (name, c)) + (\(name,c) -> (name,(),c)) $ + xpElemByNamespace ibrns xpPrim xpUnit + (xpOption $ xpContent xpText) + )) + +data Field = Username + | Nick + | Password + | Name + | First + | Last + | Email + | Address + | City + | State + | Zip + | Phone + | Url + | Date + | Misc + | Text + | Key + | OtherField Text.Text + deriving Eq + +instance Show Field where + show Username = "username" + show Nick = "nick" + show Password = "password" + show Name = "name" + show First = "first" + show Last = "last" + show Email = "email" + show Address = "address" + show City = "city" + show State = "state" + show Zip = "zip" + show Phone = "phone" + show Url = "url" + show Date = "date" + show Misc = "misc" + show Text = "text" + show Key = "key" + show (OtherField x) = Text.unpack x + +instance Read Field where + readsPrec _ "username" = [(Username , "")] + readsPrec _ "nick" = [(Nick , "")] + readsPrec _ "password" = [(Password , "")] + readsPrec _ "name" = [(Name , "")] + readsPrec _ "first" = [(First , "")] + readsPrec _ "last" = [(Last , "")] + readsPrec _ "email" = [(Email , "")] + readsPrec _ "address" = [(Address , "")] + readsPrec _ "city" = [(City , "")] + readsPrec _ "state" = [(State , "")] + readsPrec _ "zip" = [(Zip , "")] + readsPrec _ "phone" = [(Phone , "")] + readsPrec _ "url" = [(Url , "")] + readsPrec _ "date" = [(Date , "")] + readsPrec _ "misc" = [(Misc , "")] + readsPrec _ "text" = [(Text , "")] + readsPrec _ "key" = [(Key , "")] + readsPrec _ x = [(OtherField $ Text.pack x , "")] + + + +-- Registered +-- Instructions \ No newline at end of file diff --git a/tests/Tests.hs b/tests/Tests.hs index f507fa0..f19004b 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -16,7 +16,8 @@ import Data.XML.Types import Network.Xmpp import Network.Xmpp.IM.Presence import Network.Xmpp.Pickle -import Network.Xmpp.Xep.ServiceDiscovery +import qualified Network.Xmpp.Xep.ServiceDiscovery as Disco +import qualified Network.Xmpp.Xep.InbandRegistration as IBR import System.Environment import Text.XML.Stream.Elements @@ -81,9 +82,10 @@ autoAccept = forever $ do simpleMessage :: Jid -> Text -> Message simpleMessage to txt = message { messageTo = Just to - , messagePayload = [Element "body" - [] - [NodeContent $ ContentText txt] + , messagePayload = [ Element + "body" + [] + [NodeContent $ ContentText txt] ] } where @@ -95,7 +97,6 @@ simpleMessage to txt = message , messagePayload = [] } - sendUser = sendMessage . simpleMessage supervisor . Text.pack expect debug x y | x == y = debug "Ok." @@ -104,18 +105,58 @@ expect debug x y | x == y = debug "Ok." debug failMSG sendUser failMSG - wait3 :: MonadIO m => m () wait3 = liftIO $ threadDelay 1000000 -runMain :: (String -> STM ()) -> Int -> IO () -runMain debug number = do +discoTest debug = do + q <- Disco.queryInfo "species64739.dyndns.org" Nothing + case q of + Left (Disco.DiscoXMLError el e) -> do + debug (ppElement el) + debug (Text.unpack $ ppUnpickleError e) + debug (show $ length $ elementNodes el) + x -> debug $ show x + + q <- Disco.queryItems "species64739.dyndns.org" + (Just "http://jabber.org/protocol/commands") + case q of + Left (Disco.DiscoXMLError el e) -> do + debug (ppElement el) + debug (Text.unpack $ ppUnpickleError e) + debug (show $ length $ elementNodes el) + x -> debug $ show x + +iqTest debug we them = do + forM [1..10] $ \count -> do + let message = Text.pack . show $ localpart we + let payload = Payload count (even count) (Text.pack $ show count) + let body = pickleElem payloadP payload + debug "sending" + answer <- sendIQ' (Just them) Get Nothing body + case answer of + IQResponseResult r -> do + debug "received" + let Right answerPayload = unpickleElem payloadP + (fromJust $ iqResultPayload r) + expect debug (invertPayload payload) answerPayload + IQResponseTimeout -> do + debug $ "Timeout in packet: " ++ show count + IQResponseError e -> do + debug $ "Error in packet: " ++ show count + liftIO $ threadDelay 100000 + sendUser "All tests done" + debug "ending session" + +ibrTest debug = IBR.requestFields >>= debug . show + + +runMain :: (String -> STM ()) -> Int -> Bool -> IO () +runMain debug number multi = do let (we, them, active) = case number `mod` 2 of 1 -> (testUser1, testUser2,True) 0 -> (testUser2, testUser1,False) let debug' = liftIO . atomically . debug . (("Thread " ++ show number ++ ":") ++) - wait <- newEmptyTMVarIO withNewSession $ do setConnectionClosedHandler (\e -> do liftIO (debug' $ "connection lost because " ++ show e) @@ -124,6 +165,7 @@ runMain debug number = do withConnection $ Ex.catch (do connect "localhost" "species64739.dyndns.org" startTLS exampleParams + ibrTest debug' saslResponse <- simpleAuth (fromJust $ localpart we) "pwd" (resourcepart we) case saslResponse of @@ -132,60 +174,25 @@ runMain debug number = do debug' "session standing") (\e -> debug' $ show (e ::Ex.SomeException)) sendPresence presenceOnline - fork autoAccept + thread1 <- fork autoAccept sendPresence $ presenceSubscribe them - fork iqResponder + thread2 <- fork iqResponder when active $ do - q <- queryInfo "species64739.dyndns.org" Nothing - case q of - Left (DiscoXMLError el e) -> do - debug' (ppElement el) - debug' (Text.unpack $ ppUnpickleError e) - debug' (show $ length $ elementNodes el) - x -> debug' $ show x - - q <- queryItems "species64739.dyndns.org" - (Just "http://jabber.org/protocol/commands") - case q of - Left (DiscoXMLError el e) -> do - debug' (ppElement el) - debug' (Text.unpack $ ppUnpickleError e) - debug' (show $ length $ elementNodes el) - x -> debug' $ show x - - liftIO $ threadDelay 1000000 -- Wait for the other thread to go online - void . fork $ do - forM [1..10] $ \count -> do - let message = Text.pack . show $ localpart we - let payload = Payload count (even count) (Text.pack $ show count) - let body = pickleElem payloadP payload - debug' "sending" - answer <- sendIQ' (Just them) Get Nothing body - case answer of - IQResponseResult r -> do - debug' "received" - let Right answerPayload = unpickleElem payloadP - (fromJust $ iqResultPayload r) - expect debug' (invertPayload payload) answerPayload - IQResponseTimeout -> do - debug' $ "Timeout in packet: " ++ show count - IQResponseError e -> do - debug' $ "Error in packet: " ++ show count - liftIO $ threadDelay 100000 - sendUser "All tests done" - debug' "ending session" - liftIO . atomically $ putTMVar wait () - closeConnection - liftIO . atomically $ takeTMVar wait + discoTest debug' + when multi $ iqTest debug' we them + closeConnection + liftIO $ killThread thread1 + liftIO $ killThread thread2 return () return () -run i = do +run i multi = do out <- newTChanIO - forkIO . forever $ atomically (readTChan out) >>= putStrLn + debugger <- forkIO . forever $ atomically (readTChan out) >>= putStrLn let debugOut = writeTChan out - forkIO $ runMain debugOut (1 + i) - runMain debugOut (2 + i) + when multi . void $ forkIO $ runMain debugOut (1 + i) multi + runMain debugOut (2 + i) multi + -main = run 0 +main = run 0 False