initial

.gitignore

@@ -0,0 +1,6 @@
+dist/
+*.o
+*.hi
+*~
+*#
+*.#*

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)

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

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])
+     ]
+     []
+
+

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
+

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
+

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]