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

warning clean

master
Philipp Balzarek 14 years ago
parent
5eab69b427
commit
19a3005db6
11 changed files with 132 additions and 207 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. 15
      src/Example.hs
  2. 38
      src/Network/XMPP.hs
  3. 8
      src/Network/XMPP/Bind.hs
  4. 66
      src/Network/XMPP/Concurrent.hs
  5. 31
      src/Network/XMPP/Marshal.hs
  6. 24
      src/Network/XMPP/Monad.hs
  7. 16
      src/Network/XMPP/Pickle.hs
  8. 27
      src/Network/XMPP/SASL.hs
  9. 11
      src/Network/XMPP/Session.hs
  10. 21
      src/Network/XMPP/Stream.hs
  11. 16
      src/Network/XMPP/TLS.hs

15
src/Main.hs → src/Example.hs
Unescape View File

@ -1,17 +1,12 @@
{-# LANGUAGE PackageImports, OverloadedStrings #-} {-# LANGUAGE PackageImports, OverloadedStrings #-}
module Main where module Example where
import Data.Text as T import Data.Text as T
import Network.XMPP import Network.XMPP
import Network.XMPP.Concurrent
import Network.XMPP.Types
import Network
import GHC.IO.Handle
import Control.Concurrent import Control.Concurrent
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Monad import Control.Monad
import Control.Monad.Trans.State
import Control.Monad.IO.Class import Control.Monad.IO.Class
philonous :: JID philonous :: JID
@ -24,18 +19,18 @@ autoAccept :: XMPPThread ()
autoAccept = forever $ do autoAccept = forever $ do
st <- pullPresence st <- pullPresence
case st of case st of
Presence from _ id (Just Subscribe) _ _ _ _ -> Presence from _ idq (Just Subscribe) _ _ _ _ ->
sendS . SPresence $ sendS . SPresence $
Presence Nothing from id (Just Subscribed) Nothing Nothing Nothing [] Presence Nothing from idq (Just Subscribed) Nothing Nothing Nothing []
_ -> return () _ -> return ()
mirror :: XMPPThread () mirror :: XMPPThread ()
mirror = forever $ do mirror = forever $ do
st <- pullMessage st <- pullMessage
case st of case st of
Message (Just from) _ id tp subject (Just bd) thr _ -> Message (Just from) _ idq tp subject (Just bd) thr _ ->
sendS . SMessage $ sendS . SMessage $
Message Nothing from id tp subject Message Nothing from idq tp subject
(Just $ "you wrote: " `T.append` bd) thr [] (Just $ "you wrote: " `T.append` bd) thr []
_ -> return () _ -> return ()

38
src/Network/XMPP.hs
Unescape View File

@ -12,12 +12,6 @@ module Network.XMPP
, sessionConnect , sessionConnect
) where ) where
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.State
import qualified Data.ByteString as BS
import Data.Text as Text import Data.Text as Text
import Network import Network
@ -35,45 +29,29 @@ import System.IO
--fromHandle :: Handle -> Text -> Text -> Maybe Text -> Text -> IO ((), XMPPState) --fromHandle :: Handle -> Text -> Text -> Maybe Text -> Text -> IO ((), XMPPState)
fromHandle :: Handle -> Text -> Text -> Maybe Text -> Text -> XMPPThread a fromHandle :: Handle -> Text -> Text -> Maybe Text -> Text -> XMPPThread a
-> IO ((), XMPPState) -> IO ((), XMPPState)
fromHandle handle hostname username resource password a = fromHandle handle hostname username rsrc password a =
xmppFromHandle handle hostname username resource $ do xmppFromHandle handle hostname username rsrc $ do
xmppStartStream xmppStartStream
-- this will check whether the server supports tls -- this will check whether the server supports tls
-- on it's own -- on it's own
xmppStartTLS exampleParams xmppStartTLS exampleParams
xmppSASL password xmppSASL password
xmppBind resource xmppBind rsrc
xmppSession xmppSession
runThreaded a _ <- runThreaded a
return ()
--fromHandle :: Handle -> Text -> Text -> Maybe Text -> Text -> IO ((), XMPPState)
fromHandle' :: Handle -> Text -> Text -> Maybe Text -> Text -> XMPPThread a
-> IO ((), XMPPState)
fromHandle' handle hostname username resource password a =
xmppFromHandle handle hostname username resource $ do
xmppStartStream
runThreaded $ do
-- this will check whether the server supports tls
-- on it's own
singleThreaded $ xmppStartTLS exampleParams
singleThreaded $ xmppSASL password
singleThreaded $ xmppBind resource
singleThreaded $ xmppSession
a
return () return ()
connectXMPP :: HostName -> Text -> Text -> Maybe Text connectXMPP :: HostName -> Text -> Text -> Maybe Text
-> Text -> XMPPThread a -> IO ((), XMPPState) -> Text -> XMPPThread a -> IO ((), XMPPState)
connectXMPP host hostname username resource passwd a = do connectXMPP host hostname username rsrc passwd a = do
con <- connectTo host (PortNumber 5222) con <- connectTo host (PortNumber 5222)
hSetBuffering con NoBuffering hSetBuffering con NoBuffering
fromHandle' con hostname username resource passwd a fromHandle con hostname username rsrc passwd a
sessionConnect :: HostName -> Text -> Text sessionConnect :: HostName -> Text -> Text
-> Maybe Text -> XMPPThread a -> IO (a, XMPPState) -> Maybe Text -> XMPPThread a -> IO (a, XMPPState)
sessionConnect host hostname username resource a = do sessionConnect host hostname username rsrc a = do
con <- connectTo host (PortNumber 5222) con <- connectTo host (PortNumber 5222)
hSetBuffering con NoBuffering hSetBuffering con NoBuffering
xmppFromHandle con hostname username resource $ xmppFromHandle con hostname username rsrc $
xmppStartStream >> runThreaded a xmppStartStream >> runThreaded a

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

