{-# LANGUAGE OverloadedStrings #-}

-----------------------------------------------------------------------------
-- |
-- Copyright   :  (c) riskbook, 2020
-- SPDX-License-Identifier:  BSD3
--
-----------------------------------------------------------------------------
module Network.XMPP.XML
  ( strAttr
  , getVals
  , isVal
  , getText
  , getText_
  , txtpat
  , xtractp
  , matchPatterns
  , mread
  , mattr
  , mattr'
  , literal -- from HaXML
  , noelem
  , lookupAttr
  , FromXML(..)
  , ToXML(..)
  ) where

import           Text.XML                       (Node)
import           Text.XML.HaXml                 hiding (tag)
import           Text.XML.HaXml.Posn
import qualified Text.XML.HaXml.Pretty           as P
import           Text.XML.HaXml.Xtract.Parse     (xtract)
import           Text.PrettyPrint.HughesPJ       (hcat)
import           Data.Text                       (Text, pack, unpack)
import           Text.Read
import           Control.Applicative             ((<|>))

class FromXML a where
  decodeXml :: Content Posn -> Maybe a

class ToXML a where
  encodeXml :: a -> [Node]

instance FromXML () where
  decodeXml :: Content Posn -> Maybe ()
decodeXml Content Posn
_ = () -> Maybe ()
forall a. a -> Maybe a
Just ()

instance (FromXML a, FromXML b) => FromXML (Either a b) where
  decodeXml :: Content Posn -> Maybe (Either a b)
decodeXml Content Posn
m = (a -> Either a b
forall a b. a -> Either a b
Left (a -> Either a b) -> Maybe a -> Maybe (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Content Posn -> Maybe a
forall a. FromXML a => Content Posn -> Maybe a
decodeXml Content Posn
m) Maybe (Either a b) -> Maybe (Either a b) -> Maybe (Either a b)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b) -> Maybe b -> Maybe (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Content Posn -> Maybe b
forall a. FromXML a => Content Posn -> Maybe a
decodeXml Content Posn
m)

strAttr :: a -> String -> (a, CFilter i)
strAttr :: a -> String -> (a, CFilter i)
strAttr a
s String
d = (a
s, String -> CFilter i
forall i. String -> CFilter i
literal String
d)

-- | Returns strings extracted by xtract query
getVals :: Text -> [Content Posn] -> [Text]
getVals :: Text -> [Content Posn] -> [Text]
getVals Text
q = (Content Posn -> Text) -> [Content Posn] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ([Content Posn] -> Text
forall i. [Content i] -> Text
getText_ ([Content Posn] -> Text)
-> (Content Posn -> [Content Posn]) -> Content Posn -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> String -> Content Posn -> [Content Posn]
forall i. (String -> String) -> String -> CFilter i
xtract String -> String
forall a. a -> a
id (Text -> String
unpack Text
q))

-- | Queries xml for specific value
-- @isVal str = any (== str) . getVals@
isVal :: Text -> Text -> [Content Posn] -> Bool
isVal :: Text -> Text -> [Content Posn] -> Bool
isVal Text
str Text
cont = (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
str) ([Text] -> Bool)
-> ([Content Posn] -> [Text]) -> [Content Posn] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Content Posn] -> [Text]
getVals Text
cont

-- 
getText :: Content i -> Text
getText :: Content i -> Text
getText cs :: Content i
cs@CString{} = String -> Text
pack (String -> Text) -> (Content i -> String) -> Content i -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> String
render (Doc -> String) -> (Content i -> Doc) -> Content i -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Content i -> Doc
forall i. Content i -> Doc
P.content (Content i -> Text) -> Content i -> Text
forall a b. (a -> b) -> a -> b
$ Content i
cs
getText cs :: Content i
cs@CRef{}    = String -> Text
pack (String -> Text) -> (Content i -> String) -> Content i -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> String
render (Doc -> String) -> (Content i -> Doc) -> Content i -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Content i -> Doc
forall i. Content i -> Doc
P.content (Content i -> Text) -> Content i -> Text
forall a b. (a -> b) -> a -> b
$ Content i
cs
getText Content i
x =
  String -> Text
