asakul
/
pontarius-xmpp
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

compiles... again

master
Philipp Balzarek 14 years ago
parent
f27b007520
commit
ac8e907e5c
12 changed files with 381 additions and 221 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 23
      src/Data/Conduit/TLS.hs
  2. 15
      src/Network/XMPP/Bind.hs
  3. 153
      src/Network/XMPP/Concurrent.hs
  4. 62
      src/Network/XMPP/Marshal.hs
  5. 36
      src/Network/XMPP/Monad.hs
  6. 71
      src/Network/XMPP/Pickle.hs
  7. 49
      src/Network/XMPP/SASL.hs
  8. 12
      src/Network/XMPP/Session.hs
  9. 55
      src/Network/XMPP/Stream.hs
  10. 19
      src/Network/XMPP/TLS.hs
  11. 29
      src/Network/XMPP/Types.hs
  12. 78
      src/Text/XML/Stream/Elements.hs

23
src/Data/Conduit/TLS.hs
Unescape View File

@ -1,3 +1,4 @@
{-# Language NoMonomorphismRestriction #-}
module Data.Conduit.TLS module Data.Conduit.TLS
( tlsinit ( tlsinit
, module TLS , module TLS
@ -8,6 +9,7 @@ module Data.Conduit.TLS
import Control.Applicative import Control.Applicative
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Class import Control.Monad.Trans.Class
import Control.Monad.Trans.Resource
import Crypto.Random import Crypto.Random
@ -24,9 +26,11 @@ import System.Random
import System.IO import System.IO
tlsinit tlsinit
:: (MonadIO m, ResourceIO m1) => :: (MonadIO m, MonadIO m1, MonadResource m1) =>
TLSParams -> Handle TLSParams
-> m (Source m1 BS.ByteString, (BS.ByteString -> IO ())) -> Handle -> m ( Source m1 BS.ByteString
, Sink BS.ByteString m1 ()
, BS.ByteString -> IO ())
tlsinit tlsParams handle = do tlsinit tlsParams handle = do
gen <- liftIO $ (newGenIO :: IO SystemRandom) -- TODO: Find better random source? gen <- liftIO $ (newGenIO :: IO SystemRandom) -- TODO: Find better random source?
clientContext <- client tlsParams gen handle clientContext <- client tlsParams gen handle
@ -35,13 +39,20 @@ tlsinit tlsParams handle = do
(return clientContext) (return clientContext)
(bye) (bye)
(\con -> IOOpen <$> recvData con) (\con -> IOOpen <$> recvData con)
return (src let snk = sinkIO
(return clientContext)
(\_ -> return ())
(\con bs -> sendData clientContext (BL.fromChunks [bs])
>> return IOProcessing )
(\_ -> return ())
return ( src
, snk
, \s -> sendData clientContext $ BL.fromChunks [s] ) , \s -> sendData clientContext $ BL.fromChunks [s] )
-- TODO: remove -- TODO: remove
conduitStdout :: ResourceIO m conduitStdout
=> Conduit BS.ByteString m BS.ByteString :: MonadResource m => Conduit BS.ByteString m BS.ByteString
conduitStdout = conduitIO conduitStdout = conduitIO
(return ()) (return ())
(\_ -> return ()) (\_ -> return ())

15
src/Network/XMPP/Bind.hs
Unescape View File

@ -6,22 +6,25 @@ import Control.Monad.Trans.State
import Data.Text as Text import Data.Text as Text
import Data.XML.Pickle
import Data.XML.Types
import Network.XMPP.Monad import Network.XMPP.Monad
import Network.XMPP.Types import Network.XMPP.Types
import Network.XMPP.Pickle import Network.XMPP.Pickle
import Network.XMPP.Marshal import Network.XMPP.Marshal
import Text.XML.Expat.Pickle
bindReqIQ :: Maybe Text -> Stanza bindReqIQ :: Maybe Text -> Stanza
bindReqIQ resource= SIQ $ IQ Nothing Nothing "bind" Set bindReqIQ resource= SIQ $ IQ Nothing Nothing "bind" Set
(pickleElem (pickleElem
(bindP . xpOption (bindP . xpOption
$ xpElemNodes "resource" (xpContent xpText)) $ xpElemNodes "resource" (xpContent xpId))
resource resource
) )
jidP :: PU [Node Text Text] JID jidP :: PU [Node] JID
jidP = bindP $ xpElemNodes "jid" (xpContent xpPrim) jidP = bindP $ xpElemNodes "jid" (xpContent xpPrim)
xmppBind :: XMPPMonad () xmppBind :: XMPPMonad ()
@ -33,9 +36,7 @@ xmppBind = do
let (JID n d (Just r)) = unpickleElem jidP b let (JID n d (Just r)) = unpickleElem jidP b
modify (\s -> s{sResource = Just r}) modify (\s -> s{sResource = Just r})
bindP :: PU [Node Text.Text Text.Text] b -> PU [Node Text.Text Text.Text] b bindP :: PU [Node] b -> PU [Node] b
bindP c = ignoreAttrs $ xpElemNs "bind" "urn:ietf:params:xml:ns:xmpp-bind" bindP c = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-bind}bind" c
xpUnit
c

153
src/Network/XMPP/Concurrent.hs
Unescape View File

@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
module Network.XMPP.Concurrent module Network.XMPP.Concurrent
@ -20,24 +21,26 @@ import Control.Monad.Trans.State
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.Map as Map
import Data.Maybe import Data.Maybe
import Data.IORef import Data.IORef
import Data.Text(Text)
import Data.XML.Types
import Network.XMPP.Types import Network.XMPP.Types
import Network.XMPP.Monad import Network.XMPP.Monad
import Network.XMPP.Marshal import Network.XMPP.Marshal
import Network.XMPP.Pickle import Network.XMPP.Pickle
import System.IO import System.IO
import Text.XML.Expat.Format import Text.XML.Stream.Elements
import Text.XML.Expat.Pickle
data Thread = Thread { messagesRef :: IORef (Maybe (TChan Message)) data Thread = Thread { messagesRef :: IORef (Maybe (TChan Message))
, presenceRef :: IORef (Maybe (TChan Presence)) , presenceRef :: IORef (Maybe (TChan Presence))
, mShadow :: TChan Stanza -- the original chan , mShadow :: TChan Message -- the original chan
, pShadow :: TChan Stanza -- the original chan , pShadow :: TChan Presence -- the original chan
, outCh :: TChan Stanza , outCh :: TChan Stanza
} }
@ -47,34 +50,56 @@ type XMPPThread a = ReaderT Thread IO a
-- | Runs thread in XmppState monad -- | Runs thread in XmppState monad
-- returns channel of incoming and outgoing stances, respectively -- returns channel of incoming and outgoing stances, respectively
-- and an Action to stop the Threads and close the connection -- and an Action to stop the Threads and close the connection
startThreads :: XMPPMonad (TChan Stanza, TChan Stanza, IO ()) startThreads
:: XMPPMonad ( TChan Message
, TChan Presence
, TVar ( Map.Map (IQType, Text) (TChan IQ)
, Map.Map Text (TMVar IQ)
)
, TChan Stanza, IO ()
)
startThreads = do startThreads = do
writeLock <- liftIO $ newTMVarIO () writeLock <- liftIO $ newTMVarIO ()
messagesC <- liftIO newTChanIO messageC <- liftIO newTChanIO
presenceC <- liftIO newTChanIO presenceC <- liftIO newTChanIO
iqC <- liftIO newTChanIO iqC <- liftIO newTChanIO
outC <- liftIO newTChanIO outC <- liftIO newTChanIO
iqHandlers <- liftIO newTVarIO iqHandlers <- liftIO $ newTVarIO ( Map.empty, Map.empty)
pushBS <- gets sConPush pushEvents <- gets sConPush
lw <- liftIO . forkIO $ loopWrite writeLock pushBS outC pushBS <- gets sConPushBS
lw <- lift . resourceForkIO $ loopWrite writeLock pushEvents outC
cp <- liftIO . forkIO $ connPersist pushBS writeLock cp <- liftIO . forkIO $ connPersist pushBS writeLock
iqh <- lift . resourceForkIO $ handleIQs iqHandlers iqC
s <- get s <- get
rd <- lift . resourceForkIO . void . flip runStateT s . forever $ do rd <- lift . resourceForkIO . void . flip runStateT s . forever $ do
s <- pull sta <- pull
case s of case sta of
SMessage m -> liftIO . atomically $ writeTChan messageC m SMessage m -> liftIO . atomically $ writeTChan messageC m
SPresence p -> liftIO . atomically $ writeTChan presenceC p SPresence p -> liftIO . atomically $ writeTChan presenceC p
SIQ i -> liftIO . atomically $ writeTChan presenceC i SIQ i -> liftIO . atomically $ writeTChan iqC i
return (inC, outC, killConnection writeLock [lw, rd, cp]) return (messageC, presenceC, iqHandlers, outC, killConnection writeLock [lw, rd, cp])
where where
loopWrite writeLock pushBS out' = forever $ do loopWrite writeLock pushEvents out' = forever $ do
next <- liftIO . atomically $ ( takeTMVar writeLock >> readTChan out') next <- liftIO . atomically $ ( takeTMVar writeLock
liftIO . pushBS . formatNode' $ pickleElem stanzaP next >> readTChan out')
pushEvents . elementToEvents $ pickleElem stanzaP next
liftIO . atomically $ putTMVar writeLock () liftIO . atomically $ putTMVar writeLock ()
iqHandler handlers iqC = forever $ do handleIQs handlers iqC = liftIO . forever . atomically $ do
iq <- liftIO . atomically $ readTChan iqC iq <- readTChan iqC
(byNS, byID) <- readTVar handlers
let iqNS' = nameNamespace . elementName . iqBody $ iq
case iqNS' of
Nothing -> return () -- TODO: send error stanza
Just iqNS -> case iqType iq of
Get -> case Map.lookup (Get, iqNS) byNS of
Nothing -> return () -- TODO: send error stanza
Just ch -> writeTChan ch iq
Set -> case Map.lookup (Set, iqNS) byNS of
Nothing -> return () -- TODO: send error stanza
Just ch -> writeTChan ch iq
Result -> case Map.lookup (iqId iq) byID of
Nothing -> return () -- ?? Should we be sending an error?
Just tmvar -> putTMVar tmvar iq
killConnection writeLock threads = liftIO $ do killConnection writeLock threads = liftIO $ do
atomically $ takeTMVar writeLock atomically $ takeTMVar writeLock
forM threads killThread forM threads killThread
@ -83,44 +108,70 @@ startThreads = do
runThreaded :: XMPPThread a runThreaded :: XMPPThread a
-> XMPPMonad ThreadId -> XMPPMonad ThreadId
runThreaded a = do runThreaded a = do
(inC, outC, stopThreads) <- startThreads (mC, pC, hand, outC, stopThreads) <- startThreads
workerInCh <- liftIO . newIORef $ Just inC workermCh <- liftIO . newIORef $ Just mC
workerpCh <- liftIO . newIORef $ Just pC
worker <- liftIO . forkIO $ do worker <- liftIO . forkIO $ do
runReaderT a (Thread workerInCh inC outC) runReaderT a (Thread workermCh workerpCh mC pC outC)
return () return ()
return worker return worker
-- | get the inbound stanza channel, duplicate from master if necessary -- | get the inbound stanza channel, duplicate from master if necessary
-- please note that once duplicated it will keep filling up -- please note that once duplicated it will keep filling up
getInChan = do getMessageChan = do
inChR <- asks inChRef mChR <- asks messagesRef
inCh <- liftIO $ readIORef inChR mCh <- liftIO $ readIORef mChR
case inCh of case mCh of
Nothing -> do Nothing -> do
shadow <- asks shadowInCh shadow <- asks mShadow
inCh' <- liftIO $ atomically $ dupTChan shadow mCh' <- liftIO $ atomically $ dupTChan shadow
liftIO $ writeIORef inChR (Just inCh') liftIO $ writeIORef mChR (Just mCh')
return inCh' return mCh'
Just inCh -> return inCh Just mCh -> return mCh
-- | get the inbound stanza channel, duplicate from master if necessary
-- please note that once duplicated it will keep filling up
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 -- | Drop the local end of the inbound stanza channel
-- from our context so it can be GC-ed -- from our context so it can be GC-ed
dropInChan :: XMPPThread () dropMessageChan :: XMPPThread ()
dropInChan = do dropMessageChan = do
r <- asks inChRef r <- asks messagesRef
liftIO $ writeIORef r Nothing
dropPresenceChan :: XMPPThread ()
dropPresenceChan = do
r <- asks presenceRef
liftIO $ writeIORef r Nothing liftIO $ writeIORef r Nothing
-- | Read an element from the inbound stanza channel, acquiring a copy
-- of the channel as necessary
pullMessage :: XMPPThread Message
pullMessage = do
c <- getMessageChan
st <- liftIO $ atomically $ readTChan c
return st
-- | Read an element from the inbound stanza channel, acquiring a copy -- | Read an element from the inbound stanza channel, acquiring a copy
-- of the channel as necessary -- of the channel as necessary
pullS :: XMPPThread Stanza pullPresence :: XMPPThread Presence
pullS = do pullPresence = do
c <- getInChan c <- getPresenceChan
st <- liftIO $ atomically $ readTChan c st <- liftIO $ atomically $ readTChan c
return st return st
-- | Send a stanza to the server -- | Send a stanza to the server
sendS :: Stanza -> XMPPThread () sendS :: Stanza -> XMPPThread ()
sendS a = do sendS a = do
@ -132,16 +183,28 @@ sendS a = do
withNewThread :: XMPPThread () -> XMPPThread ThreadId withNewThread :: XMPPThread () -> XMPPThread ThreadId
withNewThread a = do withNewThread a = do
thread <- ask thread <- ask
inCH' <- liftIO $ newIORef Nothing mCH' <- liftIO $ newIORef Nothing
liftIO $ forkIO $ runReaderT a (thread {inChRef = inCH'}) pCH' <- liftIO $ newIORef Nothing
liftIO $ forkIO $ runReaderT a (thread {messagesRef = mCH'
,presenceRef = pCH'
})
waitForMessage :: (Message -> Bool) -> XMPPThread Message
waitForMessage f = do
s <- pullMessage
if (f s) then
return s
else do
waitForMessage f
waitFor :: (Stanza -> Bool) -> XMPPThread Stanza waitForPresence :: (Presence -> Bool) -> XMPPThread Presence
waitFor f = do waitForPresence f = do
s <- pullS s <- pullPresence
if (f s) then if (f s) then
return s return s
else do else do
waitFor f waitForPresence f
connPersist :: (BS.ByteString -> IO ()) -> TMVar () -> IO () connPersist :: (BS.ByteString -> IO ()) -> TMVar () -> IO ()
connPersist pushBS lock = forever $ do connPersist pushBS lock = forever $ do

62
src/Network/XMPP/Marshal.hs
Unescape View File

@ -7,73 +7,75 @@ import Control.Applicative((<$>))
import Data.Maybe import Data.Maybe
import Data.Text(Text) import Data.Text(Text)
import Data.XML.Types
import Data.XML.Pickle
import qualified Data.Text as Text import qualified Data.Text as Text
import Network.XMPP.Pickle import Network.XMPP.Pickle
import Network.XMPP.Types import Network.XMPP.Types
import Text.XML.Expat.Pickle
stanzaSel (SMessage _ )= 0 stanzaSel (SMessage _) = 0
stanzaSel (SPresence _ )= 1 stanzaSel (SPresence _) = 1
stanzaSel (SIQ _ )= 2 stanzaSel (SIQ _) = 2
stanzaP :: PU [Node Text Text] Stanza stanzaP :: PU [Node] Stanza
stanzaP = xpAlt stanzaSel stanzaP = xpAlt stanzaSel
[ xpWrap (SMessage , (\(SMessage m) -> m)) messageP [ xpWrap SMessage (\(SMessage m) -> m) messageP
, xpWrap (SPresence , (\(SPresence p) -> p)) presenceP , xpWrap SPresence (\(SPresence p) -> p) presenceP
, xpWrap (SIQ , (\(SIQ i) -> i)) iqP , xpWrap SIQ (\(SIQ i) -> i) iqP
] ]
messageP :: PU [Node Text Text] Message messageP :: PU [Node] Message
messageP = xpWrap ( (\((from, to, id, tp),(sub, body, thr,ext)) messageP = xpWrap (\((from, to, id, tp),(sub, body, thr,ext))
-> Message from to id tp sub body thr ext) -> Message from to id tp sub body thr ext)
, (\(Message from to id tp sub body thr ext) (\(Message from to id tp sub body thr ext)
-> ((from, to, id, tp), (sub, body, thr,ext))) -> ((from, to, id, tp), (sub, body, thr,ext)))
) $ $
xpElem "message" xpElem "message"
(xp4Tuple (xp4Tuple
(xpAttrImplied "from" xpPrim) (xpAttrImplied "from" xpPrim)
(xpAttr "to" xpPrim) (xpAttr "to" xpPrim)
(xpAttrImplied "id" xpText) (xpAttrImplied "id" xpId)
(xpAttrImplied "type" xpPrim) (xpAttrImplied "type" xpPrim)
) )
(xp4Tuple (xp4Tuple
(xpOption . xpElemNodes "subject" $ xpContent xpText) (xpOption . xpElemNodes "subject" $ xpContent xpId)
(xpOption . xpElemNodes "body" $ xpContent xpText) (xpOption . xpElemNodes "body" $ xpContent xpId)
(xpOption . xpElemNodes "thread" $ xpContent xpText) (xpOption . xpElemNodes "thread" $ xpContent xpId)
xpTrees (xpAll xpElemVerbatim)
) )
presenceP :: PU [Node Text Text] Presence presenceP :: PU [Node] Presence
presenceP = xpWrap ( (\((from, to, id, tp),(shw, stat, prio, ext)) presenceP = xpWrap (\((from, to, id, tp),(shw, stat, prio, ext))
-> Presence from to id tp shw stat prio ext) -> Presence from to id tp shw stat prio ext)
, (\(Presence from to id tp shw stat prio ext) (\(Presence from to id tp shw stat prio ext)
-> ((from, to, id, tp), (shw, stat, prio, ext))) -> ((from, to, id, tp), (shw, stat, prio, ext)))
) $ $
xpElem "presence" xpElem "presence"
(xp4Tuple (xp4Tuple
(xpAttrImplied "from" xpPrim) (xpAttrImplied "from" xpPrim)
(xpAttrImplied "to" xpPrim) (xpAttrImplied "to" xpPrim)
(xpAttrImplied "id" xpText) (xpAttrImplied "id" xpId)
(xpAttrImplied "type" xpPrim) (xpAttrImplied "type" xpPrim)
) )
(xp4Tuple (xp4Tuple
(xpOption . xpElemNodes "show" $ xpContent xpPrim) (xpOption . xpElemNodes "show" $ xpContent xpPrim)
(xpOption . xpElemNodes "status" $ xpContent xpText) (xpOption . xpElemNodes "status" $ xpContent xpId)
(xpOption . xpElemNodes "priority" $ xpContent xpPrim) (xpOption . xpElemNodes "priority" $ xpContent xpPrim)
xpTrees (xpAll xpElemVerbatim)
) )
iqP :: PU [Node Text Text] IQ iqP :: PU [Node] IQ
iqP = xpWrap ( (\((from, to, id, tp),body) -> IQ from to id tp body) iqP = xpWrap (\((from, to, id, tp),body) -> IQ from to id tp body)
, (\(IQ from to id tp body) -> ((from, to, id, tp), body)) (\(IQ from to id tp body) -> ((from, to, id, tp), body))
) $ $
xpElem "iq" xpElem "iq"
(xp4Tuple (xp4Tuple
(xpAttrImplied "from" xpPrim) (xpAttrImplied "from" xpPrim)
(xpAttrImplied "to" xpPrim) (xpAttrImplied "to" xpPrim)
(xpAttr "id" xpText) (xpAttr "id" xpId)
(xpAttr "type" xpPrim)) (xpAttr "type" xpPrim))
(xpTree) (xpElemVerbatim)

36
src/Network/XMPP/Monad.hs
Unescape View File

@ -7,6 +7,7 @@ import Control.Applicative((<$>))
import Control.Monad import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Class import Control.Monad.Trans.Class
import Control.Monad.Trans.Resource
import Control.Monad.Trans.State import Control.Monad.Trans.State
import Data.ByteString as BS import Data.ByteString as BS
@ -14,10 +15,16 @@ import Data.Text(Text)
import Data.Conduit import Data.Conduit
import Data.Conduit.Binary as CB import Data.Conduit.Binary as CB
import Data.Conduit.Hexpat as HXC
import Data.Conduit.List as CL import Data.Conduit.List as CL
import Data.Conduit.Text as CT import Data.Conduit.Text as CT
import Data.XML.Pickle
import Data.XML.Types
import Text.XML.Unresolved
import Text.XML.Stream.Parse
import Text.XML.Stream.Render as XR
import Text.XML.Stream.Elements
import qualified Data.Text as Text import qualified Data.Text as Text
import Network.XMPP.Types import Network.XMPP.Types
@ -26,32 +33,25 @@ import Network.XMPP.Pickle
import System.IO import System.IO
import Text.XML.Expat.SAX -- parseOpts :: ParseOptions tag text
import Text.XML.Expat.Pickle(PU) -- parseOpts = ParseOptions (Just UTF8) Nothing
import Text.XML.Expat.Tree
import Text.XML.Expat.Format
parseOpts :: ParseOptions tag text
parseOpts = ParseOptions (Just UTF8) Nothing
pushN :: Element -> XMPPMonad () pushN :: Element -> XMPPMonad ()
pushN x = do pushN x = do
sink <- gets sConPush sink <- gets sConPush
liftIO . sink $ formatNode' x lift . sink $ elementToEvents x
push :: Stanza -> XMPPMonad () push :: Stanza -> XMPPMonad ()
push = pushN . pickleElem stanzaP push = pushN . pickleElem stanzaP
pushOpen :: Element -> XMPPMonad () pushOpen :: Element -> XMPPMonad ()
pushOpen (Element name attrs children) = do pushOpen e = do
sink <- gets sConPush sink <- gets sConPush
let sax = StartElement name attrs lift . sink $ openElementToEvents e
liftIO . sink $ formatSAX' [sax]
forM children pushN
return () return ()
pulls :: Sink Event IO a -> XMPPMonad a pulls :: Sink Event (ResourceT IO) a -> XMPPMonad a
pulls snk = do pulls snk = do
source <- gets sConSrc source <- gets sConSrc
lift $ source $$ snk lift $ source $$ snk
@ -60,7 +60,7 @@ pullE :: XMPPMonad Element
pullE = do pullE = do
pulls elementFromEvents pulls elementFromEvents
pullPickle :: PU [Node Text Text] b -> XMPPMonad b pullPickle :: PU [Node] b -> XMPPMonad b
pullPickle p = unpickleElem p <$> pullE pullPickle p = unpickleElem p <$> pullE
pull :: XMPPMonad Stanza pull :: XMPPMonad Stanza
@ -76,11 +76,13 @@ xmppFromHandle
xmppFromHandle handle hostname username resource f = runResourceT $ do xmppFromHandle handle hostname username resource f = runResourceT $ do
liftIO $ hSetBuffering handle NoBuffering liftIO $ hSetBuffering handle NoBuffering
raw <- bufferSource $ CB.sourceHandle handle raw <- bufferSource $ CB.sourceHandle handle
src <- bufferSource $ raw $= HXC.parseBS parseOpts src <- bufferSource $ raw $= parseBytes def
let st = XMPPState let st = XMPPState
src src
raw raw
(liftIO . BS.hPut handle) (\xs -> CL.sourceList xs
$$ XR.renderBytes def =$ CB.sinkHandle handle)
(BS.hPut handle)
(Just handle) (Just handle)
def def
False False

71
src/Network/XMPP/Pickle.hs
Unescape View File

@ -11,31 +11,42 @@ import Control.Applicative((<$>))
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.Text as Text import qualified Data.Text as Text
import Data.Text.Encoding as Text import Data.Text.Encoding as Text
import Data.XML.Types
import Data.XML.Pickle
import Network.XMPP.Types import Network.XMPP.Types
import Text.XML.Expat.Pickle
import Text.XML.Expat.Tree
mbToBool (Just _) = True mbToBool (Just _) = True
mbToBool _ = False mbToBool _ = False
xpElemEmpty :: Text -> PU [Node Text Text] () xpElemEmpty :: Name -> PU [Node] ()
xpElemEmpty name = xpWrap (\((),()) -> () , xpElemEmpty name = xpWrap (\((),()) -> ())
\() -> ((),())) $ (\() -> ((),())) $
xpElem name xpUnit xpUnit xpElem name xpUnit xpUnit
xpElemExists :: Text -> PU [Node Text Text] Bool -- xpElemExists :: Name -> PU [Node] Bool
xpElemExists name = xpWrap (\x -> mbToBool x -- xpElemExists name = xpWrap (\x -> mbToBool x)
,\x -> if x then Just () else Nothing) $ -- (\x -> if x then Just () else Nothing) $
xpOption (xpElemEmpty name) -- xpOption (xpElemEmpty name)
xpNodeElem :: PU [Node] a -> PU Element a
xpNodeElem xp = PU { pickleTree = \x -> head $ (pickleTree xp x) >>= \y ->
case y of
NodeContent _ -> []
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 :: PU t ((), b) -> PU t b
ignoreAttrs = xpWrap (snd, ((),)) ignoreAttrs = xpWrap snd ((),)
mbl (Just l) = l mbl (Just l) = l
mbl Nothing = [] mbl Nothing = []
@ -47,33 +58,11 @@ right (Left l) = error l
right (Right r) = r right (Right r) = r
unpickleElem :: PU [Node tag text] c -> Node tag text -> c unpickleElem :: PU [Node] c -> Element -> c
unpickleElem p = right . unpickleTree' (xpRoot p) unpickleElem p = right . unpickle (xpNodeElem p)
pickleElem :: PU [Node tag text] a -> a -> Node tag text pickleElem :: PU [Node] a -> a -> Element
pickleElem p = pickleTree $ xpRoot p pickleElem p = pickle $ xpNodeElem p
xpEither :: PU n t1 -> PU n t2 -> PU n (Either t1 t2)
xpEither l r = xpAlt eitherSel
[xpWrap (\x -> Left x, \(Left x) -> x) l
,xpWrap (\x -> Right x, \(Right x) -> x) r
]
where
eitherSel (Left _) = 0
eitherSel (Right _) = 1
xpElemNs ::
Text
-> Text
-> PU [(Text, Text)] t1
-> PU [Node Text Text] t2
-> PU [Node Text Text] (t1, t2)
xpElemNs name ns attrs nodes =
xpWrap (\(((),a),n) -> (a,n), \(a,n) -> (((),a),n)) $
xpElem name
(xpPair
(xpAttrFixed "xmlns" ns)
attrs
)
nodes

49
src/Network/XMPP/SASL.hs
Unescape View File

@ -19,8 +19,11 @@ import qualified Data.ByteString.Base64 as B64
import qualified Data.List as L import qualified Data.List as L
import qualified Data.Digest.Pure.MD5 as MD5 import qualified Data.Digest.Pure.MD5 as MD5
import Data.List import Data.List
import Data.XML.Pickle
import Data.XML.Types
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.Text(Text)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text.Encoding as Text import qualified Data.Text.Encoding as Text
@ -29,31 +32,27 @@ import Network.XMPP.Pickle
import Network.XMPP.Stream import Network.XMPP.Stream
import Network.XMPP.Types import Network.XMPP.Types
import Numeric -- import Numeric
import qualified System.Random as Random import qualified System.Random as Random
import Text.XML.Expat.Pickle
import Text.XML.Expat.Tree
saslInitE :: Text -> Node Text Text saslInitE :: Text -> Element
saslInitE mechanism = saslInitE mechanism =
Element "auth" Element "{urn:ietf:params:xml:ns:xmpp-sasl}auth"
[ ("xmlns","urn:ietf:params:xml:ns:xmpp-sasl") [ ("mechanism", [ContentText mechanism]) ]
, ("mechanism", mechanism)
]
[] []
saslResponseE :: Text -> Node Text Text saslResponseE :: Text -> Element
saslResponseE resp = saslResponseE resp =
Element "response" Element "{urn:ietf:params:xml:ns:xmpp-sasl}response"
[("xmlns","urn:ietf:params:xml:ns:xmpp-sasl")] []
[Text resp] [NodeContent $ ContentText resp]
saslResponse2E :: Node Text Text saslResponse2E :: Element
saslResponse2E = saslResponse2E =
Element "response" Element "{urn:ietf:params:xml:ns:xmpp-sasl}response"
[("xmlns","urn:ietf:params:xml:ns:xmpp-sasl")] []
[] []
xmppSASL :: Text -> XMPPMonad () xmppSASL :: Text -> XMPPMonad ()
@ -69,7 +68,7 @@ xmppSASL passwd = do
Left x -> error $ show x Left x -> error $ show x
Right c -> return () Right c -> return ()
pushN saslResponse2E pushN saslResponse2E
Element "success" [("xmlns","urn:ietf:params:xml:ns:xmpp-sasl")] [] <- pullE Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] <- pullE
xmppRestartStream xmppRestartStream
return () return ()
@ -136,15 +135,11 @@ md5Digest uname realm password digestURI nc qop nonce cnonce=
-- Pickling -- Pickling
failurePickle :: PU [Node Text Text] (Node Text Text) failurePickle :: PU [Node] (Element)
failurePickle = ignoreAttrs $ failurePickle = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}failure"
xpElem "failure" (xpIsolate xpElemVerbatim)
(xpAttrFixed "xmlns" "urn:ietf:params:xml:ns:xmpp-sasl")
(xpTree) challengePickle :: PU [Node] Text.Text
challengePickle = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge"
challengePickle :: PU [Node Text.Text Text.Text] Text.Text (xpIsolate $ xpContent xpId)
challengePickle = ignoreAttrs $
xpElem "challenge"
(xpAttrFixed "xmlns" "urn:ietf:params:xml:ns:xmpp-sasl")
(xpContent xpText0)

12
src/Network/XMPP/Session.hs
Unescape View File

@ -6,22 +6,20 @@ import Control.Monad.Trans.State
import Data.Text as Text import Data.Text as Text
import Data.XML.Pickle
import Data.XML.Types
import Network.XMPP.Monad import Network.XMPP.Monad
import Network.XMPP.Types import Network.XMPP.Types
import Network.XMPP.Pickle import Network.XMPP.Pickle
import Network.XMPP.Marshal import Network.XMPP.Marshal
import Text.XML.Expat.Pickle
sessionIQ :: Stanza sessionIQ :: Stanza
sessionIQ = SIQ $ IQ Nothing Nothing "sess" Set sessionIQ = SIQ $ IQ Nothing Nothing "sess" Set
(pickleElem (pickleElem
(xpElemNs "session" (xpElemBlank "{urn:ietf:params:xml:ns:xmpp-session}session")
"urn:ietf:params:xml:ns:xmpp-session" ()
xpUnit
xpUnit)
((),())
) )
xmppSession :: XMPPMonad () xmppSession :: XMPPMonad ()

55
src/Network/XMPP/Stream.hs
Unescape View File

@ -14,15 +14,31 @@ import Network.XMPP.Pickle
import Network.XMPP.Types import Network.XMPP.Types
import Data.Conduit import Data.Conduit
import Data.Conduit.Hexpat as HXC
import Data.Conduit.List as CL import Data.Conduit.List as CL
import Data.Default(def)
import qualified Data.List as L import qualified Data.List as L
import Data.Text as T import Data.Text as T
import Data.XML.Types
import Data.XML.Pickle
import qualified Text.XML.Stream.Parse as XP
import Text.XML.Stream.Elements
import Text.XML.Expat.Pickle
-- import Text.XML.Stream.Elements -- import Text.XML.Stream.Elements
throwOutJunk = do
next <- peek
case next of
Nothing -> return ()
Just (EventBeginElement _ _) -> return ()
_ -> CL.drop 1 >> throwOutJunk
openElementFromEvents = do
throwOutJunk
Just (EventBeginElement name attrs) <- CL.head
return $ Element name attrs []
xmppStartStream :: XMPPMonad () xmppStartStream :: XMPPMonad ()
xmppStartStream = do xmppStartStream = do
@ -36,17 +52,18 @@ xmppRestartStream :: XMPPMonad ()
xmppRestartStream = do xmppRestartStream = do
raw <- gets sRawSrc raw <- gets sRawSrc
src <- gets sConSrc src <- gets sConSrc
newsrc <- lift (bufferSource $ raw $= HXC.parseBS parseOpts)
newsrc <- lift (bufferSource $ raw $= XP.parseBytes def)
modify (\s -> s{sConSrc = newsrc}) modify (\s -> s{sConSrc = newsrc})
xmppStartStream xmppStartStream
xmppStream :: Sink Event IO ServerFeatures xmppStream :: Sink Event (ResourceT IO) ServerFeatures
xmppStream = do xmppStream = do
xmppStreamHeader xmppStreamHeader
xmppStreamFeatures xmppStreamFeatures
xmppStreamHeader :: Sink Event IO () xmppStreamHeader :: Sink Event (ResourceT IO) ()
xmppStreamHeader = do xmppStreamHeader = do
throwOutJunk throwOutJunk
(ver, _, _) <- unpickleElem pickleStream <$> openElementFromEvents (ver, _, _) <- unpickleElem pickleStream <$> openElementFromEvents
@ -54,14 +71,14 @@ xmppStreamHeader = do
return() return()
xmppStreamFeatures :: Sink Event IO ServerFeatures xmppStreamFeatures :: Sink Event (ResourceT IO) ServerFeatures
xmppStreamFeatures = unpickleElem pickleStreamFeatures <$> elementFromEvents xmppStreamFeatures = unpickleElem pickleStreamFeatures <$> elementFromEvents
-- Pickling -- Pickling
pickleStream :: PU [Node Text Text] (Text, Maybe Text, Maybe Text) pickleStream :: PU [Node] (Text, Maybe Text, Maybe Text)
pickleStream = xpWrap (snd, (((),()),)) . pickleStream = xpWrap snd (((),()),) .
xpElemAttrs "stream:stream" $ xpElemAttrs "stream:stream" $
xpPair xpPair
(xpPair (xpPair
@ -69,32 +86,32 @@ pickleStream = xpWrap (snd, (((),()),)) .
(xpAttrFixed "xmlns:stream" "http://etherx.jabber.org/streams" ) (xpAttrFixed "xmlns:stream" "http://etherx.jabber.org/streams" )
) )
(xpTriple (xpTriple
(xpAttr "version" xpText) (xpAttr "version" xpId)
(xpOption $ xpAttr "from" xpText) (xpOption $ xpAttr "from" xpId)
(xpOption $ xpAttr "to" xpText) (xpOption $ xpAttr "to" xpId)
) )
pickleTLSFeature :: PU [Node Text Text] Bool pickleTLSFeature :: PU [Node] Bool
pickleTLSFeature = ignoreAttrs $ pickleTLSFeature = ignoreAttrs $
xpElem "starttls" xpElem "starttls"
(xpAttrFixed "xmlns" "urn:ietf:params:xml:ns:xmpp-tls") (xpAttrFixed "xmlns" "urn:ietf:params:xml:ns:xmpp-tls")
(xpElemExists "required") (xpElemExists "required")
pickleSaslFeature :: PU [Node Text Text] [Text] pickleSaslFeature :: PU [Node] [Text]
pickleSaslFeature = ignoreAttrs $ pickleSaslFeature = ignoreAttrs $
xpElem "mechanisms" xpElem "mechanisms"
(xpAttrFixed "xmlns" "urn:ietf:params:xml:ns:xmpp-sasl") (xpAttrFixed "xmlns" "urn:ietf:params:xml:ns:xmpp-sasl")
(xpList0 $ (xpList0 $
xpElemNodes "mechanism" (xpContent xpText) ) xpElemNodes "mechanism" (xpContent xpId) )
pickleStreamFeatures :: PU [Node Text Text] ServerFeatures pickleStreamFeatures :: PU [Node] ServerFeatures
pickleStreamFeatures = xpWrap ( \(tls, sasl, rest) -> SF tls (mbl sasl) rest pickleStreamFeatures = xpWrap ( \(tls, sasl, rest) -> SF tls (mbl sasl) rest)
, (\(SF tls sasl rest) -> (tls, lmb sasl, rest)) (\(SF tls sasl rest) -> (tls, lmb sasl, rest))
) $ $
xpElemNodes "stream:features" xpElemNodes "stream:features"
(xpTriple (xpTriple
(xpOption pickleTLSFeature) (xpOption pickleTLSFeature)
(xpOption pickleSaslFeature) (xpOption pickleSaslFeature)
xpTrees (xpAll xpElemVerbatim)
) )

19
src/Network/XMPP/TLS.hs
Unescape View File

@ -5,26 +5,29 @@ module Network.XMPP.TLS where
import Control.Monad import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Class import Control.Monad.Trans.Class
import Control.Monad.Trans.Resource
import Control.Monad.Trans.State import Control.Monad.Trans.State
import Data.Default
import Data.Text(Text) import Data.Text(Text)
import Data.XML.Types
import Network.XMPP.Monad import Network.XMPP.Monad
import Network.XMPP.Stream import Network.XMPP.Stream
import Network.XMPP.Types import Network.XMPP.Types
import Data.Conduit import Data.Conduit
import Data.Conduit.Hexpat as HX
import Data.Conduit.Text as CT import Data.Conduit.Text as CT
import Data.Conduit.TLS as TLS import Data.Conduit.TLS as TLS
import Data.Conduit.List as CL import Data.Conduit.List as CL
import qualified Data.List as L import qualified Data.List as L
import Text.XML.Expat.Tree import qualified Text.XML.Stream.Render as XR
starttlsE :: Node Text Text
starttlsE :: Element
starttlsE = starttlsE =
Element "starttls" [("xmlns", "urn:ietf:params:xml:ns:xmpp-tls")] [] Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] []
exampleParams :: TLSParams exampleParams :: TLSParams
@ -35,15 +38,17 @@ xmppStartTLS params = do
features <- gets sFeatures features <- gets sFeatures
unless (stls features == Nothing) $ do unless (stls features == Nothing) $ do
pushN starttlsE pushN starttlsE
Element "proceed" [("xmlns", "urn:ietf:params:xml:ns:xmpp-tls")] [] <- pullE Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] <- pullE
Just handle <- gets sConHandle Just handle <- gets sConHandle
(raw', snk) <- lift $ TLS.tlsinit params handle (raw', snk, push) <- lift $ TLS.tlsinit params handle
raw <- lift . bufferSource $ raw' raw <- lift . bufferSource $ raw'
modify (\x -> x modify (\x -> x
{ sRawSrc = raw { sRawSrc = raw
-- , sConSrc = -- Note: this momentarily leaves us in an -- , sConSrc = -- Note: this momentarily leaves us in an
-- inconsistent state -- inconsistent state
, sConPush = liftIO . snk , sConPush = \xs -> CL.sourceList xs
$$ XR.renderBytes def =$ snk
, sConPushBS = push
}) })
xmppRestartStream xmppRestartStream
modify (\s -> s{sHaveTLS = True}) modify (\s -> s{sHaveTLS = True})

29
src/Network/XMPP/Types.hs
Unescape View File

@ -7,18 +7,15 @@ import Control.Monad.Trans.State
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.Conduit import Data.Conduit
import Data.Default
import Data.List.Split as L import Data.List.Split as L
import Data.Maybe import Data.Maybe
import Data.Text as Text import Data.Text as Text
import Data.String as Str import Data.String as Str
import System.IO import Data.XML.Types
import Text.XML.Expat.SAX
import Text.XML.Expat.Tree
type Element = Node Text.Text Text.Text import System.IO
type Event = SAXEvent Text.Text Text.Text
-- | Jabber ID (JID) datatype -- | Jabber ID (JID) datatype
data JID = JID { node :: Maybe Text data JID = JID { node :: Maybe Text
@ -37,9 +34,10 @@ instance Show JID where
type XMPPMonad a = StateT XMPPState (ResourceT IO) a type XMPPMonad a = StateT XMPPState (ResourceT IO) a
data XMPPState = XMPPState data XMPPState = XMPPState
{ sConSrc :: BufferedSource IO Event { sConSrc :: BufferedSource (ResourceT IO) Event
, sRawSrc :: BufferedSource IO BS.ByteString , sRawSrc :: BufferedSource (ResourceT IO) BS.ByteString
, sConPush :: BS.ByteString -> IO () , sConPush :: [Event] -> ResourceT IO ()
, sConPushBS :: BS.ByteString -> IO ()
, sConHandle :: Maybe Handle , sConHandle :: Maybe Handle
, sFeatures :: ServerFeatures , sFeatures :: ServerFeatures
, sHaveTLS :: Bool , sHaveTLS :: Bool
@ -55,11 +53,12 @@ data ServerFeatures = SF
} deriving Show } deriving Show
def = SF instance Default ServerFeatures where
{ stls = Nothing def = SF
, saslMechanisms = [] { stls = Nothing
, other = [] , saslMechanisms = []
} , other = []
}
-- Ugh, that smells a bit. -- Ugh, that smells a bit.
@ -130,7 +129,7 @@ data MessageType = Chat | GroupChat | Headline | Normal | MessageError deriving
data PresenceType = Default | Unavailable | Subscribe | Subscribed | Unsubscribe | Unsubscribed | Probe | PresenceError deriving Eq data PresenceType = Default | Unavailable | Subscribe | Subscribed | Unsubscribe | Unsubscribed | Probe | PresenceError deriving Eq
data IQType = Get | Result | Set | IQError deriving Eq data IQType = Get | Result | Set | IQError deriving (Eq, Ord)
data ShowType = Available | Away | FreeChat | DND | XAway deriving Eq data ShowType = Available | Away | FreeChat | DND | XAway deriving Eq

78
src/Text/XML/Stream/Elements.hs
Unescape View File

@ -0,0 +1,78 @@
module Text.XML.Stream.Elements where
import Control.Applicative ((<$>))
import Control.Monad.Trans.Class
import Control.Monad.Trans.Resource as R
import Data.Text as T
import Text.XML.Unresolved
import Data.XML.Types
import Data.Conduit as C
import Data.Conduit.List as CL
import Text.XML.Stream.Parse
compressNodes :: [Node] -> [Node]
compressNodes [] = []
compressNodes [x] = [x]
compressNodes (NodeContent (ContentText x) : NodeContent (ContentText y) : z) =
compressNodes $ NodeContent (ContentText $ x `T.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
goM [] = id
goM [x] = (goM' x :)
goM (x:xs) = (goM' x :) . goM xs
goM' (MiscInstruction i) = EventInstruction i
goM' (MiscComment t) = EventComment t
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]
Write Preview
Loading…
Cancel
Save