You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
139 lines
4.6 KiB
139 lines
4.6 KiB
{-# LANGUAGE NoMonomorphismRestriction #-} |
|
{-# LANGUAGE TupleSections #-} |
|
{-# 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 Data.XML.Pickle |
|
import qualified Data.XML.Types as XML |
|
|
|
|
|
dataFormNs :: Text.Text |
|
dataFormNs = "jabber:x:data" |
|
|
|
dataFormName :: Text.Text -> XML.Name |
|
dataFormName n = XML.Name n (Just dataFormNs) Nothing |
|
|
|
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 :: Maybe Text.Text |
|
, options :: [Text.Text] |
|
} deriving Show |
|
|
|
data Field = Field { fieldVar :: Maybe Text.Text |
|
, fieldLabel :: Maybe Text.Text |
|
, fieldType :: Maybe FieldType |
|
, fieldDesc :: Maybe Text.Text |
|
, fieldRequired :: Bool |
|
, fieldValues :: [Text.Text] |
|
, fieldOptions :: [Option] |
|
} deriving Show |
|
|
|
|
|
data Form = Form { formType :: FormType |
|
, title :: Maybe Text.Text |
|
, instructions :: [Text.Text] |
|
, fields :: [Field] |
|
, reported :: Maybe [Field] |
|
, items :: [[Field]] |
|
} deriving Show |
|
|
|
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 _ _ = [] |
|
|
|
|
|
xpForm :: PU [XML.Node] Form |
|
xpForm = xpWrap (\(tp , (ttl, ins, flds, rpd, its)) -> |
|
Form tp ttl (map snd ins) flds rpd (map snd its)) |
|
(\(Form tp ttl ins flds rpd its) -> |
|
(tp , |
|
(ttl, map ((),) ins |
|
, flds, rpd, map ((),) its))) |
|
|
|
$ |
|
xpElem (dataFormName "x") |
|
(xpAttr "type" xpPrim) |
|
(xp5Tuple |
|
(xpOption $ xpElemNodes (dataFormName "title") (xpContent xpId)) |
|
(xpElems (dataFormName "instructions") xpUnit (xpContent xpId)) |
|
xpFields |
|
(xpOption $ xpElemNodes (dataFormName "reported") xpFields) |
|
(xpElems (dataFormName "item") xpUnit xpFields)) |
|
|
|
xpFields :: PU [XML.Node] [Field] |
|
xpFields = xpWrap (map $ \((var, tp, lbl),(desc, req, vals, opts)) |
|
-> Field var lbl tp desc req vals opts) |
|
(map $ \(Field var lbl tp desc req vals opts) |
|
-> ((var, tp, lbl),(desc, req, vals, opts))) $ |
|
xpElems (dataFormName "field") |
|
(xp3Tuple |
|
(xpAttrImplied "var" xpId ) |
|
(xpAttrImplied "type" xpPrim ) |
|
(xpAttrImplied "label" xpId ) |
|
) |
|
(xp4Tuple |
|
(xpOption $ xpElemText (dataFormName "desc")) |
|
(xpElemExists (dataFormName "required")) |
|
xpValues |
|
xpOptions ) |
|
|
|
xpValues :: PU [XML.Node] [Text.Text] |
|
xpValues = xpWrap (map snd) (map ((),)) |
|
(xpElems (dataFormName "value") xpUnit (xpContent xpId)) |
|
|
|
xpOptions :: PU [XML.Node] [Option] |
|
xpOptions = xpWrap |
|
(map $ \(l, os) -> Option l os) |
|
(map $ \(Option l os) -> (l, os)) $ |
|
xpElems (dataFormName "option") |
|
(xpAttrImplied "label" xpId) |
|
xpValues
|
|
|