top level types

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.

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
 

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
+

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

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 "<space added>"
+  threadDelay 30000000
+
+

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))
                     ) $

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

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

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")

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 ()

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))
                               ) $

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