{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Network.Xmpp.Utilities
    ( openElementToEvents
    , renderOpenElement
    , renderElement
    , checkHostName
    , withTMVar
    )
    where

import           Control.Applicative ((<|>))
import           Control.Concurrent.STM
import           Control.Exception
import           Control.Monad.State.Strict
import qualified Data.Attoparsec.Text as AP
import qualified Data.ByteString as BS
import           Data.Conduit as C
import           Data.Conduit.List as CL
import qualified Data.Text as Text
import           Data.Text(Text)
import qualified Data.Text.Encoding as Text
import           Data.XML.Types
import           Prelude
import           System.IO.Unsafe(unsafePerformIO)
import qualified Text.XML.Stream.Render as TXSR
import           Text.XML.Unresolved as TXU

-- | Apply f with the content of tv as state, restoring the original value when an
-- exception occurs
withTMVar :: TMVar a -> (a -> IO (c, a)) -> IO c
withTMVar :: forall a c. TMVar a -> (a -> IO (c, a)) -> IO c
withTMVar TMVar a
tv a -> IO (c, a)
f = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError (forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> STM a
takeTMVar TMVar a
tv)
                                (forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TMVar a -> a -> STM ()
putTMVar TMVar a
tv)
                                (\a
s -> do
                                      (c
x, a
s') <- a -> IO (c, a)
f a
s
                                      forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> a -> STM ()
putTMVar TMVar a
tv a
s'
                                      forall (m :: * -> *) a. Monad m => a -> m a
return c
x
                                )

openElementToEvents :: Element -> [Event]
openElementToEvents :: Element -> [Event]
openElementToEvents (Element Name
name [(Name, [Content])]
as [Node]
ns) = Name -> [(Name, [Content])] -> Event
EventBeginElement Name
name [(Name, [Content])]
as forall a. a -> [a] -> [a]
: [Node] -> [Event] -> [Event]
goN [Node]
ns []
  where
    goE :: Element -> [Event] -> [Event]
goE (Element Name
name' [(Name, [Content])]
as' [Node]
ns') =
          (Name -> [(Name, [Content])] -> Event
EventBeginElement Name
name' [(Name, [Content])]
as' forall a. a -> [a] -> [a]
:)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node] -> [Event] -> [Event]
goN [Node]
ns'
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Event
EventEndElement Name
name' forall a. a -> [a] -> [a]
:)
    goN :: [Node] -> [Event] -> [Event]
goN [] = forall a. a -> a
id
    goN [Node
x] = Node -> [Event] -> [Event]
goN' Node
x
    goN (Node
x:[Node]
xs) = Node -> [Event] -> [Event]
goN' Node
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node] -> [Event] -> [Event]
goN [Node]
xs
    goN' :: Node -> [Event] -> [Event]
goN' (NodeElement Element
e) = Element -> [Event] -> [Event]
goE Element
e
    goN' (NodeInstruction Instruction
i) = (Instruction -> Event
EventInstruction Instruction
i forall a. a -> [a] -> [a]
:)
    goN' (NodeContent Content
c) = (Content -> Event
EventContent Content
c forall a. a -> [a] -> [a]
:)
    goN' (NodeComment Text
t) = (Text -> Event
EventComment Text
t forall a. a -> [a] -> [a]
:)

renderOpenElement :: Element -> BS.ByteString
renderOpenElement :: Element -> ByteString
renderOpenElement Element
e = Text -> ByteString
Text.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Text.concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IO a -> a
unsafePerformIO
    forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a i. Monad m => [a] -> ConduitT i a m ()
CL.sourceList (Element -> [Event]
openElementToEvents Element
e) forall (m :: * -> *) a b.
Monad m =>
Source m a -> Sink a m b -> m b
$$ forall (m :: * -> *).
(PrimMonad m, MonadThrow m) =>
RenderSettings -> ConduitT Event Text m ()
TXSR.renderText forall a. Default a => a
def forall (m :: * -> *) a b c r.
Monad m =>
Conduit a m b -> ConduitT b c m r -> ConduitT a c m r
=$ forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume

