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_ = "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 ()
 

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