{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DataKinds #-}
module Network.XMPP.XEP.Form where
import Text.Hamlet.XML (xml)
import Text.XML.HaXml.Xtract.Parse (xtract)
import Data.Maybe
import Data.List (find)
import qualified Data.Text as T
import Network.XMPP.XML
instance FromXML XmppField where
decodeXml :: Content Posn -> Maybe XmppField
decodeXml Content Posn
m =
let _label :: Text
_label = Text -> Content Posn -> Text
txtpat Text
"/field/@label" Content Posn
m
typ :: Text
typ = Text -> Content Posn -> Text
txtpat Text
"/field/@type" Content Posn
m
variable :: Text
variable = Text -> Content Posn -> Text
txtpat Text
"/field/@var" Content Posn
m
in case Text
typ of
Text
"boolean" -> Text -> Bool -> XmppField
BooleanField Text
variable (Bool -> XmppField) -> Maybe Bool -> Maybe XmppField
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Bool
boolVal
Text
"text-single" -> XmppField -> Maybe XmppField
forall a. a -> Maybe a
Just (XmppField -> Maybe XmppField) -> XmppField -> Maybe XmppField
forall a b. (a -> b) -> a -> b
$ Text -> Text -> XmppField
SingleTextField Text
variable Text
txtSingleVal
Text
"list-single" ->
XmppField -> Maybe XmppField
forall a. a -> Maybe a
Just (XmppField -> Maybe XmppField) -> XmppField -> Maybe XmppField
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text -> XmppField
ListSingleField Text
variable [Text]
listOptions Text
txtSingleVal
Text
"list-multi" -> XmppField -> Maybe XmppField
forall a. a -> Maybe a
Just (XmppField -> Maybe XmppField) -> XmppField -> Maybe XmppField
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> [Text] -> XmppField
ListMultiField Text
variable [Text]
listOptions [Text]
listValues
Text
"hidden" -> XmppField -> Maybe XmppField
forall a. a -> Maybe a
Just (XmppField -> Maybe XmppField) -> XmppField -> Maybe XmppField
forall a b. (a -> b) -> a -> b
$ Text -> Text -> XmppField
HiddenField Text
variable Text
txtSingleVal
Text
_ -> Maybe XmppField
forall a. Maybe a
Nothing
where
listValues :: [Text]
listValues = Text -> Content Posn -> Text
txtpat Text
"/value/-" (Content Posn -> Text) -> [Content Posn] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> String) -> String -> CFilter Posn
forall i. (String -> String) -> String -> CFilter i
xtract String -> String
forall a. a -> a
id String
"/field/value/" Content Posn
m
listOptions :: [Text]
listOptions = Text -> Content Posn -> Text
txtpat Text
"/value/-" (Content Posn -> Text) -> [Content Posn] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> String) -> String -> CFilter Posn
forall i. (String -> String) -> String -> CFilter i
xtract String -> String
forall a. a -> a
id String
"/field/option/value" Content Posn
m
txtSingleVal :: Text
txtSingleVal = Text -> Content Posn -> Text
txtpat Text
"/field/value/-" Content Posn
m
boolVal :: Maybe Bool
boolVal = case Text -> Content Posn -> Text
txtpat Text
"/field/value/-" Content Posn
m of
Text
"0" -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
Text
"1" -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
Text
_ -> Maybe Bool
forall a. Maybe a
Nothing
newtype XmppForm = XmppForm [XmppField] deriving (XmppForm -> XmppForm -> Bool
(XmppForm -> XmppForm -> Bool)
-> (XmppForm -> XmppForm -> Bool) -> Eq XmppForm
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: XmppForm -> XmppForm -> Bool
$c/= :: XmppForm -> XmppForm -> Bool
== :: XmppForm -> XmppForm -> Bool
$c== :: XmppForm -> XmppForm -> Bool
Eq, Int -> XmppForm -> String -> String
[XmppForm] -> String -> String
XmppForm -> String
(Int -> XmppForm -> String -> String)
-> (XmppForm -> String)
-> ([XmppForm] -> String -> String)
-> Show XmppForm
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [XmppForm] -> String -> String
$cshowList :: [XmppForm] -> String -> String
show :: XmppForm -> String
$cshow :: XmppForm -> String
showsPrec :: Int -> XmppForm -> String -> String
$cshowsPrec :: Int -> XmppForm -> String -> String
Show)
type FieldName = T.Text
data XmppField =
SingleTextField
{ XmppField -> Text
xfName :: FieldName
, XmppField -> Text
stfValue :: T.Text
}
| ListSingleField
{ xfName :: FieldName
, XmppField -> [Text]
lsfOptions :: [T.Text]
, XmppField -> Text
lsfValue :: T.Text
}
| BooleanField
{ xfName :: FieldName
, XmppField -> Bool
bfValue :: Bool
}
| ListMultiField
{ xfName ::FieldName
, XmppField -> [Text]
lmfOptions :: [T.Text]
, XmppField -> [Text]
lmfValue :: [T.Text]
}
| HiddenField { xfName :: T.Text, XmppField -> Text
hfValue :: T.Text }
deriving (XmppField -> XmppField -> Bool
(XmppField -> XmppField -> Bool)
-> (XmppField -> XmppField -> Bool) -> Eq XmppField
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: XmppField -> XmppField -> Bool
$c/= :: XmppField -> XmppField -> Bool
== :: XmppField -> XmppField -> Bool
$c== :: XmppField -> XmppField -> Bool
Eq, Int -> XmppField -> String -> String
[XmppField] -> String -> String
XmppField -> String
(Int -> XmppField -> String -> String)
-> (XmppField -> String)
-> ([XmppField] -> String -> String)
-> Show XmppField
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [XmppField] -> String -> String
$cshowList :: [XmppField] -> String -> String
show :: XmppField -> String
$cshow :: XmppField -> String
showsPrec :: Int -> XmppField -> String -> String
$cshowsPrec :: Int -> XmppField -> String -> String
Show)
updateFormField :: FieldName -> (XmppField -> XmppField) -> XmppForm -> XmppForm
updateFormField :: Text -> (XmppField -> XmppField) -> XmppForm -> XmppForm
updateFormField Text
fname XmppField -> XmppField
update (XmppForm [XmppField]
fields) =
let mField :: Maybe XmppField
mField = XmppField -> XmppField
update (XmppField -> XmppField) -> Maybe XmppField -> Maybe XmppField
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (XmppField -> Bool) -> [XmppField] -> Maybe XmppField
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
fname) (Text -> Bool) -> (XmppField -> Text) -> XmppField -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmppField -> Text
xfName) [XmppField]
fields
nextFields :: [XmppField]
nextFields =
([XmppField] -> [XmppField] -> [XmppField]
forall a. Semigroup a => a -> a -> a
<> Maybe XmppField -> [XmppField]
forall a. Maybe a -> [a]
maybeToList Maybe XmppField
mField) ([XmppField] -> [XmppField])
-> ([XmppField] -> [XmppField]) -> [XmppField] -> [XmppField]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XmppField -> Bool) -> [XmppField] -> [XmppField]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
fname) (Text -> Bool) -> (XmppField -> Text) -> XmppField -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmppField -> Text
xfName) ([XmppField] -> [XmppField]) -> [XmppField] -> [XmppField]
forall a b. (a -> b) -> a -> b
$ [XmppField]
fields
in [XmppField] -> XmppForm
XmppForm [XmppField]
nextFields
setBoolValue :: Bool -> XmppField -> XmppField
setBoolValue :: Bool -> XmppField -> XmppField
setBoolValue Bool
val (BooleanField Text
name Bool
_) = Text -> Bool -> XmppField
BooleanField Text
name Bool
val
setBoolValue Bool
_ XmppField
field = XmppField
field
instance FromXML XmppForm where
decodeXml :: Content Posn -> Maybe XmppForm
decodeXml = XmppForm -> Maybe XmppForm
forall a. a -> Maybe a
Just (XmppForm -> Maybe XmppForm)
-> (Content Posn -> XmppForm) -> Content Posn -> Maybe XmppForm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [XmppField] -> XmppForm
XmppForm ([XmppField] -> XmppForm)
-> (Content Posn -> [XmppField]) -> Content Posn -> XmppForm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Content Posn -> Maybe XmppField) -> [Content Posn] -> [XmppField]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Content Posn -> Maybe XmppField
forall a. FromXML a => Content Posn -> Maybe a
decodeXml ([Content Posn] -> [XmppField])
-> CFilter Posn -> Content Posn -> [XmppField]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> String -> CFilter Posn
forall i. (String -> String) -> String -> CFilter i
xtract String -> String
forall a. a -> a
id String
"/x/field"
instance ToXML XmppForm where
encodeXml :: XmppForm -> [Node]
encodeXml (XmppForm [XmppField]
fields) =
[xml|
<x xmlns="jabber:x:data" type="submit">
$forall field <- fields
$case field
$of HiddenField name value
<field var=#{name}>
<value>#{value}
$of SingleTextField name value
<field var=#{name}>
<value>#{value}
$of BooleanField name value
<field var=#{name}>
<value>
$if value
1
$else
0
$of ListSingleField name _opts value
<field var=#{name}>
<value>#{value}
$of ListMultiField name _opts values
<field var=#{name}>
$forall value <- values
<value>#{value}
|]