Jon Kristensen
14 years ago
36 changed files with 2084 additions and 1562 deletions
@ -0,0 +1,8 @@
@@ -0,0 +1,8 @@
|
||||
dist/ |
||||
cabal-dev/ |
||||
*.o |
||||
*.hi |
||||
*~ |
||||
*# |
||||
*.#* |
||||
*_flymake.hs |
||||
@ -0,0 +1,3 @@
@@ -0,0 +1,3 @@
|
||||
[submodule "xml-types-pickle"] |
||||
path = xml-types-pickle |
||||
url = git@github.com:Philonous/xml-types-pickle.git |
||||
@ -1,89 +0,0 @@
@@ -1,89 +0,0 @@
|
||||
-- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the |
||||
-- Pontarius distribution for more details. |
||||
|
||||
-- | |
||||
-- Module: $Header$ |
||||
-- Description: Pontarius API |
||||
-- Copyright: Copyright © 2010-2012 Jon Kristensen |
||||
-- License: Apache License 2.0 |
||||
-- |
||||
-- Maintainer: jon.kristensen@nejla.com |
||||
-- Stability: unstable |
||||
-- Portability: portable |
||||
-- |
||||
-- XMPP is an open standard, extendable, and secure communications |
||||
-- protocol designed on top of XML, TLS, and SASL. Pontarius XMPP is |
||||
-- an XMPP client library, implementing the core capabilities of XMPP |
||||
-- (RFC 6120). |
||||
-- |
||||
-- Developers using this library are assumed to understand how XMPP |
||||
-- works. |
||||
-- |
||||
-- This module will be documented soon. |
||||
-- |
||||
-- Note that we are not recommending anyone to use Pontarius XMPP at |
||||
-- this time as it's still in an experimental stage and will have its |
||||
-- API and data types modified frequently. |
||||
|
||||
module Network.XMPP ( -- Network.XMPP.JID |
||||
Address (..) |
||||
, Localpart |
||||
, Domainpart |
||||
, Resourcepart |
||||
, isFull |
||||
, isBare |
||||
, fromString |
||||
, fromStrings |
||||
|
||||
-- Network.XMPP.Session |
||||
, runXMPPT |
||||
, hookStreamsOpenedEvent |
||||
, hookDisconnectedEvent |
||||
, destroy |
||||
, openStreams |
||||
, create |
||||
|
||||
-- , ClientHandler (..) |
||||
-- , ClientState (..) |
||||
-- , ConnectResult (..) |
||||
-- , HostName |
||||
-- , Password |
||||
-- , PortNumber |
||||
-- , Resource |
||||
-- , Session |
||||
-- , TerminationReason |
||||
-- , UserName |
||||
-- , sendIQ |
||||
-- , sendPresence |
||||
-- , sendMessage |
||||
-- , connect |
||||
-- , openStreams |
||||
-- , tlsSecureStreams |
||||
-- , authenticate |
||||
-- , session |
||||
-- , OpenStreamResult (..) |
||||
-- , SecureWithTLSResult (..) |
||||
-- , AuthenticateResult (..) |
||||
|
||||
-- Network.XMPP.Stanza |
||||
, StanzaID (SID) |
||||
, From |
||||
, To |
||||
, LangTag |
||||
, MessageType (..) |
||||
, Message (..) |
||||
, PresenceType (..) |
||||
, Presence (..) |
||||
, IQ (..) |
||||
, iqPayloadNamespace |
||||
, iqPayload ) where |
||||
|
||||
import Network.XMPP.Address |
||||
-- import Network.XMPP.SASL |
||||
import Network.XMPP.Session |
||||
import Network.XMPP.Stanza |
||||
import Network.XMPP.Utilities |
||||
import Network.XMPP.Types |
||||
-- import Network.XMPP.TLS |
||||
import Network.XMPP.Stream |
||||
|
||||
@ -1,172 +0,0 @@
@@ -1,172 +0,0 @@
|
||||
-- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the |
||||
-- Pontarius distribution for more details. |
||||
|
||||
{-# OPTIONS_HADDOCK hide #-} |
||||
|
||||
-- TODO: Make it possible to include host. |
||||
-- TODO: Host is assumed to be ISO 8859-1; make list of assumptions. |
||||
-- TODO: Can it contain newline characters? |
||||
|
||||
module Network.XMPP.SASL (replyToChallenge, saltedPassword, clientKey, storedKey, authMessage, clientSignature, clientProof, serverKey, serverSignature) where |
||||
|
||||
import Prelude hiding (concat, zipWith) |
||||
import Data.ByteString.Internal (c2w) |
||||
import Data.Char (isLatin1) |
||||
import Data.Digest.Pure.MD5 |
||||
import qualified Data.ByteString.Lazy as DBL (ByteString, append, pack, |
||||
fromChunks, toChunks, null) |
||||
import qualified Data.ByteString.Lazy.Char8 as DBLC (append, pack, unpack) |
||||
import qualified Data.List as DL |
||||
import Data.Text (empty, singleton) |
||||
import Text.StringPrep (StringPrepProfile (..), a1, b1, c12, c21, c22, c3, c4, c5, c6, c7, c8, c9, runStringPrep) |
||||
import Data.Ranges (inRanges, ranges) |
||||
|
||||
import Crypto.HMAC (MacKey (MacKey), hmac) |
||||
import Crypto.Hash.SHA1 (SHA1, hash) |
||||
import Data.Bits (xor) |
||||
import Data.ByteString () |
||||
import Data.ByteString.Lazy (ByteString, concat, fromChunks, pack, toChunks, zipWith) |
||||
import Data.Serialize (Serialize, encodeLazy) |
||||
import Data.Serialize.Put (putWord32be, runPutLazy) |
||||
|
||||
import Data.Maybe (fromJust, isJust) |
||||
|
||||
import qualified Data.Text as DT |
||||
|
||||
import Text.StringPrep (runStringPrep) |
||||
|
||||
data Challenge1Error = C1MultipleCriticalAttributes | |
||||
C1NotAllParametersPresent | |
||||
C1SomeParamtersPresentMoreThanOnce | |
||||
C1WrongRealm | |
||||
C1UnsupportedAlgorithm | |
||||
C1UnsupportedCharset | |
||||
C1UnsupportedQOP |
||||
deriving Show |
||||
|
||||
|
||||
-- Will produce a list of key-value pairs given a string in the format of |
||||
-- realm="somerealm",nonce="OA6MG9tEQGm2hh",qop="auth",charset=utf-8... |
||||
stringToList :: String -> [(String, String)] |
||||
stringToList "" = [] |
||||
stringToList s' = let (next, rest) = break' s' ',' |
||||
in break' next '=' : stringToList rest |
||||
where |
||||
-- Like break, but will remove the first char of the continuation, if |
||||
-- present. |
||||
break' :: String -> Char -> (String, String) |
||||
break' s' c = let (first, second) = break ((==) c) s' |
||||
in (first, removeCharIfPresent second c) |
||||
|
||||
-- Removes the first character, if present; "=hello" with '=' becomes |
||||
-- "hello". |
||||
removeCharIfPresent :: String -> Char -> String |
||||
removeCharIfPresent [] _ = [] |
||||
removeCharIfPresent (c:t) c' | c == c' = t |
||||
removeCharIfPresent s' c = s' |
||||
|
||||
-- Counts the number of directives in the pair list. |
||||
countDirectives :: String -> [(String, String)] -> Int |
||||
countDirectives v l = DL.length $ filter (isEntry v) l |
||||
where |
||||
isEntry :: String -> (String, String) -> Bool |
||||
isEntry name (name', _) | name == name' = True |
||||
| otherwise = False |
||||
|
||||
|
||||
-- Returns the given directive in the list of pairs, or Nothing. |
||||
lookupDirective :: String -> [(String, String)] -> Maybe String |
||||
lookupDirective d [] = Nothing |
||||
lookupDirective d ((d', v):t) | d == d' = Just v |
||||
| otherwise = lookupDirective d t |
||||
|
||||
|
||||
-- Returns the given directive in the list of pairs, or the default value |
||||
-- otherwise. |
||||
lookupDirectiveWithDefault :: String -> [(String, String)] -> String -> String |
||||
lookupDirectiveWithDefault di l de |
||||
| lookup == Nothing = de |
||||
| otherwise = let Just r = lookup in r |
||||
where |
||||
lookup = lookupDirective di l |
||||
|
||||
|
||||
-- Implementation of "Hi()" as specified in the Notation section of RFC 5802 |
||||
-- ("SCRAM"). It takes a string "str", a salt, and an interation count, and |
||||
-- returns an octet string. The iteration count must be greater than zero. |
||||
|
||||
hi :: ByteString -> ByteString -> Integer -> ByteString |
||||
|
||||
hi str salt i | i > 0 = xorUs $ us (concat [salt, runPutLazy $ putWord32be 1]) i |
||||
where |
||||
|
||||
-- Calculates the U's (U1 ... Ui) using the HMAC algorithm |
||||
us :: ByteString -> Integer -> [ByteString] |
||||
us a 1 = [encodeLazy (hmac (MacKey (head $ toChunks str)) a :: SHA1)] |
||||
us a x = [encodeLazy (hmac (MacKey (head $ toChunks str)) a :: SHA1)] ++ (us (encodeLazy (hmac (MacKey (head $ toChunks str)) a :: SHA1)) (x - 1)) |
||||
|
||||
-- XORs the ByteStrings: U1 XOR U2 XOR ... XOR Ui |
||||
xorUs :: [ByteString] -> ByteString |
||||
xorUs (b:bs) = foldl (\ x y -> pack $ zipWith xor x y) b bs |
||||
|
||||
|
||||
saltedPassword :: String -> ByteString -> Integer -> Maybe ByteString |
||||
|
||||
saltedPassword password salt i = if isJust password' then Just $ hi (DBLC.pack $ DT.unpack $ fromJust password') salt i else Nothing |
||||
where |
||||
password' = runStringPrep saslprepProfile (DT.pack password) |
||||
|
||||
clientKey :: ByteString -> ByteString |
||||
|
||||
clientKey sp = encodeLazy (hmac (MacKey (head $ toChunks sp)) (DBLC.pack "Client Key") :: SHA1) |
||||
|
||||
|
||||
storedKey :: ByteString -> ByteString |
||||
|
||||
storedKey ck = fromChunks [hash $ head $ toChunks ck] |
||||
|
||||
|
||||
authMessage :: String -> String -> String -> ByteString |
||||
|
||||
authMessage cfmb sfm cfmwp = DBLC.pack $ cfmb ++ "," ++ sfm ++ "," ++ cfmwp |
||||
|
||||
|
||||
clientSignature :: ByteString -> ByteString -> ByteString |
||||
|
||||
clientSignature sk am = encodeLazy (hmac (MacKey (head $ toChunks sk)) am :: SHA1) |
||||
|
||||
|
||||
clientProof :: ByteString -> ByteString -> ByteString |
||||
|
||||
clientProof ck cs = pack $ zipWith xor ck cs |
||||
|
||||
|
||||
serverKey :: ByteString -> ByteString |
||||
|
||||
serverKey sp = encodeLazy (hmac (MacKey (head $ toChunks sp)) (DBLC.pack "Server Key") :: SHA1) |
||||
|
||||
|
||||
serverSignature :: ByteString -> ByteString -> ByteString |
||||
|
||||
serverSignature servkey am = encodeLazy (hmac (MacKey (head $ toChunks servkey)) am :: SHA1) |
||||
|
||||
|
||||
-- TODO: Implement SCRAM. |
||||
|
||||
replyToChallenge = replyToChallenge |
||||
|
||||
|
||||
-- Stripts the quotations around a string, if any; "\"hello\"" becomes "hello". |
||||
|
||||
stripQuotations :: String -> String |
||||
stripQuotations "" = "" |
||||
stripQuotations s | (head s == '"') && (last s == '"') = tail $ init s |
||||
| otherwise = s |
||||
|
||||
|
||||
saslprepProfile :: StringPrepProfile |
||||
|
||||
saslprepProfile = Profile { maps = [\ char -> if char `inRanges` (ranges c12) then singleton '\x0020' else singleton char, b1] |
||||
, shouldNormalize = True |
||||
, prohibited = [a1] ++ [c12, c21, c22, c3, c4, c5, c6, c7, c8, c9] |
||||
, shouldCheckBidi = True } |
||||
@ -1,372 +0,0 @@
@@ -1,372 +0,0 @@
|
||||
-- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the |
||||
-- Pontarius distribution for more details. |
||||
|
||||
|
||||
-- TODO: Predicates on callbacks? |
||||
-- TODO: . vs $ |
||||
-- TODO: type XMPP = XMPPT IO? + runXMPP |
||||
|
||||
|
||||
{-# LANGUAGE ExistentialQuantification #-} |
||||
{-# LANGUAGE MultiParamTypeClasses #-} |
||||
|
||||
|
||||
module Network.XMPP.Session ( |
||||
XMPPT (runXMPPT) |
||||
, hookStreamsOpenedEvent |
||||
, hookDisconnectedEvent |
||||
, destroy |
||||
, openStreams |
||||
, create |
||||
, DisconnectReason |
||||
) where |
||||
|
||||
import Network.XMPP.Stream |
||||
import Network.XMPP.Types |
||||
import Network.XMPP.Utilities |
||||
|
||||
import Control.Concurrent (Chan, forkIO, forkOS, newChan, readChan, writeChan) |
||||
import Control.Monad.IO.Class (MonadIO, liftIO) |
||||
import Data.Certificate.X509 (X509) |
||||
import Data.Dynamic (Dynamic) |
||||
-- import Control.Monad.Reader (MonadReader, ReaderT, ask) |
||||
import Control.Monad.State.Lazy (MonadState, StateT, get, put, execStateT) |
||||
|
||||
import qualified Control.Exception as CE |
||||
import qualified Network as N |
||||
import System.IO (BufferMode, BufferMode(NoBuffering)) |
||||
import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput) |
||||
import Codec.Binary.UTF8.String |
||||
|
||||
|
||||
|
||||
create :: MonadIO m => XMPPT m () -> m () |
||||
|
||||
create main = do |
||||
chan <- liftIO $ newChan |
||||
idGen <- liftIO $ idGenerator "" |
||||
execStateT (runXMPPT init) (State chan idGen []) |
||||
return () |
||||
where |
||||
init = do |
||||
main |
||||
stateLoop |
||||
|
||||
|
||||
-- Internal events - events to be processed within Pontarius. |
||||
|
||||
-- data InternalEvent s m = IEC (ClientEvent s m) | IEE EnumeratorEvent | IET (TimeoutEvent s m) deriving (Show) |
||||
|
||||
|
||||
instance Show (InternalEvent m) where |
||||
show _ = "InternalEvent" |
||||
|
||||
-- | |
||||
-- Events that may be emitted from Pontarius. |
||||
|
||||
data Event = -- ConnectedEvent (Either IntFailureReason Resource) |
||||
{-|-} OpenedStreamsEvent (Maybe OpenStreamsFailureReason) |
||||
-- | TLSSecuredEvent (Maybe TLSSecuringFailureReason) |
||||
-- | AuthenticatedEvent (Either AuthenticationFailureReason Resource) |
||||
| DisconnectedEvent DisconnectReason |
||||
-- | MessageEvent (Either MessageError Message) |
||||
-- | PresenceEvent (Either PresenceError Presence) |
||||
-- | IQEvent (Either IQResult IQRequest) |
||||
-- | forall a. Dynamic a => DynamicEvent a |
||||
deriving (Show) |
||||
|
||||
-- data DynamicEvent = forall a. Dynamic a => DynamicEvent a |
||||
-- data DynamicEvent = DynamicEvent Dynamic |
||||
|
||||
|
||||
-- data ConnectedFailureReason |
||||
-- = COSFR OpenStreamsFailureReason |
||||
-- | CTSFR TLSSecureFailureReason |
||||
-- | CAFR AuthenticateFailureReason |
||||
|
||||
|
||||
-- The "hook modification" events have a higher priority than other events, and |
||||
-- are thus sent through a Chan of their own. The boolean returns value signals |
||||
-- whether or not the hook should be removed. |
||||
|
||||
-- data HookModification m |
||||
-- = MonadIO m => -- RegisterConnectedHook (ConnectedEvent -> XMPPT m Bool) (Maybe (ConnectedEvent -> Bool)) |
||||
-- | RegisterTLSSecuredHook (TLSSecuredEvent -> XMPPT m Bool) (Maybe (TLSSecuredEvent -> Bool)) |
||||
-- | RegisterAuthenticatedHook (AuthenticatedEvent -> XMPPT m Bool) (Maybe (AuthenticatedEvent -> Bool)) |
||||
-- -- | forall a. Dynamic a => RegisterDynamicHook (DynamicEvent a -> XMPPT m Bool) |
||||
-- | RegisterDynamicHook (DynamicEvent -> XMPPT m Bool) (Maybe (DynamicEvent -> Bool)) |
||||
|
||||
|
||||
-- Reads an event from the internal event channel, processes it, |
||||
-- performs the generated impure actions, and loops. |
||||
|
||||
stateLoop :: MonadIO m => XMPPT m () |
||||
|
||||
stateLoop = do |
||||
rs <- get |
||||
event <- liftIO $ readChan $ evtChan rs |
||||
liftIO $ putStrLn $ "Processing " ++ (show event) ++ "..." |
||||
processEvent event |
||||
-- sequence_ IO actions frmo procesEvent? |
||||
stateLoop |
||||
|
||||
|
||||
-- Processes an internal event and generates a list of impure actions. |
||||
|
||||
processEvent :: MonadIO m => InternalEvent m -> XMPPT m () |
||||
|
||||
processEvent (OpenStreamsEvent h p) = openStreamAction h p |
||||
where |
||||
openStreamAction :: MonadIO m => HostName -> PortNumber -> XMPPT m () |
||||
openStreamAction h p = let p' = fromIntegral p |
||||
computation chan = do -- chan ugly |
||||
-- threadID <- |
||||
handle <- N.connectTo h (N.PortNumber p') |
||||
hSetBuffering handle NoBuffering |
||||
forkIO $ conduit chan (Left handle) -- This must be done after hSetBuffering |
||||
hPutStr handle $ encodeString "<stream:stream to='" ++ h ++ "' version='1.0' xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/streams'>" -- didn't work with <?xml version='1.0'> |
||||
hFlush handle |
||||
return () |
||||
in do |
||||
rs <- get |
||||
result <- liftIO $ CE.try (computation $ evtChan rs) |
||||
case result of |
||||
Right () -> do |
||||
return () |
||||
-- -- lift $ liftIO $ putMVar (stateThreadID state) threadID |
||||
Left (CE.SomeException e) -> do -- TODO: Safe to do this? |
||||
fireStreamsOpenedEvent $ Just OpenStreamsFailureReason |
||||
-- Left error -> do |
||||
-- -- let clientState = stateClientState state |
||||
-- -- ((), clientState') <- lift $ runStateT (callback OpenStreamFailure) clientState |
||||
-- -- put $ state { stateShouldExit = True } |
||||
-- -- return $ Just e |
||||
-- return $ Just error |
||||
|
||||
|
||||
-- hookConnectedEvent :: MonadIO m => (ConnectedEvent -> XMPPT m Bool) -> (Maybe (ConnectedEvent -> Bool)) -> XMPPT m () |
||||
|
||||
-- hookConnectedEvent cb pred = ask >>= \rs -> liftIO $ writeChan (hookModChan rs) (RegisterConnectedHook cb pred) |
||||
|
||||
|
||||
-- | Hook the provided callback and (optional) predicate to the |
||||
-- "Streams Opened" event. |
||||
-- |
||||
-- The "Streams Opened" event will be fired when the stream:features element has been successfully received or an error has occurred. |
||||
|
||||
hookStreamsOpenedEvent :: MonadIO m => (Maybe OpenStreamsFailureReason -> XMPPT m Bool) -> (Maybe (Maybe OpenStreamsFailureReason -> XMPPT m Bool)) -> XMPPT m HookId |
||||
|
||||
hookStreamsOpenedEvent cb pred = do |
||||
rs <- get |
||||
hookId <- liftIO $ nextId $ hookIdGenerator rs |
||||
put $ rs { hooks = (HookId hookId, StreamsOpenedHook pred cb):hooks rs } |
||||
return $ HookId hookId |
||||
|
||||
|
||||
hookDisconnectedEvent :: MonadIO m => (DisconnectReason -> XMPPT m Bool) -> (Maybe (DisconnectReason -> XMPPT m Bool)) -> XMPPT m HookId |
||||
hookDisconnectedEvent cb pred = do |
||||
rs <- get |
||||
hookId <- liftIO $ nextId $ hookIdGenerator rs |
||||
-- TODO: Actually hook it. |
||||
return $ HookId hookId |
||||
|
||||
|
||||
-- hookTLSSecuredEvent :: MonadIO m => (TLSSecuredEvent -> XMPPT m Bool) -> (Maybe (TLSSecuredEvent -> Bool)) -> XMPPT m () |
||||
|
||||
-- hookTLSSecuredEvent cb pred = ask >>= \rs -> liftIO $ writeChan (hookModChan rs) (RegisterTLSSecuredHook cb pred) |
||||
|
||||
|
||||
-- hookAuthenticatedEvent :: MonadIO m => (AuthenticatedEvent -> XMPPT m Bool) -> (Maybe (AuthenticatedEvent -> Bool)) -> XMPPT m () |
||||
|
||||
-- hookAuthenticatedEvent cb pred = ask >>= \rs -> liftIO $ writeChan (hookModChan rs) (RegisterAuthenticatedHook cb pred) |
||||
|
||||
|
||||
-- hookDynamicEvent :: MonadIO m => (DynamicEvent -> XMPPT m Bool) -> (Maybe (DynamicEvent -> Bool)) -> XMPPT m () |
||||
|
||||
-- hookDynamicEvent cb pred = ask >>= \rs -> liftIO $ writeChan (hookModChan rs) (RegisterDynamicHook cb pred) |
||||
|
||||
|
||||
-- | Asynchronously request to open a stream to an XMPP server on the |
||||
-- given host name and port. |
||||
|
||||
openStreams :: MonadIO m => HostName -> PortNumber -> XMPPT m () |
||||
|
||||
openStreams h p = get >>= \rs -> liftIO $ writeChan (evtChan rs) (OpenStreamsEvent h p) |
||||
|
||||
|
||||
-- Like any other fire*Event function, it queries the hooks, filters |
||||
-- out the ones that are relevant, prepares them to be used with |
||||
-- processHook, and processes them. |
||||
|
||||
fireStreamsOpenedEvent :: MonadIO m => Maybe OpenStreamsFailureReason -> XMPPT m () |
||||
|
||||
fireStreamsOpenedEvent r = do |
||||
rs <- get |
||||
let hooks' = filterStreamsOpenedHooks $ hooks rs |
||||
sequence_ $ map (\(hookId, pred, cb) -> processHook hookId pred cb) $ map prepareStreamsOpenedHooks hooks' |
||||
return () |
||||
where |
||||
prepareStreamsOpenedHooks :: MonadIO m => Hook m -> (HookId, Maybe (XMPPT m Bool), XMPPT m Bool) |
||||
prepareStreamsOpenedHooks (hookId, StreamsOpenedHook pred cb) = |
||||
let pred' = case pred of |
||||
Nothing -> Nothing |
||||
Just pred'' -> Just $ pred'' r |
||||
cb' = cb r in (hookId, pred', cb') |
||||
|
||||
|
||||
-- Takes an optional predicate and a callback function, and excecutes |
||||
-- the callback function if the predicate does not exist, or exists |
||||
-- and is true, and returns True if the hook should be removed. |
||||
|
||||
processHook :: MonadIO m => HookId -> Maybe (XMPPT m Bool) -> XMPPT m Bool -> XMPPT m () |
||||
|
||||
processHook id pred cb = do |
||||
remove <- processHook' |
||||
if remove then do |
||||
rs <- get |
||||
put $ rs { hooks = removeHook id (hooks rs) } |
||||
else return () |
||||
where |
||||
processHook' = case pred of |
||||
Just pred' -> do |
||||
result <- pred' |
||||
if result then cb else return False |
||||
Nothing -> cb |
||||
|
||||
|
||||
destroy = destroy |
||||
|
||||
|
||||
filterStreamsOpenedHooks :: MonadIO m => [Hook m] -> [Hook m] |
||||
|
||||
filterStreamsOpenedHooks h = filter pred h |
||||
where |
||||
pred (_, StreamsOpenedHook _ _) = True |
||||
pred _ = False |
||||
|
||||
|
||||
removeHook :: MonadIO m => HookId -> [Hook m] -> [Hook m] |
||||
|
||||
removeHook id h = filter (\(id', _) -> id' /= id) h |
||||
|
||||
|
||||
-- tlsSecure = tlsSecure |
||||
|
||||
-- authenticate = authenticate |
||||
|
||||
|
||||
-- fireConnectedEvent = fireConnectedEvent |
||||
|
||||
|
||||
-- | |
||||
-- connect is implemented using hookStreamOpenedEvent, hookTLSSecuredEvent, and |
||||
-- hookAuthenticatedEvent, and is offered as a convenience function for clients |
||||
-- that doesn't need to perform any XMPP actions in-between opening the streams |
||||
-- and TLS securing the stream and\/or authenticating, allowing them to listen |
||||
-- for and manage one event instead of up to three. Just-values in the third and |
||||
-- fourth parameters will make connect TLS secure the stream and authenticate, |
||||
-- respectively. Most clients will want to hook to the Connected event using |
||||
-- hookConnectedEvent prior to using this function. |
||||
-- |
||||
-- The ConnectedEvent and StreamOpenedEvent are guaranteed to be generated upon |
||||
-- calling this function. So will a subset of the TLSSecuredEvent and |
||||
-- AuthenticatedEvent, depending on whether their functionalities are requested |
||||
-- using Just-values in the third and fourth parameters. |
||||
-- |
||||
-- connect is designed with the assupmtion that openStreams, tlsSecure, and |
||||
-- authenticate will not be used by the client. Calling those functions may |
||||
-- generate events that can cause connect to behave incorrectly. |
||||
|
||||
-- connect :: MonadIO m => HostName -> PortNumber -> Maybe (Maybe [X509], ([X509] -> Bool)) -> Maybe (UserName, Password, Maybe Resource) -> XMPPT m () |
||||
-- |
||||
-- connect h p Nothing Nothing = do |
||||
-- hookStreamsOpenedEvent onStreamsOpenedEvent Nothing |
||||
-- openStreams h p |
||||
-- |
||||
-- where |
||||
-- |
||||
-- onStreamsOpenedEvent Nothing = do |
||||
-- fireConnectedEvent Nothing |
||||
-- return False |
||||
-- |
||||
-- onStreamsOpenedEvent (Just e) = do |
||||
-- fireConnectedEvent $ Left $ COSFR e |
||||
-- return False |
||||
-- |
||||
-- connect h p (Just t) Nothing = do |
||||
-- hookStreamsOpenedEvent onStreamsOpenedEvent Nothing |
||||
-- openStreams h p |
||||
-- |
||||
-- where |
||||
-- |
||||
-- onStreamsOpenedEvent Nothing = do |
||||
-- hookTLSSecuredEvent onTLSSecuredEvent Nothing |
||||
-- tlsSecure |
||||
-- return False |
||||
-- |
||||
-- onStreamsOpenedEvent (Just e) = do |
||||
-- fireConnectedEvent $ Left $ COSFR e |
||||
-- return False |
||||
-- |
||||
-- onTLSSecuredEvent Nothing = do |
||||
-- fireConnectedEvent Nothing |
||||
-- return False |
||||
-- |
||||
-- onTLSSecuredEvent (Just e) = do |
||||
-- fireConnectedEvent $ Left $ CTSFR e |
||||
-- return False |
||||
-- |
||||
-- connect h p Nothing (Just a) = do |
||||
-- hookStreamsOpenedEvent onStreamsOpenedEvent Nothing |
||||
-- openStreams h p |
||||
-- |
||||
-- where |
||||
-- |
||||
-- onStreamsOpenedEvent Nothing = do |
||||
-- hookAuthenticatedEvent onAuthenticatedEvent Nothing |
||||
-- authenticate |
||||
-- return False |
||||
-- |
||||
-- onStreamsOpenedEvent (Just e) = do |
||||
-- fireConnectedEvent $ Left $ COSFR e |
||||
-- return False |
||||
-- |
||||
-- onAuthenticatedEvent (Right r) = do |
||||
-- fireConnectedEvent $ Just r |
||||
-- return False |
||||
-- |
||||
-- onAuthenticated (Left e) = do |
||||
-- fireConnectedEvent $ Left $ CAFR e |
||||
-- return False |
||||
-- |
||||
-- connect h p (Just t) (Just a) = do |
||||
-- hookStreamsOpenedEvent onStreamsOpenedEvent Nothing |
||||
-- openStreams h p |
||||
-- |
||||
-- where |
||||
-- |
||||
-- onStreamsOpenedEvent Nothing = do |
||||
-- hookTLSSecuredEvent onTLSSecuredEvent Nothing |
||||
-- tlsSecure |
||||
-- return False |
||||
-- |
||||
-- onStreamsOpenedEvent (Just e) = do |
||||
-- fireConnectedEvent $ Left $ COSFR e |
||||
-- return False |
||||
-- |
||||
-- onTLSSecuredEvent Nothing = do |
||||
-- hookAuthenticatedEvent onAuthenticatedEvent Nothing |
||||
-- authenticate |
||||
-- return False |
||||
-- |
||||
-- onTLSSecuredEvent (Just e) = do |
||||
-- fireConnectedEvent $ Left $ CTSFR e |
||||
-- return False |
||||
-- |
||||
-- onAuthenticatedEvent (Right r) = do |
||||
-- fireConnectedEvent $ Just r |
||||
-- return False |
||||
-- |
||||
-- onAuthenticated (Left e) = do |
||||
-- fireConnectedEvent $ Left $ CAFR e |
||||
-- return False |
||||
@ -1,543 +0,0 @@
@@ -1,543 +0,0 @@
|
||||
-- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the |
||||
-- Pontarius distribution for more details. |
||||
|
||||
{-# OPTIONS_HADDOCK hide #-} |
||||
|
||||
{-# LANGUAGE OverloadedStrings #-} |
||||
|
||||
module Network.XMPP.Stream ( |
||||
conduit, |
||||
presenceToXML, |
||||
iqToXML, |
||||
messageToXML, |
||||
parsePresence, |
||||
parseIQ, |
||||
parseMessage, |
||||
langTag, |
||||
versionFromString, |
||||
versionFromNumbers |
||||
) where |
||||
|
||||
import Network.XMPP.Types hiding (Continue) |
||||
|
||||
import Prelude hiding (null) |
||||
|
||||
import Control.Concurrent.Chan (Chan, writeChan) |
||||
import Control.Exception.Base (SomeException) |
||||
import Control.Monad.IO.Class (liftIO) |
||||
import Data.ByteString.Lazy (null, toChunks) |
||||
import Data.Conduit (($$), ($=), MonadResource, Sink (..), runResourceT) |
||||
import Data.Conduit.Binary (sourceHandle) |
||||
import Data.Maybe (fromJust, isJust) |
||||
import Data.Text (pack, unpack) |
||||
import Data.XML.Types (Content (..), Document (..), Element (..), Event (..), Name (..), Node (..)) |
||||
import GHC.IO.Handle (Handle) |
||||
import Network.TLS (TLSCtx, recvData) |
||||
import Text.Parsec (char, count, digit, eof, many, many1, oneOf, parse) |
||||
import Text.Parsec.ByteString (GenParser) |
||||
-- import Text.XML.Enumerator.Document (fromEvents) |
||||
import Text.XML.Stream.Parse (def, parseBytes) |
||||
import Text.XML.Unresolved (fromEvents) |
||||
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO) |
||||
|
||||
|
||||
import qualified Data.ByteString as DB (ByteString) |
||||
import qualified Data.ByteString.Char8 as DBC (pack) |
||||
import qualified Data.Conduit.List as DEL (head) |
||||
import Data.Conduit.List (consume, sourceList) -- use lazy consume instead? |
||||
|
||||
|
||||
-- Reads from the provided handle or TLS context and sends the events |
||||
-- to the internal event channel. |
||||
|
||||
conduit :: MonadIO m => Chan (InternalEvent m) -> Either Handle (TLSCtx a) -> IO () |
||||
|
||||
conduit c s = do |
||||
enumeratorResult <- case s of |
||||
Left handle -> do |
||||
print <- runResourceT $ sourceHandle handle $= parseBytes def $$ DEL.head -- $$ DEL.head -- eventConsumer c [] 0 |
||||
return $ Right 0 -- TODO |
||||
Right tlsCtx -> -- run $ enumTLS tlsCtx $$ joinI $ |
||||
-- parseBytes decodeEntities $$ eventConsumer c [] 0 |
||||
return $ Left 0 -- TODO |
||||
case enumeratorResult of |
||||
Right _ -> return () -- writeChan c $ IEE EnumeratorDone |
||||
Left e -> return () -- writeChan c $ IEE (EnumeratorException e) |
||||
-- where |
||||
-- -- Behaves like enumHandle, but reads from the TLS context instead |
||||
-- -- TODO: Type? |
||||
-- enumTLS :: TLSCtx -> Enumerator DB.ByteString IO b |
||||
-- enumTLS c s = loop c s |
||||
|
||||
-- -- TODO: Type? |
||||
-- loop :: TLSCtx -> Step DB.ByteString IO b -> Iteratee DB.ByteString IO b |
||||
-- loop c (Continue k) = do |
||||
-- d <- recvData c |
||||
-- case null d of |
||||
-- True -> loop c (Continue k) |
||||
-- False -> k (Chunks $ toChunks d) >>== loop c |
||||
-- loop _ step = returnI step |
||||
|
||||
|
||||
-- Consumes XML events from the input stream, accumulating as |
||||
-- necessary, and sends the proper events through the channel. The |
||||
-- second parameter should be initialized to [] (no events) and the |
||||
-- third to 0 (zeroth XML level). |
||||
|
||||
eventConsumer :: (MonadResource r, MonadIO m) => |
||||
Chan (InternalEvent m) -> [Event] -> Int -> Sink Event r () |
||||
|
||||
-- <stream:stream> open event received. |
||||
|
||||
eventConsumer chan [EventBeginElement (Name localName namespace prefixName) attribs] 0 |
||||
| localName == pack "stream" && isJust prefixName && fromJust prefixName == pack "stream" = do |
||||
liftIO $ putStrLn "here?" |
||||
liftIO $ writeChan chan $ EnumeratorBeginStream from to id ver lang ns |
||||
eventConsumer chan [] 1 |
||||
where |
||||
from = case lookup "from" attribs of Nothing -> Nothing; Just fromAttrib -> Just $ show fromAttrib |
||||
to = case lookup "to" attribs of Nothing -> Nothing; Just toAttrib -> Just $ show toAttrib |
||||
id = case lookup "id" attribs of Nothing -> Nothing; Just idAttrib -> Just $ show idAttrib |
||||
ver = case lookup "version" attribs of Nothing -> Nothing; Just verAttrib -> Just $ show verAttrib |
||||
lang = case lookup "xml:lang" attribs of Nothing -> Nothing; Just langAttrib -> Just $ show langAttrib |
||||
ns = case namespace of Nothing -> Nothing; Just namespaceAttrib -> Just $ unpack namespaceAttrib |
||||
|
||||
-- <stream:stream> close event received. |
||||
|
||||
eventConsumer chan [EventEndElement name] 1 |
||||
| namePrefix name == Just (pack "stream") && nameLocalName name == pack "stream" = do |
||||
liftIO $ putStrLn "here!" |
||||
liftIO $ writeChan chan $ EnumeratorEndStream |
||||
return () |
||||
|
||||
-- Ignore EventDocumentBegin event. |
||||
|
||||
eventConsumer chan [EventBeginDocument] 0 = eventConsumer chan [] 0 |
||||
|
||||
-- We have received a complete first-level XML element. Process the accumulated |
||||
-- values into an first-level element event. |
||||
|
||||
eventConsumer chan ((EventEndElement e):es) 1 = do |
||||
liftIO $ putStrLn "here..." |
||||
element <- liftIO $ eventsToElement $ reverse ((EventEndElement e):es) |
||||
liftIO $ writeChan chan $ EnumeratorFirstLevelElement element |
||||
eventConsumer chan [] 1 |
||||
|
||||
-- Normal condition - accumulate the event. |
||||
|
||||
eventConsumer chan events level = do |
||||
liftIO $ putStrLn "listenering for XML event" |
||||
event <- DEL.head |
||||
liftIO $ putStrLn "got event" |
||||
case event of |
||||
Just event' -> let level' = case event' of |
||||
EventBeginElement _ _ -> level + 1 |
||||
EventEndElement _ -> level - 1 |
||||
_ -> level |
||||
in eventConsumer chan (event':events) level' |
||||
Nothing -> eventConsumer chan events level |
||||
|
||||
|
||||
eventsToElement :: [Event] -> IO Element -- Was: Either SomeException Element |
||||
|
||||
-- TODO: Exceptions. |
||||
|
||||
eventsToElement e = do |
||||
putStrLn "eventsToElement" |
||||
doc <- runResourceT $ sourceList e $$ fromEvents |
||||
return $ documentRoot doc |
||||
-- case r of Right doc -> Right $ documentRoot doc; Left ex -> Left ex |
||||
-- where |
||||
-- -- TODO: Type? |
||||
-- eventsEnum (Continue k) = k $ Chunks e |
||||
-- eventsEnum step = returnI step |
||||
|
||||
|
||||
-- Sending stanzas is done through functions, where LangTag is Maybe. |
||||
|
||||
|
||||
-- Generates an XML element for a message stanza. The language tag provided is |
||||
-- the default language of the stream. |
||||
|
||||
messageToXML :: InternalMessage -> LangTag -> Element |
||||
|
||||
-- Non-error message. |
||||
|
||||
messageToXML (Right m) streamLang = Element "message" attribs nodes |
||||
|
||||
where |
||||
|
||||
-- Has the stanza attributes and the message type. |
||||
attribs :: [(Name, [Content])] |
||||
attribs = stanzaAttribs (messageID m) (messageFrom m) (messageTo m) stanzaLang ++ |
||||
[("type", [ContentText $ pack $ show $ messageType m])] |
||||
|
||||
-- Has an arbitrary number of elements as children. |
||||
nodes :: [Node] |
||||
nodes = map (\ x -> NodeElement x) (messagePayload m) |
||||
|
||||
stanzaLang :: Maybe LangTag |
||||
stanzaLang = stanzaLang' streamLang $ messageLangTag m |
||||
|
||||
-- Presence error. |
||||
|
||||
messageToXML (Left m) streamLang = Element "message" attribs nodes |
||||
|
||||
where |
||||
|
||||
-- Has the stanza attributes and the "error" presence type. |
||||
attribs :: [(Name, [Content])] |
||||
attribs = stanzaAttribs (messageErrorID m) (messageErrorFrom m) (messageErrorTo m) |
||||
stanzaLang ++ [("type", [ContentText $ pack "error"])] |
||||
|
||||
-- Has the error element stanza as its child. |
||||
-- TODO: Include sender XML here? |
||||
nodes :: [Node] |
||||
nodes = [NodeElement $ errorElem streamLang stanzaLang $ messageErrorStanzaError m] |
||||
|
||||
-- The stanza language tag, if it's different from the stream language tag. |
||||
stanzaLang :: Maybe LangTag |
||||
stanzaLang = stanzaLang' streamLang $ messageErrorLangTag m |
||||
|
||||
|
||||
-- Generates an XML element for a presence stanza. The language tag provided is |
||||
-- the default language of the stream. |
||||
|
||||
presenceToXML :: InternalPresence -> LangTag -> Element |
||||
|
||||
-- Non-error presence. |
||||
|
||||
presenceToXML (Right p) streamLang = Element "presence" attribs nodes |
||||
|
||||
where |
||||
|
||||
-- Has the stanza attributes and the presence type. |
||||
attribs :: [(Name, [Content])] |
||||
attribs = stanzaAttribs (presenceID p) (presenceFrom p) (presenceTo p) stanzaLang ++ |
||||
typeAttrib |
||||
|
||||
-- Has an arbitrary number of elements as children. |
||||
nodes :: [Node] |
||||
nodes = map (\ x -> NodeElement x) (presencePayload p) |
||||
|
||||
stanzaLang :: Maybe LangTag |
||||
stanzaLang = stanzaLang' streamLang $ presenceLangTag p |
||||
|
||||
typeAttrib :: [(Name, [Content])] |
||||
typeAttrib = case presenceType p of Nothing -> []; Just presenceType' -> [("type", [ContentText $ pack $ show presenceType'])] |
||||
|
||||
-- Presence error. |
||||
|
||||
presenceToXML (Left p) streamLang = Element "presence" attribs nodes |
||||
|
||||
where |
||||
|
||||
-- Has the stanza attributes and the "error" presence type. |
||||
attribs :: [(Name, [Content])] |
||||
attribs = stanzaAttribs (presenceErrorID p) (presenceErrorFrom p) (presenceErrorTo p) |
||||
stanzaLang ++ [("type", [ContentText $ pack "error"])] |
||||
|
||||
-- Has the error element stanza as its child. |
||||
-- TODO: Include sender XML here? |
||||
nodes :: [Node] |
||||
nodes = [NodeElement $ errorElem streamLang stanzaLang $ presenceErrorStanzaError p] |
||||
|
||||
-- The stanza language tag, if it's different from the stream language tag. |
||||
stanzaLang :: Maybe LangTag |
||||
stanzaLang = stanzaLang' streamLang $ presenceErrorLangTag p |
||||
|
||||
|
||||
-- Generates an XML element for a presence stanza. The language tag provided is |
||||
-- the default language of the stream. |
||||
|
||||
iqToXML :: IQ -> LangTag -> Element |
||||
|
||||
-- Request IQ. |
||||
|
||||
iqToXML (Left i) streamLang = Element "iq" attribs nodes |
||||
|
||||
where |
||||
|
||||
-- Has the stanza attributes and the IQ request type (`get' or `set'). |
||||
attribs :: [(Name, [Content])] |
||||
attribs = stanzaAttribs (iqRequestID i) (iqRequestFrom i) (iqRequestTo i) |
||||
stanzaLang ++ typeAttrib |
||||
|
||||
-- Has exactly one payload child element. |
||||
nodes :: [Node] |
||||
nodes = [NodeElement $ iqRequestPayload i] |
||||
|
||||
-- The stanza language tag, if it's different from the stream language tag. |
||||
stanzaLang :: Maybe LangTag |
||||
stanzaLang = stanzaLang' streamLang $ iqRequestLangTag i |
||||
|
||||
-- The required type attribute. |
||||
typeAttrib :: [(Name, [Content])] |
||||
typeAttrib = [("type", [ContentText $ pack $ show $ iqRequestType i])] |
||||
|
||||
-- Response result IQ. |
||||
|
||||
iqToXML (Right (Right i)) streamLang = Element "iq" attribs nodes |
||||
|
||||
where |
||||
|
||||
-- Has the stanza attributes and the IQ `result' type. |
||||
attribs :: [(Name, [Content])] |
||||
attribs = stanzaAttribs (iqResultID i) (iqResultFrom i) (iqResultTo i) |
||||
stanzaLang ++ typeAttrib |
||||
|
||||
-- Has one or zero payload child elements. |
||||
nodes :: [Node] |
||||
nodes = case iqResultPayload i of Nothing -> []; Just payloadElem -> [NodeElement payloadElem] |
||||
|
||||
stanzaLang :: Maybe LangTag |
||||
stanzaLang = stanzaLang' streamLang $ iqResultLangTag i |
||||
|
||||
-- The required type attribute. |
||||
typeAttrib :: [(Name, [Content])] |
||||
typeAttrib = [("type", [ContentText $ pack "result"])] |
||||
|
||||
-- Response error IQ. |
||||
|
||||
iqToXML (Right (Left i)) streamLang = Element "iq" attribs nodes |
||||
|
||||
where |
||||
|
||||
-- Has the stanza attributes and the presence type. |
||||
attribs :: [(Name, [Content])] |
||||
attribs = stanzaAttribs (iqErrorID i) (iqErrorFrom i) (iqErrorTo i) stanzaLang ++ |
||||
typeAttrib |
||||
|
||||
-- Has an optional elements as child. |
||||
nodes :: [Node] |
||||
nodes = case iqErrorPayload i of Nothing -> []; Just payloadElem -> [NodeElement payloadElem] |
||||
|
||||
stanzaLang :: Maybe LangTag |
||||
stanzaLang = stanzaLang' streamLang $ iqErrorLangTag i |
||||
|
||||
typeAttrib :: [(Name, [Content])] |
||||
typeAttrib = [("type", [ContentText $ pack "error"])] |
||||
|
||||
|
||||
-- Creates the error element that is common for all stanzas. |
||||
|
||||
errorElem :: LangTag -> Maybe LangTag -> StanzaError -> Element |
||||
|
||||
errorElem streamLang stanzaLang stanzaError = Element "error" typeAttrib |
||||
([defCondElem] ++ textElem ++ appSpecCondElem) |
||||
|
||||
where |
||||
|
||||
-- The required stanza error type. |
||||
typeAttrib :: [(Name, [Content])] |
||||
typeAttrib = [("type", [ContentText $ pack $ show $ stanzaErrorType stanzaError])] |
||||
|
||||
-- The required defined condition element. |
||||
defCondElem :: Node |
||||
defCondElem = NodeElement $ Element (Name (pack $ show $ stanzaErrorCondition stanzaError) (Just $ pack "urn:ietf:params:xml:ns:xmpp-stanzas") Nothing) [] [] |
||||
|
||||
|
||||
-- The optional text element. |
||||
textElem :: [Node] |
||||
textElem = case stanzaErrorText stanzaError of |
||||
Nothing -> [] |
||||
Just (textLang, text) -> |
||||
[NodeElement $ Element "{urn:ietf:params:xml:ns:xmpp-stanzas}text" |
||||
(langTagAttrib $ childLang streamLang [stanzaLang, fst $ fromJust $ stanzaErrorText stanzaError]) |
||||
[NodeContent $ ContentText $ pack text]] |
||||
|
||||
-- The optional application specific condition element. |
||||
appSpecCondElem :: [Node] |
||||
appSpecCondElem = case stanzaErrorApplicationSpecificCondition stanzaError of |
||||
Nothing -> [] |
||||
Just elem -> [NodeElement elem] |
||||
|
||||
|
||||
-- Generates the element attribute for an optional language tag. |
||||
|
||||
langTagAttrib :: Maybe LangTag -> [(Name, [Content])] |
||||
|
||||
langTagAttrib lang = case lang of Nothing -> []; Just lang' -> [("xml:lang", [ContentText $ pack $ show lang'])] |
||||
|
||||
|
||||
stanzaLang' :: LangTag -> LangTag -> Maybe LangTag |
||||
|
||||
stanzaLang' streamLang stanzaLang | streamLang == stanzaLang = Nothing |
||||
| otherwise = Just stanzaLang |
||||
|
||||
|
||||
-- Finds the language tag to set on the current element, if any. Makes sure that |
||||
-- language tags are not repeated unnecessarily (like on a child element, when |
||||
-- the parent has it). The first parameter is the stream language tag, and the |
||||
-- list of optional language tags are ordered in their XML element child |
||||
-- sequence, parent first, starting with the stanza language tag. |
||||
|
||||
childLang :: LangTag -> [Maybe LangTag] -> Maybe LangTag |
||||
|
||||
childLang streamLang optLangTags |
||||
|
||||
-- The current element does not have a language tag - set nothing. |
||||
| (head $ reverse optLangTags) == Nothing = Nothing |
||||
|
||||
-- All optional language tags are Nothing - set nothing. |
||||
| length langTags == 1 = Nothing |
||||
|
||||
-- The language tag of this element is the same as the closest parent with a |
||||
-- language tag - set nothing. |
||||
| (head langTags) == (head $ tail langTags) = Nothing |
||||
|
||||
-- Set the language tag. |
||||
| otherwise = Just $ head langTags |
||||
|
||||
where |
||||
|
||||
-- Contains the chain of language tags in descending priority order. |
||||
-- Contains at least one element - the stream language tag. |
||||
langTags = reverse $ [streamLang] ++ (map fromJust $ filter (\ l -> isJust l) optLangTags) |
||||
|
||||
|
||||
-- Creates the attributes common for all stanzas. |
||||
|
||||
stanzaAttribs :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe LangTag -> [(Name, [Content])] |
||||
|
||||
stanzaAttribs i f t l = if isJust $ i then [("id", [ContentText $ pack $ show $ fromJust i])] else [] ++ |
||||
if isJust $ f then [("from", [ContentText $ pack $ show $ fromJust f])] else [] ++ |
||||
if isJust $ t then [("to", [ContentText $ pack $ show $ fromJust t])] else [] ++ |
||||
if isJust $ l then [("xml:lang", [ContentText $ pack $ show l])] else [] |
||||
|
||||
|
||||
parseIQ :: Element -> IQ |
||||
|
||||
parseIQ = parseIQ |
||||
|
||||
|
||||
parsePresence :: Element -> InternalPresence |
||||
|
||||
parsePresence = parsePresence |
||||
|
||||
|
||||
parseMessage :: Element -> InternalMessage |
||||
|
||||
parseMessage = parseMessage |
||||
|
||||
|
||||
-- Converts a string to a PresenceType. Nothing means convertion error, Just |
||||
-- Nothing means the presence error type, and Just $ Just is the PresenceType. |
||||
|
||||
stringToPresenceType :: String -> Maybe (Maybe PresenceType) |
||||
|
||||
stringToPresenceType "probe" = Just $ Just Probe |
||||
stringToPresenceType "unavailable" = Just $ Just Unavailable |
||||
stringToPresenceType "subscribe" = Just $ Just Subscribe |
||||
stringToPresenceType "subscribed" = Just $ Just Subscribed |
||||
stringToPresenceType "unsubscribe" = Just $ Just Unsubscribe |
||||
stringToPresenceType "unsubscribed" = Just $ Just Unsubscribed |
||||
stringToPresenceType "error" = Just Nothing |
||||
stringToPresenceType _ = Nothing |
||||
|
||||
|
||||
-- Converts a Maybe MessageType to a string. Nothing means "error". |
||||
|
||||
presenceTypeToString :: Maybe PresenceType -> String |
||||
|
||||
presenceTypeToString (Just Unavailable) = "unavailable" |
||||
presenceTypeToString (Just Probe) = "probe" |
||||
presenceTypeToString Nothing = "error" |
||||
presenceTypeToString (Just Subscribe) = "subscribe" |
||||
presenceTypeToString (Just Subscribed) = "subscribed" |
||||
presenceTypeToString (Just Unsubscribe) = "unsubscribe" |
||||
presenceTypeToString (Just Unsubscribed) = "unsubscribed" |
||||
|
||||
|
||||
-- Converts a string to a MessageType. Nothing means convertion error, Just |
||||
-- Nothing means the message error type, and Just $ Just is the MessageType. |
||||
|
||||
stringToMessageType :: String -> Maybe (Maybe MessageType) |
||||
|
||||
stringToMessageType "chat" = Just $ Just Chat |
||||
stringToMessageType "error" = Just $ Nothing |
||||
stringToMessageType "groupchat" = Just $ Just Groupchat |
||||
stringToMessageType "headline" = Just $ Just Headline |
||||
stringToMessageType "normal" = Just $ Just Normal |
||||
stringToMessageType _ = Nothing |
||||
|
||||
|
||||
-- Converts a Maybe MessageType to a string. Nothing means "error". |
||||
|
||||
messageTypeToString :: Maybe MessageType -> String |
||||
|
||||
messageTypeToString (Just Chat) = "chat" |
||||
messageTypeToString Nothing = "error" |
||||
messageTypeToString (Just Groupchat) = "groupchat" |
||||
messageTypeToString (Just Headline) = "headline" |
||||
messageTypeToString (Just Normal) = "normal" |
||||
|
||||
|
||||
-- Converts a "<major>.<minor>" numeric version number to a "Version" object. |
||||
|
||||
versionFromString :: String -> Maybe Version |
||||
|
||||
versionFromString s = case parse version "" (DBC.pack s) of |
||||
Right version -> Just version |
||||
Left _ -> Nothing |
||||
|
||||
|
||||
-- Constructs a "Version" based on the major and minor version numbers. |
||||
|
||||
versionFromNumbers :: Integer -> Integer -> Version |
||||
|
||||
versionFromNumbers major minor = Version major minor |
||||
|
||||
|
||||
version :: GenParser Char st Version |
||||
|
||||
version = do |
||||
|
||||
-- Read numbers, a dot, more numbers, and end-of-file. |
||||
major <- many1 digit |
||||
char '.' |
||||
minor <- many1 digit |
||||
eof |
||||
return $ Version (read major) (read minor) |
||||
|
||||
|
||||
-- | |
||||
-- Parses, validates, and possibly constructs a "LangTag" object. |
||||
|
||||
langTag :: String -> Maybe LangTag |
||||
|
||||
langTag s = case parse languageTag "" (DBC.pack s) of |
||||
Right tag -> Just tag |
||||
Left _ -> Nothing |
||||
|
||||
|
||||
-- Parses a language tag as defined by RFC 1766 and constructs a LangTag object. |
||||
|
||||
languageTag :: GenParser Char st LangTag |
||||
|
||||
languageTag = do |
||||
|
||||
-- Read until we reach a '-' character, or EOF. This is the `primary tag'. |
||||
primTag <- tag |
||||
|
||||
-- Read zero or more subtags. |
||||
subTags <- subtags |
||||
eof |
||||
|
||||
return $ LangTag primTag subTags |
||||
where |
||||
|
||||
subtags :: GenParser Char st [String] |
||||
subtags = many $ do |
||||
char '-' |
||||
subtag <- tag |
||||
return subtag |
||||
|
||||
tag :: GenParser Char st String |
||||
tag = do |
||||
a <- many1 $ oneOf tagChars |
||||
return a |
||||
|
||||
tagChars :: [Char] |
||||
tagChars = ['a'..'z'] ++ ['A'..'Z'] |
||||
@ -1,30 +0,0 @@
@@ -1,30 +0,0 @@
|
||||
-- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the |
||||
-- Pontarius distribution for more details. |
||||
|
||||
-- TODO: TLS12 when supported in tls; TODO: TLS11 results in a read error - bug? |
||||
-- TODO: cipher_AES128_SHA1 = TLS_RSA_WITH_AES_128_CBC_SHA? |
||||
-- TODO: Compression? |
||||
-- TODO: Validate certificate |
||||
|
||||
{-# OPTIONS_HADDOCK hide #-} |
||||
|
||||
module Network.XMPP.TLS (tlsParams) where |
||||
|
||||
import Network.TLS (TLSCertificateUsage (CertificateUsageAccept), |
||||
TLSParams (..), Version (SSL3, TLS10, TLS11), |
||||
defaultLogging, nullCompression) |
||||
import Network.TLS.Extra (cipher_AES128_SHA1) |
||||
|
||||
|
||||
tlsParams :: TLSParams |
||||
|
||||
tlsParams = TLSParams { pConnectVersion = TLS10 |
||||
, pAllowedVersions = [SSL3, TLS10,TLS11] |
||||
, pCiphers = [cipher_AES128_SHA1] |
||||
, pCompressions = [nullCompression] |
||||
, pWantClientCert = False -- Used for servers |
||||
, pUseSecureRenegotiation = False -- No renegotiation |
||||
, pCertificates = [] -- TODO |
||||
, pLogging = defaultLogging -- TODO |
||||
, onCertificatesRecv = \ certificate -> |
||||
return CertificateUsageAccept } |
||||
@ -0,0 +1,45 @@
@@ -0,0 +1,45 @@
|
||||
{-# Language NoMonomorphismRestriction #-} |
||||
module Data.Conduit.TLS |
||||
( tlsinit |
||||
-- , conduitStdout |
||||
, module TLS |
||||
, module TLSExtra |
||||
) |
||||
where |
||||
|
||||
import Control.Monad(liftM) |
||||
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 Network.TLS as TLS |
||||
import Network.TLS.Extra as TLSExtra |
||||
|
||||
import System.IO(Handle) |
||||
|
||||
tlsinit |
||||
:: (MonadIO m, MonadIO m1) => |
||||
TLSParams |
||||
-> Handle -> m ( Source m1 BS.ByteString |
||||
, Sink BS.ByteString m1 () |
||||
, BS.ByteString -> IO ()) |
||||
tlsinit tlsParams handle = do |
||||
gen <- liftIO $ (newGenIO :: IO SystemRandom) -- TODO: Find better random source? |
||||
clientContext <- client tlsParams gen handle |
||||
handshake clientContext |
||||
let src = sourceState |
||||
clientContext |
||||
(\con -> StateOpen con `liftM` recvData con) |
||||
let snk = sinkState |
||||
clientContext |
||||
(\con bs -> sendData con (BL.fromChunks [bs]) |
||||
>> return (StateProcessing con)) |
||||
(\_ -> return ()) |
||||
return ( src |
||||
, snk |
||||
, \s -> sendData clientContext $ BL.fromChunks [s] ) |
||||
|
||||
@ -0,0 +1,55 @@
@@ -0,0 +1,55 @@
|
||||
{-# LANGUAGE PackageImports, OverloadedStrings #-} |
||||
module Example where |
||||
|
||||
import Data.Text as T |
||||
|
||||
import Network.XMPP |
||||
import Control.Concurrent |
||||
import Control.Concurrent.STM |
||||
import Control.Monad |
||||
import Control.Monad.IO.Class |
||||
|
||||
philonous :: JID |
||||
philonous = read "uart14@species64739.dyndns.org" |
||||
|
||||
attXmpp :: STM a -> XMPPThread a |
||||
attXmpp = liftIO . atomically |
||||
|
||||
autoAccept :: XMPPThread () |
||||
autoAccept = forever $ do |
||||
st <- pullPresence |
||||
case st of |
||||
Presence from _ idq (Just Subscribe) _ _ _ _ -> |
||||
sendS . SPresence $ |
||||
Presence Nothing from idq (Just Subscribed) Nothing Nothing Nothing [] |
||||
_ -> return () |
||||
|
||||
mirror :: XMPPThread () |
||||
mirror = forever $ do |
||||
st <- pullMessage |
||||
case st of |
||||
Message (Just from) _ idq tp subject (Just bd) thr _ -> |
||||
sendS . SMessage $ |
||||
Message Nothing from idq tp subject |
||||
(Just $ "you wrote: " `T.append` bd) thr [] |
||||
_ -> return () |
||||
|
||||
|
||||
main :: IO () |
||||
main = do |
||||
sessionConnect "localhost" "species64739.dyndns.org" "bot" Nothing $ do |
||||
-- singleThreaded $ xmppStartTLS exampleParams |
||||
singleThreaded $ xmppSASL "pwd" |
||||
xmppThreadedBind (Just "botsi") |
||||
-- singleThreaded $ xmppBind (Just "botsi") |
||||
singleThreaded $ xmppSession |
||||
forkXMPP autoAccept |
||||
forkXMPP mirror |
||||
sendS . SPresence $ Presence Nothing Nothing Nothing Nothing |
||||
(Just Available) Nothing Nothing [] |
||||
sendS . SMessage $ Message Nothing philonous Nothing Nothing Nothing |
||||
(Just "bla") Nothing [] |
||||
liftIO . forever $ threadDelay 1000000 |
||||
return () |
||||
return () |
||||
|
||||
@ -0,0 +1,65 @@
@@ -0,0 +1,65 @@
|
||||
-- Copyright © 2010-2012 Jon Kristensen. |
||||
-- Copyright 2012 Philipp Balzarek |
||||
-- See the LICENSE file in the |
||||
-- Pontarius distribution for more details. |
||||
|
||||
-- | |
||||
-- Module: $Header$ |
||||
-- Description: Pontarius API |
||||
-- Copyright: Copyright © 2010-2012 Jon Kristensen |
||||
-- License: Apache License 2.0 |
||||
-- |
||||
-- Maintainer: jon.kristensen@nejla.com |
||||
-- Stability: unstable |
||||
-- Portability: portable |
||||
-- |
||||
-- XMPP is an open standard, extendable, and secure communications |
||||
-- protocol designed on top of XML, TLS, and SASL. Pontarius XMPP is |
||||
-- an XMPP client library, implementing the core capabilities of XMPP |
||||
-- (RFC 6120). |
||||
-- |
||||
-- Developers using this library are assumed to understand how XMPP |
||||
-- works. |
||||
-- |
||||
-- This module will be documented soon. |
||||
-- |
||||
-- Note that we are not recommending anyone to use Pontarius XMPP at |
||||
-- this time as it's still in an experimental stage and will have its |
||||
-- API and data types modified frequently. |
||||
|
||||
{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} |
||||
|
||||
module Network.XMPP |
||||
( module Network.XMPP.Bind |
||||
, module Network.XMPP.Concurrent |
||||
, module Network.XMPP.Monad |
||||
, module Network.XMPP.SASL |
||||
, module Network.XMPP.Session |
||||
, module Network.XMPP.Stream |
||||
, module Network.XMPP.TLS |
||||
, module Network.XMPP.Types |
||||
, module Network.XMPP.Presence |
||||
, module Network.XMPP.Message |
||||
, xmppConnect |
||||
, xmppNewSession |
||||
) where |
||||
|
||||
import Data.Text as Text |
||||
|
||||
import Network |
||||
import Network.XMPP.Bind |
||||
import Network.XMPP.Concurrent |
||||
import Network.XMPP.Message |
||||
import Network.XMPP.Monad |
||||
import Network.XMPP.Presence |
||||
import Network.XMPP.SASL |
||||
import Network.XMPP.Session |
||||
import Network.XMPP.Stream |
||||
import Network.XMPP.TLS |
||||
import Network.XMPP.Types |
||||
|
||||
xmppConnect :: HostName -> Text -> XMPPConMonad () |
||||
xmppConnect address hostname = xmppRawConnect address hostname >> xmppStartStream |
||||
|
||||
xmppNewSession :: XMPPThread a -> IO (a, XMPPConState) |
||||
xmppNewSession = withNewSession . runThreaded |
||||
@ -0,0 +1,34 @@
@@ -0,0 +1,34 @@
|
||||
{-# LANGUAGE OverloadedStrings #-} |
||||
|
||||
module Network.XMPP.Bind where |
||||
|
||||
import Data.Text as Text |
||||
|
||||
import Data.XML.Pickle |
||||
import Data.XML.Types |
||||
|
||||
import Network.XMPP.Types |
||||
import Network.XMPP.Pickle |
||||
import Network.XMPP.Concurrent |
||||
|
||||
bindP :: PU [Node] b -> PU [Node] b |
||||
bindP c = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-bind}bind" c |
||||
|
||||
bindBody :: Maybe Text -> Element |
||||
bindBody rsrc = (pickleElem |
||||
(bindP . xpOption $ xpElemNodes "resource" (xpContent xpId)) |
||||
rsrc |
||||
) |
||||
|
||||
jidP :: PU [Node] JID |
||||
jidP = bindP $ xpElemNodes "jid" (xpContent xpPrim) |
||||
|
||||
xmppThreadedBind :: Maybe Text -> XMPPThread Text |
||||
xmppThreadedBind rsrc = do |
||||
answer <- sendIQ' Nothing Set Nothing (bindBody rsrc) |
||||
let (Right IQResult{iqResultPayload = Just b}) = answer -- TODO: Error handling |
||||
let (JID _n _d (Just r)) = unpickleElem jidP b |
||||
return r |
||||
|
||||
|
||||
|
||||
@ -0,0 +1,18 @@
@@ -0,0 +1,18 @@
|
||||
module Network.XMPP.Concurrent |
||||
( module Network.XMPP.Concurrent.Types |
||||
, module Network.XMPP.Concurrent.Monad |
||||
, module Network.XMPP.Concurrent.Threads |
||||
, module Network.XMPP.Concurrent.IQ |
||||
) where |
||||
|
||||
import Network.XMPP.Concurrent.Types |
||||
import Network.XMPP.Concurrent.Monad |
||||
import Network.XMPP.Concurrent.Threads |
||||
import Network.XMPP.Concurrent.IQ |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@ -0,0 +1,59 @@
@@ -0,0 +1,59 @@
|
||||
module Network.XMPP.Concurrent.IQ where |
||||
|
||||
import Control.Concurrent.STM |
||||
import Control.Monad.IO.Class |
||||
import Control.Monad.Trans.Reader |
||||
|
||||
import Data.XML.Types |
||||
import qualified Data.Map as Map |
||||
|
||||
import Network.XMPP.Concurrent.Types |
||||
import Network.XMPP.Concurrent.Monad |
||||
import Network.XMPP.Types |
||||
|
||||
-- | Sends an IQ, returns a 'TMVar' that will be filled with the first inbound |
||||
-- IQ with a matching ID that has type @result@ or @error@ |
||||
sendIQ :: Maybe JID -- ^ Recipient (to) |
||||
-> IQRequestType -- ^ IQ type (Get or Set) |
||||
-> Maybe LangTag -- ^ Language tag of the payload (Nothing for default) |
||||
-> Element -- ^ The iq body (there has to be exactly one) |
||||
-> XMPPThread (TMVar IQResponse) |
||||
sendIQ to tp lang body = do -- TODO: add timeout |
||||
newId <- liftIO =<< asks idGenerator |
||||
handlers <- asks iqHandlers |
||||
ref <- liftIO . atomically $ do |
||||
resRef <- newEmptyTMVar |
||||
(byNS, byId) <- readTVar handlers |
||||
writeTVar handlers (byNS, Map.insert newId resRef byId) |
||||
-- TODO: Check for id collisions (shouldn't happen?) |
||||
return resRef |
||||
sendS . IQRequestS $ IQRequest newId Nothing to lang tp body |
||||
return ref |
||||
|
||||
-- | like 'sendIQ', but waits for the answer IQ |
||||
sendIQ' :: Maybe JID |
||||
-> IQRequestType |
||||
-> Maybe LangTag |
||||
-> Element |
||||
-> XMPPThread IQResponse |
||||
sendIQ' to tp lang body = do |
||||
ref <- sendIQ to tp lang body |
||||
liftIO . atomically $ takeTMVar ref |
||||
|
||||
answerIQ :: (IQRequest, TVar Bool) |
||||
-> Either StanzaError (Maybe Element) |
||||
-> XMPPThread Bool |
||||
answerIQ ((IQRequest iqid from _to lang _tp bd), sentRef) answer = do |
||||
out <- asks outCh |
||||
let response = case answer of |
||||
Left err -> IQErrorS $ IQError iqid Nothing from lang err (Just bd) |
||||
Right res -> IQResultS $ IQResult iqid Nothing from lang res |
||||
liftIO . atomically $ do |
||||
sent <- readTVar sentRef |
||||
case sent of |
||||
False -> do |
||||
writeTVar sentRef True |
||||
|
||||
writeTChan out response |
||||
return True |
||||
True -> return False |
||||
@ -0,0 +1,169 @@
@@ -0,0 +1,169 @@
|
||||
module Network.XMPP.Concurrent.Monad where |
||||
|
||||
import Network.XMPP.Types |
||||
|
||||
import Control.Concurrent |
||||
import Control.Concurrent.STM |
||||
import qualified Control.Exception.Lifted as Ex |
||||
import Control.Monad.IO.Class |
||||
import Control.Monad.Trans.Reader |
||||
import Control.Monad.Trans.State |
||||
|
||||
import Data.IORef |
||||
import qualified Data.Map as Map |
||||
import Data.Text(Text) |
||||
|
||||
import Network.XMPP.Concurrent.Types |
||||
|
||||
-- | Register a new IQ listener. IQ requests matching the type and namespace will |
||||
-- be put in the channel. |
||||
listenIQChan :: IQRequestType -- ^ type of IQs to receive (Get / Set) |
||||
-> Text -- ^ namespace of the child element |
||||
-> XMPPThread (Bool, TChan (IQRequest, TVar Bool)) |
||||
listenIQChan tp ns = do |
||||
handlers <- asks iqHandlers |
||||
liftIO . atomically $ do |
||||
(byNS, byID) <- readTVar handlers |
||||
iqCh <- newTChan |
||||
let (present, byNS') = Map.insertLookupWithKey' (\_ new _ -> new) |
||||
(tp,ns) iqCh byNS |
||||
writeTVar handlers (byNS', byID) |
||||
return $ case present of |
||||
Nothing -> (True, iqCh) |
||||
Just iqCh' -> (False, iqCh') |
||||
|
||||
-- | get the inbound stanza channel, duplicates from master if necessary |
||||
-- please note that once duplicated it will keep filling up, call |
||||
-- 'dropMessageChan' to allow it to be garbage collected |
||||
getMessageChan :: XMPPThread (TChan (Either MessageError Message)) |
||||
getMessageChan = do |
||||
mChR <- asks messagesRef |
||||
mCh <- liftIO $ readIORef mChR |
||||
case mCh of |
||||
Nothing -> do |
||||
shadow <- asks mShadow |
||||
mCh' <- liftIO $ atomically $ dupTChan shadow |
||||
liftIO $ writeIORef mChR (Just mCh') |
||||
return mCh' |
||||
Just mCh' -> return mCh' |
||||
|
||||
-- | see 'getMessageChan' |
||||
getPresenceChan :: XMPPThread (TChan (Either PresenceError Presence)) |
||||
getPresenceChan = do |
||||
pChR <- asks presenceRef |
||||
pCh <- liftIO $ readIORef pChR |
||||
case pCh of |
||||
Nothing -> do |
||||
shadow <- asks pShadow |
||||
pCh' <- liftIO $ atomically $ dupTChan shadow |
||||
liftIO $ writeIORef pChR (Just pCh') |
||||
return pCh' |
||||
Just pCh' -> return pCh' |
||||
|
||||
-- | Drop the local end of the inbound stanza channel |
||||
-- from our context so it can be GC-ed |
||||
dropMessageChan :: XMPPThread () |
||||
dropMessageChan = do |
||||
r <- asks messagesRef |
||||
liftIO $ writeIORef r Nothing |
||||
|
||||
-- | see 'dropMessageChan' |
||||
dropPresenceChan :: XMPPThread () |
||||
dropPresenceChan = do |
||||
r <- asks presenceRef |
||||
liftIO $ writeIORef r Nothing |
||||
|
||||
-- | Read an element from the inbound stanza channel, acquiring a copy |
||||
-- of the channel as necessary |
||||
pullMessage :: XMPPThread (Either MessageError Message) |
||||
pullMessage = do |
||||
c <- getMessageChan |
||||
liftIO $ atomically $ readTChan c |
||||
|
||||
-- | Read an element from the inbound stanza channel, acquiring a copy |
||||
-- of the channel as necessary |
||||
pullPresence :: XMPPThread (Either PresenceError Presence) |
||||
pullPresence = do |
||||
c <- getPresenceChan |
||||
liftIO $ atomically $ readTChan c |
||||
|
||||
-- | Send a stanza to the server |
||||
sendS :: Stanza -> XMPPThread () |
||||
sendS a = do |
||||
out <- asks outCh |
||||
liftIO . atomically $ writeTChan out a |
||||
return () |
||||
|
||||
-- | Fork a new thread |
||||
forkXMPP :: XMPPThread () -> XMPPThread ThreadId |
||||
forkXMPP a = do |
||||
thread <- ask |
||||
mCH' <- liftIO $ newIORef Nothing |
||||
pCH' <- liftIO $ newIORef Nothing |
||||
liftIO $ forkIO $ runReaderT a (thread {messagesRef = mCH' |
||||
,presenceRef = pCH' |
||||
}) |
||||
|
||||
filterMessages :: (MessageError -> Bool) |
||||
-> (Message -> Bool) |
||||
-> XMPPThread (Either MessageError Message) |
||||
filterMessages f g = do |
||||
s <- pullMessage |
||||
case s of |
||||
Left e | f e -> return $ Left e |
||||
| otherwise -> filterMessages f g |
||||
Right m | g m -> return $ Right m |
||||
| otherwise -> filterMessages f g |
||||
|
||||
waitForMessage :: (Message -> Bool) -> XMPPThread Message |
||||
waitForMessage f = do |
||||
s <- pullMessage |
||||
case s of |
||||
Left _ -> waitForMessage f |
||||
Right m | f m -> return m |
||||
| otherwise -> waitForMessage f |
||||
|
||||
waitForMessageError :: (MessageError -> Bool) -> XMPPThread MessageError |
||||
waitForMessageError f = do |
||||
s <- pullMessage |
||||
case s of |
||||
Right _ -> waitForMessageError f |
||||
Left m | f m -> return m |
||||
| otherwise -> waitForMessageError f |
||||
|
||||
waitForPresence :: (Presence -> Bool) -> XMPPThread Presence |
||||
waitForPresence f = do |
||||
s <- pullPresence |
||||
case s of |
||||
Left _ -> waitForPresence f |
||||
Right m | f m -> return m |
||||
| otherwise -> waitForPresence f |
||||
|
||||
-- | Run an XMPPMonad action in isolation. |
||||
-- Reader and writer workers will be temporarily stopped |
||||
-- and resumed with the new session details once the action returns. |
||||
-- The Action will run in the calling thread/ |
||||
-- NB: This will /not/ catch any exceptions. If you action dies, deadlocks |
||||
-- or otherwisely exits abnormaly the XMPP session will be dead. |
||||
withConnection :: XMPPConMonad a -> XMPPThread a |
||||
withConnection a = do |
||||
readerId <- asks readerThread |
||||
stateRef <- asks conStateRef |
||||
write <- asks writeRef |
||||
wait <- liftIO $ newEmptyTMVarIO |
||||
liftIO . throwTo readerId $ Interrupt wait |
||||
s <- liftIO . atomically $ do |
||||
putTMVar wait () |
||||
takeTMVar write |
||||
takeTMVar stateRef |
||||
(res, s') <- liftIO $ runStateT a s |
||||
liftIO . atomically $ do |
||||
putTMVar write (sConPushBS s') |
||||
putTMVar stateRef s' |
||||
return res |
||||
|
||||
sendPresence :: Presence -> XMPPThread () |
||||
sendPresence = sendS . PresenceS |
||||
|
||||
sendMessage :: Message -> XMPPThread () |
||||
sendMessage = sendS . MessageS |
||||
@ -0,0 +1,178 @@
@@ -0,0 +1,178 @@
|
||||
{-# LANGUAGE ScopedTypeVariables #-} |
||||
{-# LANGUAGE OverloadedStrings #-} |
||||
module Network.XMPP.Concurrent.Threads where |
||||
|
||||
import Network.XMPP.Types |
||||
|
||||
import Control.Applicative((<$>),(<*>)) |
||||
import Control.Concurrent |
||||
import Control.Concurrent.STM |
||||
import qualified Control.Exception.Lifted as Ex |
||||
import Control.Monad |
||||
import Control.Monad.IO.Class |
||||
import Control.Monad.Trans.Class |
||||
import Control.Monad.Trans.Reader |
||||
import Control.Monad.Trans.Resource |
||||
import Control.Monad.Trans.State |
||||
|
||||
import qualified Data.ByteString as BS |
||||
import Data.Conduit |
||||
import qualified Data.Conduit.List as CL |
||||
import Data.Default (def) |
||||
import Data.IORef |
||||
import qualified Data.Map as Map |
||||
import Data.Maybe |
||||
import qualified Data.Text as Text |
||||
|
||||
import Data.XML.Types |
||||
|
||||
import Network.XMPP.Monad |
||||
import Network.XMPP.Marshal |
||||
import Network.XMPP.Pickle |
||||
import Network.XMPP.Concurrent.Types |
||||
|
||||
import Text.XML.Stream.Elements |
||||
import qualified Text.XML.Stream.Render as XR |
||||
|
||||
readWorker :: TChan (Either MessageError Message) |
||||
-> TChan (Either PresenceError Presence) |
||||
-> TVar IQHandlers |
||||
-> TMVar XMPPConState |
||||
-> IO () |
||||
readWorker messageC presenceC handlers stateRef = |
||||
Ex.mask_ . forever $ do |
||||
s <- liftIO . atomically $ takeTMVar stateRef |
||||
(sta', s') <- flip runStateT s $ Ex.catch ( do |
||||
-- we don't know whether pull will necessarily be interruptible |
||||
liftIO $ Ex.allowInterrupt |
||||
Just <$> pull |
||||
) |
||||
(\(Interrupt t) -> do |
||||
liftIO . atomically $ |
||||
putTMVar stateRef s |
||||
liftIO . atomically $ takeTMVar t |
||||
return Nothing |
||||
) |
||||
liftIO . atomically $ do |
||||
case sta' of |
||||
Nothing -> return () |
||||
Just sta -> do |
||||
putTMVar stateRef s' |
||||
case sta of |
||||
MessageS m -> do writeTChan messageC $ Right m |
||||
_ <- readTChan messageC -- Sic! |
||||
return () |
||||
-- this may seem ridiculous, but to prevent |
||||
-- the channel from filling up we immedtiately remove the |
||||
-- Stanza we just put in. It will still be |
||||
-- available in duplicates. |
||||
MessageErrorS m -> do writeTChan messageC $ Left m |
||||
_ <- readTChan messageC |
||||
return () |
||||
PresenceS p -> do |
||||
writeTChan presenceC $ Right p |
||||
_ <- readTChan presenceC |
||||
return () |
||||
PresenceErrorS p -> do |
||||
writeTChan presenceC $ Left p |
||||
_ <- readTChan presenceC |
||||
return () |
||||
|
||||
IQRequestS i -> handleIQRequest handlers i |
||||
IQResultS i -> handleIQResponse handlers (Right i) |
||||
IQErrorS i -> handleIQResponse handlers (Left i) |
||||
|
||||
|
||||
handleIQRequest handlers iq = do |
||||
(byNS, _) <- readTVar handlers |
||||
let iqNS = fromMaybe "" (nameNamespace . elementName $ iqRequestPayload iq) |
||||
case Map.lookup (iqRequestType iq, iqNS) byNS of |
||||
Nothing -> return () -- TODO: send error stanza |
||||
Just ch -> do |
||||
sent <- newTVar False |
||||
writeTChan ch (iq, sent) |
||||
|
||||
handleIQResponse handlers iq = do |
||||
(byNS, byID) <- readTVar handlers |
||||
case Map.updateLookupWithKey (\_ _ -> Nothing) (iqID iq) byID of |
||||
(Nothing, _) -> return () -- we are not supposed |
||||
-- to send an error |
||||
(Just tmvar, byID') -> do |
||||
_ <- tryPutTMVar tmvar iq -- don't block |
||||
writeTVar handlers (byNS, byID') |
||||
where |
||||
iqID (Left err) = iqErrorID err |
||||
iqID (Right iq) = iqResultID iq |
||||
|
||||
writeWorker :: TChan Stanza -> TMVar (BS.ByteString -> IO ()) -> IO () |
||||
writeWorker stCh writeR = forever $ do |
||||
(write, next) <- atomically $ (,) <$> |
||||
takeTMVar writeR <*> |
||||
readTChan stCh |
||||
_ <- write $ renderElement (pickleElem stanzaP next) |
||||
atomically $ putTMVar writeR write |
||||
|
||||
-- Two streams: input and output. Threads read from input stream and write to output stream. |
||||
-- | Runs thread in XmppState monad |
||||
-- returns channel of incoming and outgoing stances, respectively |
||||
-- and an Action to stop the Threads and close the connection |
||||
startThreads |
||||
:: XMPPConMonad ( TChan (Either MessageError Message) |
||||
, TChan (Either PresenceError Presence) |
||||
, TVar IQHandlers |
||||
, TChan Stanza |
||||
, IO () |
||||
, TMVar (BS.ByteString -> IO ()) |
||||
, TMVar XMPPConState |
||||
, ThreadId |
||||
) |
||||
|
||||
startThreads = do |
||||
writeLock <- liftIO . newTMVarIO =<< gets sConPushBS |
||||
messageC <- liftIO newTChanIO |
||||
presenceC <- liftIO newTChanIO |
||||
iqC <- liftIO newTChanIO |
||||
outC <- liftIO newTChanIO |
||||
handlers <- liftIO $ newTVarIO ( Map.empty, Map.empty) |
||||
conS <- liftIO . newTMVarIO =<< get |
||||
lw <- liftIO . forkIO $ writeWorker outC writeLock |
||||
cp <- liftIO . forkIO $ connPersist writeLock |
||||
s <- get |
||||
rd <- liftIO . forkIO $ readWorker messageC presenceC handlers conS |
||||
return (messageC, presenceC, handlers, outC |
||||
, killConnection writeLock [lw, rd, cp] |
||||
, writeLock, conS ,rd) |
||||
where |
||||
killConnection writeLock threads = liftIO $ do |
||||
_ <- atomically $ takeTMVar writeLock -- Should we put it back? |
||||
_ <- forM threads killThread |
||||
return() |
||||
|
||||
-- | Start worker threads and run action. The supplied action will run |
||||
-- in the calling thread. use 'forkXMPP' to start another thread. |
||||
runThreaded :: XMPPThread a |
||||
-> XMPPConMonad a |
||||
runThreaded a = do |
||||
liftIO . putStrLn $ "starting threads" |
||||
(mC, pC, hand, outC, _stopThreads, writeR, conS, rdr ) <- startThreads |
||||
liftIO . putStrLn $ "threads running" |
||||
workermCh <- liftIO . newIORef $ Nothing |
||||
workerpCh <- liftIO . newIORef $ Nothing |
||||
idRef <- liftIO $ newTVarIO 1 |
||||
let getId = atomically $ do |
||||
curId <- readTVar idRef |
||||
writeTVar idRef (curId + 1 :: Integer) |
||||
return . read. show $ curId |
||||
s <- get |
||||
liftIO . putStrLn $ "starting application" |
||||
liftIO $ runReaderT a (Thread workermCh workerpCh mC pC outC hand writeR rdr getId conS) |
||||
|
||||
|
||||
-- | Sends a blank space every 30 seconds to keep the connection alive |
||||
connPersist :: TMVar (BS.ByteString -> IO ()) -> IO () |
||||
connPersist lock = forever $ do |
||||
pushBS <- atomically $ takeTMVar lock |
||||
pushBS " " |
||||
atomically $ putTMVar lock pushBS |
||||
-- putStrLn "<space added>" |
||||
threadDelay 30000000 |
||||
@ -0,0 +1,48 @@
@@ -0,0 +1,48 @@
|
||||
{-# LANGUAGE DeriveDataTypeable #-} |
||||
|
||||
module Network.XMPP.Concurrent.Types where |
||||
|
||||
import qualified Control.Exception.Lifted as Ex |
||||
import Control.Concurrent |
||||
import Control.Concurrent.STM |
||||
import Control.Monad.Trans.Reader |
||||
|
||||
import qualified Data.ByteString as BS |
||||
import Data.IORef |
||||
import qualified Data.Map as Map |
||||
import Data.Text(Text) |
||||
import Data.Typeable |
||||
|
||||
|
||||
import Network.XMPP.Types |
||||
|
||||
|
||||
type IQHandlers = (Map.Map (IQRequestType, Text) (TChan (IQRequest, TVar Bool)) |
||||
, Map.Map StanzaId (TMVar IQResponse) |
||||
) |
||||
|
||||
data Thread = Thread { messagesRef :: IORef (Maybe ( TChan (Either |
||||
MessageError |
||||
Message |
||||
))) |
||||
, presenceRef :: IORef (Maybe (TChan (Either |
||||
PresenceError |
||||
Presence |
||||
))) |
||||
, mShadow :: TChan (Either MessageError |
||||
Message) -- the original chan |
||||
, pShadow :: TChan (Either PresenceError |
||||
Presence) -- the original chan |
||||
, outCh :: TChan Stanza |
||||
, iqHandlers :: TVar IQHandlers |
||||
, writeRef :: TMVar (BS.ByteString -> IO () ) |
||||
, readerThread :: ThreadId |
||||
, idGenerator :: IO StanzaId |
||||
, conStateRef :: TMVar XMPPConState |
||||
} |
||||
|
||||
type XMPPThread a = ReaderT Thread IO a |
||||
|
||||
data Interrupt = Interrupt (TMVar ()) deriving Typeable |
||||
instance Show Interrupt where show _ = "<Interrupt>" |
||||
instance Ex.Exception Interrupt |
||||
@ -0,0 +1,195 @@
@@ -0,0 +1,195 @@
|
||||
{-# Language OverloadedStrings, ViewPatterns, NoMonomorphismRestriction #-} |
||||
|
||||
module Network.XMPP.Marshal where |
||||
|
||||
import Data.XML.Pickle |
||||
import Data.XML.Types |
||||
|
||||
import Network.XMPP.Types |
||||
|
||||
stanzaSel :: Stanza -> Int |
||||
stanzaSel (IQRequestS _) = 0 |
||||
stanzaSel (IQResultS _) = 1 |
||||
stanzaSel (IQErrorS _) = 2 |
||||
stanzaSel (MessageS _) = 3 |
||||
stanzaSel (MessageErrorS _) = 4 |
||||
stanzaSel (PresenceS _) = 5 |
||||
stanzaSel (PresenceErrorS _) = 6 |
||||
|
||||
stanzaP :: PU [Node] Stanza |
||||
stanzaP = xpAlt stanzaSel |
||||
[ xpWrap IQRequestS (\(IQRequestS x) -> x) xpIQRequest |
||||
, xpWrap IQResultS (\(IQResultS x) -> x) xpIQResult |
||||
, xpWrap IQErrorS (\(IQErrorS x) -> x) xpIQError |
||||
, xpWrap MessageS (\(MessageS x) -> x) xpMessage |
||||
, xpWrap MessageErrorS (\(MessageErrorS x) -> x) xpMessageError |
||||
, xpWrap PresenceS (\(PresenceS x) -> x) xpPresence |
||||
, xpWrap PresenceErrorS (\(PresenceErrorS x) -> x) xpPresenceError |
||||
] |
||||
|
||||
xmlLang :: Name |
||||
xmlLang = Name "lang" Nothing (Just "xml") |
||||
|
||||
xpLangTag :: PU [Attribute] (Maybe LangTag) |
||||
xpLangTag = xpAttrImplied xmlLang xpPrim |
||||
|
||||
xpMessage :: PU [Node] (Message) |
||||
xpMessage = xpWrap (\((tp, qid, from, to, lang), (sub, body, thr, ext)) |
||||
-> Message qid from to lang tp sub thr body ext) |
||||
(\(Message qid from to lang tp sub thr body ext) |
||||
-> ((tp, qid, from, to, lang), (sub, body, thr, ext))) |
||||
$ |
||||
xpElem "{jabber:client}message" |
||||
(xp5Tuple |
||||
(xpDefault Normal $ xpAttr "type" xpPrim) |
||||
(xpAttrImplied "id" xpPrim) |
||||
(xpAttrImplied "from" xpPrim) |
||||
(xpAttrImplied "to" xpPrim) |
||||
(xpAttrImplied xmlLang xpPrim) |
||||
-- TODO: NS? |
||||
) |
||||
(xp4Tuple |
||||
(xpOption . xpElemNodes "{jabber:client}subject" $ xpContent xpId) |
||||
(xpOption . xpElemNodes "{jabber:client}body" $ xpContent xpId) |
||||
(xpOption . xpElemNodes "{jabber:client}thread" $ xpContent xpId) |
||||
(xpAll xpElemVerbatim) |
||||
) |
||||
|
||||
|
||||
xpPresence :: PU [Node] Presence |
||||
xpPresence = xpWrap (\((qid, from, to, lang, tp),(shw, stat, prio, ext)) |
||||
-> Presence qid from to lang tp shw stat prio ext) |
||||
(\(Presence qid from to lang tp shw stat prio ext) |
||||
-> ((qid, from, to, lang, tp), (shw, stat, prio, ext))) |
||||
$ |
||||
xpElem "{jabber:client}presence" |
||||
(xp5Tuple |
||||
(xpAttrImplied "id" xpPrim) |
||||
(xpAttrImplied "from" xpPrim) |
||||
(xpAttrImplied "to" xpPrim) |
||||
xpLangTag |
||||
(xpAttrImplied "type" xpPrim) |
||||
) |
||||
(xp4Tuple |
||||
(xpOption . xpElemNodes "{jabber:client}show" $ xpContent xpPrim) |
||||
(xpOption . xpElemNodes "{jabber:client}status" $ xpContent xpId) |
||||
(xpOption . xpElemNodes "{jabber:client}priority" $ xpContent xpPrim) |
||||
(xpAll xpElemVerbatim) |
||||
) |
||||
|
||||
xpIQRequest :: PU [Node] IQRequest |
||||
xpIQRequest = xpWrap (\((qid, from, to, lang, tp),body) |
||||
-> IQRequest qid from to lang tp body) |
||||
(\(IQRequest qid from to lang tp body) |
||||
-> ((qid, from, to, lang, tp), body)) |
||||
$ |
||||
xpElem "{jabber:client}iq" |
||||
(xp5Tuple |
||||
(xpAttr "id" xpPrim) |
||||
(xpAttrImplied "from" xpPrim) |
||||
(xpAttrImplied "to" xpPrim) |
||||
xpLangTag |
||||
((xpAttr "type" xpPrim)) |
||||
) |
||||
(xpElemVerbatim) |
||||
|
||||
xpIQResult :: PU [Node] IQResult |
||||
xpIQResult = xpWrap (\((qid, from, to, lang, _tp),body) |
||||
-> IQResult qid from to lang body) |
||||
(\(IQResult qid from to lang body) |
||||
-> ((qid, from, to, lang, ()), body)) |
||||
$ |
||||
xpElem "{jabber:client}iq" |
||||
(xp5Tuple |
||||
(xpAttr "id" xpPrim) |
||||
(xpAttrImplied "from" xpPrim) |
||||
(xpAttrImplied "to" xpPrim) |
||||
xpLangTag |
||||
((xpAttrFixed "type" "result")) |
||||
) |
||||
(xpOption xpElemVerbatim) |
||||
|
||||
---------------------------------------------------------- |
||||
-- Errors |
||||
---------------------------------------------------------- |
||||
|
||||
xpErrorCondition :: PU [Node] StanzaErrorCondition |
||||
xpErrorCondition = xpWrap (\(cond, (), ()) -> cond) (\cond -> (cond, (), ())) $ |
||||
xpElemByNamespace |
||||
"urn:ietf:params:xml:ns:xmpp-stanzas" xpPrim |
||||
xpUnit |
||||
xpUnit |
||||
|
||||
xpStanzaError :: PU [Node] StanzaError |
||||
xpStanzaError = xpWrap |
||||
(\(tp, (cond, txt, ext)) -> StanzaError tp cond txt ext) |
||||
(\(StanzaError tp cond txt ext) -> (tp, (cond, txt, ext))) $ |
||||
xpElem "{jabber:client}error" |
||||
(xpAttr "type" xpPrim) |
||||
(xp3Tuple |
||||
xpErrorCondition |
||||
(xpOption $ xpElem "{jabber:client}text" |
||||
(xpAttrImplied xmlLang xpPrim) |
||||
(xpContent xpId) |
||||
) |
||||
(xpOption xpElemVerbatim) |
||||
) |
||||
|
||||
xpMessageError :: PU [Node] (MessageError) |
||||
xpMessageError = xpWrap (\((_, qid, from, to, lang), (err, ext)) |
||||
-> MessageError qid from to lang err ext) |
||||
(\(MessageError qid from to lang err ext) |
||||
-> (((), qid, from, to, lang), (err, ext))) |
||||
$ |
||||
xpElem "{jabber:client}message" |
||||
(xp5Tuple |
||||
(xpAttrFixed "type" "error") |
||||
(xpAttrImplied "id" xpPrim) |
||||
(xpAttrImplied "from" xpPrim) |
||||
(xpAttrImplied "to" xpPrim) |
||||
(xpAttrImplied xmlLang xpPrim) |
||||
-- TODO: NS? |
||||
) |
||||
(xp2Tuple |
||||
xpStanzaError |
||||
(xpAll xpElemVerbatim) |
||||
) |
||||
|
||||
xpPresenceError :: PU [Node] PresenceError |
||||
xpPresenceError = xpWrap (\((qid, from, to, lang, _),(err, ext)) |
||||
-> PresenceError qid from to lang err ext) |
||||
(\(PresenceError qid from to lang err ext) |
||||
-> ((qid, from, to, lang, ()), (err, ext))) |
||||
$ |
||||
xpElem "{jabber:client}presence" |
||||
(xp5Tuple |
||||
(xpAttrImplied "id" xpPrim) |
||||
(xpAttrImplied "from" xpPrim) |
||||
(xpAttrImplied "to" xpPrim) |
||||
xpLangTag |
||||
(xpAttrFixed "type" "error") |
||||
) |
||||
(xp2Tuple |
||||
xpStanzaError |
||||
(xpAll xpElemVerbatim) |
||||
) |
||||
|
||||
xpIQError :: PU [Node] IQError |
||||
xpIQError = xpWrap (\((qid, from, to, lang, _tp),(err, body)) |
||||
-> IQError qid from to lang err body) |
||||
(\(IQError qid from to lang err body) |
||||
-> ((qid, from, to, lang, ()), (err, body))) |
||||
$ |
||||
xpElem "{jabber:client}iq" |
||||
(xp5Tuple |
||||
(xpAttr "id" xpPrim) |
||||
(xpAttrImplied "from" xpPrim) |
||||
(xpAttrImplied "to" xpPrim) |
||||
xpLangTag |
||||
((xpAttrFixed "type" "error")) |
||||
) |
||||
(xp2Tuple |
||||
xpStanzaError |
||||
(xpOption xpElemVerbatim) |
||||
) |
||||
|
||||
@ -0,0 +1,36 @@
@@ -0,0 +1,36 @@
|
||||
{-# LANGUAGE RecordWildCards #-} |
||||
module Network.XMPP.Message where |
||||
|
||||
import Data.Text(Text) |
||||
import Data.XML.Types |
||||
|
||||
import Network.XMPP.Types |
||||
|
||||
message :: Message |
||||
message = Message { messageID = Nothing |
||||
, messageFrom = Nothing |
||||
, messageTo = Nothing |
||||
, messageLangTag = Nothing |
||||
, messageType = Normal |
||||
, messageSubject = Nothing |
||||
, messageThread = Nothing |
||||
, messageBody = Nothing |
||||
, messagePayload = [] |
||||
} |
||||
|
||||
simpleMessage :: JID -> Text -> Message |
||||
simpleMessage to txt = message { messageTo = Just to |
||||
, messageBody = Just txt |
||||
} |
||||
|
||||
answerMessage :: Message -> Text -> [Element] -> Maybe Message |
||||
answerMessage Message{messageFrom = Just frm, ..} txt payload = |
||||
Just $ Message{ messageFrom = messageTo |
||||
, messageID = Nothing |
||||
, messageTo = Just frm |
||||
, messageBody = Just txt |
||||
, messagePayload = payload |
||||
, .. |
||||
} |
||||
answerMessage _ _ _ = Nothing |
||||
|
||||
@ -0,0 +1,150 @@
@@ -0,0 +1,150 @@
|
||||
{-# LANGUAGE OverloadedStrings #-} |
||||
|
||||
module Network.XMPP.Monad where |
||||
|
||||
import Control.Applicative((<$>)) |
||||
import Control.Monad |
||||
import Control.Monad.IO.Class |
||||
import Control.Monad.Trans.Class |
||||
--import Control.Monad.Trans.Resource |
||||
import Control.Concurrent |
||||
import Control.Monad.Trans.State |
||||
|
||||
import Data.ByteString as BS |
||||
import Data.Conduit |
||||
import Data.Conduit.Binary as CB |
||||
import Data.Conduit.List as CL |
||||
import Data.Text(Text) |
||||
import Data.XML.Pickle |
||||
import Data.XML.Types |
||||
|
||||
import Network |
||||
import Network.XMPP.Types |
||||
import Network.XMPP.Marshal |
||||
import Network.XMPP.Pickle |
||||
|
||||
import System.IO |
||||
|
||||
import Text.XML.Stream.Elements |
||||
import Text.XML.Stream.Parse as XP |
||||
import Text.XML.Stream.Render as XR |
||||
|
||||
|
||||
pushN :: Element -> XMPPConMonad () |
||||
pushN x = do |
||||
sink <- gets sConPushBS |
||||
liftIO . sink $ renderElement x |
||||
|
||||
push :: Stanza -> XMPPConMonad () |
||||
push = pushN . pickleElem stanzaP |
||||
|
||||
pushOpen :: Element -> XMPPConMonad () |
||||
pushOpen e = do |
||||
sink <- gets sConPushBS |
||||
liftIO . sink $ renderOpenElement e |
||||
return () |
||||
|
||||
pulls :: Sink Event IO b -> XMPPConMonad b |
||||
pulls snk = do |
||||
source <- gets sConSrc |
||||
(src', r) <- lift $ source $$+ snk |
||||
modify $ (\s -> s {sConSrc = src'}) |
||||
return r |
||||
|
||||
pullE :: XMPPConMonad Element |
||||
pullE = pulls elementFromEvents |
||||
|
||||
pullPickle :: PU [Node] a -> XMPPConMonad a |
||||
pullPickle p = unpickleElem p <$> pullE |
||||
|
||||
pull :: XMPPConMonad Stanza |
||||
pull = pullPickle stanzaP |
||||
|
||||
xmppFromHandle :: Handle |
||||
-> Text |
||||
-> Text |
||||
-> Maybe Text |
||||
-> XMPPConMonad a |
||||
-> IO (a, XMPPConState) |
||||
xmppFromHandle handle hostname username res f = do |
||||
liftIO $ hSetBuffering handle NoBuffering |
||||
let raw = sourceHandle' handle |
||||
let src = raw $= XP.parseBytes def |
||||
let st = XMPPConState |
||||
src |
||||
(raw) |
||||
(BS.hPut handle) |
||||
(Just handle) |
||||
(SF Nothing [] []) |
||||
False |
||||
(Just hostname) |
||||
(Just username) |
||||
res |
||||
runStateT f st |
||||
|
||||
-- TODO: Once pullrequest has been merged, switch back to upstream |
||||
sourceHandle' :: MonadIO m => Handle -> Source m BS.ByteString |
||||
sourceHandle' h = |
||||
src |
||||
where |
||||
src = PipeM pull close |
||||
|
||||
pull = do |
||||
bs <- liftIO (BS.hGetSome h 4096) |
||||
if BS.null bs |
||||
then return $ Done Nothing () |
||||
else return $ HaveOutput src close bs |
||||
|
||||
close = return () |
||||
|
||||
sinkHandle' :: MonadIO m |
||||
=> Handle |
||||
-> Sink BS.ByteString m () |
||||
sinkHandle' h = |
||||
NeedInput push close |
||||
where |
||||
push input = PipeM |
||||
(liftIO (BS.hPut h input) >> return (NeedInput push close)) |
||||
(return ()) |
||||
close = return () |
||||
|
||||
zeroSource :: Source IO output |
||||
zeroSource = sourceState () (\_ -> forever $ threadDelay 10000000) |
||||
|
||||
xmppZeroConState :: XMPPConState |
||||
xmppZeroConState = XMPPConState |
||||
{ sConSrc = zeroSource |
||||
, sRawSrc = zeroSource |
||||
, sConPushBS = (\_ -> return ()) |
||||
, sConHandle = Nothing |
||||
, sFeatures = SF Nothing [] [] |
||||
, sHaveTLS = False |
||||
, sHostname = Nothing |
||||
, sUsername = Nothing |
||||
, sResource = Nothing |
||||
} |
||||
|
||||
xmppRawConnect :: HostName -> Text -> XMPPConMonad () |
||||
xmppRawConnect host hostname = do |
||||
uname <- gets sUsername |
||||
con <- liftIO $ do |
||||
con <- connectTo host (PortNumber 5222) |
||||
hSetBuffering con NoBuffering |
||||
return con |
||||
let raw = sourceHandle' con |
||||
let src = raw $= XP.parseBytes def |
||||
let st = XMPPConState |
||||
src |
||||
(raw) |
||||
(BS.hPut con) |
||||
(Just con) |
||||
(SF Nothing [] []) |
||||
False |
||||
(Just hostname) |
||||
uname |
||||
Nothing |
||||
put st |
||||
|
||||
withNewSession :: XMPPConMonad a -> IO (a, XMPPConState) |
||||
withNewSession action = do |
||||
runStateT action xmppZeroConState |
||||
@ -0,0 +1,62 @@
@@ -0,0 +1,62 @@
|
||||
{-# LANGUAGE NoMonomorphismRestriction #-} |
||||
{-# LANGUAGE OverloadedStrings #-} |
||||
{-# LANGUAGE TupleSections #-} |
||||
|
||||
-- Marshalling between XML and Native Types |
||||
|
||||
|
||||
module Network.XMPP.Pickle where |
||||
|
||||
import Data.XML.Types |
||||
import Data.XML.Pickle |
||||
|
||||
import Text.XML.Stream.Elements |
||||
|
||||
mbToBool :: Maybe t -> Bool |
||||
mbToBool (Just _) = True |
||||
mbToBool _ = False |
||||
|
||||
xpElemEmpty :: Name -> PU [Node] () |
||||
xpElemEmpty name = xpWrap (\((),()) -> ()) |
||||
(\() -> ((),())) $ |
||||
xpElem name xpUnit xpUnit |
||||
|
||||
-- xpElemExists :: Name -> PU [Node] Bool |
||||
-- xpElemExists name = xpWrap (\x -> mbToBool x) |
||||
-- (\x -> if x then Just () else Nothing) $ |
||||
-- xpOption (xpElemEmpty name) |
||||
|
||||
|
||||
xpNodeElem :: PU [Node] a -> PU Element a |
||||
xpNodeElem xp = PU { pickleTree = \x -> head $ (pickleTree xp x) >>= \y -> |
||||
case y of |
||||
NodeElement e -> [e] |
||||
_ -> [] |
||||
, unpickleTree = \x -> case unpickleTree xp $ [NodeElement x] of |
||||
Left l -> Left l |
||||
Right (a,(_,c)) -> Right (a,(Nothing,c)) |
||||
} |
||||
|
||||
ignoreAttrs :: PU t ((), b) -> PU t b |
||||
ignoreAttrs = xpWrap snd ((),) |
||||
|
||||
mbl :: Maybe [a] -> [a] |
||||
mbl (Just l) = l |
||||
mbl Nothing = [] |
||||
|
||||
lmb :: [t] -> Maybe [t] |
||||
lmb [] = Nothing |
||||
lmb x = Just x |
||||
|
||||
right :: Either [Char] t -> t |
||||
right (Left l) = error l |
||||
right (Right r) = r |
||||
|
||||
unpickleElem :: PU [Node] c -> Element -> c |
||||
unpickleElem p x = case unpickle (xpNodeElem p) x of |
||||
Left l -> error $ l ++ "\n saw: " ++ ppElement x |
||||
Right r -> r |
||||
|
||||
pickleElem :: PU [Node] a -> a -> Element |
||||
pickleElem p = pickle $ xpNodeElem p |
||||
|
||||
@ -0,0 +1,78 @@
@@ -0,0 +1,78 @@
|
||||
module Network.XMPP.Presence where |
||||
|
||||
import Data.Text(Text) |
||||
import Network.XMPP.Types |
||||
|
||||
|
||||
presence :: Presence |
||||
presence = Presence { presenceID = Nothing |
||||
, presenceFrom = Nothing |
||||
, presenceTo = Nothing |
||||
, presenceLangTag = Nothing |
||||
, presenceType = Nothing |
||||
, presenceShowType = Nothing |
||||
, presenceStatus = Nothing |
||||
, presencePriority = Nothing |
||||
, presencePayload = [] |
||||
} |
||||
|
||||
presenceSubscribe :: JID -> Presence |
||||
presenceSubscribe to = presence { presenceTo = Just to |
||||
, presenceType = Just Subscribe |
||||
} |
||||
|
||||
-- | Is presence a subscription request |
||||
isPresenceSubscribe :: Presence -> Bool |
||||
isPresenceSubscribe pres = presenceType pres == (Just Subscribe) |
||||
|
||||
-- | Approve a subscripton of an entity |
||||
presenceSubscribed :: JID -> Presence |
||||
presenceSubscribed to = presence { presenceTo = Just to |
||||
, presenceType = Just Subscribed |
||||
} |
||||
|
||||
-- | Is presence a subscription approval |
||||
isPresenceSubscribed :: Presence -> Bool |
||||
isPresenceSubscribed pres = presenceType pres == (Just Subscribed) |
||||
|
||||
-- | End a subscription with an entity |
||||
presenceUnsubscribe :: JID -> Presence |
||||
presenceUnsubscribe to = presence { presenceTo = Just to |
||||
, presenceType = Just Unsubscribed |
||||
} |
||||
|
||||
-- | Is presence an unsubscription request |
||||
isPresenceUnsubscribe :: Presence -> Bool |
||||
isPresenceUnsubscribe pres = presenceType pres == (Just Unsubscribe) |
||||
|
||||
-- | Signals to the server that the client is available for communication |
||||
presenceOnline :: Presence |
||||
presenceOnline = presence |
||||
|
||||
-- | Signals to the server that the client is no longer available for communication. |
||||
presenceOffline :: Presence |
||||
presenceOffline = presence {presenceType = Just Unavailable} |
||||
|
||||
status |
||||
:: Maybe Text -- ^ Status message |
||||
-> Maybe ShowType -- ^ Status Type |
||||
-> Maybe Int -- ^ Priority |
||||
-> Presence |
||||
status txt showType prio = presence { presenceShowType = showType |
||||
, presencePriority = prio |
||||
, presenceStatus = txt |
||||
} |
||||
|
||||
-- | Sets the current availability status. This implicitly sets the clients |
||||
-- status online |
||||
presenceAvail :: ShowType -> Presence |
||||
presenceAvail showType = status Nothing (Just showType) Nothing |
||||
|
||||
-- | Sets the current status message. This implicitly sets the clients |
||||
-- status online |
||||
presenceMessage :: Text -> Presence |
||||
presenceMessage txt = status (Just txt) Nothing Nothing |
||||
|
||||
-- | Adds a recipient to a presence notification |
||||
presTo :: Presence -> JID -> Presence |
||||
presTo pres to = pres{presenceTo = Just to} |
||||
@ -0,0 +1,167 @@
@@ -0,0 +1,167 @@
|
||||
{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} |
||||
module Network.XMPP.SASL where |
||||
|
||||
import Control.Applicative |
||||
import Control.Monad |
||||
import Control.Monad.IO.Class |
||||
import Control.Monad.Trans.State |
||||
|
||||
import qualified Crypto.Classes as CC |
||||
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as AP |
||||
import qualified Data.Binary as Binary |
||||
import qualified Data.ByteString as BS |
||||
import qualified Data.ByteString.Base64 as B64 |
||||
import qualified Data.ByteString.Char8 as BS8 |
||||
import qualified Data.ByteString.Lazy as BL |
||||
import qualified Data.Digest.Pure.MD5 as MD5 |
||||
import qualified Data.List as L |
||||
import Data.XML.Pickle |
||||
import Data.XML.Types |
||||
|
||||
import qualified Data.Text as Text |
||||
import Data.Text (Text) |
||||
import qualified Data.Text.Encoding as Text |
||||
|
||||
import Network.XMPP.Monad |
||||
import Network.XMPP.Stream |
||||
import Network.XMPP.Types |
||||
|
||||
import qualified System.Random as Random |
||||
|
||||
|
||||
saslInitE :: Text -> Element |
||||
saslInitE mechanism = |
||||
Element "{urn:ietf:params:xml:ns:xmpp-sasl}auth" |
||||
[ ("mechanism", [ContentText mechanism]) ] |
||||
[] |
||||
|
||||
saslResponseE :: Text -> Element |
||||
saslResponseE resp = |
||||
Element "{urn:ietf:params:xml:ns:xmpp-sasl}response" |
||||
[] |
||||
[NodeContent $ ContentText resp] |
||||
|
||||
saslResponse2E :: Element |
||||
saslResponse2E = |
||||
Element "{urn:ietf:params:xml:ns:xmpp-sasl}response" |
||||
[] |
||||
[] |
||||
|
||||
xmppSASL:: Text -> Text -> XMPPConMonad (Either String Text) |
||||
xmppSASL uname passwd = do |
||||
realm <- gets sHostname |
||||
case realm of |
||||
Just realm' -> do |
||||
xmppStartSASL realm' uname passwd |
||||
modify (\s -> s{sUsername = Just uname}) |
||||
return $ Right uname |
||||
Nothing -> return $ Left "No connection found" |
||||
|
||||
xmppStartSASL :: Text |
||||
-> Text |
||||
-> Text |
||||
-> XMPPConMonad () |
||||
xmppStartSASL realm username passwd = do |
||||
mechanisms <- gets $ saslMechanisms . sFeatures |
||||
unless ("DIGEST-MD5" `elem` mechanisms) . error $ "No usable auth mechanism: " ++ show mechanisms |
||||
pushN $ saslInitE "DIGEST-MD5" |
||||
Right challenge <- B64.decode . Text.encodeUtf8<$> pullPickle challengePickle |
||||
let Right pairs = toPairs challenge |
||||
pushN . saslResponseE =<< createResponse realm username passwd pairs |
||||
challenge2 <- pullPickle (xpEither failurePickle challengePickle) |
||||
case challenge2 of |
||||
Left x -> error $ show x |
||||
Right _ -> return () |
||||
pushN saslResponse2E |
||||
Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] <- pullE |
||||
xmppRestartStream |
||||
return () |
||||
|
||||
createResponse :: Text |
||||
-> Text |
||||
-> Text |
||||
-> [(BS8.ByteString, BS8.ByteString)] |
||||
-> XMPPConMonad Text |
||||
createResponse hostname username passwd' pairs = do |
||||
let Just qop = L.lookup "qop" pairs |
||||
let Just nonce = L.lookup "nonce" pairs |
||||
let uname = Text.encodeUtf8 username |
||||
let passwd = Text.encodeUtf8 passwd' |
||||
let realm = Text.encodeUtf8 hostname |
||||
g <- liftIO $ Random.newStdGen |
||||
let cnonce = BS.tail . BS.init . |
||||
B64.encode . BS.pack . take 8 $ Random.randoms g |
||||
let nc = "00000001" |
||||
let digestURI = ("xmpp/" `BS.append` realm) |
||||
let digest = md5Digest |
||||
uname |
||||
realm |
||||
passwd |
||||
digestURI |
||||
nc |
||||
qop |
||||
nonce |
||||
cnonce |
||||
let response = BS.intercalate"," . map (BS.intercalate "=") $ |
||||
[["username" , quote uname ] |
||||
,["realm" , quote realm ] |
||||
,["nonce" , quote nonce ] |
||||
,["cnonce" , quote cnonce ] |
||||
,["nc" , nc ] |
||||
,["qop" , qop ] |
||||
,["digest-uri", quote digestURI ] |
||||
,["response" , digest ] |
||||
,["charset" , "utf-8" ] |
||||
] |
||||
return . Text.decodeUtf8 $ B64.encode response |
||||
where quote x = BS.concat ["\"",x,"\""] |
||||
|
||||
toPairs :: BS.ByteString -> Either String [(BS.ByteString, BS.ByteString)] |
||||
toPairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do |
||||
AP.skipSpace |
||||
name <- AP.takeWhile1 (/= '=') |
||||
_ <- AP.char '=' |
||||
quote <- ((AP.char '"' >> return True) `mplus` return False) |
||||
content <- AP.takeWhile1 (AP.notInClass ",\"" ) |
||||
when quote . void $ AP.char '"' |
||||
return (name,content) |
||||
|
||||
hash :: [BS8.ByteString] -> BS8.ByteString |
||||
hash = BS8.pack . show |
||||
. (CC.hash' :: BS.ByteString -> MD5.MD5Digest) . BS.intercalate (":") |
||||
|
||||
hashRaw :: [BS8.ByteString] -> BS8.ByteString |
||||
hashRaw = toStrict . Binary.encode |
||||
. (CC.hash' :: BS.ByteString -> MD5.MD5Digest) . BS.intercalate (":") |
||||
|
||||
toStrict :: BL.ByteString -> BS8.ByteString |
||||
toStrict = BS.concat . BL.toChunks |
||||
|
||||
-- TODO: this only handles MD5-sess |
||||
|
||||
md5Digest :: BS8.ByteString |
||||
-> BS8.ByteString |
||||
-> BS8.ByteString |
||||
-> BS8.ByteString |
||||
-> BS8.ByteString |
||||
-> BS8.ByteString |
||||
-> BS8.ByteString |
||||
-> BS8.ByteString |
||||
-> BS8.ByteString |
||||
md5Digest uname realm password digestURI nc qop nonce cnonce= |
||||
let ha1 = hash [hashRaw [uname,realm,password], nonce, cnonce] |
||||
ha2 = hash ["AUTHENTICATE", digestURI] |
||||
in hash [ha1,nonce, nc, cnonce,qop,ha2] |
||||
|
||||
|
||||
-- Pickling |
||||
|
||||
failurePickle :: PU [Node] (Element) |
||||
failurePickle = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}failure" |
||||
(xpIsolate xpElemVerbatim) |
||||
|
||||
challengePickle :: PU [Node] Text.Text |
||||
challengePickle = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" |
||||
(xpIsolate $ xpContent xpId) |
||||
|
||||
@ -0,0 +1,35 @@
@@ -0,0 +1,35 @@
|
||||
{-# LANGUAGE OverloadedStrings #-} |
||||
|
||||
module Network.XMPP.Session where |
||||
|
||||
import Data.XML.Pickle |
||||
import Data.XML.Types(Element) |
||||
|
||||
import Network.XMPP.Monad |
||||
import Network.XMPP.Pickle |
||||
import Network.XMPP.Types |
||||
|
||||
sessionXML :: Element |
||||
sessionXML = pickleElem |
||||
(xpElemBlank "{urn:ietf:params:xml:ns:xmpp-session}session" ) |
||||
() |
||||
|
||||
|
||||
|
||||
|
||||
sessionIQ :: Stanza |
||||
sessionIQ = IQRequestS $ IQRequest { iqRequestID = "sess" |
||||
, iqRequestFrom = Nothing |
||||
, iqRequestTo = Nothing |
||||
, iqRequestLangTag = Nothing |
||||
, iqRequestType = Set |
||||
, iqRequestPayload = sessionXML |
||||
} |
||||
|
||||
xmppSession :: XMPPConMonad () |
||||
xmppSession = do |
||||
push $ sessionIQ |
||||
answer <- pull |
||||
let IQResultS (IQResult "sess" Nothing Nothing _lang _body) = answer |
||||
return () |
||||
|
||||
@ -0,0 +1,102 @@
@@ -0,0 +1,102 @@
|
||||
{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} |
||||
{-# LANGUAGE TupleSections #-} |
||||
|
||||
module Network.XMPP.Stream where |
||||
|
||||
import Control.Applicative((<$>)) |
||||
import Control.Monad(unless) |
||||
import Control.Monad.Trans.State |
||||
|
||||
import Data.Conduit |
||||
import Data.Conduit.List as CL |
||||
import Data.Text as T |
||||
import Data.XML.Pickle |
||||
import Data.XML.Types |
||||
|
||||
import Network.XMPP.Monad |
||||
import Network.XMPP.Pickle |
||||
import Network.XMPP.Types |
||||
|
||||
import Text.XML.Stream.Elements |
||||
import Text.XML.Stream.Parse as XP |
||||
|
||||
-- import Text.XML.Stream.Elements |
||||
|
||||
throwOutJunk :: Monad m => Sink Event m () |
||||
throwOutJunk = do |
||||
next <- CL.peek |
||||
case next of |
||||
Nothing -> return () |
||||
Just (EventBeginElement _ _) -> return () |
||||
_ -> CL.drop 1 >> throwOutJunk |
||||
|
||||
openElementFromEvents :: Monad m => Sink Event m Element |
||||
openElementFromEvents = do |
||||
throwOutJunk |
||||
Just (EventBeginElement name attrs) <- CL.head |
||||
return $ Element name attrs [] |
||||
|
||||
|
||||
xmppStartStream :: XMPPConMonad () |
||||
xmppStartStream = do |
||||
hostname <- gets sHostname |
||||
pushOpen $ pickleElem pickleStream ("1.0",Nothing, hostname) |
||||
features <- pulls xmppStream |
||||
modify (\s -> s {sFeatures = features}) |
||||
return () |
||||
|
||||
xmppRestartStream :: XMPPConMonad () |
||||
xmppRestartStream = do |
||||
raw <- gets sRawSrc |
||||
let newsrc = raw $= XP.parseBytes def |
||||
modify (\s -> s{sConSrc = newsrc}) |
||||
xmppStartStream |
||||
|
||||
|
||||
xmppStream :: Sink Event IO ServerFeatures |
||||
xmppStream = do |
||||
xmppStreamHeader |
||||
xmppStreamFeatures |
||||
|
||||
xmppStreamHeader :: Sink Event IO () |
||||
xmppStreamHeader = do |
||||
throwOutJunk |
||||
(ver, _, _) <- unpickleElem pickleStream <$> openElementFromEvents |
||||
unless (ver == "1.0") $ error "Not XMPP version 1.0 " |
||||
return() |
||||
|
||||
|
||||
xmppStreamFeatures :: Sink Event IO ServerFeatures |
||||
xmppStreamFeatures = unpickleElem pickleStreamFeatures <$> elementFromEvents |
||||
|
||||
|
||||
-- Pickling |
||||
|
||||
pickleStream :: PU [Node] (Text, Maybe Text, Maybe Text) |
||||
pickleStream = xpElemAttrs (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) |
||||
(xpTriple |
||||
(xpAttr "version" xpId) |
||||
(xpOption $ xpAttr "from" xpId) |
||||
(xpOption $ xpAttr "to" xpId) |
||||
) |
||||
|
||||
pickleTLSFeature :: PU [Node] Bool |
||||
pickleTLSFeature = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-tls}starttls" |
||||
(xpElemExists "required") |
||||
|
||||
pickleSaslFeature :: PU [Node] [Text] |
||||
pickleSaslFeature = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}mechanisms" |
||||
(xpAll $ xpElemNodes |
||||
"{urn:ietf:params:xml:ns:xmpp-sasl}mechanism" (xpContent xpId) ) |
||||
|
||||
pickleStreamFeatures :: PU [Node] ServerFeatures |
||||
pickleStreamFeatures = xpWrap ( \(tls, sasl, rest) -> SF tls (mbl sasl) rest) |
||||
(\(SF tls sasl rest) -> (tls, lmb sasl, rest)) |
||||
$ |
||||
xpElemNodes (Name "features" (Just "http://etherx.jabber.org/streams") (Just "stream")) |
||||
(xpTriple |
||||
(xpOption pickleTLSFeature) |
||||
(xpOption pickleSaslFeature) |
||||
(xpAll xpElemVerbatim) |
||||
) |
||||
|
||||
@ -0,0 +1,59 @@
@@ -0,0 +1,59 @@
|
||||
{-# LANGUAGE OverloadedStrings #-} |
||||
|
||||
module Network.XMPP.TLS where |
||||
|
||||
import Control.Monad |
||||
import Control.Monad.Trans.Class |
||||
import Control.Monad.Trans.State |
||||
|
||||
import Data.Conduit |
||||
import Data.Conduit.List as CL |
||||
import Data.Conduit.TLS as TLS |
||||
import Data.Default |
||||
import Data.XML.Types |
||||
|
||||
import qualified Network.TLS as TLS |
||||
import qualified Network.TLS.Extra as TLS |
||||
import Network.XMPP.Monad |
||||
import Network.XMPP.Stream |
||||
import Network.XMPP.Types |
||||
|
||||
import qualified Text.XML.Stream.Render as XR |
||||
|
||||
|
||||
starttlsE :: Element |
||||
starttlsE = |
||||
Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] [] |
||||
|
||||
exampleParams :: TLS.TLSParams |
||||
exampleParams = TLS.defaultParams |
||||
{pConnectVersion = TLS.TLS10 |
||||
, pAllowedVersions = [TLS.SSL3, TLS.TLS10, TLS.TLS11] |
||||
, pCiphers = [TLS.cipher_AES128_SHA1] |
||||
, pCompressions = [TLS.nullCompression] |
||||
, pWantClientCert = False -- Used for servers |
||||
, pUseSecureRenegotiation = False -- No renegotiation |
||||
, pCertificates = [] -- TODO |
||||
, pLogging = TLS.defaultLogging -- TODO |
||||
, onCertificatesRecv = \ certificate -> |
||||
return TLS.CertificateUsageAccept |
||||
} |
||||
|
||||
xmppStartTLS :: TLS.TLSParams -> XMPPConMonad () |
||||
xmppStartTLS params = do |
||||
features <- gets sFeatures |
||||
unless (stls features == Nothing) $ do |
||||
pushN starttlsE |
||||
Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] <- pullE |
||||
Just handle <- gets sConHandle |
||||
(raw, snk, psh) <- lift $ TLS.tlsinit params handle |
||||
modify (\x -> x |
||||
{ sRawSrc = raw |
||||
-- , sConSrc = -- Note: this momentarily leaves us in an |
||||
-- inconsistent state |
||||
, sConPushBS = psh |
||||
}) |
||||
xmppRestartStream |
||||
modify (\s -> s{sHaveTLS = True}) |
||||
return () |
||||
|
||||
@ -0,0 +1,124 @@
@@ -0,0 +1,124 @@
|
||||
{-# LANGUAGE PackageImports, OverloadedStrings, NoMonomorphismRestriction #-} |
||||
module Example where |
||||
|
||||
import Control.Concurrent |
||||
import Control.Concurrent.STM |
||||
import Control.Monad |
||||
import Control.Monad.IO.Class |
||||
|
||||
import Data.Maybe |
||||
import Data.Text (Text) |
||||
import qualified Data.Text as Text |
||||
import Data.XML.Pickle |
||||
import Data.XML.Types |
||||
|
||||
import Network.XMPP |
||||
import Network.XMPP.Pickle |
||||
|
||||
import System.Environment |
||||
import Text.XML.Stream.Elements |
||||
|
||||
testUser1 :: JID |
||||
testUser1 = read "testuser1@species64739.dyndns.org/bot1" |
||||
|
||||
testUser2 :: JID |
||||
testUser2 = read "testuser2@species64739.dyndns.org/bot2" |
||||
|
||||
supervisor :: JID |
||||
supervisor = read "uart14@species64739.dyndns.org" |
||||
|
||||
|
||||
attXmpp :: STM a -> XMPPThread a |
||||
attXmpp = liftIO . atomically |
||||
|
||||
testNS :: Text |
||||
testNS = "xmpp:library:test" |
||||
|
||||
data Payload = Payload Int Bool Text deriving (Eq, Show) |
||||
|
||||
payloadP = xpWrap (\((counter,flag) , message) -> Payload counter flag message) |
||||
(\(Payload counter flag message) ->((counter,flag) , message)) $ |
||||
xpElem (Name "request" (Just testNS) Nothing) |
||||
(xpPair |
||||
(xpAttr "counter" xpPrim) |
||||
(xpAttr "flag" xpPrim) |
||||
) |
||||
(xpElemNodes (Name "message" (Just testNS) Nothing) |
||||
(xpContent xpId)) |
||||
|
||||
invertPayload (Payload count flag message) = Payload (count + 1) (not flag) (Text.reverse message) |
||||
|
||||
iqResponder = do |
||||
(free, chan) <- listenIQChan Get testNS |
||||
unless free $ liftIO $ putStrLn "Channel was already taken" |
||||
>> error "hanging up" |
||||
forever $ do |
||||
next@(iq,_) <- liftIO . atomically $ readTChan chan |
||||
let payload = unpickleElem payloadP $ iqRequestPayload iq |
||||
let answerPayload = invertPayload payload |
||||
let answerBody = pickleElem payloadP answerPayload |
||||
answerIQ next (Right $ Just answerBody) |
||||
|
||||
autoAccept :: XMPPThread () |
||||
autoAccept = forever $ do |
||||
st <- waitForPresence isPresenceSubscribe |
||||
sendPresence $ presenceSubscribed (fromJust $ presenceFrom st) |
||||
|
||||
sendUser = sendMessage . simpleMessage supervisor . Text.pack |
||||
|
||||
expect debug x y | x == y = debug "Ok." |
||||
| otherwise = do |
||||
let failMSG = "failed" ++ show x ++ " /= " ++ show y |
||||
debug failMSG |
||||
sendUser failMSG |
||||
|
||||
|
||||
wait3 :: MonadIO m => m () |
||||
wait3 = liftIO $ threadDelay 1000000 |
||||
|
||||
runMain :: (String -> STM ()) -> Int -> IO () |
||||
runMain debug number = do |
||||
let (we, them, active) = case number of |
||||
1 -> (testUser1, testUser2,True) |
||||
2 -> (testUser2, testUser1,False) |
||||
_ -> error "Need either 1 or 2" |
||||
let debug' = liftIO . atomically . |
||||
debug . (("Thread " ++ show number ++ ":") ++) |
||||
xmppNewSession $ do |
||||
debug' "running" |
||||
withConnection $ do |
||||
xmppConnect "localhost" "species64739.dyndns.org" |
||||
xmppStartTLS exampleParams |
||||
saslResponse <- xmppSASL (fromJust $ node we) "pwd" |
||||
case saslResponse of |
||||
Right _ -> return () |
||||
Left e -> error e |
||||
xmppThreadedBind (resource we) |
||||
withConnection $ xmppSession |
||||
debug' "session standing" |
||||
sendPresence presenceOnline |
||||
forkXMPP autoAccept |
||||
forkXMPP iqResponder |
||||
when active . void . forkXMPP $ do |
||||
forM [1..10] $ \count -> do |
||||
let message = Text.pack . show $ node we |
||||
let payload = Payload count (even count) (Text.pack $ show count) |
||||
let body = pickleElem payloadP payload |
||||
Right answer <- sendIQ' (Just them) Get Nothing body |
||||
let answerPayload = unpickleElem payloadP |
||||
(fromJust $ iqResultPayload answer) |
||||
expect debug' (invertPayload payload) answerPayload |
||||
liftIO $ threadDelay 100000 |
||||
sendUser "All tests done" |
||||
liftIO . forever $ threadDelay 10000000 |
||||
return () |
||||
return () |
||||
|
||||
|
||||
main = do |
||||
out <- newTChanIO |
||||
forkIO . forever $ atomically (readTChan out) >>= putStrLn |
||||
let debugOut = writeTChan out |
||||
forkIO $ runMain debugOut 1 |
||||
runMain debugOut 2 |
||||
|
||||
@ -0,0 +1,88 @@
@@ -0,0 +1,88 @@
|
||||
module Text.XML.Stream.Elements where |
||||
|
||||
import Control.Applicative ((<$>)) |
||||
import Control.Monad.Trans.Class |
||||
import Control.Monad.Trans.Resource as R |
||||
|
||||
import qualified Data.ByteString as BS |
||||
import qualified Data.Text as Text |
||||
import qualified Data.Text.Encoding as Text |
||||
import Data.XML.Types |
||||
import qualified Text.XML.Stream.Render as TXSR |
||||
import Text.XML.Unresolved as TXU |
||||
|
||||
import Data.Conduit as C |
||||
import Data.Conduit.List as CL |
||||
|
||||
import System.IO.Unsafe(unsafePerformIO) |
||||
|
||||
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 |
||||
|
||||
elementFromEvents :: R.MonadThrow m => C.Sink Event m Element |
||||
elementFromEvents = do |
||||
x <- CL.peek |
||||
case x of |
||||
Just (EventBeginElement n as) -> goE n as |
||||
_ -> lift $ R.monadThrow $ InvalidEventStream $ "not an element: " ++ show x |
||||
where |
||||
many' f = |
||||
go id |
||||
where |
||||
go front = do |
||||
x <- f |
||||
case x of |
||||
Nothing -> return $ front [] |
||||
Just y -> go (front . (:) y) |
||||
dropReturn x = CL.drop 1 >> return x |
||||
goE n as = do |
||||
CL.drop 1 |
||||
ns <- many' goN |
||||
y <- CL.head |
||||
if y == Just (EventEndElement n) |
||||
then return $ Element n as $ compressNodes ns |
||||
else lift $ R.monadThrow $ InvalidEventStream $ "Missing end element for " ++ show n ++ ", got: " ++ show y |
||||
goN = do |
||||
x <- CL.peek |
||||
case x of |
||||
Just (EventBeginElement n as) -> (Just . NodeElement) <$> goE n as |
||||
Just (EventInstruction i) -> dropReturn $ Just $ NodeInstruction i |
||||
Just (EventContent c) -> dropReturn $ Just $ NodeContent c |
||||
Just (EventComment t) -> dropReturn $ Just $ NodeComment t |
||||
Just (EventCDATA t) -> dropReturn $ Just $ NodeContent $ ContentText t |
||||
_ -> return 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 :) |
||||
|
||||
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 |
||||
@ -0,0 +1,7 @@
@@ -0,0 +1,7 @@
|
||||
module Utils where |
||||
|
||||
whileJust f = do |
||||
f' <- f |
||||
case f' of |
||||
Just x -> x : whileJust f |
||||
Nothing -> [] |
||||
Loading…
Reference in new issue