From f27b0075205e69fec61f6d5975b39b4c84eefae8 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 22 Mar 2012 00:32:38 +0100 Subject: [PATCH] top level types --- LICENSE | 9 ++ src/Data/Conduit/Hexpat.hs | 3 + src/Network/XMPP.hs | 45 ++++++++++ src/Network/XMPP/Bind.hs | 3 + src/Network/XMPP/Concurrent.hs | 154 +++++++++++++++++++++++++++++++++ src/Network/XMPP/Marshal.hs | 5 ++ src/Network/XMPP/Monad.hs | 3 + src/Network/XMPP/Pickle.hs | 16 +++- src/Network/XMPP/SASL.hs | 9 ++ src/Network/XMPP/Session.hs | 32 +++++++ src/Network/XMPP/Stream.hs | 6 ++ src/Network/XMPP/TLS.hs | 6 ++ 12 files changed, 290 insertions(+), 1 deletion(-) create mode 100644 LICENSE create mode 100644 src/Network/XMPP.hs create mode 100644 src/Network/XMPP/Concurrent.hs create mode 100644 src/Network/XMPP/Session.hs diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..d53ad5c --- /dev/null +++ b/LICENSE @@ -0,0 +1,9 @@ +The MIT License + +Copyright (c) 2012 Philipp Balzarek + +Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/src/Data/Conduit/Hexpat.hs b/src/Data/Conduit/Hexpat.hs index e62de16..1c4eef4 100644 --- a/src/Data/Conduit/Hexpat.hs +++ b/src/Data/Conduit/Hexpat.hs @@ -181,5 +181,8 @@ throwOutJunk = do Just (StartElement _ _) -> return () _ -> CL.drop 1 >> throwOutJunk +saxToElements + :: (Eq tag, Show tag, MonadIO m, Resource m) => + Conduit (SAXEvent tag text) m (Node tag text) saxToElements = C.sequence $ throwOutJunk >> elementFromEvents diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs new file mode 100644 index 0000000..7f00330 --- /dev/null +++ b/src/Network/XMPP.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} +module Network.XMPP where + +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.State + +import qualified Data.ByteString as BS +import Data.Text as Text + +import Network +import Network.XMPP.Concurrent +import Network.XMPP.Monad +import Network.XMPP.TLS +import Network.XMPP.Stream +import Network.XMPP.SASL +import Network.XMPP.Types +import Network.XMPP.Bind +import Network.XMPP.Session + + +import System.IO + +--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 + -- this will check whether the server supports tls + -- on it's own + xmppStartTLS exampleParams + xmppSASL password + xmppBind + xmppSession + runThreaded a + return () + +connectXMPP :: HostName -> Text -> Text -> Maybe Text + -> Text -> XMPPThread a -> IO ((), XMPPState) +connectXMPP host hostname username resource passwd a = do + con <- connectTo host (PortNumber 5222) + hSetBuffering con NoBuffering + fromHandle con hostname username resource passwd a + diff --git a/src/Network/XMPP/Bind.hs b/src/Network/XMPP/Bind.hs index b56d055..8857bcd 100644 --- a/src/Network/XMPP/Bind.hs +++ b/src/Network/XMPP/Bind.hs @@ -13,6 +13,7 @@ import Network.XMPP.Marshal import Text.XML.Expat.Pickle +bindReqIQ :: Maybe Text -> Stanza bindReqIQ resource= SIQ $ IQ Nothing Nothing "bind" Set (pickleElem (bindP . xpOption @@ -23,6 +24,7 @@ bindReqIQ resource= SIQ $ IQ Nothing Nothing "bind" Set jidP :: PU [Node Text Text] JID jidP = bindP $ xpElemNodes "jid" (xpContent xpPrim) +xmppBind :: XMPPMonad () xmppBind = do res <- gets sResource push $ bindReqIQ res @@ -31,6 +33,7 @@ xmppBind = do let (JID n d (Just r)) = unpickleElem jidP b modify (\s -> s{sResource = Just r}) +bindP :: PU [Node Text.Text Text.Text] b -> PU [Node Text.Text Text.Text] b bindP c = ignoreAttrs $ xpElemNs "bind" "urn:ietf:params:xml:ns:xmpp-bind" xpUnit c diff --git a/src/Network/XMPP/Concurrent.hs b/src/Network/XMPP/Concurrent.hs new file mode 100644 index 0000000..5fe1519 --- /dev/null +++ b/src/Network/XMPP/Concurrent.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module Network.XMPP.Concurrent + where + +-- import Network.XMPP.Stream +import Network.XMPP.Types + +import Control.Concurrent +import Control.Concurrent.STM +import Control.Concurrent.STM.TChan +import Control.Concurrent.STM.TMVar +import Control.Monad.IO.Class +import Control.Monad +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.Maybe +import Data.IORef + +import Network.XMPP.Types +import Network.XMPP.Monad +import Network.XMPP.Marshal +import Network.XMPP.Pickle + + +import System.IO + +import Text.XML.Expat.Format +import Text.XML.Expat.Pickle + +data Thread = Thread { messagesRef :: IORef (Maybe (TChan Message)) + , presenceRef :: IORef (Maybe (TChan Presence)) + , mShadow :: TChan Stanza -- the original chan + , pShadow :: TChan Stanza -- the original chan + , outCh :: TChan Stanza + } + +type XMPPThread a = ReaderT Thread IO a + +-- 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 :: XMPPMonad (TChan Stanza, TChan Stanza, IO ()) +startThreads = do + writeLock <- liftIO $ newTMVarIO () + messagesC <- liftIO newTChanIO + presenceC <- liftIO newTChanIO + iqC <- liftIO newTChanIO + outC <- liftIO newTChanIO + iqHandlers <- liftIO newTVarIO + pushBS <- gets sConPush + lw <- liftIO . forkIO $ loopWrite writeLock pushBS outC + cp <- liftIO . forkIO $ connPersist pushBS writeLock + s <- get + rd <- lift . resourceForkIO . void . flip runStateT s . forever $ do + s <- pull + case s of + SMessage m -> liftIO . atomically $ writeTChan messageC m + SPresence p -> liftIO . atomically $ writeTChan presenceC p + SIQ i -> liftIO . atomically $ writeTChan presenceC i + return (inC, outC, killConnection writeLock [lw, rd, cp]) + where + loopWrite writeLock pushBS out' = forever $ do + next <- liftIO . atomically $ ( takeTMVar writeLock >> readTChan out') + liftIO . pushBS . formatNode' $ pickleElem stanzaP next + liftIO . atomically $ putTMVar writeLock () + iqHandler handlers iqC = forever $ do + iq <- liftIO . atomically $ readTChan iqC + + + killConnection writeLock threads = liftIO $ do + atomically $ takeTMVar writeLock + forM threads killThread + return() + +runThreaded :: XMPPThread a + -> XMPPMonad ThreadId +runThreaded a = do + (inC, outC, stopThreads) <- startThreads + workerInCh <- liftIO . newIORef $ Just inC + worker <- liftIO . forkIO $ do + runReaderT a (Thread workerInCh inC outC) + return () + return worker + + +-- | get the inbound stanza channel, duplicate from master if necessary +-- please note that once duplicated it will keep filling up +getInChan = do + inChR <- asks inChRef + inCh <- liftIO $ readIORef inChR + case inCh of + Nothing -> do + shadow <- asks shadowInCh + inCh' <- liftIO $ atomically $ dupTChan shadow + liftIO $ writeIORef inChR (Just inCh') + return inCh' + Just inCh -> return inCh + + +-- | Drop the local end of the inbound stanza channel +-- from our context so it can be GC-ed +dropInChan :: XMPPThread () +dropInChan = do + r <- asks inChRef + liftIO $ writeIORef r Nothing + + +-- | Read an element from the inbound stanza channel, acquiring a copy +-- of the channel as necessary +pullS :: XMPPThread Stanza +pullS = do + c <- getInChan + st <- liftIO $ atomically $ readTChan c + return st + +-- | 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 +withNewThread :: XMPPThread () -> XMPPThread ThreadId +withNewThread a = do + thread <- ask + inCH' <- liftIO $ newIORef Nothing + liftIO $ forkIO $ runReaderT a (thread {inChRef = inCH'}) + +waitFor :: (Stanza -> Bool) -> XMPPThread Stanza +waitFor f = do + s <- pullS + if (f s) then + return s + else do + waitFor f + +connPersist :: (BS.ByteString -> IO ()) -> TMVar () -> IO () +connPersist pushBS lock = forever $ do + atomically $ takeTMVar lock + pushBS " " + atomically $ putTMVar lock () +-- putStrLn "" + threadDelay 30000000 + + diff --git a/src/Network/XMPP/Marshal.hs b/src/Network/XMPP/Marshal.hs index 48695d2..c95ce3c 100644 --- a/src/Network/XMPP/Marshal.hs +++ b/src/Network/XMPP/Marshal.hs @@ -5,6 +5,7 @@ module Network.XMPP.Marshal where import Control.Applicative((<$>)) import Data.Maybe +import Data.Text(Text) import qualified Data.Text as Text @@ -17,12 +18,14 @@ stanzaSel (SMessage _ )= 0 stanzaSel (SPresence _ )= 1 stanzaSel (SIQ _ )= 2 +stanzaP :: PU [Node Text Text] Stanza stanzaP = xpAlt stanzaSel [ xpWrap (SMessage , (\(SMessage m) -> m)) messageP , xpWrap (SPresence , (\(SPresence p) -> p)) presenceP , xpWrap (SIQ , (\(SIQ i) -> i)) iqP ] +messageP :: PU [Node Text Text] Message 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) @@ -42,6 +45,7 @@ messageP = xpWrap ( (\((from, to, id, tp),(sub, body, thr,ext)) xpTrees ) +presenceP :: PU [Node Text Text] Presence 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) @@ -61,6 +65,7 @@ presenceP = xpWrap ( (\((from, to, id, tp),(shw, stat, prio, ext)) xpTrees ) +iqP :: PU [Node Text Text] IQ iqP = xpWrap ( (\((from, to, id, tp),body) -> IQ from to id tp body) , (\(IQ from to id tp body) -> ((from, to, id, tp), body)) ) $ diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index 262bad9..2db6c84 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -27,9 +27,11 @@ import Network.XMPP.Pickle import System.IO import Text.XML.Expat.SAX +import Text.XML.Expat.Pickle(PU) import Text.XML.Expat.Tree import Text.XML.Expat.Format +parseOpts :: ParseOptions tag text parseOpts = ParseOptions (Just UTF8) Nothing pushN :: Element -> XMPPMonad () @@ -58,6 +60,7 @@ pullE :: XMPPMonad Element pullE = do pulls elementFromEvents +pullPickle :: PU [Node Text Text] b -> XMPPMonad b pullPickle p = unpickleElem p <$> pullE pull :: XMPPMonad Stanza diff --git a/src/Network/XMPP/Pickle.hs b/src/Network/XMPP/Pickle.hs index 3b39058..d171a6e 100644 --- a/src/Network/XMPP/Pickle.hs +++ b/src/Network/XMPP/Pickle.hs @@ -23,14 +23,18 @@ import Text.XML.Expat.Tree mbToBool (Just _) = True mbToBool _ = False +xpElemEmpty :: Text -> PU [Node Text Text] () xpElemEmpty name = xpWrap (\((),()) -> () , \() -> ((),())) $ xpElem name xpUnit xpUnit +xpElemExists :: Text -> PU [Node Text Text] Bool xpElemExists name = xpWrap (\x -> mbToBool x ,\x -> if x then Just () else Nothing) $ xpOption (xpElemEmpty name) + +ignoreAttrs :: PU t ((), b) -> PU t b ignoreAttrs = xpWrap (snd, ((),)) mbl (Just l) = l @@ -42,9 +46,14 @@ lmb x = Just x right (Left l) = error l right (Right r) = r + +unpickleElem :: PU [Node tag text] c -> Node tag text -> c unpickleElem p = right . unpickleTree' (xpRoot p) + +pickleElem :: PU [Node tag text] a -> a -> Node tag text pickleElem p = pickleTree $ xpRoot 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 @@ -54,7 +63,12 @@ xpEither l r = xpAlt eitherSel 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 diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index a8aaf67..21a8632 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -21,6 +21,7 @@ import qualified Data.Digest.Pure.MD5 as MD5 import Data.List import qualified Data.Text as Text +import Data.Text (Text) import qualified Data.Text.Encoding as Text import Network.XMPP.Monad @@ -35,6 +36,7 @@ import qualified System.Random as Random import Text.XML.Expat.Pickle import Text.XML.Expat.Tree +saslInitE :: Text -> Node Text Text saslInitE mechanism = Element "auth" [ ("xmlns","urn:ietf:params:xml:ns:xmpp-sasl") @@ -42,16 +44,19 @@ saslInitE mechanism = ] [] +saslResponseE :: Text -> Node Text Text saslResponseE resp = Element "response" [("xmlns","urn:ietf:params:xml:ns:xmpp-sasl")] [Text resp] +saslResponse2E :: Node Text Text saslResponse2E = Element "response" [("xmlns","urn:ietf:params:xml:ns:xmpp-sasl")] [] +xmppSASL :: Text -> XMPPMonad () xmppSASL passwd = do mechanisms <- gets $ saslMechanisms . sFeatures unless ("DIGEST-MD5" `elem` mechanisms) $ error "No usable auth mechanism" @@ -68,6 +73,7 @@ xmppSASL passwd = do xmppRestartStream return () +createResponse :: Text -> [(BS8.ByteString, BS8.ByteString)] -> XMPPMonad Text createResponse passwd' pairs = do let Just qop = L.lookup "qop" pairs let Just nonce = L.lookup "nonce" pairs @@ -112,9 +118,11 @@ toPairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do 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 (":") @@ -128,6 +136,7 @@ md5Digest uname realm password digestURI nc qop nonce cnonce= -- Pickling +failurePickle :: PU [Node Text Text] (Node Text Text) failurePickle = ignoreAttrs $ xpElem "failure" (xpAttrFixed "xmlns" "urn:ietf:params:xml:ns:xmpp-sasl") diff --git a/src/Network/XMPP/Session.hs b/src/Network/XMPP/Session.hs new file mode 100644 index 0000000..6d90975 --- /dev/null +++ b/src/Network/XMPP/Session.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.XMPP.Session where + +import Control.Monad.Trans.State + +import Data.Text as Text + +import Network.XMPP.Monad +import Network.XMPP.Types +import Network.XMPP.Pickle +import Network.XMPP.Marshal + +import Text.XML.Expat.Pickle + + +sessionIQ :: Stanza +sessionIQ = SIQ $ IQ Nothing Nothing "sess" Set + (pickleElem + (xpElemNs "session" + "urn:ietf:params:xml:ns:xmpp-session" + xpUnit + xpUnit) + ((),()) + ) + +xmppSession :: XMPPMonad () +xmppSession = do + push $ sessionIQ + answer <- pull + let SIQ (IQ Nothing Nothing "sess" Result b) = answer + return () \ No newline at end of file diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index f21beab..223fc89 100644 --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -24,6 +24,7 @@ import Text.XML.Expat.Pickle -- import Text.XML.Stream.Elements +xmppStartStream :: XMPPMonad () xmppStartStream = do hostname <- gets sHostname pushOpen $ pickleElem pickleStream ("1.0",Nothing, Just hostname) @@ -31,6 +32,7 @@ xmppStartStream = do modify (\s -> s {sFeatures = features}) return () +xmppRestartStream :: XMPPMonad () xmppRestartStream = do raw <- gets sRawSrc src <- gets sConSrc @@ -58,6 +60,7 @@ xmppStreamFeatures = unpickleElem pickleStreamFeatures <$> elementFromEvents -- Pickling +pickleStream :: PU [Node Text Text] (Text, Maybe Text, Maybe Text) pickleStream = xpWrap (snd, (((),()),)) . xpElemAttrs "stream:stream" $ xpPair @@ -71,17 +74,20 @@ pickleStream = xpWrap (snd, (((),()),)) . (xpOption $ xpAttr "to" xpText) ) +pickleTLSFeature :: PU [Node Text Text] Bool pickleTLSFeature = ignoreAttrs $ xpElem "starttls" (xpAttrFixed "xmlns" "urn:ietf:params:xml:ns:xmpp-tls") (xpElemExists "required") +pickleSaslFeature :: PU [Node Text Text] [Text] pickleSaslFeature = ignoreAttrs $ xpElem "mechanisms" (xpAttrFixed "xmlns" "urn:ietf:params:xml:ns:xmpp-sasl") (xpList0 $ xpElemNodes "mechanism" (xpContent xpText) ) +pickleStreamFeatures :: PU [Node Text Text] ServerFeatures pickleStreamFeatures = xpWrap ( \(tls, sasl, rest) -> SF tls (mbl sasl) rest , (\(SF tls sasl rest) -> (tls, lmb sasl, rest)) ) $ diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index a9d2a57..de310a4 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -7,6 +7,8 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.State +import Data.Text(Text) + import Network.XMPP.Monad import Network.XMPP.Stream import Network.XMPP.Types @@ -20,11 +22,15 @@ import qualified Data.List as L import Text.XML.Expat.Tree +starttlsE :: Node Text Text starttlsE = Element "starttls" [("xmlns", "urn:ietf:params:xml:ns:xmpp-tls")] [] + +exampleParams :: TLSParams exampleParams = TLS.defaultParams {TLS.pCiphers = TLS.ciphersuite_strong} +xmppStartTLS :: TLSParams -> XMPPMonad Bool xmppStartTLS params = do features <- gets sFeatures unless (stls features == Nothing) $ do