module Network.Xmpp.Utilities (presTo, message, answerMessage, openElementToEvents, renderOpenElement, renderElement) where
import Network.Xmpp.Types
import Control.Monad.STM
import Control.Concurrent.STM.TVar
import Prelude
import Data.XML.Types
import qualified Data.Attoparsec.Text as AP
import qualified Data.Text as Text
import qualified Data.ByteString as BS
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import System.IO.Unsafe(unsafePerformIO)
import Data.Conduit.List as CL
import Control.Applicative ((<$>))
import Control.Exception
import Control.Monad.Trans.Class
import Data.Conduit as C
import Data.XML.Types
import qualified Text.XML.Stream.Render as TXSR
import Text.XML.Unresolved as TXU
idGenerator :: Text.Text -> IO IdGenerator
idGenerator prefix = atomically $ do
tvar <- newTVar $ ids prefix
return $ IdGenerator $ next tvar
where
next :: TVar [Text.Text] -> IO Text.Text
next tvar = atomically $ do
list <- readTVar tvar
case list of
[] -> error "empty list in Utilities.hs"
(x:xs) -> do
writeTVar tvar xs
return x
ids :: Text.Text -> [Text.Text]
ids p = Prelude.map (\ id -> Text.append p id) ids'
where
ids' :: [Text.Text]
ids' = Prelude.map Text.pack $ Prelude.concatMap ids'' [1..]
ids'' :: Integer -> [String]
ids'' 0 = [""]
ids'' l = [x:xs | x <- repertoire, xs <- ids'' (l 1)]
repertoire :: String
repertoire = ['a'..'z']
versionFromNumbers :: Integer -> Integer -> Version
versionFromNumbers major minor = Version major minor
presTo :: Presence -> Jid -> Presence
presTo pres to = pres{presenceTo = Just to}
message :: Message
message = Message { messageID = Nothing
, messageFrom = Nothing
, messageTo = Nothing
, messageLangTag = Nothing
, messageType = Normal
, messagePayload = []
}
answerMessage :: Message -> [Element] -> Maybe Message
answerMessage Message{messageFrom = Just frm, ..} payload =
Just Message{ messageFrom = messageTo
, messageID = Nothing
, messageTo = Just frm
, messagePayload = payload
, ..
}
answerMessage _ _ = Nothing
openElementToEvents :: Element -> [Event]
openElementToEvents (Element name as ns) = EventBeginElement name as : goN ns []
where
goE (Element name' as' ns') =
(EventBeginElement name' as' :)
. goN ns'
. (EventEndElement name' :)
goN [] = id
goN [x] = goN' x
goN (x:xs) = goN' x . goN xs
goN' (NodeElement e) = goE e
goN' (NodeInstruction i) = (EventInstruction i :)
goN' (NodeContent c) = (EventContent c :)
goN' (NodeComment t) = (EventComment t :)
renderOpenElement :: Element -> BS.ByteString
renderOpenElement e = Text.encodeUtf8 . Text.concat . unsafePerformIO
$ CL.sourceList (openElementToEvents e) $$ TXSR.renderText def =$ CL.consume
renderElement :: Element -> BS.ByteString
renderElement e = Text.encodeUtf8 . Text.concat . unsafePerformIO
$ CL.sourceList (elementToEvents e) $$ TXSR.renderText def =$ CL.consume
where
elementToEvents :: Element -> [Event]
elementToEvents e@(Element name _ _) = openElementToEvents e ++ [EventEndElement name]