Jon Kristensen
14 years ago
36 changed files with 2084 additions and 1562 deletions
@ -0,0 +1,8 @@ |
|||||||
|
dist/ |
||||||
|
cabal-dev/ |
||||||
|
*.o |
||||||
|
*.hi |
||||||
|
*~ |
||||||
|
*# |
||||||
|
*.#* |
||||||
|
*_flymake.hs |
||||||
@ -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 @@ |
|||||||
-- 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 @@ |
|||||||
-- 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 @@ |
|||||||
-- 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 @@ |
|||||||
-- 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 @@ |
|||||||
-- 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 @@ |
|||||||
|
{-# 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 @@ |
|||||||
|
{-# 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 @@ |
|||||||
|
-- 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 @@ |
|||||||
|
{-# 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 @@ |
|||||||
|
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 @@ |
|||||||
|
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 @@ |
|||||||
|
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 @@ |
|||||||
|
{-# 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 @@ |
|||||||
|
{-# 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 @@ |
|||||||
|
{-# 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 @@ |
|||||||
|
{-# 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 @@ |
|||||||
|
{-# 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 @@ |
|||||||
|
{-# 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 @@ |
|||||||
|
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 @@ |
|||||||
|
{-# 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 @@ |
|||||||
|
{-# 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 @@ |
|||||||
|
{-# 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 @@ |
|||||||
|
{-# 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 @@ |
|||||||
|
{-# 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 @@ |
|||||||
|
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 @@ |
|||||||
|
module Utils where |
||||||
|
|
||||||
|
whileJust f = do |
||||||
|
f' <- f |
||||||
|
case f' of |
||||||
|
Just x -> x : whileJust f |
||||||
|
Nothing -> [] |
||||||
Loading…
Reference in new issue