{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE DataKinds         #-}

-----------------------------------------------------------------------------
-- |
-- Copyright   :  (c) riskbook, 2020
-- SPDX-License-Identifier:  BSD3
--
-----------------------------------------------------------------------------
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

-- Specification:
-- https://xmpp.org/extensions/xep-0004.html#table-2
--

-- https://xmpp.org/extensions/xep-0004.html#table-2
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}
    |]