{-# 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
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]
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
hostnameP :: AP.Parser Text
hostnameP :: Parser Text
hostnameP = do
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]