@ -12,16 +12,14 @@ 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
bindReqIQ :: Maybe Text -> Stanza bindReqIQ :: Maybe Text -> Stanza
bindReqIQ resource= SIQ $ IQ Nothing Nothing "bind" Set bindReqIQ rsrc= SIQ $ IQ Nothing Nothing "bind" Set
(pickleElem (pickleElem
(bindP . xpOption (bindP . xpOption
$ xpElemNodes "resource" (xpContent xpId)) $ xpElemNodes "resource" (xpContent xpId))
resource rsrc
) )
jidP :: PU [Node] JID jidP :: PU [Node] JID
@ -32,7 +30,7 @@ xmppBind res = do
push $ bindReqIQ res push $ bindReqIQ res
answer <- pull answer <- pull
let SIQ (IQ Nothing Nothing _ Result b) = answer let SIQ (IQ Nothing Nothing _ Result b) = answer
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] b -> PU [Node] b bindP :: PU [Node] b -> PU [Node] b

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

@ -13,9 +13,6 @@ import Network.XMPP.Types
import Control.Applicative((<$>),(<*>)) import Control.Applicative((<$>),(<*>))
import Control.Concurrent import Control.Concurrent
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Concurrent.STM.TChan
import Control.Concurrent.STM.TMVar
import Control.Exception (throwTo)
import qualified Control.Exception.Lifted as Ex import qualified Control.Exception.Lifted as Ex
import Control.Monad import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
@ -24,38 +21,33 @@ import Control.Monad.Trans.Reader
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
import Control.Monad.Trans.State import Control.Monad.Trans.State
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.Conduit import Data.Conduit
import qualified Data.Conduit.List as CL import qualified Data.Conduit.List as CL
import Data.Default (def) import Data.Default (def)
import Data.IORef import Data.IORef
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.Text(Text) import Data.Text(Text)
import Data.Typeable import Data.Typeable
import Data.XML.Types import Data.XML.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 Text.XML.Stream.Elements import Text.XML.Stream.Elements
import qualified Text.XML.Stream.Render as XR import qualified Text.XML.Stream.Render as XR
type IQHandlers = (Map.Map (IQType, Text) (TChan IQ), Map.Map Text (TMVar IQ))
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 Message -- the original chan , mShadow :: TChan Message -- the original chan
, pShadow :: TChan Presence -- the original chan , pShadow :: TChan Presence -- the original chan
, outCh :: TChan Stanza , outCh :: TChan Stanza
, iqHandlers :: TVar ( Map.Map (IQType, Text) (TChan IQ) , iqHandlers :: TVar IQHandlers
, Map.Map Text (TMVar IQ)
)
, writeRef :: TMVar (BS.ByteString -> IO () ) , writeRef :: TMVar (BS.ByteString -> IO () )
, readerThread :: ThreadId , readerThread :: ThreadId
, idGenerator :: IO Text , idGenerator :: IO Text
@ -95,16 +87,17 @@ readWorker messageC presenceC iqC s = Ex.catch (forever . flip runStateT s $ do
) )
writeWorker :: TChan Stanza -> TMVar (BS.ByteString -> IO ()) -> IO () writeWorker :: TChan Stanza -> TMVar (BS.ByteString -> IO ()) -> IO ()
writeWorker stCh writeRef = forever $ do writeWorker stCh writeR = forever $ do
(write, next) <- atomically $ (,) <$> (write, next) <- atomically $ (,) <$>
takeTMVar writeRef <*> takeTMVar writeR <*>
readTChan stCh readTChan stCh
outBS <- CL.sourceList (elementToEvents $ pickleElem stanzaP next) outBS <- CL.sourceList (elementToEvents $ pickleElem stanzaP next)
$= XR.renderBytes def $$ CL.consume $= XR.renderBytes def $$ CL.consume
forM outBS write _ <- forM outBS write
atomically $ putTMVar writeRef write atomically $ putTMVar writeR write
handleIQs :: MonadIO m => TVar IQHandlers -> TChan IQ -> m a
handleIQs handlers iqC = liftIO . forever . atomically $ do handleIQs handlers iqC = liftIO . forever . atomically $ do
iq <- readTChan iqC iq <- readTChan iqC
(byNS, byID) <- readTVar handlers (byNS, byID) <- readTVar handlers
@ -118,13 +111,15 @@ handleIQs handlers iqC = liftIO . forever . atomically $ do
Set -> case Map.lookup (Set, iqNS) byNS of Set -> case Map.lookup (Set, iqNS) byNS of
Nothing -> return () -- TODO: send error stanza Nothing -> return () -- TODO: send error stanza
Just ch -> writeTChan ch iq Just ch -> writeTChan ch iq
Result -> case Map.updateLookupWithKey (\_ _ -> Nothing) -- Result / Error :
_ -> case Map.updateLookupWithKey (\_ _ -> Nothing)
(iqId iq) byID of (iqId iq) byID of
(Nothing, _) -> return () -- we are not supposed (Nothing, _) -> return () -- we are not supposed
-- to send an error -- to send an error
(Just tmvar, byID') -> do (Just tmvar, byID') -> do
tryPutTMVar tmvar iq -- don't block _ <- tryPutTMVar tmvar iq -- don't block
writeTVar handlers (byNS, byID) writeTVar handlers (byNS, byID')
-- Two streams: input and output. Threads read from input stream and write to output stream. -- Two streams: input and output. Threads read from input stream and write to output stream.
@ -149,25 +144,17 @@ startThreads = do
presenceC <- liftIO newTChanIO presenceC <- liftIO newTChanIO
iqC <- liftIO newTChanIO iqC <- liftIO newTChanIO
outC <- liftIO newTChanIO outC <- liftIO newTChanIO
iqHandlers <- liftIO $ newTVarIO ( Map.empty, Map.empty) handlers <- liftIO $ newTVarIO ( Map.empty, Map.empty)
pushEvents <- gets sConPush
pushBS <- gets sConPushBS
lw <- liftIO . forkIO $ writeWorker outC writeLock lw <- liftIO . forkIO $ writeWorker outC writeLock
cp <- liftIO . forkIO $ connPersist writeLock cp <- liftIO . forkIO $ connPersist writeLock
iqh <- liftIO . forkIO $ handleIQs iqHandlers iqC iqh <- liftIO . forkIO $ handleIQs handlers iqC
s <- get s <- get
rd <- lift . resourceForkIO $ readWorker messageC presenceC iqC s rd <- lift . resourceForkIO $ readWorker messageC presenceC iqC s
return (messageC, presenceC, iqHandlers, outC, killConnection writeLock [lw, rd, cp], writeLock, rd) return (messageC, presenceC, handlers, outC, killConnection writeLock [lw, rd, cp, iqh], writeLock, rd)
where where
loopWrite writeLock pushEvents out' = forever $ do
next <- liftIO . atomically $ ( takeTMVar writeLock
>> readTChan out')
pushEvents . elementToEvents $ pickleElem stanzaP next
liftIO . atomically $ putTMVar writeLock ()
killConnection writeLock threads = liftIO $ do killConnection writeLock threads = liftIO $ do
atomically $ takeTMVar writeLock _ <- atomically $ takeTMVar writeLock -- Should we put it back?
forM threads killThread _ <- forM threads killThread
return() return()
@ -195,7 +182,7 @@ listenIQChan tp ns = do
runThreaded :: XMPPThread a runThreaded :: XMPPThread a
-> XMPPMonad a -> XMPPMonad a
runThreaded a = do runThreaded a = do
(mC, pC, hand, outC, stopThreads, writeR, reader ) <- startThreads (mC, pC, hand, outC, _stopThreads, writeR, rdr ) <- startThreads
workermCh <- liftIO . newIORef $ Nothing workermCh <- liftIO . newIORef $ Nothing
workerpCh <- liftIO . newIORef $ Nothing workerpCh <- liftIO . newIORef $ Nothing
idRef <- liftIO $ newTVarIO 1 idRef <- liftIO $ newTVarIO 1
@ -203,13 +190,14 @@ runThreaded a = do
curId <- readTVar idRef curId <- readTVar idRef
writeTVar idRef (curId + 1 :: Integer) writeTVar idRef (curId + 1 :: Integer)
return . Text.pack $ show curId return . Text.pack $ show curId
liftIO $ runReaderT a (Thread workermCh workerpCh mC pC outC hand writeR reader getId) liftIO $ runReaderT a (Thread workermCh workerpCh mC pC outC hand writeR rdr getId)
-- | get the inbound stanza channel, duplicates from master if necessary -- | get the inbound stanza channel, duplicates from master if necessary
-- please note that once duplicated it will keep filling up, call -- please note that once duplicated it will keep filling up, call
-- 'dropMessageChan' to allow it to be garbage collected -- 'dropMessageChan' to allow it to be garbage collected
getMessageChan :: XMPPThread (TChan Message)
getMessageChan = do getMessageChan = do
mChR <- asks messagesRef mChR <- asks messagesRef
mCh <- liftIO $ readIORef mChR mCh <- liftIO $ readIORef mChR
@ -219,9 +207,10 @@ getMessageChan = do
mCh' <- liftIO $ atomically $ dupTChan shadow mCh' <- liftIO $ atomically $ dupTChan shadow
liftIO $ writeIORef mChR (Just mCh') liftIO $ writeIORef mChR (Just mCh')
return mCh' return mCh'
Just mCh -> return mCh Just mCh' -> return mCh'
-- | see 'getMessageChan' -- | see 'getMessageChan'
getPresenceChan :: XMPPThread (TChan Presence)
getPresenceChan = do getPresenceChan = do
pChR <- asks presenceRef pChR <- asks presenceRef
pCh <- liftIO $ readIORef pChR pCh <- liftIO $ readIORef pChR
@ -231,7 +220,7 @@ getPresenceChan = do
pCh' <- liftIO $ atomically $ dupTChan shadow pCh' <- liftIO $ atomically $ dupTChan shadow
liftIO $ writeIORef pChR (Just pCh') liftIO $ writeIORef pChR (Just pCh')
return pCh' return pCh'
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
@ -313,9 +302,10 @@ connPersist lock = forever $ do
singleThreaded :: XMPPMonad () -> XMPPThread () singleThreaded :: XMPPMonad () -> XMPPThread ()
singleThreaded a = do singleThreaded a = do
writeLock <- asks writeRef writeLock <- asks writeRef
reader <- asks readerThread rdr <- asks readerThread
liftIO . atomically $ takeTMVar writeLock _ <- liftIO . atomically $ takeTMVar writeLock -- we replace it with the
liftIO . throwTo reader . ReaderSignal $ do -- one returned by a
liftIO . throwTo rdr . ReaderSignal $ do
a a
out <- gets sConPushBS out <- gets sConPushBS
liftIO . atomically $ putTMVar writeLock out liftIO . atomically $ putTMVar writeLock out

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

@ -2,20 +2,13 @@
module Network.XMPP.Marshal where module Network.XMPP.Marshal where
import Control.Applicative((<$>))
import Data.Maybe
import Data.Text(Text)
import Data.XML.Types
import Data.XML.Pickle import Data.XML.Pickle
import Data.XML.Types
import qualified Data.Text as Text
import Network.XMPP.Pickle
import Network.XMPP.Types import Network.XMPP.Types
stanzaSel :: Num a => Stanza -> a
stanzaSel (SMessage _) = 0 stanzaSel (SMessage _) = 0
stanzaSel (SPresence _) = 1 stanzaSel (SPresence _) = 1
stanzaSel (SIQ _) = 2 stanzaSel (SIQ _) = 2
@ -28,10 +21,10 @@ stanzaP = xpAlt stanzaSel
] ]
messageP :: PU [Node] Message messageP :: PU [Node] Message
messageP = xpWrap (\((from, to, id, tp),(sub, body, thr,ext)) messageP = xpWrap (\((from, to, qid, tp),(sub, body, thr,ext))
-> Message from to id tp sub body thr ext) -> Message from to qid tp sub body thr ext)
(\(Message from to id tp sub body thr ext) (\(Message from to qid tp sub body thr ext)
-> ((from, to, id, tp), (sub, body, thr,ext))) -> ((from, to, qid, tp), (sub, body, thr,ext)))
$ $
xpElem "{jabber:client}message" xpElem "{jabber:client}message"
(xp4Tuple (xp4Tuple
@ -48,10 +41,10 @@ messageP = xpWrap (\((from, to, id, tp),(sub, body, thr,ext))
) )
presenceP :: PU [Node] Presence presenceP :: PU [Node] Presence
presenceP = xpWrap (\((from, to, id, tp),(shw, stat, prio, ext)) presenceP = xpWrap (\((from, to, qid, tp),(shw, stat, prio, ext))
-> Presence from to id tp shw stat prio ext) -> Presence from to qid tp shw stat prio ext)
(\(Presence from to id tp shw stat prio ext) (\(Presence from to qid tp shw stat prio ext)
-> ((from, to, id, tp), (shw, stat, prio, ext))) -> ((from, to, qid, tp), (shw, stat, prio, ext)))
$ $
xpElem "{jabber:client}presence" xpElem "{jabber:client}presence"
(xp4Tuple (xp4Tuple
@ -68,8 +61,8 @@ presenceP = xpWrap (\((from, to, id, tp),(shw, stat, prio, ext))
) )
iqP :: PU [Node] IQ iqP :: PU [Node] IQ
iqP = xpWrap (\((from, to, id, tp),body) -> IQ from to id tp body) iqP = xpWrap (\((from, to, qid, tp),body) -> IQ from to qid tp body)
(\(IQ from to id tp body) -> ((from, to, id, tp), body)) (\(IQ from to qid tp body) -> ((from, to, qid, tp), body))
$ $
xpElem "{jabber:client}iq" xpElem "{jabber:client}iq"
(xp4Tuple (xp4Tuple

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

@ -3,32 +3,19 @@
module Network.XMPP.Monad where module Network.XMPP.Monad where
import Control.Applicative((<$>)) import Control.Applicative((<$>))
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.Resource
import Control.Monad.Trans.State import Control.Monad.Trans.State
import Data.ByteString as BS import Data.ByteString as BS
import Data.Default(def)
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 CH
import Data.Conduit.List as CL import Data.Conduit.List as CL
import Data.Conduit.Text as CT
import Data.Conduit.TLS import Data.Conduit.TLS
import Data.Text(Text)
import Data.XML.Pickle import Data.XML.Pickle
import Data.XML.Types import Data.XML.Types
import Text.XML.Stream.Parse as XP
import Text.XML.Stream.Render as XR
import Text.XML.Stream.Elements
import qualified Data.Text as Text
import Network.XMPP.Types import Network.XMPP.Types
import Network.XMPP.Marshal import Network.XMPP.Marshal
@ -36,6 +23,11 @@ import Network.XMPP.Pickle
import System.IO import System.IO
import Text.XML.Stream.Elements
import Text.XML.Stream.Parse as XP
import Text.XML.Stream.Render as XR
pushN :: Element -> XMPPMonad () pushN :: Element -> XMPPMonad ()
pushN x = do pushN x = do
sink <- gets sConPush sink <- gets sConPush
@ -70,7 +62,7 @@ xmppFromHandle
:: Handle -> Text -> Text -> Maybe Text :: Handle -> Text -> Text -> Maybe Text
-> XMPPMonad a -> XMPPMonad a
-> IO (a, XMPPState) -> IO (a, XMPPState)
xmppFromHandle handle hostname username resource f = runResourceT $ do xmppFromHandle handle hostname username res f = runResourceT $ do
liftIO $ hSetBuffering handle NoBuffering liftIO $ hSetBuffering handle NoBuffering
let raw = CB.sourceHandle handle $= conduitStdout let raw = CB.sourceHandle handle $= conduitStdout
let src = raw $= XP.parseBytes def let src = raw $= XP.parseBytes def
@ -85,6 +77,6 @@ xmppFromHandle handle hostname username resource f = runResourceT $ do
False False
hostname hostname
username username
resource res
runStateT f st runStateT f st

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

@ -7,20 +7,11 @@
module Network.XMPP.Pickle where module Network.XMPP.Pickle where
import Control.Applicative((<$>))
import qualified Data.ByteString as BS
import qualified Data.Text as Text
import Data.Text.Encoding as Text
import Data.XML.Types import Data.XML.Types
import Data.XML.Pickle import Data.XML.Pickle
import Network.XMPP.Types
mbToBool :: Maybe t -> Bool
mbToBool (Just _) = True mbToBool (Just _) = True
mbToBool _ = False mbToBool _ = False
@ -38,8 +29,8 @@ xpElemEmpty name = xpWrap (\((),()) -> ())
xpNodeElem :: PU [Node] a -> PU Element a xpNodeElem :: PU [Node] a -> PU Element a
xpNodeElem xp = PU { pickleTree = \x -> head $ (pickleTree xp x) >>= \y -> xpNodeElem xp = PU { pickleTree = \x -> head $ (pickleTree xp x) >>= \y ->
case y of case y of
NodeContent _ -> []
NodeElement e -> [e] NodeElement e -> [e]
_ -> []
, unpickleTree = \x -> case unpickleTree xp $ [NodeElement x] of , unpickleTree = \x -> case unpickleTree xp $ [NodeElement x] of
Left l -> Left l Left l -> Left l
Right (a,(_,c)) -> Right (a,(Nothing,c)) Right (a,(_,c)) -> Right (a,(Nothing,c))
@ -48,12 +39,15 @@ xpNodeElem xp = PU { pickleTree = \x -> head $ (pickleTree xp x) >>= \y ->
ignoreAttrs :: PU t ((), b) -> PU t b ignoreAttrs :: PU t ((), b) -> PU t b
ignoreAttrs = xpWrap snd ((),) ignoreAttrs = xpWrap snd ((),)
mbl :: Maybe [a] -> [a]
mbl (Just l) = l mbl (Just l) = l
mbl Nothing = [] mbl Nothing = []
lmb :: [t] -> Maybe [t]
lmb [] = Nothing lmb [] = Nothing
lmb x = Just x lmb x = Just x
right :: Either [Char] t -> t
right (Left l) = error l right (Left l) = error l
right (Right r) = r right (Right r) = r

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

@ -4,7 +4,6 @@ module Network.XMPP.SASL where
import Control.Applicative 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.State import Control.Monad.Trans.State
import qualified Crypto.Classes as CC import qualified Crypto.Classes as CC
@ -12,28 +11,22 @@ import qualified Crypto.Classes as CC
import qualified Data.Attoparsec.ByteString.Char8 as AP import qualified Data.Attoparsec.ByteString.Char8 as AP
import qualified Data.Binary as Binary import qualified Data.Binary as Binary
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BL8
import qualified Data.ByteString.Base64 as B64
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 qualified Data.List as L
import Data.XML.Pickle import Data.XML.Pickle
import Data.XML.Types 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
import Network.XMPP.Monad import Network.XMPP.Monad
import Network.XMPP.Pickle
import Network.XMPP.Stream import Network.XMPP.Stream
import Network.XMPP.Types import Network.XMPP.Types
import Numeric
import qualified System.Random as Random import qualified System.Random as Random
@ -66,7 +59,7 @@ xmppSASL passwd = do
challenge2 <- pullPickle (xpEither failurePickle challengePickle) challenge2 <- pullPickle (xpEither failurePickle challengePickle)
case challenge2 of case challenge2 of
Left x -> error $ show x Left x -> error $ show x
Right c -> return () Right _ -> return ()
pushN saslResponse2E pushN saslResponse2E
Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] <- pullE Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] <- pullE
xmppRestartStream xmppRestartStream
@ -111,7 +104,7 @@ toPairs :: BS.ByteString -> Either String [(BS.ByteString, BS.ByteString)]
toPairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do toPairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do
AP.skipSpace AP.skipSpace
name <- AP.takeWhile1 (/= '=') name <- AP.takeWhile1 (/= '=')
AP.char '=' _ <- AP.char '='
quote <- ((AP.char '"' >> return True) `mplus` return False) quote <- ((AP.char '"' >> return True) `mplus` return False)
content <- AP.takeWhile1 (AP.notInClass ",\"" ) content <- AP.takeWhile1 (AP.notInClass ",\"" )
when quote . void $ AP.char '"' when quote . void $ AP.char '"'
@ -125,8 +118,20 @@ hashRaw :: [BS8.ByteString] -> BS8.ByteString
hashRaw = toStrict . Binary.encode hashRaw = toStrict . Binary.encode
. (CC.hash' :: BS.ByteString -> MD5.MD5Digest) . BS.intercalate (":") . (CC.hash' :: BS.ByteString -> MD5.MD5Digest) . BS.intercalate (":")
toStrict :: BL.ByteString -> BS8.ByteString
toStrict = BS.concat . BL.toChunks toStrict = BS.concat . BL.toChunks
-- TODO: this only handles MD5-sess -- 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= md5Digest uname realm password digestURI nc qop nonce cnonce=
let ha1 = hash [hashRaw [uname,realm,password], nonce, cnonce] let ha1 = hash [hashRaw [uname,realm,password], nonce, cnonce]
ha2 = hash ["AUTHENTICATE", digestURI] ha2 = hash ["AUTHENTICATE", digestURI]

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

@ -2,18 +2,11 @@
module Network.XMPP.Session where module Network.XMPP.Session where
import Control.Monad.Trans.State
import Data.Text as Text
import Data.XML.Pickle import Data.XML.Pickle
import Data.XML.Types
import Network.XMPP.Monad import Network.XMPP.Monad
import Network.XMPP.Types
import Network.XMPP.Pickle import Network.XMPP.Pickle
import Network.XMPP.Marshal import Network.XMPP.Types
sessionIQ :: Stanza sessionIQ :: Stanza
sessionIQ = SIQ $ IQ Nothing Nothing "sess" Set sessionIQ = SIQ $ IQ Nothing Nothing "sess" Set
@ -26,5 +19,5 @@ xmppSession :: XMPPMonad ()
xmppSession = do xmppSession = do
push $ sessionIQ push $ sessionIQ
answer <- pull answer <- pull
let SIQ (IQ Nothing Nothing "sess" Result b) = answer let SIQ (IQ Nothing Nothing "sess" Result _body) = answer
return () return ()

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

@ -4,32 +4,25 @@
module Network.XMPP.Stream where module Network.XMPP.Stream where
import Control.Applicative((<$>)) import Control.Applicative((<$>))
import Control.Monad(unless, forever) import Control.Monad(unless)
import Control.Monad.Trans.Class
import Control.Monad.Trans.State import Control.Monad.Trans.State
import Control.Monad.IO.Class
import Network.XMPP.Monad
import Network.XMPP.Pickle
import Network.XMPP.Types
import Data.Conduit import Data.Conduit
import Data.Default(def)
-- import qualified Data.Conduit.Hexpat as CH
import Data.Conduit.List as CL import Data.Conduit.List as CL
import Data.Conduit.Text as CT
import Data.Default(def)
import qualified Data.List as L
import Data.Text as T import Data.Text as T
import Data.XML.Pickle import Data.XML.Pickle
import Data.XML.Types import Data.XML.Types
-- import qualified Text.XML.Stream.Parse as XP import Network.XMPP.Monad
import Network.XMPP.Pickle
import Network.XMPP.Types
import Text.XML.Stream.Elements import Text.XML.Stream.Elements
import Text.XML.Stream.Parse as XP import Text.XML.Stream.Parse as XP
-- import Text.XML.Stream.Elements -- import Text.XML.Stream.Elements
throwOutJunk :: Monad m => Sink Event m ()
throwOutJunk = do throwOutJunk = do
next <- CL.peek next <- CL.peek
case next of case next of
@ -37,6 +30,7 @@ throwOutJunk = do
Just (EventBeginElement _ _) -> return () Just (EventBeginElement _ _) -> return ()
_ -> CL.drop 1 >> throwOutJunk _ -> CL.drop 1 >> throwOutJunk
openElementFromEvents :: Monad m => Sink Event m Element
openElementFromEvents = do openElementFromEvents = do
throwOutJunk throwOutJunk
Just (EventBeginElement name attrs) <- CL.head Just (EventBeginElement name attrs) <- CL.head
@ -54,7 +48,6 @@ xmppStartStream = do
xmppRestartStream :: XMPPMonad () xmppRestartStream :: XMPPMonad ()
xmppRestartStream = do xmppRestartStream = do
raw <- gets sRawSrc raw <- gets sRawSrc
src <- gets sConSrc
let newsrc = raw $= XP.parseBytes def let newsrc = raw $= XP.parseBytes def
modify (\s -> s{sConSrc = newsrc}) modify (\s -> s{sConSrc = newsrc})
xmppStartStream xmppStartStream

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

@ -3,25 +3,19 @@
module Network.XMPP.TLS where module Network.XMPP.TLS where
import Control.Monad import Control.Monad
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.Conduit
import Data.Conduit.List as CL
import Data.Conduit.TLS as TLS
import Data.Default import Data.Default
import Data.Text(Text)
import Data.XML.Types 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.Text as CT
import Data.Conduit.TLS as TLS
import Data.Conduit.List as CL
import qualified Data.List as L
import qualified Text.XML.Stream.Render as XR import qualified Text.XML.Stream.Render as XR
@ -40,14 +34,14 @@ xmppStartTLS params = do
pushN starttlsE pushN starttlsE
Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] <- pullE Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] <- pullE
Just handle <- gets sConHandle Just handle <- gets sConHandle
(raw, snk, push) <- lift $ TLS.tlsinit params handle (raw, snk, psh) <- lift $ TLS.tlsinit params handle
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 = \xs -> CL.sourceList xs , sConPush = \xs -> CL.sourceList xs
$$ XR.renderBytes def =$ snk $$ XR.renderBytes def =$ snk
, sConPushBS = push , sConPushBS = psh
}) })
xmppRestartStream xmppRestartStream
modify (\s -> s{sHaveTLS = True}) modify (\s -> s{sHaveTLS = True})

Write Preview
Loading…
Cancel
Save