{-# 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 :: TMVar a -> (a -> IO (c, a)) -> IO c
withTMVar TMVar a
tv a -> IO (c, a)
f = IO a -> (a -> IO ()) -> (a -> IO c) -> IO c
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError (STM a -> IO a
forall a. STM a -> IO a
atomically (STM a -> IO a) -> STM a -> IO a
forall a b. (a -> b) -> a -> b
$ TMVar a -> STM a
forall a. TMVar a -> STM a
takeTMVar TMVar a
tv)
                                (STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (a -> STM ()) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar a -> a -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar a
tv)
                                (\a
s -> do
                                      (c
x, a
s') <- a -> IO (c, a)
f a
s
                                      STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar a -> a -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar a
tv a
s'
                                      c -> IO c
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 Event -> [Event] -> [Event]
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' Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
:)
        ([Event] -> [Event]) -> ([Event] -> [Event]) -> [Event] -> [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node] -> [Event] -> [Event]
goN [Node]
ns'
        ([Event] -> [Event]) -> ([Event] -> [Event]) -> [Event] -> [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Event
EventEndElement Name
name' Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
:)
    goN :: [Node] -> [Event] -> [Event]
goN [] = [Event] -> [Event]
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 ([Event] -> [Event]) -> ([Event] -> [Event]) -> [Event] -> [Event]
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 Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
:)
    goN' (NodeContent Content
c) = (Content -> Event
EventContent Content
c Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
:)
    goN' (NodeComment Text
t) = (Text -> Event
EventComment Text
t Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
:)

renderOpenElement :: Element -> BS.ByteString
renderOpenElement :: Element -> ByteString
renderOpenElement Element
e = Text -> ByteString
Text.encodeUtf8 (Text -> ByteString)
-> (IO [Text] -> Text) -> IO [Text] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Text.concat ([Text] -> Text) -> (IO [Text] -> [Text]) -> IO [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO [Text] -> [Text]
forall a. IO a -> a
unsafePerformIO
    (IO [Text] -> ByteString) -> IO [Text] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Event] -> ConduitT () Event IO ()
forall (m :: * -> *) a i. Monad m => [a] -> ConduitT i a m ()
CL.sourceList (Element -> [Event]
openElementToEvents Element
e) ConduitT () Event IO () -> Sink Event IO [Text] -> IO [Text]
forall (m :: * -> *) a b.
Monad m =>
Source m a -> Sink a m b -> m b
$$ RenderSettings -> ConduitT Event Text IO ()
forall (m :: * -> *).
(PrimMonad m, MonadThrow m) =>
RenderSettings -> ConduitT Event Text m ()
TXSR.renderText RenderSettings
forall a. Default a => a
def ConduitT Event Text IO ()
-> ConduitT Text Void IO [Text] -> Sink Event IO [Text]
forall (m :: * -> *) a b c r.
Monad m =>
Conduit a m b -> ConduitT b c m r -> ConduitT a c m r
=$ ConduitT Text Void IO [Text]
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 (Text -> ByteString)
-> (IO [Text] -> Text) -> IO [Text] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Text.concat ([Text] -> Text) -> (IO [Text] -> [Text]) -> IO [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO [Text] -> [Text]
forall a. IO a -> a
unsafePerformIO
    (IO [Text] -> ByteString) -> IO [Text] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Event] -> ConduitT () Event IO ()
forall (m :: * -> *) a i. Monad m => [a] -> ConduitT i a m ()
CL.sourceList (Element -> [Event]
elementToEvents Element
e) ConduitT () Event IO () -> Sink Event IO [Text] -> IO [Text]
forall (m :: * -> *) a b.
Monad m =>
Source m a -> Sink a m b -> m b
$$ RenderSettings -> ConduitT Event Text IO ()
forall (m :: * -> *).
(PrimMonad m, MonadThrow m) =>
RenderSettings -> ConduitT Event Text m ()
TXSR.renderText RenderSettings
forall a. Default a => a
def ConduitT Event Text IO ()
-> ConduitT Text Void IO [Text] -> Sink Event IO [Text]
forall (m :: * -> *) a b c r.
Monad m =>
Conduit a m b -> ConduitT b c m r -> ConduitT a c m r
=$ ConduitT Text Void IO [Text]
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
                                              [Event] -> [Event] -> [Event]
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 =
    Either String Text -> Maybe Text
forall b a. Either b a -> Maybe a
eitherToMaybeHostName (Either String Text -> Maybe Text)
-> Either String Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Parser Text -> Text -> Either String Text
forall a. Parser a -> Text -> Either String a
AP.parseOnly Parser Text
hostnameP Text
t
  where
    eitherToMaybeHostName :: Either b a -> Maybe a
eitherToMaybeHostName = (b -> Maybe a) -> (a -> Maybe a) -> Either b a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> b -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) a -> Maybe a
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 ((Char -> Bool) -> Parser Char) -> (Char -> Bool) -> Parser Char
forall a b. (a -> b) -> a -> b
$ String -> Char -> Bool
AP.inClass (String -> Char -> Bool) -> String -> Char -> Bool
forall a b. (a -> b) -> a -> b
$ [Char
'A'..Char
'Z'] String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
'a'..Char
'z'] String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
'0'..Char
'9']
    Text
t <- (Char -> Bool) -> Parser Text
AP.takeWhile ((Char -> Bool) -> Parser Text) -> (Char -> Bool) -> Parser Text
forall a b. (a -> b) -> a -> b
$ String -> Char -> Bool
AP.inClass (String -> Char -> Bool) -> String -> Char -> Bool
forall a b. (a -> b) -> a -> b
$ [Char
'A'..Char
'Z'] String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
'a'..Char
'z'] String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
'0'..Char
'9'] String -> String -> String
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
63
        then String -> Parser Text
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Label too long."
        else do
            Parser Text ()
forall t. Chunk t => Parser t ()
AP.endOfInput
            Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
label
            Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do
                Char
_ <- (Char -> Bool) -> Parser Char
AP.satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.')
                Text
r <- Parser Text
hostnameP
                if Text -> Int
Text.length Text
label Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Text -> Int
Text.length Text
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
255
                    then String -> Parser Text
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Hostname too long."
                    else Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.concat [Text
label, String -> Text
Text.pack String
".", Text
r]