Initial work on Data Forms, IBR

.gitignore

@@ -3,7 +3,3 @@ cabal-dev/
 wiki/
 *.o
 *.hi
-*~
-*#
-*.#*
-*_flymake.hs

examples/EchoClient.hs

@@ -25,26 +25,21 @@ import Network.Xmpp.IM
 
 -- Server and authentication details.
 
-hostname = "nejla.com"
+hostname = "localhost"
-hostname_ = "xmpp.nejla.com" -- TODO
+
 -- portNumber = 5222 -- TODO
-userName = ""
+username = ""
 password = ""
+resource = Nothing
 
 
 -- TODO: Incomplete code, needs documentation, etc.
 main :: IO ()
 main = do
     withNewSession $ do
-        withConnection $ do
+        withConnection $ simpleConnect hostname username password resource
-            connect hostname_ hostname
-            -- startTLS exampleParams
-            saslResponse <- simpleAuth userName password (Just "echo-client")
-            case saslResponse of
-                Right _ -> return ()
-                Left e -> error $ show e
         sendPresence presenceOnline
-        fork echo
+        echo
         return ()
     return ()
 

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

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 ()

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")
 

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 _  _              = []

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

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,7 +82,8 @@ autoAccept = forever $ do
 simpleMessage :: Jid -> Text -> Message
 simpleMessage to txt = message
     { messageTo = Just to
-    , messagePayload = [Element "body"
+    , messagePayload = [ Element
+                             "body"
                               []
                               [NodeContent $ ContentText txt]
                        ]
@@ -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 ()
+discoTest debug = do
-runMain debug number = 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
+        discoTest debug'
-            forM [1..10] $ \count -> do
+        when multi $ iqTest debug' we them
-                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
+        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)
+  when multi . void $ forkIO $ runMain debugOut (1 + i) multi
-  runMain debugOut (2 + i)
+  runMain debugOut (2 + i) multi
+
 
-main = run 0
+main = run 0 False