renderElement :: Element -> BS.ByteString
renderElement :: Element -> ByteString
renderElement Element
e = Text -> ByteString
Text.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Text.concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IO a -> a
unsafePerformIO
    forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a i. Monad m => [a] -> ConduitT i a m ()
CL.sourceList (Element -> [Event]
elementToEvents Element
e) forall (m :: * -> *) a b.
Monad m =>
Source m a -> Sink a m b -> m b
$$ forall (m :: * -> *).
(PrimMonad m, MonadThrow m) =>
RenderSettings -> ConduitT Event Text m ()
TXSR.renderText forall a. Default a => a
def forall (m :: * -> *) a b c r.
Monad m =>
Conduit a m b -> ConduitT b c m r -> ConduitT a c m r
=$ forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume
  where
    elementToEvents :: Element -> [Event]
    elementToEvents :: Element -> [Event]
elementToEvents el :: Element
el@(Element Name
name [(Name, [Content])]
_ [Node]
_) = Element -> [Event]
openElementToEvents Element
el
                                              forall a. [a] -> [a] -> [a]
++ [Name -> Event
EventEndElement Name
name]

-- | Validates the hostname string in accordance with RFC 1123.
checkHostName :: Text -> Maybe Text
checkHostName :: Text -> Maybe Text
checkHostName Text
t =
    forall {a} {a}. Either a a -> Maybe a
eitherToMaybeHostName forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Text -> Either String a
AP.parseOnly Parser Text
hostnameP Text
t
  where
    eitherToMaybeHostName :: Either a a -> Maybe a
eitherToMaybeHostName = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just

-- Validation of RFC 1123 hostnames.
hostnameP :: AP.Parser Text
hostnameP :: Parser Text
hostnameP = do
    -- Hostnames may not begin with a hyphen.
    Char
h <- (Char -> Bool) -> Parser Char
AP.satisfy forall a b. (a -> b) -> a -> b
$ String -> Char -> Bool
AP.inClass forall a b. (a -> b) -> a -> b
$ [Char
'A'..Char
'Z'] forall a. [a] -> [a] -> [a]
++ [Char
'a'..Char
'z'] forall a. [a] -> [a] -> [a]
++ [Char
'0'..Char
'9']
    Text
t <- (Char -> Bool) -> Parser Text
AP.takeWhile forall a b. (a -> b) -> a -> b
$ String -> Char -> Bool
AP.inClass forall a b. (a -> b) -> a -> b
$ [Char
'A'..Char
'Z'] forall a. [a] -> [a] -> [a]
++ [Char
'a'..Char
'z'] forall a. [a] -> [a] -> [a]
++ [Char
'0'..Char
'9'] forall a. [a] -> [a] -> [a]
++ [Char
'-']
    let label :: Text
label = [Text] -> Text
Text.concat [String -> Text
Text.pack [Char
h], Text
t]
    if Text -> Int
Text.length Text
label forall a. Ord a => a -> a -> Bool
> Int
63
        then forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Label too long."
        else do
            forall t. Chunk t => Parser t ()
AP.endOfInput
            forall (m :: * -> *) a. Monad m => a -> m a
return Text
label
            forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do
                Char
_ <- (Char -> Bool) -> Parser Char
AP.satisfy (forall a. Eq a => a -> a -> Bool
== Char
'.')
                Text
r <- Parser Text
hostnameP
                if Text -> Int
Text.length Text
label forall a. Num a => a -> a -> a
+ Int
1 forall a. Num a => a -> a -> a
+ Text -> Int
Text.length Text
r forall a. Ord a => a -> a -> Bool
> Int
255
                    then forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Hostname too long."
                    else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.concat [Text
label, String -> Text
Text.pack String
".", Text
r]