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