-----------------------------------------------------------------------------
-- |
-- Module      :  Network.XMPP.Print
-- Copyright   :  (c) Dmitry Astapov, 2006 ; pierre, 2007
-- License     :  BSD-style (see the file LICENSE)
-- Copyright   :  (c) riskbook, 2020
-- SPDX-License-Identifier:  BSD3
-- 
-- Maintainer  :  Dmitry Astapov <dastapov@gmail.com>, pierre <k.pierre.k@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- An XMPP pretty-printing combinators
-- Ported from Text.HTML to HaXML combinatiors
--
-----------------------------------------------------------------------------

module Network.XMPP.Print
  ( -- Top-level rendering functions
    renderXmpp
  , putXmppLn
  , hPutXmpp
  , hPutNode
    -- XMPP primitives: tags
  , stream
  , streamEnd
    -- XMPP primitives: attributes
  , to
  ) where

import           System.IO
import qualified Data.Text                       as T
import qualified Data.Text.Lazy                  as TL
import           Text.XML                        (Node)
import           Text.XML.HaXml                  hiding (tag)
import           Text.XML.HaXml.Posn             (Posn)
import qualified Text.XML.HaXml.Pretty           as P
import           Text.Blaze.Renderer.Text        (renderMarkup)
import           Text.Blaze                      (toMarkup)

import           Network.XMPP.UTF8
import           Network.XMPP.Utils
import           Network.XMPP.XML

-- | Convert the internal representation (built using HaXml combinators) into string, 
-- and print it out
putXmppLn :: Content Posn -> IO ()
putXmppLn :: Content Posn -> IO ()
putXmppLn = String -> IO ()
putStrLn (String -> IO ())
-> (Content Posn -> String) -> Content Posn -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Content Posn -> String
renderXmpp

-- | Convert the internal representation (built using HaXml combinators) into string, 
-- and print it to the specified Handle, without trailing newline
hPutXmpp :: Handle -> Content Posn -> IO ()
hPutXmpp :: Handle -> Content Posn -> IO ()
hPutXmpp Handle
h Content Posn
msg = 
  do let str :: String
str = Content Posn -> String
renderXmpp Content Posn
msg
     String -> IO ()
debugIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Sending: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str
     Handle -> String -> IO ()
hPutStr Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String
toUTF8 String
str

hPutNode :: Handle -> Node -> IO ()
hPutNode :: Handle -> Node -> IO ()
hPutNode Handle
h Node
n = do
  let str :: String
str = Text -> String
T.unpack (Text -> String) -> (Node -> Text) -> Node -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.toStrict (Text -> Text) -> (Node -> Text) -> Node -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Markup -> Text
renderMarkup (Markup -> Text) -> (Node -> Markup) -> Node -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> Markup
forall a. ToMarkup a => a -> Markup
toMarkup (Node -> String) -> Node -> String
forall a b. (a -> b) -> a -> b
$ Node
n
  String -> IO ()
debugIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Sending: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str
  Handle -> String -> IO ()
hPutStr Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String
toUTF8 String
str

-- | Render HaXML combinators into string, hacked for XMPP
renderXmpp :: Content Posn -> String
renderXmpp :: Content Posn -> String
renderXmpp Content Posn
theXml = case Content Posn
theXml of
  -- stupid hack for <stream:stream> and </stream:stream>
  xml :: Content Posn
xml@(CElem (Elem (N String
"stream:stream") [Attribute]
_ [Content Posn]
_) Posn
_) ->
    (:) Char
'<' (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'<') (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
tail (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ Content Posn -> Doc
forall i. Content i -> Doc
P.content Content Posn
xml
  Content Posn
xml -> Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ Content Posn -> Doc
forall i. Content i -> Doc
P.content Content Posn
xml


---
--- XMPP construction combinators, based on the Text.Html
---

stream :: Show a => a -> T.Text -> CFilter i
stream :: a -> Text -> CFilter i
stream a
typ Text
server =
  String -> [(String, CFilter i)] -> [CFilter i] -> CFilter i
forall i.
String -> [(String, CFilter i)] -> [CFilter i] -> CFilter i
mkElemAttr String
"stream:stream"
    [ String -> String -> (String, CFilter i)
forall a i. a -> String -> (a, CFilter i)
strAttr String
"xmlns:stream" String
"http://etherx.jabber.org/streams"
    , String -> String -> (String, CFilter i)
forall a i. a -> String -> (a, CFilter i)
strAttr String
"xml:language" String
"en"
    , String -> String -> (String, CFilter i)
forall a i. a -> String -> (a, CFilter i)
strAttr String
"version" String
"1.0"
    , String -> String -> (String, CFilter i)
forall a i. a -> String -> (a, CFilter i)
strAttr String
"to" (String -> (String, CFilter i)) -> String -> (String, CFilter i)
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
server
    , String -> String -> (String, CFilter i)
forall a i. a -> String -> (a, CFilter i)
strAttr String
"xmlns" (a -> String
forall a. Show a => a -> String
show a
typ)
    ]
    [ String -> [(String, CFilter i)] -> [CFilter i] -> CFilter i
forall i.
String -> [(String, CFilter i)] -> [CFilter i] -> CFilter i
mkElemAttr String
"" [] []  ]
-- TODO: to use hamlet here, we shoud be able to render non-closing tag like `<stream ...>`
--       but hamlet autho close tags and i see no ways to control it
-- head [xml|
--   <stream:stream
--     xmlns:stream="http://etherx.jabber.org/streams"
--     xml:language="en"
--     version="1.0"
--     to=#{T.pack server}
--     xmlns=#{T.pack (show typ)}
--   />
--

streamEnd :: CFilter i
streamEnd :: CFilter i
streamEnd = String -> [(String, CFilter i)] -> [CFilter i] -> CFilter i
forall i.
String -> [(String, CFilter i)] -> [CFilter i] -> CFilter i
mkElemAttr String
"/stream:stream" [] [String -> [(String, CFilter i)] -> [CFilter i] -> CFilter i
forall i.
String -> [(String, CFilter i)] -> [CFilter i] -> CFilter i
mkElemAttr String
"" [] []]

---
--- Predefined XMPP attributes
---
to :: String -> (String, CFilter i)
to :: String -> (String, CFilter i)
to = String -> String -> (String, CFilter i)
forall a i. a -> String -> (a, CFilter i)
strAttr String
"to"