Permalink
Browse files

Initial work on Data Forms, IBR

  • Loading branch information...
1 parent 498bfac commit 58e611385f38e3b32c171e56557ab163d1f1c014 @Philonous Philonous committed Jul 27, 2012
View
@@ -3,7 +3,3 @@ cabal-dev/
wiki/
*.o
*.hi
-*~
-*#
-*.#*
-*_flymake.hs
View
@@ -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 ()
View
@@ -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
View
@@ -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 ()
@@ -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")
@@ -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 _ _ = []
@@ -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
Oops, something went wrong.

0 comments on commit 58e6113

Please sign in to comment.