From abf217754c08ee5f99a445bb2e22b334eb0efac1 Mon Sep 17 00:00:00 2001
From: Philipp Balzarek <p.balzarek@googlemail.com>
Date: Sat, 13 Oct 2012 14:44:02 +0200
Subject: [PATCH] complete the basic code to work with data forms

---
 source/Network/Xmpp/Xep/DataForms.hs | 85 +++++++++++++++++++++++-----
 1 file changed, 71 insertions(+), 14 deletions(-)

diff --git a/source/Network/Xmpp/Xep/DataForms.hs b/source/Network/Xmpp/Xep/DataForms.hs
index 6172a1f..9491acd 100644
--- a/source/Network/Xmpp/Xep/DataForms.hs
+++ b/source/Network/Xmpp/Xep/DataForms.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 -- | XEP 0004: Data Forms (http://xmpp.org/extensions/xep-0004.html)
@@ -10,8 +12,14 @@ import qualified Data.XML.Types as XML
 import Data.XML.Pickle
 import qualified Data.Text as Text
 
+import qualified Text.XML.Stream.Parse as Parse
+
+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
@@ -27,25 +35,27 @@ instance Read FormType where
     readsPrec _ "result" = [(ResultF, "")]
     readsPrec _ _        = []
 
-data Option = Option { label :: Text.Text
+data Option = Option { label :: Maybe Text.Text
                      , options :: [Text.Text]
-                     }
+                     } deriving Show
 
-data Field = Field { fieldType :: FieldType
-                   , desc :: Maybe Text.Text
-                   , required :: Bool
-                   , value :: [Text.Text]
-                   , option :: [Option]
-                   }
+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 :: Maybe Text.Text
-                 , field :: [Field]
-                 }
-
-
+                 , instructions :: [Text.Text]
+                 , fields :: [Field]
+                 , reported :: Maybe [Field]
+                 , items :: [[Field]]
+                 } deriving Show
 
 data FieldType = Boolean
                | Fixed
@@ -58,7 +68,6 @@ data FieldType = Boolean
                | TextPrivate
                | TextSingle
 
-
 instance Show FieldType where
     show Boolean     = "boolean"
     show Fixed       = "fixed"
@@ -83,3 +92,51 @@ instance Read FieldType where
     readsPrec _  "text-private" = [(TextPrivate ,"")]
     readsPrec _  "text-single"  = [(TextSingle  ,"")]
     readsPrec _  _              = []
+
+
+xpForm :: PU [XML.Node] Form
+xpForm = xpWrap (\(tp , (title, instructions, fields, reported, items)) ->
+                  Form tp title (map snd instructions) fields reported (map snd items))
+                 (\(Form tp title instructions fields reported items) ->
+                     (tp ,
+                     (title, map ((),) instructions
+                     , fields, reported, map ((),) items)))
+
+          $
+    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, label),(desc, req, vals, opts))
+                     -> Field var label tp desc req vals opts)
+                  (map $ \(Field var label tp desc req vals opts)
+                        -> ((var, tp, label),(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