From 2193a15fbafc2e38739a75b3ec4f1555593dc426 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sun, 18 Mar 2012 18:40:35 +0100 Subject: [PATCH] initial --- .gitignore | 6 +++ src/Network/TLSConduit.hs | 40 +++++++++++++++++ src/Network/XMPP/Monad.hs | 63 +++++++++++++++++++++++++++ src/Network/XMPP/Stream.hs | 76 +++++++++++++++++++++++++++++++++ src/Network/XMPP/TLS.hs | 44 +++++++++++++++++++ src/Network/XMPPConduit.hs | 61 ++++++++++++++++++++++++++ src/Text/XML/Stream/Elements.hs | 76 +++++++++++++++++++++++++++++++++ xmpp-lib.cabal | 0 8 files changed, 366 insertions(+) create mode 100644 .gitignore create mode 100644 src/Network/TLSConduit.hs create mode 100644 src/Network/XMPP/Monad.hs create mode 100644 src/Network/XMPP/Stream.hs create mode 100644 src/Network/XMPP/TLS.hs create mode 100644 src/Network/XMPPConduit.hs create mode 100644 src/Text/XML/Stream/Elements.hs create mode 100644 xmpp-lib.cabal diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..a0ba28c --- /dev/null +++ b/.gitignore @@ -0,0 +1,6 @@ +dist/ +*.o +*.hi +*~ +*# +*.#* \ No newline at end of file diff --git a/src/Network/TLSConduit.hs b/src/Network/TLSConduit.hs new file mode 100644 index 0000000..7eedcf4 --- /dev/null +++ b/src/Network/TLSConduit.hs @@ -0,0 +1,40 @@ +module Network.TLSConduit + ( tlsinit + , module TLS + , module TLSExtra + ) + where + +import Control.Applicative +import Control.Monad.Trans + +import Crypto.Random + +import Data.ByteString +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) +import System.Random + +tlsinit + :: (MonadIO m, ResourceIO m1) => + TLSParams -> Handle + -> m (Source m1 ByteString, Sink ByteString m1 ()) +tlsinit tlsParams handle = do + gen <- liftIO $ (newGenIO :: IO SystemRandom) -- TODO: Find better random source? + clientContext <- client tlsParams gen handle + handshake clientContext + let src = sourceIO + (return clientContext) + bye + (\con -> IOOpen <$> recvData con) + let snk = sinkIO + (return clientContext) + (\_ -> return ()) + (\ctx dt -> sendData ctx (BL.fromChunks [dt]) >> return IOProcessing) + (\_ -> return ()) + return (src, snk) diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs new file mode 100644 index 0000000..ae2dfaf --- /dev/null +++ b/src/Network/XMPP/Monad.hs @@ -0,0 +1,63 @@ +module Network.XMPP.Monad where + +import Control.Monad.Trans +import Control.Monad.Trans.State + +import Data.Conduit +import Data.Conduit.List as CL +import Data.XML.Types + +import Data.Default +import Data.Text + +import System.IO + +import Text.XML.Stream.Elements + +type XMPPMonad a = StateT XMPPState (ResourceT IO) a + +data XMPPState = XMPPState + { conSrc :: BufferedSource IO Event + , conSink :: Sink Event IO () + , conHandle :: Maybe Handle + , sFeatures :: ServerFeatures + , haveTLS :: Bool + , sHostname :: Text + , jid :: Text + } + +data ServerFeatures = SF + { stls :: Bool + , stlsRequired :: Bool + , saslMechanisms :: [Text] + , other :: [Element] + } deriving Show + +instance Default ServerFeatures where + def = SF + { stls = False + , stlsRequired = False + , saslMechanisms = [] + , other = [] + } + +push :: Element -> XMPPMonad () +push x = do + sink <- gets conSink + lift $ CL.sourceList (elementToEvents x) $$ sink + +pushOpen :: Element -> XMPPMonad () +pushOpen x = do + sink <- gets conSink + lift $ CL.sourceList (elementToEvents' x) $$ sink + + +pulls :: Sink Event IO a -> XMPPMonad a +pulls snk = do + source <- gets conSrc + lift $ source $$ snk + +pull :: XMPPMonad Element +pull = do + source <- gets conSrc + pulls elementFromEvents diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs new file mode 100644 index 0000000..c38be19 --- /dev/null +++ b/src/Network/XMPP/Stream.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} + +module Network.XMPP.Stream where + +import Control.Monad(unless) +import Control.Monad.Trans.State + +import Network.XMPP.Monad + +import Data.Conduit +import Data.Conduit.List as CL +import qualified Data.List as L +import Data.Text as T +import Data.XML.Types + +import Text.XML.Stream.Elements + +xmppStartStream = do + hostname <- gets sHostname + pushOpen $ streamE hostname + features <- pulls xmppStream + modify (\s -> s {sFeatures = features}) + return () + + +xmppStream :: ResourceThrow m => Sink Event m ServerFeatures +xmppStream = do + xmppStreamHeader + xmppStreamFeatures + + +xmppStreamHeader :: Resource m => Sink Event m () +xmppStreamHeader = do + Just EventBeginDocument <- CL.head + Just (EventBeginElement "{http://etherx.jabber.org/streams}stream" streamAttrs) <- CL.head + unless (checkVersion streamAttrs) $ error "Not XMPP version 1.0 " + return () + where + checkVersion = L.any (\x -> (fst x == "version") && (snd x == [ContentText "1.0"])) + + +xmppStreamFeatures + :: ResourceThrow m => Sink Event m ServerFeatures +xmppStreamFeatures = do + Element "{http://etherx.jabber.org/streams}features" [] features' <- elementFromEvents + let features = do + f <- features' + case f of + NodeElement e -> [e] + _ -> [] + let starttls = features >>= isNamed "{urn:ietf:params:xml:ns:xmpp-tls}starttls" + let starttlsRequired = starttls + >>= elementChildren + >>= isNamed "{urn:ietf:params:xml:ns:xmpp-tls}required" + let mechanisms = features + >>= isNamed "{urn:ietf:params:xml:ns:xmpp-sasl}mechanisms" + >>= elementChildren + >>= isNamed "{urn:ietf:params:xml:ns:xmpp-sasl}mechanism" + >>= elementText + return SF { stls = not $ L.null starttls + , stlsRequired = not $ L.null starttlsRequired + , saslMechanisms = mechanisms + , other = features + } + +streamE :: T.Text -> Element +streamE hostname = + Element (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) + [ + ("xml:language" , [ContentText "en"]) + , ("version", [ContentText "1.0"]) + , ("to", [ContentText hostname]) + ] + [] + + diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs new file mode 100644 index 0000000..c351acc --- /dev/null +++ b/src/Network/XMPP/TLS.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.XMPP.TLS where + +import Control.Monad(when) +import Control.Monad.Trans +import Control.Monad.Trans.State + +import Network.XMPP.Monad +import Network.XMPP.Stream +import Network.TLSConduit as TLS + +import Data.Conduit +import Data.Conduit.Text as CT +import Data.Conduit.List as CL +import qualified Data.List as L +import Data.XML.Types + +import Text.XML.Stream.Elements +import Text.XML.Stream.Parse +import Text.XML.Stream.Render as XR + + +starttlsE = + Element (Name "starttls" (Just "urn:ietf:params:xml:ns:xmpp-tls") Nothing ) [] [] + +exampleParams = TLS.defaultParams {TLS.pCiphers = TLS.ciphersuite_strong} + +xmppStartTLS params = do + features <- gets sFeatures + when (stls features) $ do + push starttlsE + Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] <- pull + Just handle <- gets conHandle + (src', snk) <- lift $ TLS.tlsinit params handle + src <- lift . bufferSource $ src' $= CT.decode CT.utf8 $= parseText def + modify (\x -> x + { conSrc = src + , conSink = XR.renderBytes def =$ snk + }) + xmppStartStream + modify (\s -> s{haveTLS = True}) + gets haveTLS + diff --git a/src/Network/XMPPConduit.hs b/src/Network/XMPPConduit.hs new file mode 100644 index 0000000..3a0cd7a --- /dev/null +++ b/src/Network/XMPPConduit.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} +module Network.XMPPConduit where + +import Control.Exception +import Control.Monad +import Control.Monad.ST (runST) +import Control.Monad.Trans +import Control.Monad.Trans.Class +import Control.Monad.Trans.State +import Control.Applicative + + +import Data.Conduit as C +import Data.Conduit.Binary as CB +import Data.Conduit.Text as CT +import Data.Default +import Data.List as L +import Data.Text as T +import Data.XML.Types + +import GHC.IO.Handle + +import Network +import qualified Network.TLSConduit as TLS + +import System.IO +import System.Random + +import Text.XML.Stream.Elements +import Text.XML.Stream.Render as XR +import Text.XML.Stream.Parse + +import qualified Data.Conduit.List as CL + + +xmppSASL = do + return () + +xmppFromHandle handle hostname jid = do + liftIO $ hSetBuffering handle NoBuffering + src <- bufferSource $ CB.sourceHandle handle $= CT.decode CT.utf8 $= parseText def + let st = XMPPState + src + (XR.renderBytes def =$ CB.sinkHandle handle) + (Just handle) + def + False + hostname + jid + flip runStateT st $ do + xmppStartStream + xmppStartTLS + xmppSASL + +main = do + con <- connectTo "localhost" (PortNumber 5222) + hSetBuffering con NoBuffering + fs <- runResourceT $ xmppFromHandle con "species_64739.dyndns.org" "uart14" + putStrLn "" + hGetContents con >>= putStrLn + diff --git a/src/Text/XML/Stream/Elements.hs b/src/Text/XML/Stream/Elements.hs new file mode 100644 index 0000000..8301c7c --- /dev/null +++ b/src/Text/XML/Stream/Elements.hs @@ -0,0 +1,76 @@ +module Text.XML.Stream.Elements where + +import Control.Applicative ((<$>)) +import Control.Monad.Trans.Class + +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 :: C.ResourceThrow m => C.Sink Event m Element +elementFromEvents = do + x <- CL.peek + case x of + Just (EventBeginElement n as) -> goE n as + _ -> lift $ C.resourceThrow $ 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 $ C.resourceThrow $ 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 + + +elementToEvents' :: Element -> [Event] +elementToEvents' (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 e@(Element name _ _) = elementToEvents' e ++ [EventEndElement name] diff --git a/xmpp-lib.cabal b/xmpp-lib.cabal new file mode 100644 index 0000000..e69de29