forall a. HasCallStack => String -> a
error
    (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$  String
"Attempt to extract text from content that is not a string: "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
render (Content i -> Doc
forall i. Content i -> Doc
P.content Content i
x)

getText_ :: [Content i] -> Text
getText_ :: [Content i] -> Text
getText_ = String -> Text
pack (String -> Text) -> ([Content i] -> String) -> [Content i] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> String
render (Doc -> String) -> ([Content i] -> Doc) -> [Content i] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
hcat ([Doc] -> Doc) -> ([Content i] -> [Doc]) -> [Content i] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Content i -> Doc) -> [Content i] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Content i -> Doc
forall i. Content i -> Doc
P.content

-- | Extract text from `Content Posn' with supplied pattern
txtpat :: Text      -- ^ xtract-like pattern to match
    -> Content Posn -- ^ message being processed
    -> Text         -- ^ result of extraction
txtpat :: Text -> Content Posn -> Text
txtpat Text
p Content Posn
m = [Content Posn] -> Text
forall i. [Content i] -> Text
getText_ ([Content Posn] -> Text) -> [Content Posn] -> Text
forall a b. (a -> b) -> a -> b
$ (String -> String) -> String -> Content Posn -> [Content Posn]
forall i. (String -> String) -> String -> CFilter i
xtract String -> String
forall a. a -> a
id (Text -> String
unpack Text
p) Content Posn
m

xtractp :: (Text -> Text) -> Text -> Content i -> Bool
xtractp :: (Text -> Text) -> Text -> Content i -> Bool
xtractp Text -> Text
f Text
p Content i
m = Bool -> Bool
not (Bool -> Bool) -> ([Content i] -> Bool) -> [Content i] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Content i] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Content i] -> Bool) -> [Content i] -> Bool
forall a b. (a -> b) -> a -> b
$ (String -> String) -> String -> CFilter i
forall i. (String -> String) -> String -> CFilter i
xtract (Text -> String
unpack (Text -> String) -> (String -> Text) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
f (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack) (Text -> String
unpack Text
p) Content i
m

matchPatterns :: Content i -> [Text] -> Bool
matchPatterns :: Content i -> [Text] -> Bool
matchPatterns Content i
m = (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Text -> Bool) -> [Text] -> Bool)
-> (Text -> Bool) -> [Text] -> Bool
forall a b. (a -> b) -> a -> b
$ (Text -> Content i -> Bool) -> Content i -> Text -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Text -> Text) -> Text -> Content i -> Bool
forall i. (Text -> Text) -> Text -> Content i -> Bool
xtractp Text -> Text
forall a. a -> a
id) Content i
m

mread :: Read a => Text -> Maybe a
mread :: Text -> Maybe a
mread Text
"" = Maybe a
forall a. Maybe a
Nothing
mread Text
a = String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe a) -> String -> Maybe a
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
a

mattr :: (Show a) => b -> Maybe a -> [(b, CFilter i)]
mattr :: b -> Maybe a -> [(b, CFilter i)]
mattr b
s (Just a
a) = [ b -> String -> (b, CFilter i)
forall a i. a -> String -> (a, CFilter i)
strAttr b
s (a -> String
forall a. Show a => a -> String
show a
a) ]
mattr b
_ Maybe a
Nothing = []

mattr' :: a -> Maybe String -> [(a, CFilter i)]
mattr' :: a -> Maybe String -> [(a, CFilter i)]
mattr' a
s (Just String
a) = [ a -> String -> (a, CFilter i)
forall a i. a -> String -> (a, CFilter i)
strAttr a
s String
a ]
mattr' a
_ Maybe String
Nothing = []

noelem :: Content Posn
noelem :: Content Posn
noelem = Element Posn -> Posn -> Content Posn
forall i. Element i -> i -> Content i
CElem (QName -> [Attribute] -> [Content Posn] -> Element Posn
forall i. QName -> [Attribute] -> [Content i] -> Element i
Elem (String -> QName
N String
"root") [] []) Posn
noPos

lookupAttr :: String -> [Attribute] -> Maybe String
lookupAttr :: String -> [Attribute] -> Maybe String
lookupAttr String
k [Attribute]
lst = do
  AttValue
x <- QName -> [Attribute] -> Maybe AttValue
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (String -> QName
N String
k) [Attribute]
lst
  case AttValue
x of
    AttValue [Left String
str] -> String -> Maybe String
forall a. a -> Maybe a
Just String
str
    AttValue [Either String Reference]
_          -> Maybe String
forall a. Maybe a
Nothing