Browse Source
Conflicts: source/Network/Xmpp/Concurrent/Types.hs source/Network/Xmpp/Connection_.hs source/Network/Xmpp/Internal.hs source/Network/Xmpp/Pickle.hs source/Network/Xmpp/Session.hs source/Network/Xmpp/Stream.hs source/Network/Xmpp/Types.hs source/Network/Xmpp/Xep/InbandRegistration.hsmaster
Philipp Balzarek
13 years ago
29 changed files with 1148 additions and 790 deletions
|
After Width: | Height: | Size: 326 KiB |
|
After Width: | Height: | Size: 81 KiB |
@ -1,81 +0,0 @@
@@ -1,81 +0,0 @@
|
||||
{-# Language NoMonomorphismRestriction #-} |
||||
{-# OPTIONS_HADDOCK hide #-} |
||||
module Data.Conduit.Tls |
||||
( tlsinit |
||||
-- , conduitStdout |
||||
, module TLS |
||||
, module TLSExtra |
||||
) |
||||
where |
||||
|
||||
import Control.Monad |
||||
import Control.Monad (liftM, when) |
||||
import Control.Monad.IO.Class |
||||
|
||||
import Crypto.Random |
||||
|
||||
import qualified Data.ByteString as BS |
||||
import qualified Data.ByteString.Lazy as BL |
||||
import Data.Conduit |
||||
import qualified Data.Conduit.Binary as CB |
||||
import Data.IORef |
||||
|
||||
import Network.TLS as TLS |
||||
import Crypto.Random.API |
||||
import Network.TLS.Extra as TLSExtra |
||||
|
||||
import System.IO (Handle) |
||||
|
||||
client params gen backend = do |
||||
contextNew backend params gen |
||||
|
||||
defaultParams = defaultParamsClient |
||||
|
||||
tlsinit :: (MonadIO m, MonadIO m1) => |
||||
Bool |
||||
-> TLSParams |
||||
-> Backend |
||||
-> m ( Source m1 BS.ByteString |
||||
, Sink BS.ByteString m1 () |
||||
, BS.ByteString -> IO () |
||||
, Int -> m1 BS.ByteString |
||||
, Context |
||||
) |
||||
tlsinit debug tlsParams backend = do |
||||
when debug . liftIO $ putStrLn "TLS with debug mode enabled" |
||||
gen <- liftIO $ getSystemRandomGen -- TODO: Find better random source? |
||||
con <- client tlsParams gen backend |
||||
handshake con |
||||
let src = forever $ do |
||||
dt <- liftIO $ recvData con |
||||
when debug (liftIO $ putStr "in: " >> BS.putStrLn dt) |
||||
yield dt |
||||
let snk = do |
||||
d <- await |
||||
case d of |
||||
Nothing -> return () |
||||
Just x -> do |
||||
sendData con (BL.fromChunks [x]) |
||||
when debug (liftIO $ putStr "out: " >> BS.putStrLn x) |
||||
snk |
||||
read <- liftIO $ mkReadBuffer (recvData con) |
||||
return ( src |
||||
, snk |
||||
, \s -> do |
||||
when debug (liftIO $ BS.putStrLn s) |
||||
sendData con $ BL.fromChunks [s] |
||||
, liftIO . read |
||||
, con |
||||
) |
||||
|
||||
mkReadBuffer :: IO BS.ByteString -> IO (Int -> IO BS.ByteString) |
||||
mkReadBuffer read = do |
||||
buffer <- newIORef BS.empty |
||||
let read' n = do |
||||
nc <- readIORef buffer |
||||
bs <- if BS.null nc then read |
||||
else return nc |
||||
let (result, rest) = BS.splitAt n bs |
||||
writeIORef buffer rest |
||||
return result |
||||
return read' |
||||
@ -1,57 +0,0 @@
@@ -1,57 +0,0 @@
|
||||
{-# LANGUAGE OverloadedStrings #-} |
||||
|
||||
{-# OPTIONS_HADDOCK hide #-} |
||||
|
||||
module Network.Xmpp.Bind where |
||||
|
||||
import Control.Exception |
||||
|
||||
import Data.Text as Text |
||||
import Data.XML.Pickle |
||||
import Data.XML.Types |
||||
|
||||
import Network.Xmpp.Connection_ |
||||
import Network.Xmpp.Pickle |
||||
import Network.Xmpp.Types |
||||
|
||||
import Control.Monad.State(modify) |
||||
|
||||
import Control.Concurrent.STM.TMVar |
||||
|
||||
import Control.Monad.Error |
||||
|
||||
-- Produces a `bind' element, optionally wrapping a resource. |
||||
bindBody :: Maybe Text -> Element |
||||
bindBody = pickleElem $ |
||||
-- Pickler to produce a |
||||
-- "<bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'/>" |
||||
-- element, with a possible "<resource>[JID]</resource>" |
||||
-- child. |
||||
xpBind . xpOption $ xpElemNodes "resource" (xpContent xpId) |
||||
|
||||
-- Sends a (synchronous) IQ set request for a (`Just') given or server-generated |
||||
-- resource and extract the JID from the non-error response. |
||||
xmppBind :: Maybe Text -> TMVar Connection -> IO (Either XmppFailure Jid) |
||||
xmppBind rsrc c = runErrorT $ do |
||||
answer <- ErrorT $ pushIQ' "bind" Nothing Set Nothing (bindBody rsrc) c |
||||
case answer of |
||||
Right IQResult{iqResultPayload = Just b} -> do |
||||
let jid = unpickleElem xpJid b |
||||
case jid of |
||||
Right jid' -> do |
||||
ErrorT $ withConnection (do |
||||
modify $ \s -> s{cJid = Just jid'} |
||||
return $ Right jid') c -- not pretty |
||||
return jid' |
||||
otherwise -> throwError XmppOtherFailure |
||||
-- TODO: Log: ("Bind couldn't unpickle JID from " ++ show answer) |
||||
otherwise -> throwError XmppOtherFailure |
||||
where |
||||
-- Extracts the character data in the `jid' element. |
||||
xpJid :: PU [Node] Jid |
||||
xpJid = xpBind $ xpElemNodes jidName (xpContent xpPrim) |
||||
jidName = "{urn:ietf:params:xml:ns:xmpp-bind}jid" |
||||
|
||||
-- A `bind' element pickler. |
||||
xpBind :: PU [Node] b -> PU [Node] b |
||||
xpBind c = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-bind}bind" c |
||||
@ -1,205 +0,0 @@
@@ -1,205 +0,0 @@
|
||||
{-# OPTIONS_HADDOCK hide #-} |
||||
|
||||
-- This module deals with JIDs, also known as XMPP addresses. For more |
||||
-- information on JIDs, see RFC 6122: XMPP: Address Format. |
||||
|
||||
module Network.Xmpp.Jid |
||||
( Jid(..) |
||||
, fromText |
||||
, fromStrings |
||||
, isBare |
||||
, isFull |
||||
) where |
||||
|
||||
import Control.Applicative ((<$>),(<|>)) |
||||
import Control.Monad(guard) |
||||
|
||||
import qualified Data.Attoparsec.Text as AP |
||||
import Data.Maybe(fromJust) |
||||
import qualified Data.Set as Set |
||||
import Data.String (IsString(..)) |
||||
import Data.Text (Text) |
||||
import qualified Data.Text as Text |
||||
import qualified Text.NamePrep as SP |
||||
import qualified Text.StringPrep as SP |
||||
|
||||
-- | A JID is XMPP\'s native format for addressing entities in the network. It |
||||
-- is somewhat similar to an e-mail address but contains three parts instead of |
||||
-- two. |
||||
data Jid = Jid { -- | The @localpart@ of a JID is an optional identifier placed |
||||
-- before the domainpart and separated from the latter by a |
||||
-- \'\@\' character. Typically a localpart uniquely identifies |
||||
-- the entity requesting and using network access provided by a |
||||
-- server (i.e., a local account), although it can also |
||||
-- represent other kinds of entities (e.g., a chat room |
||||
-- associated with a multi-user chat service). The entity |
||||
-- represented by an XMPP localpart is addressed within the |
||||
-- context of a specific domain (i.e., |
||||
-- @localpart\@domainpart@). |
||||
localpart :: !(Maybe Text) |
||||
|
||||
-- | The domainpart typically identifies the /home/ server to |
||||
-- which clients connect for XML routing and data management |
||||
-- functionality. However, it is not necessary for an XMPP |
||||
-- domainpart to identify an entity that provides core XMPP |
||||
-- server functionality (e.g., a domainpart can identify an |
||||
-- entity such as a multi-user chat service, a |
||||
-- publish-subscribe service, or a user directory). |
||||
, domainpart :: !Text |
||||
|
||||
-- | The resourcepart of a JID is an optional identifier placed |
||||
-- after the domainpart and separated from the latter by the |
||||
-- \'\/\' character. A resourcepart can modify either a |
||||
-- @localpart\@domainpart@ address or a mere @domainpart@ |
||||
-- address. Typically a resourcepart uniquely identifies a |
||||
-- specific connection (e.g., a device or location) or object |
||||
-- (e.g., an occupant in a multi-user chat room) belonging to |
||||
-- the entity associated with an XMPP localpart at a domain |
||||
-- (i.e., @localpart\@domainpart/resourcepart@). |
||||
, resourcepart :: !(Maybe Text) |
||||
} deriving Eq |
||||
|
||||
instance Show Jid where |
||||
show (Jid nd dmn res) = |
||||
maybe "" ((++ "@") . Text.unpack) nd ++ Text.unpack dmn ++ |
||||
maybe "" (('/' :) . Text.unpack) res |
||||
|
||||
instance Read Jid where |
||||
readsPrec _ x = case fromText (Text.pack x) of |
||||
Nothing -> [] |
||||
Just j -> [(j,"")] |
||||
|
||||
instance IsString Jid where |
||||
fromString = fromJust . fromText . Text.pack |
||||
|
||||
-- | Converts a Text to a JID. |
||||
fromText :: Text -> Maybe Jid |
||||
fromText t = do |
||||
(l, d, r) <- eitherToMaybe $ AP.parseOnly jidParts t |
||||
fromStrings l d r |
||||
where |
||||
eitherToMaybe = either (const Nothing) Just |
||||
|
||||
-- | Converts localpart, domainpart, and resourcepart strings to a JID. Runs the |
||||
-- appropriate stringprep profiles and validates the parts. |
||||
fromStrings :: Maybe Text -> Text -> Maybe Text -> Maybe Jid |
||||
fromStrings l d r = do |
||||
localPart <- case l of |
||||
Nothing -> return Nothing |
||||
Just l'-> do |
||||
l'' <- SP.runStringPrep nodeprepProfile l' |
||||
guard $ validPartLength l'' |
||||
let prohibMap = Set.fromList nodeprepExtraProhibitedCharacters |
||||
guard $ Text.all (`Set.notMember` prohibMap) l'' |
||||
return $ Just l'' |
||||
domainPart <- SP.runStringPrep (SP.namePrepProfile False) d |
||||
guard $ validDomainPart domainPart |
||||
resourcePart <- case r of |
||||
Nothing -> return Nothing |
||||
Just r' -> do |
||||
r'' <- SP.runStringPrep resourceprepProfile r' |
||||
guard $ validPartLength r'' |
||||
return $ Just r'' |
||||
return $ Jid localPart domainPart resourcePart |
||||
where |
||||
validDomainPart :: Text -> Bool |
||||
validDomainPart _s = True -- TODO |
||||
|
||||
validPartLength :: Text -> Bool |
||||
validPartLength p = Text.length p > 0 && Text.length p < 1024 |
||||
|
||||
-- | Returns 'True' if the JID is /bare/, and 'False' otherwise. |
||||
isBare :: Jid -> Bool |
||||
isBare j | resourcepart j == Nothing = True |
||||
| otherwise = False |
||||
|
||||
-- | Returns 'True' if the JID is /full/, and 'False' otherwise. |
||||
isFull :: Jid -> Bool |
||||
isFull = not . isBare |
||||
|
||||
-- Parses an JID string and returns its three parts. It performs no validation |
||||
-- or transformations. |
||||
jidParts :: AP.Parser (Maybe Text, Text, Maybe Text) |
||||
jidParts = do |
||||
-- Read until we reach an '@', a '/', or EOF. |
||||
a <- AP.takeWhile1 (AP.notInClass ['@', '/']) |
||||
-- Case 1: We found an '@', and thus the localpart. At least the domainpart |
||||
-- is remaining. Read the '@' and until a '/' or EOF. |
||||
do |
||||
b <- domainPartP |
||||
-- Case 1A: We found a '/' and thus have all the JID parts. Read the '/' |
||||
-- and until EOF. |
||||
do |
||||
c <- resourcePartP -- Parse resourcepart |
||||
return (Just a, b, Just c) |
||||
-- Case 1B: We have reached EOF; the JID is in the form |
||||
-- localpart@domainpart. |
||||
<|> do |
||||
AP.endOfInput |
||||
return (Just a, b, Nothing) |
||||
-- Case 2: We found a '/'; the JID is in the form |
||||
-- domainpart/resourcepart. |
||||
<|> do |
||||
b <- resourcePartP |
||||
AP.endOfInput |
||||
return (Nothing, a, Just b) |
||||
-- Case 3: We have reached EOF; we have an JID consisting of only a |
||||
-- domainpart. |
||||
<|> do |
||||
AP.endOfInput |
||||
return (Nothing, a, Nothing) |
||||
where |
||||
-- Read an '@' and everything until a '/'. |
||||
domainPartP :: AP.Parser Text |
||||
domainPartP = do |
||||
_ <- AP.char '@' |
||||
AP.takeWhile1 (/= '/') |
||||
-- Read everything until a '/'. |
||||
resourcePartP :: AP.Parser Text |
||||
resourcePartP = do |
||||
_ <- AP.char '/' |
||||
AP.takeText |
||||
|
||||
-- The `nodeprep' StringPrep profile. |
||||
nodeprepProfile :: SP.StringPrepProfile |
||||
nodeprepProfile = SP.Profile { SP.maps = [SP.b1, SP.b2] |
||||
, SP.shouldNormalize = True |
||||
, SP.prohibited = [SP.a1 |
||||
, SP.c11 |
||||
, SP.c12 |
||||
, SP.c21 |
||||
, SP.c22 |
||||
, SP.c3 |
||||
, SP.c4 |
||||
, SP.c5 |
||||
, SP.c6 |
||||
, SP.c7 |
||||
, SP.c8 |
||||
, SP.c9 |
||||
] |
||||
, SP.shouldCheckBidi = True |
||||
} |
||||
|
||||
-- These characters needs to be checked for after normalization. |
||||
nodeprepExtraProhibitedCharacters :: [Char] |
||||
nodeprepExtraProhibitedCharacters = ['\x22', '\x26', '\x27', '\x2F', '\x3A', |
||||
'\x3C', '\x3E', '\x40'] |
||||
|
||||
-- The `resourceprep' StringPrep profile. |
||||
resourceprepProfile :: SP.StringPrepProfile |
||||
resourceprepProfile = SP.Profile { SP.maps = [SP.b1] |
||||
, SP.shouldNormalize = True |
||||
, SP.prohibited = [ SP.a1 |
||||
, SP.c12 |
||||
, SP.c21 |
||||
, SP.c22 |
||||
, SP.c3 |
||||
, SP.c4 |
||||
, SP.c5 |
||||
, SP.c6 |
||||
, SP.c7 |
||||
, SP.c8 |
||||
, SP.c9 |
||||
] |
||||
, SP.shouldCheckBidi = True |
||||
} |
||||
@ -1,36 +0,0 @@
@@ -1,36 +0,0 @@
|
||||
{-# LANGUAGE RecordWildCards #-} |
||||
{-# OPTIONS_HADDOCK hide #-} |
||||
|
||||
module Network.Xmpp.Message |
||||
( Message(..) |
||||
, MessageError(..) |
||||
, MessageType(..) |
||||
, answerMessage |
||||
, message |
||||
) where |
||||
|
||||
import Data.XML.Types |
||||
|
||||
import Network.Xmpp.Types |
||||
|
||||
-- | An empty message. |
||||
message :: Message |
||||
message = Message { messageID = Nothing |
||||
, messageFrom = Nothing |
||||
, messageTo = Nothing |
||||
, messageLangTag = Nothing |
||||
, messageType = Normal |
||||
, messagePayload = [] |
||||
} |
||||
|
||||
-- Produce an answer message with the given payload, switching the "from" and |
||||
-- "to" attributes in the original message. |
||||
answerMessage :: Message -> [Element] -> Maybe Message |
||||
answerMessage Message{messageFrom = Just frm, ..} payload = |
||||
Just Message{ messageFrom = messageTo |
||||
, messageID = Nothing |
||||
, messageTo = Just frm |
||||
, messagePayload = payload |
||||
, .. |
||||
} |
||||
answerMessage _ _ = Nothing |
||||
@ -1,10 +0,0 @@
@@ -1,10 +0,0 @@
|
||||
{-# OPTIONS_HADDOCK hide #-} |
||||
|
||||
module Network.Xmpp.Presence where |
||||
|
||||
import Data.Text(Text) |
||||
import Network.Xmpp.Types |
||||
|
||||
-- | Add a recipient to a presence notification. |
||||
presTo :: Presence -> Jid -> Presence |
||||
presTo pres to = pres{presenceTo = Just to} |
||||
@ -1,108 +0,0 @@
@@ -1,108 +0,0 @@
|
||||
{-# OPTIONS_HADDOCK hide #-} |
||||
{-# LANGUAGE DeriveDataTypeable #-} |
||||
{-# LANGUAGE OverloadedStrings #-} |
||||
module Text.Xml.Stream.Elements where |
||||
|
||||
import Control.Applicative ((<$>)) |
||||
import Control.Exception |
||||
import Control.Monad.Trans.Class |
||||
import Control.Monad.Trans.Resource as R |
||||
|
||||
import qualified Data.ByteString as BS |
||||
import Data.Conduit as C |
||||
import Data.Conduit.List as CL |
||||
import qualified Data.Text as Text |
||||
import qualified Data.Text.Encoding as Text |
||||
import Data.Typeable |
||||
import Data.XML.Types |
||||
|
||||
import System.IO.Unsafe(unsafePerformIO) |
||||
|
||||
import qualified Text.XML.Stream.Render as TXSR |
||||
import Text.XML.Unresolved as TXU |
||||
|
||||
compressNodes :: [Node] -> [Node] |
||||
compressNodes [] = [] |
||||
compressNodes [x] = [x] |
||||
compressNodes (NodeContent (ContentText x) : NodeContent (ContentText y) : z) = |
||||
compressNodes $ NodeContent (ContentText $ x `Text.append` y) : z |
||||
compressNodes (x:xs) = x : compressNodes xs |
||||
|
||||
streamName :: Name |
||||
streamName = |
||||
(Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) |
||||
|
||||
data StreamEnd = StreamEnd deriving (Typeable, Show) |
||||
instance Exception StreamEnd |
||||
|
||||
data InvalidXmppXml = InvalidXmppXml String deriving (Show, Typeable) |
||||
|
||||
instance Exception InvalidXmppXml |
||||
|
||||
parseElement txt = documentRoot $ TXU.parseText_ TXU.def txt |
||||
|
||||
elements :: R.MonadThrow m => C.Conduit Event m Element |
||||
elements = do |
||||
x <- C.await |
||||
case x of |
||||
Just (EventBeginElement n as) -> do |
||||
goE n as >>= C.yield |
||||
elements |
||||
Just (EventEndElement streamName) -> lift $ R.monadThrow StreamEnd |
||||
Nothing -> return () |
||||
_ -> lift $ R.monadThrow $ InvalidXmppXml $ "not an element: " ++ show x |
||||
where |
||||
many' f = |
||||
go id |
||||
where |
||||
go front = do |
||||
x <- f |
||||
case x of |
||||
Left x -> return $ (x, front []) |
||||
Right y -> go (front . (:) y) |
||||
goE n as = do |
||||
(y, ns) <- many' goN |
||||
if y == Just (EventEndElement n) |
||||
then return $ Element n as $ compressNodes ns |
||||
else lift $ R.monadThrow $ InvalidXmppXml $ |
||||
"Missing close tag: " ++ show n |
||||
goN = do |
||||
x <- await |
||||
case x of |
||||
Just (EventBeginElement n as) -> (Right . NodeElement) <$> goE n as |
||||
Just (EventInstruction i) -> return $ Right $ NodeInstruction i |
||||
Just (EventContent c) -> return $ Right $ NodeContent c |
||||
Just (EventComment t) -> return $ Right $ NodeComment t |
||||
Just (EventCDATA t) -> return $ Right $ NodeContent $ ContentText t |
||||
_ -> return $ Left x |
||||
|
||||
|
||||
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 :) |
||||
|
||||
elementToEvents :: Element -> [Event] |
||||
elementToEvents e@(Element name _ _) = openElementToEvents e ++ [EventEndElement name] |
||||
|
||||
|
||||
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 |
||||
|
||||
ppElement :: Element -> String |
||||
ppElement = Text.unpack . Text.decodeUtf8 . renderElement |
||||
Loading…
Reference in new issue