diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..a3c8b33 --- /dev/null +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "xml-types-pickle"] + path = xml-types-pickle + url = git@github.com:Philonous/xml-types-pickle.git diff --git a/LICENSE b/LICENSE index 43bf2b5..1c21bf5 100644 --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,7 @@ -Copyright © 2010-2012, Jon Kristensen. +Copyright © 2005-2011 Dmitry Astapov +Copyright © 2005-2011 k.pierre +Copyright © 2010-2012 Jon Kristensen +Copyright © 2012 Philipp Balzarek Licensed under the Apache License, Version 2.0 (the "License"); you you may not use this file except in compliance with the License. You diff --git a/pontarius.cabal b/pontarius.cabal index ecc58c4..ec387dd 100644 --- a/pontarius.cabal +++ b/pontarius.cabal @@ -1,11 +1,11 @@ Name: pontarius -Version: 0.0.8.0 +Version: 0.1.0.0 Cabal-Version: >= 1.6 Build-Type: Simple -- License: License-File: LICENSE Copyright: Copyright © 2010-2012, Jon Kristensen -Author: Jon Kristensen, Mahdi Abdinejadi +Author: Jon Kristensen, Mahdi Abdinejadi, Philipp Balzarek Maintainer: jon.kristensen@nejla.com Stability: alpha -- Homepage: @@ -15,45 +15,59 @@ Synopsis: An incomplete implementation of RFC 6120 (XMPP: Core) Description: Pontarius is a work in progress of an implementation of RFC 6120 (XMPP: Core). Category: Network -Tested-With: GHC ==7.0.4 +Tested-With: GHC == 7.4.1 -- Data-Files: -- Data-Dir: -- Extra-Source-Files: -- Extra-Tmp-Files: Library + hs-source-dirs: src Exposed: True - Build-Depends: base >= 2 && < 5, parsec, crypto-api, base64-string, pureMD5, - utf8-string, network, xml-types, text, transformers, - bytestring, cereal, random, - tls, tls-extra, containers, mtl, text-icu, - stringprep, asn1-data, cryptohash, time, - certificate, ranges, uuid, conduit, xml-conduit - -- Other-Modules: - -- HS-Source-Dirs: - -- Extensions: - -- Build-Tools: - -- Buildable: - -- GHC-Options: - -- GHC-Prof-Options: - -- Hugs-Options: - -- NHC98-Options: - -- Includes: - -- Install-Includes: - -- Include-Dirs: - -- C-Sources: - -- Extra-Libraries: - -- Extra-Lib-Dirs: - -- CC-Options: - -- LD-Options: - -- Pkgconfig-Depends: - -- Frameworks: + Build-Depends: base >4 && <5 + , conduit -any + , resourcet -any + , containers -any + , random -any + , tls -any + , tls-extra -any + , pureMD5 -any + , base64-bytestring -any + , binary -any + , attoparsec -any + , crypto-api -any + , text -any + , bytestring -any + , transformers -any + , mtl -any + , network -any + , lifted-base -any + , split -any + , stm -any + , xml-types -any + , xml-conduit -any + , xml-types-pickle -any + , data-default -any + Exposed-modules: Network.XMPP.Types + -- Network.XMPP + + -- , Network.XMPP.SASL + -- , Network.XMPP.Stream + -- , Network.XMPP.Pickle + -- , Network.XMPP.Marshal + -- , Network.XMPP.Monad + -- , Network.XMPP.Concurrent + -- , Network.XMPP.TLS + -- , Network.XMPP.Bind + -- , Network.XMPP.Session + -- , Text.XML.Stream.Elements + -- , Data.Conduit.TLS + GHC-Options: -Wall + Source-Repository head Type: git - -- Module: Location: git://github.com/nejla/pontarius.git - -- Subdir: -- Source-Repository this -- Type: git diff --git a/src/Data/Conduit/TLS.hs b/src/Data/Conduit/TLS.hs new file mode 100644 index 0000000..bf2adf1 --- /dev/null +++ b/src/Data/Conduit/TLS.hs @@ -0,0 +1,48 @@ +{-# Language NoMonomorphismRestriction #-} +module Data.Conduit.TLS + ( tlsinit +-- , conduitStdout + , module TLS + , module TLSExtra + ) + where + +import Control.Applicative +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource + +import Crypto.Random + +import qualified Data.ByteString as BS +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) + +tlsinit + :: (MonadIO m, MonadIO m1, MonadResource m1) => + TLSParams + -> Handle -> m ( Source m1 BS.ByteString + , Sink BS.ByteString m1 () + , BS.ByteString -> IO ()) +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 ()) + (\con bs -> sendData con (BL.fromChunks [bs]) + >> return IOProcessing ) + (\_ -> return ()) + return ( src + , snk + , \s -> sendData clientContext $ BL.fromChunks [s] ) + diff --git a/src/Example.hs b/src/Example.hs new file mode 100644 index 0000000..916ceb2 --- /dev/null +++ b/src/Example.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE PackageImports, OverloadedStrings #-} +module Example where + +import Data.Text as T + +import Network.XMPP +import Control.Concurrent +import Control.Concurrent.STM +import Control.Monad +import Control.Monad.IO.Class + +philonous :: JID +philonous = read "uart14@species64739.dyndns.org" + +attXmpp :: STM a -> XMPPThread a +attXmpp = liftIO . atomically + +autoAccept :: XMPPThread () +autoAccept = forever $ do + st <- pullPresence + case st of + Presence from _ idq (Just Subscribe) _ _ _ _ -> + sendS . SPresence $ + Presence Nothing from idq (Just Subscribed) Nothing Nothing Nothing [] + _ -> return () + +mirror :: XMPPThread () +mirror = forever $ do + st <- pullMessage + case st of + Message (Just from) _ idq tp subject (Just bd) thr _ -> + sendS . SMessage $ + Message Nothing from idq tp subject + (Just $ "you wrote: " `T.append` bd) thr [] + _ -> return () + + +main :: IO () +main = do + sessionConnect "localhost" "species64739.dyndns.org" "bot" Nothing $ do +-- singleThreaded $ xmppStartTLS exampleParams + singleThreaded $ xmppSASL "pwd" + xmppThreadedBind (Just "botsi") +-- singleThreaded $ xmppBind (Just "botsi") + singleThreaded $ xmppSession + forkXMPP autoAccept + forkXMPP mirror + sendS . SPresence $ Presence Nothing Nothing Nothing Nothing + (Just Available) Nothing Nothing [] + sendS . SMessage $ Message Nothing philonous Nothing Nothing Nothing + (Just "bla") Nothing [] + liftIO . forever $ threadDelay 1000000 + return () + return () + diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs index 57be806..d2e96b5 100644 --- a/src/Network/XMPP.hs +++ b/src/Network/XMPP.hs @@ -1,4 +1,6 @@ --- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the +-- Copyright © 2010-2012 Jon Kristensen. +-- Copyright 2012 Philipp Balzarek +-- See the LICENSE file in the -- Pontarius distribution for more details. -- | @@ -25,65 +27,66 @@ -- this time as it's still in an experimental stage and will have its -- API and data types modified frequently. -module Network.XMPP ( -- Network.XMPP.JID - Address (..) - , Localpart - , Domainpart - , Resourcepart - , isFull - , isBare - , fromString - , fromStrings +{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} - -- Network.XMPP.Session - , runXMPPT - , hookStreamsOpenedEvent - , hookDisconnectedEvent - , destroy - , openStreams - , create - - -- , ClientHandler (..) - -- , ClientState (..) - -- , ConnectResult (..) - -- , HostName - -- , Password - -- , PortNumber - -- , Resource - -- , Session - -- , TerminationReason - -- , UserName - -- , sendIQ - -- , sendPresence - -- , sendMessage - -- , connect - -- , openStreams - -- , tlsSecureStreams - -- , authenticate - -- , session - -- , OpenStreamResult (..) - -- , SecureWithTLSResult (..) - -- , AuthenticateResult (..) +module Network.XMPP + ( module Network.XMPP.Bind + , module Network.XMPP.Concurrent + , module Network.XMPP.Monad + , module Network.XMPP.SASL + , module Network.XMPP.Session + , module Network.XMPP.Stream + , module Network.XMPP.TLS + , module Network.XMPP.Types + , module Network.XMPP.Presence + , module Network.XMPP.Message +-- , connectXMPP + , sessionConnect + ) where - -- Network.XMPP.Stanza - , StanzaID (SID) - , From - , To - , LangTag - , MessageType (..) - , Message (..) - , PresenceType (..) - , Presence (..) - , IQ (..) - , iqPayloadNamespace - , iqPayload ) where +import Data.Text as Text -import Network.XMPP.Address --- import Network.XMPP.SASL +import Network +import Network.XMPP.Bind +import Network.XMPP.Concurrent +import Network.XMPP.Message +import Network.XMPP.Monad +import Network.XMPP.Presence +import Network.XMPP.SASL import Network.XMPP.Session -import Network.XMPP.Stanza -import Network.XMPP.Utilities -import Network.XMPP.Types --- import Network.XMPP.TLS import Network.XMPP.Stream +import Network.XMPP.TLS +import Network.XMPP.Types + +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 rsrc password a = +-- xmppFromHandle handle hostname username rsrc $ do +-- xmppStartStream +-- -- this will check whether the server supports tls +-- -- on it's own +-- xmppStartTLS exampleParams +-- xmppSASL password +-- xmppBind rsrc +-- xmppSession +-- _ <- runThreaded a +-- return () + +-- connectXMPP :: HostName -> Text -> Text -> Maybe Text +-- -> Text -> XMPPThread a -> IO ((), XMPPState) +-- connectXMPP host hostname username rsrc passwd a = do +-- con <- connectTo host (PortNumber 5222) +-- hSetBuffering con NoBuffering +-- fromHandle con hostname username rsrc passwd a + +sessionConnect :: HostName -> Text -> Text + -> Maybe Text -> XMPPThread a -> IO (a, XMPPConState) +sessionConnect host hostname username rsrc a = do + con <- connectTo host (PortNumber 5222) + hSetBuffering con NoBuffering + xmppFromHandle con hostname username rsrc $ + xmppStartStream >> runThreaded a diff --git a/src/Network/XMPP/Bind.hs b/src/Network/XMPP/Bind.hs new file mode 100644 index 0000000..4ea7b3f --- /dev/null +++ b/src/Network/XMPP/Bind.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.XMPP.Bind where + +import Data.Text as Text + +import Data.XML.Pickle +import Data.XML.Types + +import Network.XMPP.Types +import Network.XMPP.Pickle +import Network.XMPP.Concurrent + +bindP :: PU [Node] b -> PU [Node] b +bindP c = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-bind}bind" c + +bindBody :: Maybe Text -> Element +bindBody rsrc = (pickleElem + (bindP . xpOption $ xpElemNodes "resource" (xpContent xpId)) + rsrc + ) + +jidP :: PU [Node] JID +jidP = bindP $ xpElemNodes "jid" (xpContent xpPrim) + +xmppThreadedBind :: Maybe Text -> XMPPThread Text +xmppThreadedBind rsrc = do + answer <- sendIQ' Nothing Set Nothing (bindBody rsrc) + let (Right IQResult{iqResultPayload = Just b}) = answer -- TODO: Error handling + let (JID _n _d (Just r)) = unpickleElem jidP b + return r + + + diff --git a/src/Network/XMPP/Concurrent.hs b/src/Network/XMPP/Concurrent.hs new file mode 100644 index 0000000..19f4ef7 --- /dev/null +++ b/src/Network/XMPP/Concurrent.hs @@ -0,0 +1,18 @@ +module Network.XMPP.Concurrent +( module Network.XMPP.Concurrent.Types +, module Network.XMPP.Concurrent.Monad +, module Network.XMPP.Concurrent.Threads +, module Network.XMPP.Concurrent.IQ +) where + +import Network.XMPP.Concurrent.Types +import Network.XMPP.Concurrent.Monad +import Network.XMPP.Concurrent.Threads +import Network.XMPP.Concurrent.IQ + + + + + + + diff --git a/src/Network/XMPP/Concurrent/IQ.hs b/src/Network/XMPP/Concurrent/IQ.hs new file mode 100644 index 0000000..cc97898 --- /dev/null +++ b/src/Network/XMPP/Concurrent/IQ.hs @@ -0,0 +1,59 @@ +module Network.XMPP.Concurrent.IQ where + +import Control.Concurrent.STM +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader + +import Data.XML.Types +import qualified Data.Map as Map + +import Network.XMPP.Concurrent.Types +import Network.XMPP.Concurrent.Monad +import Network.XMPP.Types + +-- | Sends an IQ, returns a 'TMVar' that will be filled with the first inbound +-- IQ with a matching ID that has type @result@ or @error@ +sendIQ :: Maybe JID -- ^ Recipient (to) + -> IQRequestType -- ^ IQ type (Get or Set) + -> Maybe LangTag -- ^ Language tag of the payload (Nothing for default) + -> Element -- ^ The iq body (there has to be exactly one) + -> XMPPThread (TMVar IQResponse) +sendIQ to tp lang body = do -- TODO: add timeout + newId <- liftIO =<< asks idGenerator + handlers <- asks iqHandlers + ref <- liftIO . atomically $ do + resRef <- newEmptyTMVar + (byNS, byId) <- readTVar handlers + writeTVar handlers (byNS, Map.insert newId resRef byId) + -- TODO: Check for id collisions (shouldn't happen?) + return resRef + sendS . IQRequestS $ IQRequest newId Nothing to lang tp body + return ref + +-- | like 'sendIQ', but waits for the answer IQ +sendIQ' :: Maybe JID + -> IQRequestType + -> Maybe LangTag + -> Element + -> XMPPThread IQResponse +sendIQ' to tp lang body = do + ref <- sendIQ to tp lang body + liftIO . atomically $ takeTMVar ref + +answerIQ :: (IQRequest, TVar Bool) + -> Either StanzaError (Maybe Element) + -> XMPPThread Bool +answerIQ ((IQRequest iqid from _to lang _tp bd), sentRef) answer = do + out <- asks outCh + let response = case answer of + Left err -> IQErrorS $ IQError iqid Nothing from lang err (Just bd) + Right res -> IQResultS $ IQResult iqid Nothing from lang res + liftIO . atomically $ do + sent <- readTVar sentRef + case sent of + False -> do + writeTVar sentRef True + + writeTChan out response + return True + True -> return False diff --git a/src/Network/XMPP/Concurrent/Monad.hs b/src/Network/XMPP/Concurrent/Monad.hs new file mode 100644 index 0000000..69b2f29 --- /dev/null +++ b/src/Network/XMPP/Concurrent/Monad.hs @@ -0,0 +1,161 @@ +module Network.XMPP.Concurrent.Monad where + +import Network.XMPP.Types + +import Control.Concurrent +import Control.Concurrent.STM +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State + +import Data.IORef +import qualified Data.Map as Map +import Data.Text(Text) + +import Network.XMPP.Concurrent.Types + +-- | Register a new IQ listener. IQ requests matching the type and namespace will +-- be put in the channel. +listenIQChan :: IQRequestType -- ^ type of IQs to receive (Get / Set) + -> Text -- ^ namespace of the child element + -> XMPPThread (Bool, TChan (IQRequest, TVar Bool)) +listenIQChan tp ns = do + handlers <- asks iqHandlers + liftIO . atomically $ do + (byNS, byID) <- readTVar handlers + iqCh <- newTChan + let (present, byNS') = Map.insertLookupWithKey' (\_ new _ -> new) + (tp,ns) iqCh byNS + writeTVar handlers (byNS', byID) + return $ case present of + Nothing -> (True, iqCh) + Just iqCh' -> (False, iqCh') + +-- | get the inbound stanza channel, duplicates from master if necessary +-- please note that once duplicated it will keep filling up, call +-- 'dropMessageChan' to allow it to be garbage collected +getMessageChan :: XMPPThread (TChan (Either MessageError Message)) +getMessageChan = do + mChR <- asks messagesRef + mCh <- liftIO $ readIORef mChR + case mCh of + Nothing -> do + shadow <- asks mShadow + mCh' <- liftIO $ atomically $ dupTChan shadow + liftIO $ writeIORef mChR (Just mCh') + return mCh' + Just mCh' -> return mCh' + +-- | see 'getMessageChan' +getPresenceChan :: XMPPThread (TChan (Either PresenceError Presence)) +getPresenceChan = do + pChR <- asks presenceRef + pCh <- liftIO $ readIORef pChR + case pCh of + Nothing -> do + shadow <- asks pShadow + pCh' <- liftIO $ atomically $ dupTChan shadow + liftIO $ writeIORef pChR (Just pCh') + return pCh' + Just pCh' -> return pCh' + +-- | Drop the local end of the inbound stanza channel +-- from our context so it can be GC-ed +dropMessageChan :: XMPPThread () +dropMessageChan = do + r <- asks messagesRef + liftIO $ writeIORef r Nothing + +-- | see 'dropMessageChan' +dropPresenceChan :: XMPPThread () +dropPresenceChan = do + r <- asks presenceRef + liftIO $ writeIORef r Nothing + +-- | Read an element from the inbound stanza channel, acquiring a copy +-- of the channel as necessary +pullMessage :: XMPPThread (Either MessageError Message) +pullMessage = do + c <- getMessageChan + liftIO $ atomically $ readTChan c + +-- | Read an element from the inbound stanza channel, acquiring a copy +-- of the channel as necessary +pullPresence :: XMPPThread (Either PresenceError Presence) +pullPresence = do + c <- getPresenceChan + liftIO $ atomically $ readTChan c + +-- | 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 +forkXMPP :: XMPPThread () -> XMPPThread ThreadId +forkXMPP a = do + thread <- ask + mCH' <- liftIO $ newIORef Nothing + pCH' <- liftIO $ newIORef Nothing + liftIO $ forkIO $ runReaderT a (thread {messagesRef = mCH' + ,presenceRef = pCH' + }) + +filterMessages :: (MessageError -> Bool) + -> (Message -> Bool) + -> XMPPThread (Either MessageError Message) +filterMessages f g = do + s <- pullMessage + case s of + Left e | f e -> return $ Left e + | otherwise -> filterMessages f g + Right m | g m -> return $ Right m + | otherwise -> filterMessages f g + +waitForMessage :: (Message -> Bool) -> XMPPThread Message +waitForMessage f = do + s <- pullMessage + case s of + Left _ -> waitForMessage f + Right m | f m -> return m + | otherwise -> waitForMessage f + +waitForMessageError :: (MessageError -> Bool) -> XMPPThread MessageError +waitForMessageError f = do + s <- pullMessage + case s of + Right _ -> waitForMessageError f + Left m | f m -> return m + | otherwise -> waitForMessageError f + +waitForPresence :: (Presence -> Bool) -> XMPPThread Presence +waitForPresence f = do + s <- pullPresence + case s of + Left _ -> waitForPresence f + Right m | f m -> return m + | otherwise -> waitForPresence f + +-- | Run an XMPPMonad action in isolation. +-- Reader and writer workers will be temporarily stopped +-- and resumed with the new session details once the action returns. +-- The Action will run in the reader thread. +withConnection :: XMPPConMonad () -> XMPPThread () +withConnection a = do + writeLock <- asks writeRef + rdr <- asks readerThread + _ <- liftIO . atomically $ takeTMVar writeLock -- we replace it with the + -- one returned by a + liftIO . throwTo rdr . ReaderSignal $ do + a + out <- gets sConPushBS + liftIO . atomically $ putTMVar writeLock out + return () + +sendPresence :: Presence -> XMPPThread () +sendPresence = sendS . PresenceS + +sendMessage :: Message -> XMPPThread () +sendMessage = sendS . MessageS \ No newline at end of file diff --git a/src/Network/XMPP/Concurrent/Threads.hs b/src/Network/XMPP/Concurrent/Threads.hs new file mode 100644 index 0000000..ad59d02 --- /dev/null +++ b/src/Network/XMPP/Concurrent/Threads.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.XMPP.Concurrent.Threads where + +import Network.XMPP.Types + +import Control.Applicative((<$>),(<*>)) +import Control.Concurrent +import Control.Concurrent.STM +import qualified Control.Exception.Lifted as Ex +import Control.Monad +import Control.Monad.IO.Class +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.Conduit +import qualified Data.Conduit.List as CL +import Data.Default (def) +import Data.IORef +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Text as Text + +import Data.XML.Types + +import Network.XMPP.Monad +import Network.XMPP.Marshal +import Network.XMPP.Pickle +import Network.XMPP.Concurrent.Types + +import Text.XML.Stream.Elements +import qualified Text.XML.Stream.Render as XR + +readWorker :: TChan (Either MessageError Message) + -> TChan (Either PresenceError Presence) + -> TVar IQHandlers + -> XMPPConState + -> ResourceT IO () +readWorker messageC presenceC handlers s = Ex.catch + (forever . flip runStateT s $ do + sta <- pull + liftIO .atomically $ do + case sta of + MessageS m -> do writeTChan messageC $ Right m + _ <- readTChan messageC -- Sic! + return () + -- this may seem ridiculous, but to prevent + -- the channel from filling up we immedtiately remove the + -- Stanza we just put in. It will still be + -- available in duplicates. + MessageErrorS m -> do writeTChan messageC $ Left m + _ <- readTChan messageC + return () + PresenceS p -> do + writeTChan presenceC $ Right p + _ <- readTChan presenceC + return () + PresenceErrorS p -> do + writeTChan presenceC $ Left p + _ <- readTChan presenceC + return () + + IQRequestS i -> handleIQRequest handlers i + IQResultS i -> handleIQResponse handlers (Right i) + IQErrorS i -> handleIQResponse handlers (Left i) + ) + ( \(ReaderSignal a) -> do + ((),s') <- runStateT a s + readWorker messageC presenceC handlers s' + ) + +handleIQRequest handlers iq = do + (byNS, _) <- readTVar handlers + let iqNS = fromMaybe "" (nameNamespace . elementName $ iqRequestPayload iq) + case Map.lookup (iqRequestType iq, iqNS) byNS of + Nothing -> return () -- TODO: send error stanza + Just ch -> do + sent <- newTVar False + writeTChan ch (iq, sent) + +handleIQResponse handlers iq = do + (byNS, byID) <- readTVar handlers + case Map.updateLookupWithKey (\_ _ -> Nothing) (iqID iq) byID of + (Nothing, _) -> return () -- we are not supposed + -- to send an error + (Just tmvar, byID') -> do + _ <- tryPutTMVar tmvar iq -- don't block + writeTVar handlers (byNS, byID') + where + iqID (Left err) = iqErrorID err + iqID (Right iq) = iqResultID iq + +writeWorker :: TChan Stanza -> TMVar (BS.ByteString -> IO ()) -> IO () +writeWorker stCh writeR = forever $ do + (write, next) <- atomically $ (,) <$> + takeTMVar writeR <*> + readTChan stCh + outBS <- CL.sourceList (elementToEvents $ pickleElem stanzaP next) + $= XR.renderBytes def $$ CL.consume + _ <- forM outBS write + atomically $ putTMVar writeR write + +-- 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 + :: XMPPConMonad ( TChan (Either MessageError Message) + , TChan (Either PresenceError Presence) + , TVar IQHandlers + , TChan Stanza, IO () + , TMVar (BS.ByteString -> IO ()) + , ThreadId + ) + +startThreads = do + writeLock <- liftIO . newTMVarIO =<< gets sConPushBS + messageC <- liftIO newTChanIO + presenceC <- liftIO newTChanIO + iqC <- liftIO newTChanIO + outC <- liftIO newTChanIO + handlers <- liftIO $ newTVarIO ( Map.empty, Map.empty) + lw <- liftIO . forkIO $ writeWorker outC writeLock + cp <- liftIO . forkIO $ connPersist writeLock + s <- get + rd <- lift . resourceForkIO $ readWorker messageC presenceC handlers s + return (messageC, presenceC, handlers, outC, killConnection writeLock [lw, rd, cp], writeLock, rd) + where + killConnection writeLock threads = liftIO $ do + _ <- atomically $ takeTMVar writeLock -- Should we put it back? + _ <- forM threads killThread + return() + + +-- | Start worker threads and run action. The supplied action will run +-- in the calling thread. use 'forkXMPP' to start another thread. +runThreaded :: XMPPThread a + -> XMPPConMonad a +runThreaded a = do + (mC, pC, hand, outC, _stopThreads, writeR, rdr ) <- startThreads + workermCh <- liftIO . newIORef $ Nothing + workerpCh <- liftIO . newIORef $ Nothing + idRef <- liftIO $ newTVarIO 1 + let getId = atomically $ do + curId <- readTVar idRef + writeTVar idRef (curId + 1 :: Integer) + return . read. show $ curId + liftIO $ runReaderT a (Thread workermCh workerpCh mC pC outC hand writeR rdr getId) + +-- | Sends a blank space every 30 seconds to keep the connection alive +connPersist :: TMVar (BS.ByteString -> IO ()) -> IO () +connPersist lock = forever $ do + pushBS <- atomically $ takeTMVar lock + pushBS " " + atomically $ putTMVar lock pushBS +-- putStrLn "" + threadDelay 30000000 diff --git a/src/Network/XMPP/Concurrent/Types.hs b/src/Network/XMPP/Concurrent/Types.hs new file mode 100644 index 0000000..889638b --- /dev/null +++ b/src/Network/XMPP/Concurrent/Types.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Network.XMPP.Concurrent.Types where + +import qualified Control.Exception.Lifted as Ex +import Control.Concurrent +import Control.Concurrent.STM +import Control.Monad.Trans.Reader + +import qualified Data.ByteString as BS +import Data.IORef +import qualified Data.Map as Map +import Data.Text(Text) +import Data.Typeable + + +import Network.XMPP.Types + + +type IQHandlers = (Map.Map (IQRequestType, Text) (TChan (IQRequest, TVar Bool)) + , Map.Map StanzaId (TMVar IQResponse) + ) + +data Thread = Thread { messagesRef :: IORef (Maybe ( TChan (Either + MessageError + Message + ))) + , presenceRef :: IORef (Maybe (TChan (Either + PresenceError + Presence + ))) + , mShadow :: TChan (Either MessageError + Message) -- the original chan + , pShadow :: TChan (Either PresenceError + Presence) -- the original chan + , outCh :: TChan Stanza + , iqHandlers :: TVar IQHandlers + , writeRef :: TMVar (BS.ByteString -> IO () ) + , readerThread :: ThreadId + , idGenerator :: IO StanzaId + } + +type XMPPThread a = ReaderT Thread IO a + + +data ReaderSignal = ReaderSignal (XMPPConMonad ()) deriving Typeable +instance Show ReaderSignal where show _ = "" +instance Ex.Exception ReaderSignal diff --git a/src/Network/XMPP/Marshal.hs b/src/Network/XMPP/Marshal.hs new file mode 100644 index 0000000..6f32fde --- /dev/null +++ b/src/Network/XMPP/Marshal.hs @@ -0,0 +1,195 @@ +{-# Language OverloadedStrings, ViewPatterns, NoMonomorphismRestriction #-} + +module Network.XMPP.Marshal where + +import Data.XML.Pickle +import Data.XML.Types + +import Network.XMPP.Types + +stanzaSel :: Stanza -> Int +stanzaSel (IQRequestS _) = 0 +stanzaSel (IQResultS _) = 1 +stanzaSel (IQErrorS _) = 2 +stanzaSel (MessageS _) = 3 +stanzaSel (MessageErrorS _) = 4 +stanzaSel (PresenceS _) = 5 +stanzaSel (PresenceErrorS _) = 6 + +stanzaP :: PU [Node] Stanza +stanzaP = xpAlt stanzaSel + [ xpWrap IQRequestS (\(IQRequestS x) -> x) xpIQRequest + , xpWrap IQResultS (\(IQResultS x) -> x) xpIQResult + , xpWrap IQErrorS (\(IQErrorS x) -> x) xpIQError + , xpWrap MessageS (\(MessageS x) -> x) xpMessage + , xpWrap MessageErrorS (\(MessageErrorS x) -> x) xpMessageError + , xpWrap PresenceS (\(PresenceS x) -> x) xpPresence + , xpWrap PresenceErrorS (\(PresenceErrorS x) -> x) xpPresenceError + ] + +xmlLang :: Name +xmlLang = Name "lang" Nothing (Just "xml") + +xpLangTag :: PU [Attribute] (Maybe LangTag) +xpLangTag = xpAttrImplied xmlLang xpPrim + +xpMessage :: PU [Node] (Message) +xpMessage = xpWrap (\((tp, qid, from, to, lang), (sub, body, thr, ext)) + -> Message qid from to lang tp sub thr body ext) + (\(Message qid from to lang tp sub thr body ext) + -> ((tp, qid, from, to, lang), (sub, body, thr, ext))) + $ + xpElem "{jabber:client}message" + (xp5Tuple + (xpDefault Normal $ xpAttr "type" xpPrim) + (xpAttrImplied "id" xpPrim) + (xpAttrImplied "from" xpPrim) + (xpAttrImplied "to" xpPrim) + (xpAttrImplied xmlLang xpPrim) + -- TODO: NS? + ) + (xp4Tuple + (xpOption . xpElemNodes "{jabber:client}subject" $ xpContent xpId) + (xpOption . xpElemNodes "{jabber:client}body" $ xpContent xpId) + (xpOption . xpElemNodes "{jabber:client}thread" $ xpContent xpId) + (xpAll xpElemVerbatim) + ) + + +xpPresence :: PU [Node] Presence +xpPresence = xpWrap (\((qid, from, to, lang, tp),(shw, stat, prio, ext)) + -> Presence qid from to lang tp shw stat prio ext) + (\(Presence qid from to lang tp shw stat prio ext) + -> ((qid, from, to, lang, tp), (shw, stat, prio, ext))) + $ + xpElem "{jabber:client}presence" + (xp5Tuple + (xpAttrImplied "id" xpPrim) + (xpAttrImplied "from" xpPrim) + (xpAttrImplied "to" xpPrim) + xpLangTag + (xpAttrImplied "type" xpPrim) + ) + (xp4Tuple + (xpOption . xpElemNodes "{jabber:client}show" $ xpContent xpPrim) + (xpOption . xpElemNodes "{jabber:client}status" $ xpContent xpId) + (xpOption . xpElemNodes "{jabber:client}priority" $ xpContent xpPrim) + (xpAll xpElemVerbatim) + ) + +xpIQRequest :: PU [Node] IQRequest +xpIQRequest = xpWrap (\((qid, from, to, lang, tp),body) + -> IQRequest qid from to lang tp body) + (\(IQRequest qid from to lang tp body) + -> ((qid, from, to, lang, tp), body)) + $ + xpElem "{jabber:client}iq" + (xp5Tuple + (xpAttr "id" xpPrim) + (xpAttrImplied "from" xpPrim) + (xpAttrImplied "to" xpPrim) + xpLangTag + ((xpAttr "type" xpPrim)) + ) + (xpElemVerbatim) + +xpIQResult :: PU [Node] IQResult +xpIQResult = xpWrap (\((qid, from, to, lang, _tp),body) + -> IQResult qid from to lang body) + (\(IQResult qid from to lang body) + -> ((qid, from, to, lang, ()), body)) + $ + xpElem "{jabber:client}iq" + (xp5Tuple + (xpAttr "id" xpPrim) + (xpAttrImplied "from" xpPrim) + (xpAttrImplied "to" xpPrim) + xpLangTag + ((xpAttrFixed "type" "result")) + ) + (xpOption xpElemVerbatim) + +---------------------------------------------------------- +-- Errors +---------------------------------------------------------- + +xpErrorCondition :: PU [Node] StanzaErrorCondition +xpErrorCondition = xpWrap (\(cond, (), ()) -> cond) (\cond -> (cond, (), ())) $ + xpElemByNamespace + "urn:ietf:params:xml:ns:xmpp-stanzas" xpPrim + xpUnit + xpUnit + +xpStanzaError :: PU [Node] StanzaError +xpStanzaError = xpWrap + (\(tp, (cond, txt, ext)) -> StanzaError tp cond txt ext) + (\(StanzaError tp cond txt ext) -> (tp, (cond, txt, ext))) $ + xpElem "{jabber:client}error" + (xpAttr "type" xpPrim) + (xp3Tuple + xpErrorCondition + (xpOption $ xpElem "{jabber:client}text" + (xpAttrImplied xmlLang xpPrim) + (xpContent xpId) + ) + (xpOption xpElemVerbatim) + ) + +xpMessageError :: PU [Node] (MessageError) +xpMessageError = xpWrap (\((_, qid, from, to, lang), (err, ext)) + -> MessageError qid from to lang err ext) + (\(MessageError qid from to lang err ext) + -> (((), qid, from, to, lang), (err, ext))) + $ + xpElem "{jabber:client}message" + (xp5Tuple + (xpAttrFixed "type" "error") + (xpAttrImplied "id" xpPrim) + (xpAttrImplied "from" xpPrim) + (xpAttrImplied "to" xpPrim) + (xpAttrImplied xmlLang xpPrim) + -- TODO: NS? + ) + (xp2Tuple + xpStanzaError + (xpAll xpElemVerbatim) + ) + +xpPresenceError :: PU [Node] PresenceError +xpPresenceError = xpWrap (\((qid, from, to, lang, _),(err, ext)) + -> PresenceError qid from to lang err ext) + (\(PresenceError qid from to lang err ext) + -> ((qid, from, to, lang, ()), (err, ext))) + $ + xpElem "{jabber:client}presence" + (xp5Tuple + (xpAttrImplied "id" xpPrim) + (xpAttrImplied "from" xpPrim) + (xpAttrImplied "to" xpPrim) + xpLangTag + (xpAttrFixed "type" "error") + ) + (xp2Tuple + xpStanzaError + (xpAll xpElemVerbatim) + ) + +xpIQError :: PU [Node] IQError +xpIQError = xpWrap (\((qid, from, to, lang, _tp),(err, body)) + -> IQError qid from to lang err body) + (\(IQError qid from to lang err body) + -> ((qid, from, to, lang, ()), (err, body))) + $ + xpElem "{jabber:client}iq" + (xp5Tuple + (xpAttr "id" xpPrim) + (xpAttrImplied "from" xpPrim) + (xpAttrImplied "to" xpPrim) + xpLangTag + ((xpAttrFixed "type" "error")) + ) + (xp2Tuple + xpStanzaError + (xpOption xpElemVerbatim) + ) + diff --git a/src/Network/XMPP/Message.hs b/src/Network/XMPP/Message.hs new file mode 100644 index 0000000..6d1dadc --- /dev/null +++ b/src/Network/XMPP/Message.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE RecordWildCards #-} +module Network.XMPP.Message where + +import Data.Text(Text) +import Data.XML.Types + +import Network.XMPP.Types + +message :: Message +message = Message { messageID = Nothing + , messageFrom = Nothing + , messageTo = Nothing + , messageLangTag = Nothing + , messageType = Normal + , messageSubject = Nothing + , messageThread = Nothing + , messageBody = Nothing + , messagePayload = [] + } + +simpleMessage :: JID -> Text -> Message +simpleMessage to txt = message { messageTo = Just to + , messageBody = Just txt + } + +answerMessage :: Message -> Text -> [Element] -> Maybe Message +answerMessage Message{messageFrom = Just frm, ..} txt payload = + Just $ Message{ messageFrom = messageTo + , messageID = Nothing + , messageTo = Just frm + , messageBody = Just txt + , messagePayload = payload + , .. + } +answerMessage _ _ _ = Nothing + diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs new file mode 100644 index 0000000..ff3aded --- /dev/null +++ b/src/Network/XMPP/Monad.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.XMPP.Monad where + +import Control.Applicative((<$>)) +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Resource +import Control.Monad.Trans.State + +import Data.ByteString as BS +import Data.Conduit +import Data.Conduit.Binary as CB +import Data.Conduit.List as CL +import Data.Text(Text) +import Data.XML.Pickle +import Data.XML.Types + +import Network.XMPP.Types +import Network.XMPP.Marshal +import Network.XMPP.Pickle + +import System.IO + +import Text.XML.Stream.Elements +import Text.XML.Stream.Parse as XP +import Text.XML.Stream.Render as XR + + +pushN :: Element -> XMPPConMonad () +pushN x = do + sink <- gets sConPush + lift . sink $ elementToEvents x + +push :: Stanza -> XMPPConMonad () +push = pushN . pickleElem stanzaP + +pushOpen :: Element -> XMPPConMonad () +pushOpen e = do + sink <- gets sConPush + lift . sink $ openElementToEvents e + return () + +pulls :: Sink Event (ResourceT IO) b -> XMPPConMonad b +pulls snk = do + source <- gets sConSrc + (src', r) <- lift $ source $$+ snk + modify $ (\s -> s {sConSrc = src'}) + return r + +pullE :: XMPPConMonad Element +pullE = pulls elementFromEvents + +pullPickle :: PU [Node] a -> XMPPConMonad a +pullPickle p = unpickleElem p <$> pullE + +pull :: XMPPConMonad Stanza +pull = pullPickle stanzaP + +xmppFromHandle :: Handle + -> Text + -> Text + -> Maybe Text + -> XMPPConMonad a + -> IO (a, XMPPConState) +xmppFromHandle handle hostname username res f = runResourceT $ do + liftIO $ hSetBuffering handle NoBuffering + let raw = CB.sourceHandle handle + let src = raw $= XP.parseBytes def + let st = XMPPConState + src + (raw) + (\xs -> CL.sourceList xs + $$ XR.renderBytes def =$ CB.sinkHandle handle) + (BS.hPut handle) + (Just handle) + (SF Nothing [] []) + False + hostname + username + res + runStateT f st + diff --git a/src/Network/XMPP/Pickle.hs b/src/Network/XMPP/Pickle.hs new file mode 100644 index 0000000..c1b15c9 --- /dev/null +++ b/src/Network/XMPP/Pickle.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +-- Marshalling between XML and Native Types + + +module Network.XMPP.Pickle where + +import Data.XML.Types +import Data.XML.Pickle + + +mbToBool :: Maybe t -> Bool +mbToBool (Just _) = True +mbToBool _ = False + +xpElemEmpty :: Name -> PU [Node] () +xpElemEmpty name = xpWrap (\((),()) -> ()) + (\() -> ((),())) $ + xpElem name xpUnit xpUnit + +-- xpElemExists :: Name -> PU [Node] Bool +-- xpElemExists name = xpWrap (\x -> mbToBool x) +-- (\x -> if x then Just () else Nothing) $ +-- xpOption (xpElemEmpty name) + + +xpNodeElem :: PU [Node] a -> PU Element a +xpNodeElem xp = PU { pickleTree = \x -> head $ (pickleTree xp x) >>= \y -> + case y of + NodeElement e -> [e] + _ -> [] + , unpickleTree = \x -> case unpickleTree xp $ [NodeElement x] of + Left l -> Left l + Right (a,(_,c)) -> Right (a,(Nothing,c)) + } + +ignoreAttrs :: PU t ((), b) -> PU t b +ignoreAttrs = xpWrap snd ((),) + +mbl :: Maybe [a] -> [a] +mbl (Just l) = l +mbl Nothing = [] + +lmb :: [t] -> Maybe [t] +lmb [] = Nothing +lmb x = Just x + +right :: Either [Char] t -> t +right (Left l) = error l +right (Right r) = r + + +unpickleElem :: PU [Node] c -> Element -> c +unpickleElem p x = case unpickle (xpNodeElem p) x of + Left l -> error $ l ++ "\n saw: " ++ show x + Right r -> r + +pickleElem :: PU [Node] a -> a -> Element +pickleElem p = pickle $ xpNodeElem p + + + diff --git a/src/Network/XMPP/Presence.hs b/src/Network/XMPP/Presence.hs new file mode 100644 index 0000000..f948596 --- /dev/null +++ b/src/Network/XMPP/Presence.hs @@ -0,0 +1,78 @@ +module Network.XMPP.Presence where + +import Data.Text(Text) +import Network.XMPP.Types + + +presence :: Presence +presence = Presence { presenceID = Nothing + , presenceFrom = Nothing + , presenceTo = Nothing + , presenceLangTag = Nothing + , presenceType = Nothing + , presenceShowType = Nothing + , presenceStatus = Nothing + , presencePriority = Nothing + , presencePayload = [] + } + +presenceSubscribe :: JID -> Presence +presenceSubscribe to = presence { presenceTo = Just to + , presenceType = Just Subscribe + } + +-- | Is presence a subscription request +isPresenceSubscribe :: Presence -> Bool +isPresenceSubscribe pres = presenceType pres == (Just Subscribe) + +-- | Approve a subscripton of an entity +presenceSubscribed :: JID -> Presence +presenceSubscribed to = presence { presenceTo = Just to + , presenceType = Just Subscribed + } + +-- | Is presence a subscription approval +isPresenceSubscribed :: Presence -> Bool +isPresenceSubscribed pres = presenceType pres == (Just Subscribed) + +-- | End a subscription with an entity +presenceUnsubscribe :: JID -> Presence +presenceUnsubscribe to = presence { presenceTo = Just to + , presenceType = Just Unsubscribed + } + +-- | Is presence an unsubscription request +isPresenceUnsubscribe :: Presence -> Bool +isPresenceUnsubscribe pres = presenceType pres == (Just Unsubscribe) + +-- | Signals to the server that the client is available for communication +presenceOnline :: Presence +presenceOnline = presence + +-- | Signals to the server that the client is no longer available for communication. +presenceOffline :: Presence +presenceOffline = presence {presenceType = Just Unavailable} + +status + :: Maybe Text -- ^ Status message + -> Maybe ShowType -- ^ Status Type + -> Maybe Int -- ^ Priority + -> Presence +status txt showType prio = presence { presenceShowType = showType + , presencePriority = prio + , presenceStatus = txt + } + +-- | Sets the current availability status. This implicitly sets the clients +-- status online +presenceAvail :: ShowType -> Presence +presenceAvail showType = status Nothing (Just showType) Nothing + +-- | Sets the current status message. This implicitly sets the clients +-- status online +presenceMessage :: Text -> Presence +presenceMessage txt = status (Just txt) Nothing Nothing + +-- | Adds a recipient to a presence notification +presTo :: Presence -> JID -> Presence +presTo pres to = pres{presenceTo = Just to} \ No newline at end of file diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index 4cf7419..d893150 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -1,172 +1,150 @@ --- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the --- Pontarius distribution for more details. - -{-# OPTIONS_HADDOCK hide #-} - --- TODO: Make it possible to include host. --- TODO: Host is assumed to be ISO 8859-1; make list of assumptions. --- TODO: Can it contain newline characters? - -module Network.XMPP.SASL (replyToChallenge, saltedPassword, clientKey, storedKey, authMessage, clientSignature, clientProof, serverKey, serverSignature) where - -import Prelude hiding (concat, zipWith) -import Data.ByteString.Internal (c2w) -import Data.Char (isLatin1) -import Data.Digest.Pure.MD5 -import qualified Data.ByteString.Lazy as DBL (ByteString, append, pack, - fromChunks, toChunks, null) -import qualified Data.ByteString.Lazy.Char8 as DBLC (append, pack, unpack) -import qualified Data.List as DL -import Data.Text (empty, singleton) -import Text.StringPrep (StringPrepProfile (..), a1, b1, c12, c21, c22, c3, c4, c5, c6, c7, c8, c9, runStringPrep) -import Data.Ranges (inRanges, ranges) +{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} +module Network.XMPP.SASL where + +import Control.Applicative +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.State + +import qualified Crypto.Classes as CC + +import qualified Data.Attoparsec.ByteString.Char8 as AP +import qualified Data.Binary as Binary +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as BL +import qualified Data.Digest.Pure.MD5 as MD5 +import qualified Data.List as L +import Data.XML.Pickle +import Data.XML.Types + +import qualified Data.Text as Text +import Data.Text (Text) +import qualified Data.Text.Encoding as Text + +import Network.XMPP.Monad +import Network.XMPP.Stream +import Network.XMPP.Types + +import qualified System.Random as Random + + +saslInitE :: Text -> Element +saslInitE mechanism = + Element "{urn:ietf:params:xml:ns:xmpp-sasl}auth" + [ ("mechanism", [ContentText mechanism]) ] + [] + +saslResponseE :: Text -> Element +saslResponseE resp = + Element "{urn:ietf:params:xml:ns:xmpp-sasl}response" + [] + [NodeContent $ ContentText resp] + +saslResponse2E :: Element +saslResponse2E = + Element "{urn:ietf:params:xml:ns:xmpp-sasl}response" + [] + [] + +xmppSASL :: Text -> XMPPConMonad () +xmppSASL passwd = do + mechanisms <- gets $ saslMechanisms . sFeatures + unless ("DIGEST-MD5" `elem` mechanisms) . error $ "No usable auth mechanism: " ++ show mechanisms + pushN $ saslInitE "DIGEST-MD5" + Right challenge <- B64.decode . Text.encodeUtf8<$> pullPickle challengePickle + let Right pairs = toPairs challenge + pushN . saslResponseE =<< createResponse passwd pairs + challenge2 <- pullPickle (xpEither failurePickle challengePickle) + case challenge2 of + Left x -> error $ show x + Right _ -> return () + pushN saslResponse2E + Element "{urn:ietf:params:xml:ns:xmpp-sasl}success" [] [] <- pullE + xmppRestartStream + return () + +createResponse :: Text -> [(BS8.ByteString, BS8.ByteString)] -> XMPPConMonad Text +createResponse passwd' pairs = do + let Just qop = L.lookup "qop" pairs + let Just nonce = L.lookup "nonce" pairs + uname <- Text.encodeUtf8 <$> gets sUsername + let passwd = Text.encodeUtf8 passwd' + realm <- Text.encodeUtf8 <$> gets sHostname + g <- liftIO $ Random.newStdGen + let cnonce = BS.tail . BS.init . + B64.encode . BS.pack . take 8 $ Random.randoms g + let nc = "00000001" + let digestURI = ("xmpp/" `BS.append` realm) + let digest = md5Digest + uname + realm + passwd + digestURI + nc + qop + nonce + cnonce + let response = BS.intercalate"," . map (BS.intercalate "=") $ + [["username" , quote uname ] + ,["realm" , quote realm ] + ,["nonce" , quote nonce ] + ,["cnonce" , quote cnonce ] + ,["nc" , nc ] + ,["qop" , qop ] + ,["digest-uri", quote digestURI ] + ,["response" , digest ] + ,["charset" , "utf-8" ] + ] + return . Text.decodeUtf8 $ B64.encode response + where quote x = BS.concat ["\"",x,"\""] + +toPairs :: BS.ByteString -> Either String [(BS.ByteString, BS.ByteString)] +toPairs = AP.parseOnly . flip AP.sepBy1 (void $ AP.char ',') $ do + AP.skipSpace + name <- AP.takeWhile1 (/= '=') + _ <- AP.char '=' + quote <- ((AP.char '"' >> return True) `mplus` return False) + content <- AP.takeWhile1 (AP.notInClass ",\"" ) + 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 (":") + +toStrict :: BL.ByteString -> BS8.ByteString +toStrict = BS.concat . BL.toChunks + +-- 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= + let ha1 = hash [hashRaw [uname,realm,password], nonce, cnonce] + ha2 = hash ["AUTHENTICATE", digestURI] + in hash [ha1,nonce, nc, cnonce,qop,ha2] + + +-- Pickling + +failurePickle :: PU [Node] (Element) +failurePickle = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}failure" + (xpIsolate xpElemVerbatim) + +challengePickle :: PU [Node] Text.Text +challengePickle = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}challenge" + (xpIsolate $ xpContent xpId) -import Crypto.HMAC (MacKey (MacKey), hmac) -import Crypto.Hash.SHA1 (SHA1, hash) -import Data.Bits (xor) -import Data.ByteString () -import Data.ByteString.Lazy (ByteString, concat, fromChunks, pack, toChunks, zipWith) -import Data.Serialize (Serialize, encodeLazy) -import Data.Serialize.Put (putWord32be, runPutLazy) - -import Data.Maybe (fromJust, isJust) - -import qualified Data.Text as DT - -import Text.StringPrep (runStringPrep) - -data Challenge1Error = C1MultipleCriticalAttributes | - C1NotAllParametersPresent | - C1SomeParamtersPresentMoreThanOnce | - C1WrongRealm | - C1UnsupportedAlgorithm | - C1UnsupportedCharset | - C1UnsupportedQOP - deriving Show - - --- Will produce a list of key-value pairs given a string in the format of --- realm="somerealm",nonce="OA6MG9tEQGm2hh",qop="auth",charset=utf-8... -stringToList :: String -> [(String, String)] -stringToList "" = [] -stringToList s' = let (next, rest) = break' s' ',' - in break' next '=' : stringToList rest - where - -- Like break, but will remove the first char of the continuation, if - -- present. - break' :: String -> Char -> (String, String) - break' s' c = let (first, second) = break ((==) c) s' - in (first, removeCharIfPresent second c) - - -- Removes the first character, if present; "=hello" with '=' becomes - -- "hello". - removeCharIfPresent :: String -> Char -> String - removeCharIfPresent [] _ = [] - removeCharIfPresent (c:t) c' | c == c' = t - removeCharIfPresent s' c = s' - --- Counts the number of directives in the pair list. -countDirectives :: String -> [(String, String)] -> Int -countDirectives v l = DL.length $ filter (isEntry v) l - where - isEntry :: String -> (String, String) -> Bool - isEntry name (name', _) | name == name' = True - | otherwise = False - - --- Returns the given directive in the list of pairs, or Nothing. -lookupDirective :: String -> [(String, String)] -> Maybe String -lookupDirective d [] = Nothing -lookupDirective d ((d', v):t) | d == d' = Just v - | otherwise = lookupDirective d t - - --- Returns the given directive in the list of pairs, or the default value --- otherwise. -lookupDirectiveWithDefault :: String -> [(String, String)] -> String -> String -lookupDirectiveWithDefault di l de - | lookup == Nothing = de - | otherwise = let Just r = lookup in r - where - lookup = lookupDirective di l - - --- Implementation of "Hi()" as specified in the Notation section of RFC 5802 --- ("SCRAM"). It takes a string "str", a salt, and an interation count, and --- returns an octet string. The iteration count must be greater than zero. - -hi :: ByteString -> ByteString -> Integer -> ByteString - -hi str salt i | i > 0 = xorUs $ us (concat [salt, runPutLazy $ putWord32be 1]) i - where - - -- Calculates the U's (U1 ... Ui) using the HMAC algorithm - us :: ByteString -> Integer -> [ByteString] - us a 1 = [encodeLazy (hmac (MacKey (head $ toChunks str)) a :: SHA1)] - us a x = [encodeLazy (hmac (MacKey (head $ toChunks str)) a :: SHA1)] ++ (us (encodeLazy (hmac (MacKey (head $ toChunks str)) a :: SHA1)) (x - 1)) - - -- XORs the ByteStrings: U1 XOR U2 XOR ... XOR Ui - xorUs :: [ByteString] -> ByteString - xorUs (b:bs) = foldl (\ x y -> pack $ zipWith xor x y) b bs - - -saltedPassword :: String -> ByteString -> Integer -> Maybe ByteString - -saltedPassword password salt i = if isJust password' then Just $ hi (DBLC.pack $ DT.unpack $ fromJust password') salt i else Nothing - where - password' = runStringPrep saslprepProfile (DT.pack password) - -clientKey :: ByteString -> ByteString - -clientKey sp = encodeLazy (hmac (MacKey (head $ toChunks sp)) (DBLC.pack "Client Key") :: SHA1) - - -storedKey :: ByteString -> ByteString - -storedKey ck = fromChunks [hash $ head $ toChunks ck] - - -authMessage :: String -> String -> String -> ByteString - -authMessage cfmb sfm cfmwp = DBLC.pack $ cfmb ++ "," ++ sfm ++ "," ++ cfmwp - - -clientSignature :: ByteString -> ByteString -> ByteString - -clientSignature sk am = encodeLazy (hmac (MacKey (head $ toChunks sk)) am :: SHA1) - - -clientProof :: ByteString -> ByteString -> ByteString - -clientProof ck cs = pack $ zipWith xor ck cs - - -serverKey :: ByteString -> ByteString - -serverKey sp = encodeLazy (hmac (MacKey (head $ toChunks sp)) (DBLC.pack "Server Key") :: SHA1) - - -serverSignature :: ByteString -> ByteString -> ByteString - -serverSignature servkey am = encodeLazy (hmac (MacKey (head $ toChunks servkey)) am :: SHA1) - - --- TODO: Implement SCRAM. - -replyToChallenge = replyToChallenge - - --- Stripts the quotations around a string, if any; "\"hello\"" becomes "hello". - -stripQuotations :: String -> String -stripQuotations "" = "" -stripQuotations s | (head s == '"') && (last s == '"') = tail $ init s - | otherwise = s - - -saslprepProfile :: StringPrepProfile - -saslprepProfile = Profile { maps = [\ char -> if char `inRanges` (ranges c12) then singleton '\x0020' else singleton char, b1] - , shouldNormalize = True - , prohibited = [a1] ++ [c12, c21, c22, c3, c4, c5, c6, c7, c8, c9] - , shouldCheckBidi = True } diff --git a/src/Network/XMPP/Session.hs b/src/Network/XMPP/Session.hs index a05b517..7b37a44 100644 --- a/src/Network/XMPP/Session.hs +++ b/src/Network/XMPP/Session.hs @@ -1,372 +1,35 @@ --- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the --- Pontarius distribution for more details. +{-# LANGUAGE OverloadedStrings #-} +module Network.XMPP.Session where --- TODO: Predicates on callbacks? --- TODO: . vs $ --- TODO: type XMPP = XMPPT IO? + runXMPP +import Data.XML.Pickle +import Data.XML.Types(Element) - -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE MultiParamTypeClasses #-} - - -module Network.XMPP.Session ( - XMPPT (runXMPPT) - , hookStreamsOpenedEvent - , hookDisconnectedEvent - , destroy - , openStreams - , create - , DisconnectReason -) where - -import Network.XMPP.Stream +import Network.XMPP.Monad +import Network.XMPP.Pickle import Network.XMPP.Types -import Network.XMPP.Utilities -import Control.Concurrent (Chan, forkIO, forkOS, newChan, readChan, writeChan) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Certificate.X509 (X509) -import Data.Dynamic (Dynamic) --- import Control.Monad.Reader (MonadReader, ReaderT, ask) -import Control.Monad.State.Lazy (MonadState, StateT, get, put, execStateT) +sessionXML :: Element +sessionXML = pickleElem + (xpElemBlank "{urn:ietf:params:xml:ns:xmpp-session}session" ) + () -import qualified Control.Exception as CE -import qualified Network as N -import System.IO (BufferMode, BufferMode(NoBuffering)) -import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput) -import Codec.Binary.UTF8.String -create :: MonadIO m => XMPPT m () -> m () +sessionIQ :: Stanza +sessionIQ = IQRequestS $ IQRequest { iqRequestID = "sess" + , iqRequestFrom = Nothing + , iqRequestTo = Nothing + , iqRequestLangTag = Nothing + , iqRequestType = Set + , iqRequestPayload = sessionXML + } -create main = do - chan <- liftIO $ newChan - idGen <- liftIO $ idGenerator "" - execStateT (runXMPPT init) (State chan idGen []) +xmppSession :: XMPPConMonad () +xmppSession = do + push $ sessionIQ + answer <- pull + let IQResultS (IQResult "sess" Nothing Nothing _lang _body) = answer return () - where - init = do - main - stateLoop - - --- Internal events - events to be processed within Pontarius. - --- data InternalEvent s m = IEC (ClientEvent s m) | IEE EnumeratorEvent | IET (TimeoutEvent s m) deriving (Show) - - -instance Show (InternalEvent m) where - show _ = "InternalEvent" - --- | --- Events that may be emitted from Pontarius. - -data Event = -- ConnectedEvent (Either IntFailureReason Resource) - {-|-} OpenedStreamsEvent (Maybe OpenStreamsFailureReason) - -- | TLSSecuredEvent (Maybe TLSSecuringFailureReason) - -- | AuthenticatedEvent (Either AuthenticationFailureReason Resource) - | DisconnectedEvent DisconnectReason - -- | MessageEvent (Either MessageError Message) - -- | PresenceEvent (Either PresenceError Presence) - -- | IQEvent (Either IQResult IQRequest) - -- | forall a. Dynamic a => DynamicEvent a - deriving (Show) - --- data DynamicEvent = forall a. Dynamic a => DynamicEvent a --- data DynamicEvent = DynamicEvent Dynamic - - --- data ConnectedFailureReason --- = COSFR OpenStreamsFailureReason --- | CTSFR TLSSecureFailureReason --- | CAFR AuthenticateFailureReason - - --- The "hook modification" events have a higher priority than other events, and --- are thus sent through a Chan of their own. The boolean returns value signals --- whether or not the hook should be removed. - --- data HookModification m --- = MonadIO m => -- RegisterConnectedHook (ConnectedEvent -> XMPPT m Bool) (Maybe (ConnectedEvent -> Bool)) - -- | RegisterTLSSecuredHook (TLSSecuredEvent -> XMPPT m Bool) (Maybe (TLSSecuredEvent -> Bool)) - -- | RegisterAuthenticatedHook (AuthenticatedEvent -> XMPPT m Bool) (Maybe (AuthenticatedEvent -> Bool)) - -- -- | forall a. Dynamic a => RegisterDynamicHook (DynamicEvent a -> XMPPT m Bool) - -- | RegisterDynamicHook (DynamicEvent -> XMPPT m Bool) (Maybe (DynamicEvent -> Bool)) - - --- Reads an event from the internal event channel, processes it, --- performs the generated impure actions, and loops. - -stateLoop :: MonadIO m => XMPPT m () - -stateLoop = do - rs <- get - event <- liftIO $ readChan $ evtChan rs - liftIO $ putStrLn $ "Processing " ++ (show event) ++ "..." - processEvent event - -- sequence_ IO actions frmo procesEvent? - stateLoop - - --- Processes an internal event and generates a list of impure actions. - -processEvent :: MonadIO m => InternalEvent m -> XMPPT m () - -processEvent (OpenStreamsEvent h p) = openStreamAction h p - where - openStreamAction :: MonadIO m => HostName -> PortNumber -> XMPPT m () - openStreamAction h p = let p' = fromIntegral p - computation chan = do -- chan ugly - -- threadID <- - handle <- N.connectTo h (N.PortNumber p') - hSetBuffering handle NoBuffering - forkIO $ conduit chan (Left handle) -- This must be done after hSetBuffering - hPutStr handle $ encodeString "" -- didn't work with - hFlush handle - return () - in do - rs <- get - result <- liftIO $ CE.try (computation $ evtChan rs) - case result of - Right () -> do - return () - -- -- lift $ liftIO $ putMVar (stateThreadID state) threadID - Left (CE.SomeException e) -> do -- TODO: Safe to do this? - fireStreamsOpenedEvent $ Just OpenStreamsFailureReason - -- Left error -> do - -- -- let clientState = stateClientState state - -- -- ((), clientState') <- lift $ runStateT (callback OpenStreamFailure) clientState - -- -- put $ state { stateShouldExit = True } - -- -- return $ Just e - -- return $ Just error - - --- hookConnectedEvent :: MonadIO m => (ConnectedEvent -> XMPPT m Bool) -> (Maybe (ConnectedEvent -> Bool)) -> XMPPT m () - --- hookConnectedEvent cb pred = ask >>= \rs -> liftIO $ writeChan (hookModChan rs) (RegisterConnectedHook cb pred) - - --- | Hook the provided callback and (optional) predicate to the --- "Streams Opened" event. --- --- The "Streams Opened" event will be fired when the stream:features element has been successfully received or an error has occurred. - -hookStreamsOpenedEvent :: MonadIO m => (Maybe OpenStreamsFailureReason -> XMPPT m Bool) -> (Maybe (Maybe OpenStreamsFailureReason -> XMPPT m Bool)) -> XMPPT m HookId - -hookStreamsOpenedEvent cb pred = do - rs <- get - hookId <- liftIO $ nextId $ hookIdGenerator rs - put $ rs { hooks = (HookId hookId, StreamsOpenedHook pred cb):hooks rs } - return $ HookId hookId - - -hookDisconnectedEvent :: MonadIO m => (DisconnectReason -> XMPPT m Bool) -> (Maybe (DisconnectReason -> XMPPT m Bool)) -> XMPPT m HookId -hookDisconnectedEvent cb pred = do - rs <- get - hookId <- liftIO $ nextId $ hookIdGenerator rs - -- TODO: Actually hook it. - return $ HookId hookId - - --- hookTLSSecuredEvent :: MonadIO m => (TLSSecuredEvent -> XMPPT m Bool) -> (Maybe (TLSSecuredEvent -> Bool)) -> XMPPT m () - --- hookTLSSecuredEvent cb pred = ask >>= \rs -> liftIO $ writeChan (hookModChan rs) (RegisterTLSSecuredHook cb pred) - - --- hookAuthenticatedEvent :: MonadIO m => (AuthenticatedEvent -> XMPPT m Bool) -> (Maybe (AuthenticatedEvent -> Bool)) -> XMPPT m () - --- hookAuthenticatedEvent cb pred = ask >>= \rs -> liftIO $ writeChan (hookModChan rs) (RegisterAuthenticatedHook cb pred) - - --- hookDynamicEvent :: MonadIO m => (DynamicEvent -> XMPPT m Bool) -> (Maybe (DynamicEvent -> Bool)) -> XMPPT m () - --- hookDynamicEvent cb pred = ask >>= \rs -> liftIO $ writeChan (hookModChan rs) (RegisterDynamicHook cb pred) - - --- | Asynchronously request to open a stream to an XMPP server on the --- given host name and port. - -openStreams :: MonadIO m => HostName -> PortNumber -> XMPPT m () - -openStreams h p = get >>= \rs -> liftIO $ writeChan (evtChan rs) (OpenStreamsEvent h p) - - --- Like any other fire*Event function, it queries the hooks, filters --- out the ones that are relevant, prepares them to be used with --- processHook, and processes them. - -fireStreamsOpenedEvent :: MonadIO m => Maybe OpenStreamsFailureReason -> XMPPT m () - -fireStreamsOpenedEvent r = do - rs <- get - let hooks' = filterStreamsOpenedHooks $ hooks rs - sequence_ $ map (\(hookId, pred, cb) -> processHook hookId pred cb) $ map prepareStreamsOpenedHooks hooks' - return () - where - prepareStreamsOpenedHooks :: MonadIO m => Hook m -> (HookId, Maybe (XMPPT m Bool), XMPPT m Bool) - prepareStreamsOpenedHooks (hookId, StreamsOpenedHook pred cb) = - let pred' = case pred of - Nothing -> Nothing - Just pred'' -> Just $ pred'' r - cb' = cb r in (hookId, pred', cb') - - --- Takes an optional predicate and a callback function, and excecutes --- the callback function if the predicate does not exist, or exists --- and is true, and returns True if the hook should be removed. - -processHook :: MonadIO m => HookId -> Maybe (XMPPT m Bool) -> XMPPT m Bool -> XMPPT m () - -processHook id pred cb = do - remove <- processHook' - if remove then do - rs <- get - put $ rs { hooks = removeHook id (hooks rs) } - else return () - where - processHook' = case pred of - Just pred' -> do - result <- pred' - if result then cb else return False - Nothing -> cb - - -destroy = destroy - - -filterStreamsOpenedHooks :: MonadIO m => [Hook m] -> [Hook m] - -filterStreamsOpenedHooks h = filter pred h - where - pred (_, StreamsOpenedHook _ _) = True - pred _ = False - - -removeHook :: MonadIO m => HookId -> [Hook m] -> [Hook m] - -removeHook id h = filter (\(id', _) -> id' /= id) h - - --- tlsSecure = tlsSecure - --- authenticate = authenticate - - --- fireConnectedEvent = fireConnectedEvent - - --- | --- connect is implemented using hookStreamOpenedEvent, hookTLSSecuredEvent, and --- hookAuthenticatedEvent, and is offered as a convenience function for clients --- that doesn't need to perform any XMPP actions in-between opening the streams --- and TLS securing the stream and\/or authenticating, allowing them to listen --- for and manage one event instead of up to three. Just-values in the third and --- fourth parameters will make connect TLS secure the stream and authenticate, --- respectively. Most clients will want to hook to the Connected event using --- hookConnectedEvent prior to using this function. --- --- The ConnectedEvent and StreamOpenedEvent are guaranteed to be generated upon --- calling this function. So will a subset of the TLSSecuredEvent and --- AuthenticatedEvent, depending on whether their functionalities are requested --- using Just-values in the third and fourth parameters. --- --- connect is designed with the assupmtion that openStreams, tlsSecure, and --- authenticate will not be used by the client. Calling those functions may --- generate events that can cause connect to behave incorrectly. --- connect :: MonadIO m => HostName -> PortNumber -> Maybe (Maybe [X509], ([X509] -> Bool)) -> Maybe (UserName, Password, Maybe Resource) -> XMPPT m () --- --- connect h p Nothing Nothing = do --- hookStreamsOpenedEvent onStreamsOpenedEvent Nothing --- openStreams h p --- --- where --- --- onStreamsOpenedEvent Nothing = do --- fireConnectedEvent Nothing --- return False --- --- onStreamsOpenedEvent (Just e) = do --- fireConnectedEvent $ Left $ COSFR e --- return False --- --- connect h p (Just t) Nothing = do --- hookStreamsOpenedEvent onStreamsOpenedEvent Nothing --- openStreams h p --- --- where --- --- onStreamsOpenedEvent Nothing = do --- hookTLSSecuredEvent onTLSSecuredEvent Nothing --- tlsSecure --- return False --- --- onStreamsOpenedEvent (Just e) = do --- fireConnectedEvent $ Left $ COSFR e --- return False --- --- onTLSSecuredEvent Nothing = do --- fireConnectedEvent Nothing --- return False --- --- onTLSSecuredEvent (Just e) = do --- fireConnectedEvent $ Left $ CTSFR e --- return False --- --- connect h p Nothing (Just a) = do --- hookStreamsOpenedEvent onStreamsOpenedEvent Nothing --- openStreams h p --- --- where --- --- onStreamsOpenedEvent Nothing = do --- hookAuthenticatedEvent onAuthenticatedEvent Nothing --- authenticate --- return False --- --- onStreamsOpenedEvent (Just e) = do --- fireConnectedEvent $ Left $ COSFR e --- return False --- --- onAuthenticatedEvent (Right r) = do --- fireConnectedEvent $ Just r --- return False --- --- onAuthenticated (Left e) = do --- fireConnectedEvent $ Left $ CAFR e --- return False --- --- connect h p (Just t) (Just a) = do --- hookStreamsOpenedEvent onStreamsOpenedEvent Nothing --- openStreams h p --- --- where --- --- onStreamsOpenedEvent Nothing = do --- hookTLSSecuredEvent onTLSSecuredEvent Nothing --- tlsSecure --- return False --- --- onStreamsOpenedEvent (Just e) = do --- fireConnectedEvent $ Left $ COSFR e --- return False --- --- onTLSSecuredEvent Nothing = do --- hookAuthenticatedEvent onAuthenticatedEvent Nothing --- authenticate --- return False --- --- onTLSSecuredEvent (Just e) = do --- fireConnectedEvent $ Left $ CTSFR e --- return False --- --- onAuthenticatedEvent (Right r) = do --- fireConnectedEvent $ Just r --- return False --- --- onAuthenticated (Left e) = do --- fireConnectedEvent $ Left $ CAFR e --- return False \ No newline at end of file diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs index 7586646..a54e6ae 100644 --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -1,543 +1,102 @@ --- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the --- Pontarius distribution for more details. +{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Network.XMPP.Stream where + +import Control.Applicative((<$>)) +import Control.Monad(unless) +import Control.Monad.Trans.State + +import Data.Conduit +import Data.Conduit.List as CL +import Data.Text as T +import Data.XML.Pickle +import Data.XML.Types + +import Network.XMPP.Monad +import Network.XMPP.Pickle +import Network.XMPP.Types + +import Text.XML.Stream.Elements +import Text.XML.Stream.Parse as XP + +-- import Text.XML.Stream.Elements + +throwOutJunk :: Monad m => Sink Event m () +throwOutJunk = do + next <- CL.peek + case next of + Nothing -> return () + Just (EventBeginElement _ _) -> return () + _ -> CL.drop 1 >> throwOutJunk + +openElementFromEvents :: Monad m => Sink Event m Element +openElementFromEvents = do + throwOutJunk + Just (EventBeginElement name attrs) <- CL.head + return $ Element name attrs [] + + +xmppStartStream :: XMPPConMonad () +xmppStartStream = do + hostname <- gets sHostname + pushOpen $ pickleElem pickleStream ("1.0",Nothing, Just hostname) + features <- pulls xmppStream + modify (\s -> s {sFeatures = features}) + return () + +xmppRestartStream :: XMPPConMonad () +xmppRestartStream = do + raw <- gets sRawSrc + let newsrc = raw $= XP.parseBytes def + modify (\s -> s{sConSrc = newsrc}) + xmppStartStream + + +xmppStream :: Sink Event (ResourceT IO) ServerFeatures +xmppStream = do + xmppStreamHeader + xmppStreamFeatures + +xmppStreamHeader :: Sink Event (ResourceT IO) () +xmppStreamHeader = do + throwOutJunk + (ver, _, _) <- unpickleElem pickleStream <$> openElementFromEvents + unless (ver == "1.0") $ error "Not XMPP version 1.0 " + return() + + +xmppStreamFeatures :: Sink Event (ResourceT IO) ServerFeatures +xmppStreamFeatures = unpickleElem pickleStreamFeatures <$> elementFromEvents + + +-- Pickling + +pickleStream :: PU [Node] (Text, Maybe Text, Maybe Text) +pickleStream = xpElemAttrs (Name "stream" (Just "http://etherx.jabber.org/streams") (Just "stream")) + (xpTriple + (xpAttr "version" xpId) + (xpOption $ xpAttr "from" xpId) + (xpOption $ xpAttr "to" xpId) + ) + +pickleTLSFeature :: PU [Node] Bool +pickleTLSFeature = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-tls}starttls" + (xpElemExists "required") + +pickleSaslFeature :: PU [Node] [Text] +pickleSaslFeature = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-sasl}mechanisms" + (xpAll $ xpElemNodes + "{urn:ietf:params:xml:ns:xmpp-sasl}mechanism" (xpContent xpId) ) + +pickleStreamFeatures :: PU [Node] ServerFeatures +pickleStreamFeatures = xpWrap ( \(tls, sasl, rest) -> SF tls (mbl sasl) rest) + (\(SF tls sasl rest) -> (tls, lmb sasl, rest)) + $ + xpElemNodes (Name "features" (Just "http://etherx.jabber.org/streams") (Just "stream")) + (xpTriple + (xpOption pickleTLSFeature) + (xpOption pickleSaslFeature) + (xpAll xpElemVerbatim) + ) -{-# OPTIONS_HADDOCK hide #-} - -{-# LANGUAGE OverloadedStrings #-} - -module Network.XMPP.Stream ( -conduit, -presenceToXML, -iqToXML, -messageToXML, -parsePresence, -parseIQ, -parseMessage, -langTag, -versionFromString, -versionFromNumbers -) where - -import Network.XMPP.Types hiding (Continue) - -import Prelude hiding (null) - -import Control.Concurrent.Chan (Chan, writeChan) -import Control.Exception.Base (SomeException) -import Control.Monad.IO.Class (liftIO) -import Data.ByteString.Lazy (null, toChunks) -import Data.Conduit (($$), ($=), MonadResource, Sink (..), runResourceT) -import Data.Conduit.Binary (sourceHandle) -import Data.Maybe (fromJust, isJust) -import Data.Text (pack, unpack) -import Data.XML.Types (Content (..), Document (..), Element (..), Event (..), Name (..), Node (..)) -import GHC.IO.Handle (Handle) -import Network.TLS (TLSCtx, recvData) -import Text.Parsec (char, count, digit, eof, many, many1, oneOf, parse) -import Text.Parsec.ByteString (GenParser) --- import Text.XML.Enumerator.Document (fromEvents) -import Text.XML.Stream.Parse (def, parseBytes) -import Text.XML.Unresolved (fromEvents) - -import Control.Monad.IO.Class (MonadIO, liftIO) - - -import qualified Data.ByteString as DB (ByteString) -import qualified Data.ByteString.Char8 as DBC (pack) -import qualified Data.Conduit.List as DEL (head) -import Data.Conduit.List (consume, sourceList) -- use lazy consume instead? - - --- Reads from the provided handle or TLS context and sends the events --- to the internal event channel. - -conduit :: MonadIO m => Chan (InternalEvent m) -> Either Handle (TLSCtx a) -> IO () - -conduit c s = do - enumeratorResult <- case s of - Left handle -> do - print <- runResourceT $ sourceHandle handle $= parseBytes def $$ DEL.head -- $$ DEL.head -- eventConsumer c [] 0 - return $ Right 0 -- TODO - Right tlsCtx -> -- run $ enumTLS tlsCtx $$ joinI $ - -- parseBytes decodeEntities $$ eventConsumer c [] 0 - return $ Left 0 -- TODO - case enumeratorResult of - Right _ -> return () -- writeChan c $ IEE EnumeratorDone - Left e -> return () -- writeChan c $ IEE (EnumeratorException e) --- where --- -- Behaves like enumHandle, but reads from the TLS context instead --- -- TODO: Type? --- enumTLS :: TLSCtx -> Enumerator DB.ByteString IO b --- enumTLS c s = loop c s - --- -- TODO: Type? --- loop :: TLSCtx -> Step DB.ByteString IO b -> Iteratee DB.ByteString IO b --- loop c (Continue k) = do --- d <- recvData c --- case null d of --- True -> loop c (Continue k) --- False -> k (Chunks $ toChunks d) >>== loop c --- loop _ step = returnI step - - --- Consumes XML events from the input stream, accumulating as --- necessary, and sends the proper events through the channel. The --- second parameter should be initialized to [] (no events) and the --- third to 0 (zeroth XML level). - -eventConsumer :: (MonadResource r, MonadIO m) => - Chan (InternalEvent m) -> [Event] -> Int -> Sink Event r () - --- open event received. - -eventConsumer chan [EventBeginElement (Name localName namespace prefixName) attribs] 0 - | localName == pack "stream" && isJust prefixName && fromJust prefixName == pack "stream" = do - liftIO $ putStrLn "here?" - liftIO $ writeChan chan $ EnumeratorBeginStream from to id ver lang ns - eventConsumer chan [] 1 - where - from = case lookup "from" attribs of Nothing -> Nothing; Just fromAttrib -> Just $ show fromAttrib - to = case lookup "to" attribs of Nothing -> Nothing; Just toAttrib -> Just $ show toAttrib - id = case lookup "id" attribs of Nothing -> Nothing; Just idAttrib -> Just $ show idAttrib - ver = case lookup "version" attribs of Nothing -> Nothing; Just verAttrib -> Just $ show verAttrib - lang = case lookup "xml:lang" attribs of Nothing -> Nothing; Just langAttrib -> Just $ show langAttrib - ns = case namespace of Nothing -> Nothing; Just namespaceAttrib -> Just $ unpack namespaceAttrib - --- close event received. - -eventConsumer chan [EventEndElement name] 1 - | namePrefix name == Just (pack "stream") && nameLocalName name == pack "stream" = do - liftIO $ putStrLn "here!" - liftIO $ writeChan chan $ EnumeratorEndStream - return () - --- Ignore EventDocumentBegin event. - -eventConsumer chan [EventBeginDocument] 0 = eventConsumer chan [] 0 - --- We have received a complete first-level XML element. Process the accumulated --- values into an first-level element event. - -eventConsumer chan ((EventEndElement e):es) 1 = do - liftIO $ putStrLn "here..." - element <- liftIO $ eventsToElement $ reverse ((EventEndElement e):es) - liftIO $ writeChan chan $ EnumeratorFirstLevelElement element - eventConsumer chan [] 1 - --- Normal condition - accumulate the event. - -eventConsumer chan events level = do - liftIO $ putStrLn "listenering for XML event" - event <- DEL.head - liftIO $ putStrLn "got event" - case event of - Just event' -> let level' = case event' of - EventBeginElement _ _ -> level + 1 - EventEndElement _ -> level - 1 - _ -> level - in eventConsumer chan (event':events) level' - Nothing -> eventConsumer chan events level - - -eventsToElement :: [Event] -> IO Element -- Was: Either SomeException Element - --- TODO: Exceptions. - -eventsToElement e = do - putStrLn "eventsToElement" - doc <- runResourceT $ sourceList e $$ fromEvents - return $ documentRoot doc --- case r of Right doc -> Right $ documentRoot doc; Left ex -> Left ex --- where --- -- TODO: Type? --- eventsEnum (Continue k) = k $ Chunks e --- eventsEnum step = returnI step - - --- Sending stanzas is done through functions, where LangTag is Maybe. - - --- Generates an XML element for a message stanza. The language tag provided is --- the default language of the stream. - -messageToXML :: InternalMessage -> LangTag -> Element - --- Non-error message. - -messageToXML (Right m) streamLang = Element "message" attribs nodes - - where - - -- Has the stanza attributes and the message type. - attribs :: [(Name, [Content])] - attribs = stanzaAttribs (messageID m) (messageFrom m) (messageTo m) stanzaLang ++ - [("type", [ContentText $ pack $ show $ messageType m])] - - -- Has an arbitrary number of elements as children. - nodes :: [Node] - nodes = map (\ x -> NodeElement x) (messagePayload m) - - stanzaLang :: Maybe LangTag - stanzaLang = stanzaLang' streamLang $ messageLangTag m - --- Presence error. - -messageToXML (Left m) streamLang = Element "message" attribs nodes - - where - - -- Has the stanza attributes and the "error" presence type. - attribs :: [(Name, [Content])] - attribs = stanzaAttribs (messageErrorID m) (messageErrorFrom m) (messageErrorTo m) - stanzaLang ++ [("type", [ContentText $ pack "error"])] - - -- Has the error element stanza as its child. - -- TODO: Include sender XML here? - nodes :: [Node] - nodes = [NodeElement $ errorElem streamLang stanzaLang $ messageErrorStanzaError m] - - -- The stanza language tag, if it's different from the stream language tag. - stanzaLang :: Maybe LangTag - stanzaLang = stanzaLang' streamLang $ messageErrorLangTag m - - --- Generates an XML element for a presence stanza. The language tag provided is --- the default language of the stream. - -presenceToXML :: InternalPresence -> LangTag -> Element - --- Non-error presence. - -presenceToXML (Right p) streamLang = Element "presence" attribs nodes - - where - - -- Has the stanza attributes and the presence type. - attribs :: [(Name, [Content])] - attribs = stanzaAttribs (presenceID p) (presenceFrom p) (presenceTo p) stanzaLang ++ - typeAttrib - - -- Has an arbitrary number of elements as children. - nodes :: [Node] - nodes = map (\ x -> NodeElement x) (presencePayload p) - - stanzaLang :: Maybe LangTag - stanzaLang = stanzaLang' streamLang $ presenceLangTag p - - typeAttrib :: [(Name, [Content])] - typeAttrib = case presenceType p of Nothing -> []; Just presenceType' -> [("type", [ContentText $ pack $ show presenceType'])] - --- Presence error. - -presenceToXML (Left p) streamLang = Element "presence" attribs nodes - - where - - -- Has the stanza attributes and the "error" presence type. - attribs :: [(Name, [Content])] - attribs = stanzaAttribs (presenceErrorID p) (presenceErrorFrom p) (presenceErrorTo p) - stanzaLang ++ [("type", [ContentText $ pack "error"])] - - -- Has the error element stanza as its child. - -- TODO: Include sender XML here? - nodes :: [Node] - nodes = [NodeElement $ errorElem streamLang stanzaLang $ presenceErrorStanzaError p] - - -- The stanza language tag, if it's different from the stream language tag. - stanzaLang :: Maybe LangTag - stanzaLang = stanzaLang' streamLang $ presenceErrorLangTag p - - --- Generates an XML element for a presence stanza. The language tag provided is --- the default language of the stream. - -iqToXML :: IQ -> LangTag -> Element - --- Request IQ. - -iqToXML (Left i) streamLang = Element "iq" attribs nodes - - where - - -- Has the stanza attributes and the IQ request type (`get' or `set'). - attribs :: [(Name, [Content])] - attribs = stanzaAttribs (iqRequestID i) (iqRequestFrom i) (iqRequestTo i) - stanzaLang ++ typeAttrib - - -- Has exactly one payload child element. - nodes :: [Node] - nodes = [NodeElement $ iqRequestPayload i] - - -- The stanza language tag, if it's different from the stream language tag. - stanzaLang :: Maybe LangTag - stanzaLang = stanzaLang' streamLang $ iqRequestLangTag i - - -- The required type attribute. - typeAttrib :: [(Name, [Content])] - typeAttrib = [("type", [ContentText $ pack $ show $ iqRequestType i])] - --- Response result IQ. - -iqToXML (Right (Right i)) streamLang = Element "iq" attribs nodes - - where - - -- Has the stanza attributes and the IQ `result' type. - attribs :: [(Name, [Content])] - attribs = stanzaAttribs (iqResultID i) (iqResultFrom i) (iqResultTo i) - stanzaLang ++ typeAttrib - - -- Has one or zero payload child elements. - nodes :: [Node] - nodes = case iqResultPayload i of Nothing -> []; Just payloadElem -> [NodeElement payloadElem] - - stanzaLang :: Maybe LangTag - stanzaLang = stanzaLang' streamLang $ iqResultLangTag i - - -- The required type attribute. - typeAttrib :: [(Name, [Content])] - typeAttrib = [("type", [ContentText $ pack "result"])] - --- Response error IQ. - -iqToXML (Right (Left i)) streamLang = Element "iq" attribs nodes - - where - - -- Has the stanza attributes and the presence type. - attribs :: [(Name, [Content])] - attribs = stanzaAttribs (iqErrorID i) (iqErrorFrom i) (iqErrorTo i) stanzaLang ++ - typeAttrib - - -- Has an optional elements as child. - nodes :: [Node] - nodes = case iqErrorPayload i of Nothing -> []; Just payloadElem -> [NodeElement payloadElem] - - stanzaLang :: Maybe LangTag - stanzaLang = stanzaLang' streamLang $ iqErrorLangTag i - - typeAttrib :: [(Name, [Content])] - typeAttrib = [("type", [ContentText $ pack "error"])] - - --- Creates the error element that is common for all stanzas. - -errorElem :: LangTag -> Maybe LangTag -> StanzaError -> Element - -errorElem streamLang stanzaLang stanzaError = Element "error" typeAttrib - ([defCondElem] ++ textElem ++ appSpecCondElem) - - where - - -- The required stanza error type. - typeAttrib :: [(Name, [Content])] - typeAttrib = [("type", [ContentText $ pack $ show $ stanzaErrorType stanzaError])] - - -- The required defined condition element. - defCondElem :: Node - defCondElem = NodeElement $ Element (Name (pack $ show $ stanzaErrorCondition stanzaError) (Just $ pack "urn:ietf:params:xml:ns:xmpp-stanzas") Nothing) [] [] - - - -- The optional text element. - textElem :: [Node] - textElem = case stanzaErrorText stanzaError of - Nothing -> [] - Just (textLang, text) -> - [NodeElement $ Element "{urn:ietf:params:xml:ns:xmpp-stanzas}text" - (langTagAttrib $ childLang streamLang [stanzaLang, fst $ fromJust $ stanzaErrorText stanzaError]) - [NodeContent $ ContentText $ pack text]] - - -- The optional application specific condition element. - appSpecCondElem :: [Node] - appSpecCondElem = case stanzaErrorApplicationSpecificCondition stanzaError of - Nothing -> [] - Just elem -> [NodeElement elem] - - --- Generates the element attribute for an optional language tag. - -langTagAttrib :: Maybe LangTag -> [(Name, [Content])] - -langTagAttrib lang = case lang of Nothing -> []; Just lang' -> [("xml:lang", [ContentText $ pack $ show lang'])] - - -stanzaLang' :: LangTag -> LangTag -> Maybe LangTag - -stanzaLang' streamLang stanzaLang | streamLang == stanzaLang = Nothing - | otherwise = Just stanzaLang - - --- Finds the language tag to set on the current element, if any. Makes sure that --- language tags are not repeated unnecessarily (like on a child element, when --- the parent has it). The first parameter is the stream language tag, and the --- list of optional language tags are ordered in their XML element child --- sequence, parent first, starting with the stanza language tag. - -childLang :: LangTag -> [Maybe LangTag] -> Maybe LangTag - -childLang streamLang optLangTags - - -- The current element does not have a language tag - set nothing. - | (head $ reverse optLangTags) == Nothing = Nothing - - -- All optional language tags are Nothing - set nothing. - | length langTags == 1 = Nothing - - -- The language tag of this element is the same as the closest parent with a - -- language tag - set nothing. - | (head langTags) == (head $ tail langTags) = Nothing - - -- Set the language tag. - | otherwise = Just $ head langTags - - where - - -- Contains the chain of language tags in descending priority order. - -- Contains at least one element - the stream language tag. - langTags = reverse $ [streamLang] ++ (map fromJust $ filter (\ l -> isJust l) optLangTags) - - --- Creates the attributes common for all stanzas. - -stanzaAttribs :: Maybe StanzaID -> Maybe From -> Maybe To -> Maybe LangTag -> [(Name, [Content])] - -stanzaAttribs i f t l = if isJust $ i then [("id", [ContentText $ pack $ show $ fromJust i])] else [] ++ - if isJust $ f then [("from", [ContentText $ pack $ show $ fromJust f])] else [] ++ - if isJust $ t then [("to", [ContentText $ pack $ show $ fromJust t])] else [] ++ - if isJust $ l then [("xml:lang", [ContentText $ pack $ show l])] else [] - - -parseIQ :: Element -> IQ - -parseIQ = parseIQ - - -parsePresence :: Element -> InternalPresence - -parsePresence = parsePresence - - -parseMessage :: Element -> InternalMessage - -parseMessage = parseMessage - - --- Converts a string to a PresenceType. Nothing means convertion error, Just --- Nothing means the presence error type, and Just $ Just is the PresenceType. - -stringToPresenceType :: String -> Maybe (Maybe PresenceType) - -stringToPresenceType "probe" = Just $ Just Probe -stringToPresenceType "unavailable" = Just $ Just Unavailable -stringToPresenceType "subscribe" = Just $ Just Subscribe -stringToPresenceType "subscribed" = Just $ Just Subscribed -stringToPresenceType "unsubscribe" = Just $ Just Unsubscribe -stringToPresenceType "unsubscribed" = Just $ Just Unsubscribed -stringToPresenceType "error" = Just Nothing -stringToPresenceType _ = Nothing - - --- Converts a Maybe MessageType to a string. Nothing means "error". - -presenceTypeToString :: Maybe PresenceType -> String - -presenceTypeToString (Just Unavailable) = "unavailable" -presenceTypeToString (Just Probe) = "probe" -presenceTypeToString Nothing = "error" -presenceTypeToString (Just Subscribe) = "subscribe" -presenceTypeToString (Just Subscribed) = "subscribed" -presenceTypeToString (Just Unsubscribe) = "unsubscribe" -presenceTypeToString (Just Unsubscribed) = "unsubscribed" - - --- Converts a string to a MessageType. Nothing means convertion error, Just --- Nothing means the message error type, and Just $ Just is the MessageType. - -stringToMessageType :: String -> Maybe (Maybe MessageType) - -stringToMessageType "chat" = Just $ Just Chat -stringToMessageType "error" = Just $ Nothing -stringToMessageType "groupchat" = Just $ Just Groupchat -stringToMessageType "headline" = Just $ Just Headline -stringToMessageType "normal" = Just $ Just Normal -stringToMessageType _ = Nothing - - --- Converts a Maybe MessageType to a string. Nothing means "error". - -messageTypeToString :: Maybe MessageType -> String - -messageTypeToString (Just Chat) = "chat" -messageTypeToString Nothing = "error" -messageTypeToString (Just Groupchat) = "groupchat" -messageTypeToString (Just Headline) = "headline" -messageTypeToString (Just Normal) = "normal" - - --- Converts a "." numeric version number to a "Version" object. - -versionFromString :: String -> Maybe Version - -versionFromString s = case parse version "" (DBC.pack s) of - Right version -> Just version - Left _ -> Nothing - - --- Constructs a "Version" based on the major and minor version numbers. - -versionFromNumbers :: Integer -> Integer -> Version - -versionFromNumbers major minor = Version major minor - - -version :: GenParser Char st Version - -version = do - - -- Read numbers, a dot, more numbers, and end-of-file. - major <- many1 digit - char '.' - minor <- many1 digit - eof - return $ Version (read major) (read minor) - - --- | --- Parses, validates, and possibly constructs a "LangTag" object. - -langTag :: String -> Maybe LangTag - -langTag s = case parse languageTag "" (DBC.pack s) of - Right tag -> Just tag - Left _ -> Nothing - - --- Parses a language tag as defined by RFC 1766 and constructs a LangTag object. - -languageTag :: GenParser Char st LangTag - -languageTag = do - - -- Read until we reach a '-' character, or EOF. This is the `primary tag'. - primTag <- tag - - -- Read zero or more subtags. - subTags <- subtags - eof - - return $ LangTag primTag subTags - where - - subtags :: GenParser Char st [String] - subtags = many $ do - char '-' - subtag <- tag - return subtag - - tag :: GenParser Char st String - tag = do - a <- many1 $ oneOf tagChars - return a - - tagChars :: [Char] - tagChars = ['a'..'z'] ++ ['A'..'Z'] diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index a0ac88b..a536bb8 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -1,30 +1,59 @@ --- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the --- Pontarius distribution for more details. +{-# LANGUAGE OverloadedStrings #-} --- TODO: TLS12 when supported in tls; TODO: TLS11 results in a read error - bug? --- TODO: cipher_AES128_SHA1 = TLS_RSA_WITH_AES_128_CBC_SHA? --- TODO: Compression? --- TODO: Validate certificate +module Network.XMPP.TLS where -{-# OPTIONS_HADDOCK hide #-} +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.State -module Network.XMPP.TLS (tlsParams) where +import Data.Conduit +import Data.Conduit.List as CL +import Data.Conduit.TLS as TLS +import Data.Default +import Data.XML.Types -import Network.TLS (TLSCertificateUsage (CertificateUsageAccept), - TLSParams (..), Version (SSL3, TLS10, TLS11), - defaultLogging, nullCompression) -import Network.TLS.Extra (cipher_AES128_SHA1) +import qualified Network.TLS as TLS +import qualified Network.TLS.Extra as TLS +import Network.XMPP.Monad +import Network.XMPP.Stream +import Network.XMPP.Types +import qualified Text.XML.Stream.Render as XR -tlsParams :: TLSParams -tlsParams = TLSParams { pConnectVersion = TLS10 - , pAllowedVersions = [SSL3, TLS10,TLS11] - , pCiphers = [cipher_AES128_SHA1] - , pCompressions = [nullCompression] +starttlsE :: Element +starttlsE = + Element "{urn:ietf:params:xml:ns:xmpp-tls}starttls" [] [] + +exampleParams :: TLS.TLSParams +exampleParams = TLS.TLSParams { pConnectVersion = TLS.TLS10 + , pAllowedVersions = [TLS.SSL3, TLS.TLS10, TLS.TLS11] + , pCiphers = [TLS.cipher_AES128_SHA1] + , pCompressions = [TLS.nullCompression] , pWantClientCert = False -- Used for servers , pUseSecureRenegotiation = False -- No renegotiation , pCertificates = [] -- TODO - , pLogging = defaultLogging -- TODO + , pLogging = TLS.defaultLogging -- TODO , onCertificatesRecv = \ certificate -> - return CertificateUsageAccept } + return TLS.CertificateUsageAccept } + +xmppStartTLS :: TLS.TLSParams -> XMPPConMonad () +xmppStartTLS params = do + features <- gets sFeatures + unless (stls features == Nothing) $ do + pushN starttlsE + Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] <- pullE + Just handle <- gets sConHandle + (raw, snk, psh) <- lift $ TLS.tlsinit params handle + modify (\x -> x + { sRawSrc = raw +-- , sConSrc = -- Note: this momentarily leaves us in an + -- inconsistent state + , sConPush = \xs -> CL.sourceList xs + $$ XR.renderBytes def =$ snk + , sConPushBS = psh + }) + xmppRestartStream + modify (\s -> s{sHaveTLS = True}) + return () + diff --git a/src/Network/XMPP/TLS_flymake.hs b/src/Network/XMPP/TLS_flymake.hs deleted file mode 100644 index a0ac88b..0000000 --- a/src/Network/XMPP/TLS_flymake.hs +++ /dev/null @@ -1,30 +0,0 @@ --- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the --- Pontarius distribution for more details. - --- TODO: TLS12 when supported in tls; TODO: TLS11 results in a read error - bug? --- TODO: cipher_AES128_SHA1 = TLS_RSA_WITH_AES_128_CBC_SHA? --- TODO: Compression? --- TODO: Validate certificate - -{-# OPTIONS_HADDOCK hide #-} - -module Network.XMPP.TLS (tlsParams) where - -import Network.TLS (TLSCertificateUsage (CertificateUsageAccept), - TLSParams (..), Version (SSL3, TLS10, TLS11), - defaultLogging, nullCompression) -import Network.TLS.Extra (cipher_AES128_SHA1) - - -tlsParams :: TLSParams - -tlsParams = TLSParams { pConnectVersion = TLS10 - , pAllowedVersions = [SSL3, TLS10,TLS11] - , pCiphers = [cipher_AES128_SHA1] - , pCompressions = [nullCompression] - , pWantClientCert = False -- Used for servers - , pUseSecureRenegotiation = False -- No renegotiation - , pCertificates = [] -- TODO - , pLogging = defaultLogging -- TODO - , onCertificatesRecv = \ certificate -> - return CertificateUsageAccept } diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index 728d7fa..cd3f164 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} -- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the -- Pontarius distribution for more details. @@ -6,97 +7,28 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE OverloadedStrings #-} -module Network.XMPP.Types ( -StanzaId (..), -From, -To, -IQ, -IQRequest (..), -IQResponse (..), -Message (..), -MessageType (..), -Presence (..), -PresenceType (..), -StanzaError (..), -StanzaErrorType (..), -StanzaErrorCondition (..), - HostName - , Password - , PortNumber - , Resource - , UserName, -Challenge (..), -Success (..), -InternalEvent (..), --- TLSState (..), -Address (..), -Localpart, -Domainpart, -Resourcepart, -LangTag (..), -ConnectionState (..), -ClientEvent (..), -XMPPT (..), -OpenStreamsFailureReason (..), -DisconnectReason (..), -StreamState (..), -AuthenticationState (..), -ConnectResult (..), -OpenStreamResult (..), -SecureWithTLSResult (..), -AuthenticateResult (..), -ServerAddress (..), -XMPPError (..), -Timeout, -TimeoutEvent (..), -StreamError (..), -IdGenerator (..), -Version (..), -IQError (..), -IQResult (..), -IQRequestType (..), -PresenceError (..), -InternalPresence (..), -InternalMessage (..), -MessageError (..), -HookId (..), -Hook (..), -HookPayload (..), -State (..), -SessionSettings (..) -) where +module Network.XMPP.Types where -- import Network.XMPP.Utilities (idGenerator) -import GHC.IO.Handle (Handle, hPutStr, hFlush, hSetBuffering, hWaitForInput) +import Control.Applicative((<$>)) +import Control.Monad.IO.Class +import Control.Monad.State -import qualified Network as N - -import qualified Control.Exception as CE - -import Control.Monad.State hiding (State) - -import Data.XML.Types - -import Network.TLS hiding (Version) -import Network.TLS.Cipher - -import qualified Control.Monad.Error as CME - -import Data.IORef +import qualified Data.ByteString as BS +import Data.Conduit +import Data.List.Split as L +import Data.String(IsString(..)) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.XML.Types -import Data.Certificate.X509 (X509) - -import Data.List (intersperse) -import Data.Char (toLower) - -import Control.Exception.Base (SomeException) - -import Control.Concurrent +import qualified Network as N -import Data.Maybe (fromJust) +import System.IO -- | The string prefix MUST be @@ -126,57 +58,97 @@ data SessionSettings = -- @IDGenerator@, is guaranteed to be unique for the XMPP session. -- Stanza identifiers are generated by Pontarius. -data StanzaId = SI String deriving (Eq) +data StanzaId = SI Text deriving (Eq, Ord) instance Show StanzaId where - show (SI s) = s + show (SI s) = Text.unpack s +instance Read StanzaId where + readsPrec _ x = [(SI $ Text.pack x, "")] --- | --- @From@ is a readability type synonym for @Address@. - -type From = Address - +instance IsString StanzaId where + fromString = SI . Text.pack -- | --- @To@ is a readability type synonym for @Address@. - -type To = Address +-- @From@ is a readability type synonym for @Address@. +-- | Jabber ID (JID) datatype +data JID = JID { node :: Maybe Text + -- ^ Account name + , domain :: Text + -- ^ Server adress + , resource :: Maybe Text + -- ^ Resource name + } + +instance Show JID where + show (JID nd dmn res) = + maybe "" ((++ "@") . Text.unpack) nd ++ + (Text.unpack dmn) ++ + maybe "" (('/' :) . Text.unpack) res + +parseJID :: [Char] -> [JID] +parseJID jid = do + (jid', rst) <- case L.splitOn "@" jid of + [rest] -> [(JID Nothing, rest)] + [nd,rest] -> [(JID (Just (Text.pack nd)), rest)] + _ -> [] + case L.splitOn "/" rst of + [dmn] -> [jid' (Text.pack dmn) Nothing] + [dmn, rsrc] -> [jid' (Text.pack dmn) (Just (Text.pack rsrc))] + _ -> [] + +instance Read JID where + readsPrec _ x = (,"") <$> parseJID x -- An Info/Query (IQ) stanza is either of the type "request" ("get" or -- "set") or "response" ("result" or "error"). The @IQ@ type wraps -- these two sub-types. --- +-- -- Objects of this type cannot be generated by Pontarius applications, -- but are only created internally. -type IQ = Either IQRequest IQResponse - +data Stanza = IQRequestS IQRequest + | IQResultS IQResult + | IQErrorS IQError + | MessageS Message + | MessageErrorS MessageError + | PresenceS Presence + | PresenceErrorS PresenceError -- | -- A "request" Info/Query (IQ) stanza is one with either "get" or -- "set" as type. They are guaranteed to always contain a payload. --- +-- -- Objects of this type cannot be generated by Pontarius applications, -- but are only created internally. -data IQRequest = IQRequest { iqRequestID :: StanzaId - , iqRequestFrom :: Maybe From - , iqRequestTo :: Maybe To - , iqRequestLangTag :: LangTag - , iqRequestType :: IQRequestType - , iqRequestPayload :: Element } +data IQRequest = IQRequest { iqRequestID :: StanzaId + , iqRequestFrom :: Maybe JID + , iqRequestTo :: Maybe JID + , iqRequestLangTag :: Maybe LangTag + , iqRequestType :: IQRequestType + , iqRequestPayload :: Element + } deriving (Show) -data IQRequestType = Get | Set deriving (Show) +data IQRequestType = Get | Set deriving (Eq, Ord) + +instance Show IQRequestType where + show Get = "get" + show Set = "set" + +instance Read IQRequestType where + readsPrec _ "get" = [(Get, "")] + readsPrec _ "set" = [(Set, "")] + readsPrec _ _ = [] -- | -- A "response" Info/Query (IQ) stanza is one with either "result" or -- "error" as type. We have devided IQ responses into two types. --- +-- -- Objects of this type cannot be generated by Pontarius applications, -- but are only created internally. @@ -188,9 +160,9 @@ type IQResponse = Either IQError IQResult -- but are only created internally. data IQResult = IQResult { iqResultID :: StanzaId - , iqResultFrom :: Maybe From - , iqResultTo :: Maybe To - , iqResultLangTag :: LangTag + , iqResultFrom :: Maybe JID + , iqResultTo :: Maybe JID + , iqResultLangTag :: Maybe LangTag , iqResultPayload :: Maybe Element } deriving (Show) @@ -200,79 +172,88 @@ data IQResult = IQResult { iqResultID :: StanzaId -- but are only created internally. data IQError = IQError { iqErrorID :: StanzaId - , iqErrorFrom :: Maybe From - , iqErrorTo :: Maybe To - , iqErrorLangTag :: LangTag - , iqErrorPayload :: Maybe Element - , iqErrorStanzaError :: StanzaError } + , iqErrorFrom :: Maybe JID + , iqErrorTo :: Maybe JID + , iqErrorLangTag :: Maybe LangTag + , iqErrorStanzaError :: StanzaError + , iqErrorPayload :: Maybe Element -- should this be []? + } deriving (Show) - -- | -- A non-error message stanza. --- +-- -- Objects of this type cannot be generated by Pontarius applications, -- but are only created internally. -data Message = Message { messageID :: Maybe StanzaId - , messageFrom :: Maybe From - , messageTo :: Maybe To - , messageLangTag :: LangTag - , messageType :: MessageType - , messagePayload :: [Element] } +data Message = Message { messageID :: Maybe StanzaId + , messageFrom :: Maybe JID + , messageTo :: Maybe JID + , messageLangTag :: Maybe LangTag + , messageType :: MessageType + , messageSubject :: Maybe Text + , messageThread :: Maybe Text + , messageBody :: Maybe Text + , messagePayload :: [Element] + } deriving (Show) -- | -- An error message stanza. --- +-- -- Objects of this type cannot be generated by Pontarius applications, -- but are only created internally. data MessageError = MessageError { messageErrorID :: Maybe StanzaId - , messageErrorFrom :: Maybe From - , messageErrorTo :: Maybe To - , messageErrorLangTag :: LangTag - , messageErrorPayload :: Maybe [Element] - , messageErrorStanzaError :: StanzaError } + , messageErrorFrom :: Maybe JID + , messageErrorTo :: Maybe JID + , messageErrorLangTag :: Maybe LangTag + , messageErrorStanzaError :: StanzaError + , messageErrorPayload :: [Element] + } deriving (Show) --- Objects of this type cannot be generated by Pontarius applications, --- but are only created internally. - -type InternalMessage = Either MessageError Message - - -- | -- @MessageType@ holds XMPP message types as defined in XMPP-IM. The -- "error" message type is left out as errors are wrapped in -- @MessageError@. -data MessageType = Chat | -- ^ - Groupchat | -- ^ - Headline | -- ^ +data MessageType = Chat | -- ^ + GroupChat | -- ^ + Headline | -- ^ Normal -- ^ The default message type deriving (Eq) instance Show MessageType where show Chat = "chat" - show Groupchat = "groupchat" + show GroupChat = "groupchat" show Headline = "headline" show Normal = "normal" +instance Read MessageType where + readsPrec _ "chat" = [( Chat ,"")] + readsPrec _ "groupchat" = [( GroupChat ,"")] + readsPrec _ "headline" = [( Headline ,"")] + readsPrec _ "normal" = [( Normal ,"")] + readsPrec _ _ = [( Normal ,"")] -- | -- Objects of this type cannot be generated by Pontarius applications, -- but are only created internally. -data Presence = Presence { presenceID :: StanzaId - , presenceFrom :: Maybe From - , presenceTo :: Maybe To - , presenceLangTag :: LangTag - , presenceType :: Maybe PresenceType - , presencePayload :: [Element] } +data Presence = Presence { presenceID :: Maybe StanzaId + , presenceFrom :: Maybe JID + , presenceTo :: Maybe JID + , presenceLangTag :: Maybe LangTag + , presenceType :: Maybe PresenceType + , presenceShowType :: Maybe ShowType + , presenceStatus :: Maybe Text + , presencePriority :: Maybe Int + , presencePayload :: [Element] + } deriving (Show) @@ -281,20 +262,14 @@ data Presence = Presence { presenceID :: StanzaId -- but are only created internally. data PresenceError = PresenceError { presenceErrorID :: Maybe StanzaId - , presenceErrorFrom :: Maybe From - , presenceErrorTo :: Maybe To - , presenceErrorLangTag :: LangTag - , presenceErrorPayload :: Maybe [Element] - , presenceErrorStanzaError :: StanzaError } + , presenceErrorFrom :: Maybe JID + , presenceErrorTo :: Maybe JID + , presenceErrorLangTag :: Maybe LangTag + , presenceErrorStanzaError :: StanzaError + , presenceErrorPayload :: [Element] + } deriving (Show) - --- Objects of this type cannot be generated by Pontarius applications, --- but are only created internally. - -type InternalPresence = Either PresenceError Presence - - -- | -- @PresenceType@ holds XMPP presence types. The "error" message type -- is left out as errors are using @PresenceError@. @@ -306,6 +281,7 @@ data PresenceType = Subscribe | -- ^ Sender wants to subscribe to presence -- subscription Probe | -- ^ Sender requests current presence; -- should only be used by servers + Default | Unavailable deriving (Eq) @@ -315,8 +291,44 @@ instance Show PresenceType where show Unsubscribe = "unsubscribe" show Unsubscribed = "unsubscribed" show Probe = "probe" + show Default = "" show Unavailable = "unavailable" +instance Read PresenceType where + readsPrec _ "" = [( Default ,"")] + readsPrec _ "available" = [( Default ,"")] + readsPrec _ "unavailable" = [( Unavailable ,"")] + readsPrec _ "subscribe" = [( Subscribe ,"")] + readsPrec _ "subscribed" = [( Subscribed ,"")] + readsPrec _ "unsubscribe" = [( Unsubscribe ,"")] + readsPrec _ "unsubscribed" = [( Unsubscribed ,"")] + readsPrec _ "probe" = [( Probe ,"")] + readsPrec _ _ = [] + +data ShowType = Available + | Away + | FreeChat + | DND + | XAway + deriving Eq + +instance Show ShowType where + show Available = "" + show Away = "away" + show FreeChat = "chat" + show DND = "dnd" + show XAway = "xa" + +instance Read ShowType where + readsPrec _ "" = [( Available ,"")] + readsPrec _ "available" = [( Available ,"")] + readsPrec _ "away" = [( Away ,"")] + readsPrec _ "chat" = [( FreeChat ,"")] + readsPrec _ "dnd" = [( DND ,"")] + readsPrec _ "xa" = [( XAway ,"")] + readsPrec _ "invisible" = [( Available ,"")] + readsPrec _ _ = [] + -- | -- All stanzas (IQ, message, presence) can cause errors, which in the XMPP @@ -327,7 +339,7 @@ instance Show PresenceType where data StanzaError = StanzaError { stanzaErrorType :: StanzaErrorType , stanzaErrorCondition :: StanzaErrorCondition - , stanzaErrorText :: Maybe (Maybe LangTag, String) + , stanzaErrorText :: Maybe (Maybe LangTag, Text) , stanzaErrorApplicationSpecificCondition :: Maybe Element } deriving (Eq, Show) @@ -350,6 +362,14 @@ instance Show StanzaErrorType where show Auth = "auth" show Wait = "wait" +instance Read StanzaErrorType where + readsPrec _ "auth" = [( Auth , "")] + readsPrec _ "cancel" = [( Cancel , "")] + readsPrec _ "continue" = [( Continue, "")] + readsPrec _ "modify" = [( Modify , "")] + readsPrec _ "wait" = [( Wait , "")] + readsPrec _ _ = [] + -- | -- Stanza errors are accommodated with one of the error conditions listed below. @@ -417,15 +437,37 @@ instance Show StanzaErrorCondition where show UndefinedCondition = "undefined-condition" show UnexpectedRequest = "unexpected-request" - +instance Read StanzaErrorCondition where + readsPrec _ "bad-request" = [(BadRequest , "")] + readsPrec _ "conflict" = [(Conflict , "")] + readsPrec _ "feature-not-implemented" = [(FeatureNotImplemented, "")] + readsPrec _ "forbidden" = [(Forbidden , "")] + readsPrec _ "gone" = [(Gone , "")] + readsPrec _ "internal-server-error" = [(InternalServerError , "")] + readsPrec _ "item-not-found" = [(ItemNotFound , "")] + readsPrec _ "jid-malformed" = [(JIDMalformed , "")] + readsPrec _ "not-acceptable" = [(NotAcceptable , "")] + readsPrec _ "not-allowed" = [(NotAllowed , "")] + readsPrec _ "not-authorized" = [(NotAuthorized , "")] + readsPrec _ "payment-required" = [(PaymentRequired , "")] + readsPrec _ "recipient-unavailable" = [(RecipientUnavailable , "")] + readsPrec _ "redirect" = [(Redirect , "")] + readsPrec _ "registration-required" = [(RegistrationRequired , "")] + readsPrec _ "remote-server-not-found" = [(RemoteServerNotFound , "")] + readsPrec _ "remote-server-timeout" = [(RemoteServerTimeout , "")] + readsPrec _ "resource-constraint" = [(ResourceConstraint , "")] + readsPrec _ "service-unavailable" = [(ServiceUnavailable , "")] + readsPrec _ "subscription-required" = [(SubscriptionRequired , "")] + readsPrec _ "unexpected-request" = [(UnexpectedRequest , "")] + readsPrec _ "undefined-condition" = [(UndefinedCondition , "")] + readsPrec _ _ = [(UndefinedCondition , "")] -- ============================================================================= -- OTHER STUFF -- ============================================================================= - data SASLFailure = SASLFailure { saslFailureCondition :: SASLError - , saslFailureText :: Maybe String } -- TODO: XMLLang + , saslFailureText :: Maybe Text } -- TODO: XMLLang data SASLError = -- SASLAborted | -- Client aborted - should not happen @@ -449,7 +491,7 @@ data SASLError = -- SASLAborted | -- Client aborted - should not happen -- SASLMalformedRequest | -- Invalid syntax - should not happen SASLMechanismTooWeak | -- ^ The receiving entity policy -- requires a stronger mechanism - SASLNotAuthorized (Maybe String) | -- ^ Invalid credentials + SASLNotAuthorized (Maybe Text) | -- ^ Invalid credentials -- provided, or some -- generic authentication -- failure has occurred @@ -459,22 +501,9 @@ data SASLError = -- SASLAborted | -- Client aborted - should not happen -- to try again later -instance Eq ConnectionState where - Disconnected == Disconnected = True - (Connected p h) == (Connected p_ h_) = p == p_ && h == h_ - -- (ConnectedPostFeatures s p h t) == (ConnectedPostFeatures s p h t) = True - -- (ConnectedAuthenticated s p h t) == (ConnectedAuthenticated s p h t) = True - _ == _ = False - -data XMPPError = UncaughtEvent deriving (Eq, Show) - -instance CME.Error XMPPError where - strMsg "UncaughtEvent" = UncaughtEvent +-- | Readability type for host name Texts. - --- | Readability type for host name Strings. - -type HostName = String -- This is defined in Network as well +-- type HostName = Text -- This is defined in Network as well -- | Readability type for port number Integers. @@ -482,111 +511,23 @@ type HostName = String -- This is defined in Network as well type PortNumber = Integer -- We use N(etwork).PortID (PortNumber) internally --- | Readability type for user name Strings. - -type UserName = String - - --- | Readability type for password Strings. - -type Password = String +-- | Readability type for user name Texts. +type UserName = Text --- | Readability type for (Address) resource identifier Strings. -type Resource = String +-- | Readability type for password Texts. +type Password = Text -data TimeoutEvent s m = TimeoutEvent StanzaId Timeout (StateT s m ()) -instance Show (TimeoutEvent s m) where - show (TimeoutEvent (SI i) t _) = "TimeoutEvent (ID: " ++ (show i) ++ ", timeout: " ++ (show t) ++ ")" +-- | Readability type for (Address) resource identifier Texts. +type Resource = Text -data StreamState = PreStream | - PreFeatures StreamProperties | - PostFeatures StreamProperties StreamFeatures +type StreamID = Text -data AuthenticationState = NoAuthentication | AuthenticatingPreChallenge1 String String (Maybe Resource) | AuthenticatingPreChallenge2 String String (Maybe Resource) | AuthenticatingPreSuccess String String (Maybe Resource) | AuthenticatedUnbound String (Maybe Resource) | AuthenticatedBound String Resource - - --- Client actions that needs to be performed in the (main) state loop are --- converted to ClientEvents and sent through the internal event channel. - ---data ClientEvent s m = CEOpenStream N.HostName PortNumber --- (OpenStreamResult -> StateT s m ()) | --- CESecureWithTLS (Maybe [X509]) ([X509] -> Bool) --- (SecureWithTLSResult -> StateT s m ()) | --- CEAuthenticate UserName Password (Maybe Resource) --- (AuthenticateResult -> StateT s m ()) | --- CEMessage Message (Maybe (Message -> StateT s m Bool)) (Maybe (Timeout, StateT s m ())) (Maybe (StreamError -> StateT s m ())) | --- CEPresence Presence (Maybe (Presence -> StateT s m Bool)) (Maybe (Timeout, StateT s m ())) (Maybe (StreamError -> StateT s m ())) | --- CEIQ IQ (Maybe (IQ -> StateT s m Bool)) (Maybe (Timeout, StateT s m ())) (Maybe (StreamError -> StateT s m ())) | --- CEAction (Maybe (StateT s m Bool)) (StateT s m ()) - - -data ClientEvent = ClientEventTest - - ---instance Show (ClientEvent s m) where --- show (CEOpenStream h p _) = "CEOpenStream " ++ h ++ " " ++ (show p) --- show (CESecureWithTLS c _ _) = "CESecureWithTLS " ++ (show c) --- show (CEAuthenticate u p r _) = "CEAuthenticate " ++ u ++ " " ++ p ++ " " ++ --- (show r) --- show (CEIQ s _ _ _) = "CEIQ" --- show (CEMessage s _ _ _) = "CEMessage" --- show (CEPresence s _ _ _) = "CEPresence" --- --- show (CEAction _ _) = "CEAction" - - -type StreamID = String - -data ConnectionState = Disconnected | Connected ServerAddress Handle - --- data TLSState = NoTLS | PreProceed | PreHandshake | PostHandshake TLSCtx - -data Challenge = Chal String deriving (Show) - -data Success = Succ String deriving (Show) - - -type StreamProperties = Float -type StreamFeatures = String - - -data ConnectResult = ConnectSuccess StreamProperties StreamFeatures (Maybe Resource) | - ConnectOpenStreamFailure | - ConnectSecureWithTLSFailure | - ConnectAuthenticateFailure - -data OpenStreamResult = OpenStreamSuccess StreamProperties StreamFeatures | - OpenStreamFailure - -data SecureWithTLSResult = SecureWithTLSSuccess StreamProperties StreamFeatures | SecureWithTLSFailure - -data AuthenticateResult = AuthenticateSuccess StreamProperties StreamFeatures Resource | AuthenticateFailure - --- Address is a data type that has to be constructed in this module using either --- address or stringToAddress. - -data Address = Address { localpart :: Maybe Localpart - , domainpart :: Domainpart - , resourcepart :: Maybe Resourcepart } - deriving (Eq) - -instance Show Address where - show (Address { localpart = n, domainpart = s, resourcepart = r }) - | n == Nothing && r == Nothing = s - | r == Nothing = let Just n' = n in n' ++ "@" ++ s - | n == Nothing = let Just r' = r in s ++ "/" ++ r' - | otherwise = let Just n' = n; Just r' = r - in n' ++ "@" ++ s ++ "/" ++ r' - -type Localpart = String -type Domainpart = String -type Resourcepart = String data ServerAddress = ServerAddress N.HostName N.PortNumber deriving (Eq) @@ -604,9 +545,7 @@ data StreamError = StreamError -- strings MUST be appropriate for use in the stanza id attirubte. -- For a default implementation, see @idGenerator@. -newtype IdGenerator = IdGenerator (IORef [String]) - - +newtype IdGenerator = IdGenerator (IO Text) --- other stuff @@ -630,83 +569,70 @@ instance Ord Version where | otherwise = compare aminor bminor -data LangTag = LangTag { primaryTag :: String - , subtags :: [String] } +data LangTag = LangTag { primaryTag :: Text + , subtags :: [Text] } + deriving (Eq) -- TODO: remove -- Displays the language tag in the form of "en-US". instance Show LangTag where - show (LangTag p []) = p - show (LangTag p s) = p ++ "-" ++ (concat $ intersperse "-" s) - - --- Two language tags are considered equal of they contain the same tags (case-insensitive). - -instance Eq LangTag where - (LangTag ap as) == (LangTag bp bs) - | length as == length bs && map toLower ap == map toLower bp = - all (\ (a, b) -> map toLower a == map toLower b) $ zip as bs - | otherwise = False - - - - - - + show (LangTag p []) = Text.unpack p + show (LangTag p s) = Text.unpack . Text.concat + $ [p, "-", Text.intercalate "-" s] -- TODO: clean up +parseLangTag :: Text -> [LangTag] +parseLangTag txt = case Text.splitOn "-" txt of + [] -> [] + prim: subs -> [LangTag prim subs] +instance Read LangTag where + readsPrec _ txt = (,"") <$> (parseLangTag $ Text.pack txt) +-- Two language tags are considered equal of they contain the same tags (case-insensitive). +-- TODO: port +-- instance Eq LangTag where +-- (LangTag ap as) == (LangTag bp bs) +-- | length as == length bs && map toLower ap == map toLower bp = +-- all (\ (a, b) -> map toLower a == map toLower b) $ zip as bs +-- | otherwise = False +data ServerFeatures = SF + { stls :: Maybe Bool + , saslMechanisms :: [Text.Text] + , other :: [Element] + } deriving Show -data InternalEvent m - = OpenStreamsEvent HostName PortNumber - -- | DisconnectEvent - | RegisterStreamsOpenedHook (Maybe (Maybe OpenStreamsFailureReason -> XMPPT m Bool)) (Maybe OpenStreamsFailureReason -> XMPPT m Bool) - | EnumeratorFirstLevelElement Element - -- | IEEE EnumeratorEvent - | EnumeratorDone - | EnumeratorBeginStream (Maybe String) (Maybe String) (Maybe String) (Maybe String) (Maybe String) (Maybe String) - | EnumeratorEndStream - | EnumeratorException CE.SomeException +data XMPPConState = XMPPConState + { sConSrc :: Source (ResourceT IO) Event + , sRawSrc :: Source (ResourceT IO) BS.ByteString + , sConPush :: [Event] -> ResourceT IO () + , sConPushBS :: BS.ByteString -> IO () + , sConHandle :: Maybe Handle + , sFeatures :: ServerFeatures + , sHaveTLS :: Bool + , sHostname :: Text + , sUsername :: Text + , sResource :: Maybe Text + } -- | -- The XMPP monad transformer. Contains internal state in order to -- work with Pontarius. Pontarius clients needs to operate in this -- context. -newtype XMPPT m a = XMPPT { runXMPPT :: StateT (State m) m a } deriving (Monad, MonadIO) +newtype XMPPT m a = XMPPT { runXMPPT :: StateT XMPPConState m a } deriving (Monad, MonadIO) +type XMPPConMonad a = StateT XMPPConState (ResourceT IO) a -- Make XMPPT derive the Monad and MonadIO instances. -deriving instance (Monad m, MonadIO m) => MonadState (State m) (XMPPT m) +deriving instance (Monad m, MonadIO m) => MonadState (XMPPConState) (XMPPT m) -- We need a channel because multiple threads needs to append events, -- and we need to wait for events when there are none. - -data State m = State { evtChan :: Chan (InternalEvent m) - , hookIdGenerator :: IdGenerator - , hooks :: [Hook m] } - - -data HookId = HookId String deriving (Eq) - -data HookPayload m = StreamsOpenedHook (Maybe (Maybe OpenStreamsFailureReason -> XMPPT m Bool)) (Maybe OpenStreamsFailureReason -> XMPPT m Bool) - -type Hook m = (HookId, HookPayload m) - - --- TODO: Possible ways opening a stream can fail. -data OpenStreamsFailureReason = OpenStreamsFailureReason deriving (Show) - --- data TLSSecureFailureReason = TLSSecureFailureReason - --- data AuthenticateFailureReason = AuthenticateFailureReason - -data DisconnectReason = DisconnectReason deriving (Show) \ No newline at end of file diff --git a/src/Network/XMPP_flymake.hs b/src/Network/XMPP_flymake.hs deleted file mode 100644 index 57be806..0000000 --- a/src/Network/XMPP_flymake.hs +++ /dev/null @@ -1,89 +0,0 @@ --- Copyright © 2010-2012 Jon Kristensen. See the LICENSE file in the --- Pontarius distribution for more details. - --- | --- Module: $Header$ --- Description: Pontarius API --- Copyright: Copyright © 2010-2012 Jon Kristensen --- License: Apache License 2.0 --- --- Maintainer: jon.kristensen@nejla.com --- Stability: unstable --- Portability: portable --- --- XMPP is an open standard, extendable, and secure communications --- protocol designed on top of XML, TLS, and SASL. Pontarius XMPP is --- an XMPP client library, implementing the core capabilities of XMPP --- (RFC 6120). --- --- Developers using this library are assumed to understand how XMPP --- works. --- --- This module will be documented soon. --- --- Note that we are not recommending anyone to use Pontarius XMPP at --- this time as it's still in an experimental stage and will have its --- API and data types modified frequently. - -module Network.XMPP ( -- Network.XMPP.JID - Address (..) - , Localpart - , Domainpart - , Resourcepart - , isFull - , isBare - , fromString - , fromStrings - - -- Network.XMPP.Session - , runXMPPT - , hookStreamsOpenedEvent - , hookDisconnectedEvent - , destroy - , openStreams - , create - - -- , ClientHandler (..) - -- , ClientState (..) - -- , ConnectResult (..) - -- , HostName - -- , Password - -- , PortNumber - -- , Resource - -- , Session - -- , TerminationReason - -- , UserName - -- , sendIQ - -- , sendPresence - -- , sendMessage - -- , connect - -- , openStreams - -- , tlsSecureStreams - -- , authenticate - -- , session - -- , OpenStreamResult (..) - -- , SecureWithTLSResult (..) - -- , AuthenticateResult (..) - - -- Network.XMPP.Stanza - , StanzaID (SID) - , From - , To - , LangTag - , MessageType (..) - , Message (..) - , PresenceType (..) - , Presence (..) - , IQ (..) - , iqPayloadNamespace - , iqPayload ) where - -import Network.XMPP.Address --- import Network.XMPP.SASL -import Network.XMPP.Session -import Network.XMPP.Stanza -import Network.XMPP.Utilities -import Network.XMPP.Types --- import Network.XMPP.TLS -import Network.XMPP.Stream - diff --git a/src/Tests.hs b/src/Tests.hs new file mode 100644 index 0000000..6043679 --- /dev/null +++ b/src/Tests.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE PackageImports, OverloadedStrings #-} +module Example where + +import Network.XMPP +import Control.Concurrent +import Control.Concurrent.STM +import Control.Monad +import Control.Monad.IO.Class + +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as Text +import Data.XML.Pickle +import Data.XML.Types + +import Network.XMPP.Pickle + +import System.Environment + +testUser1 :: JID +testUser1 = read "testuser1@species64739.dyndns.org/bot1" + +testUser2 :: JID +testUser2 = read "testuser2@species64739.dyndns.org/bot2" + +supervisor :: JID +supervisor = read "uart14@species64739.dyndns.org" + + +attXmpp :: STM a -> XMPPThread a +attXmpp = liftIO . atomically + +testNS :: Text +testNS = "xmpp:library:test" + +data Payload = Payload Int Bool Text deriving (Eq, Show) + +payloadP = xpWrap (\((counter,flag) , message) -> Payload counter flag message) + (\(Payload counter flag message) ->((counter,flag) , message)) $ + xpElem (Name "request" (Just testNS) Nothing) + (xpPair + (xpAttr "counter" xpPrim) + (xpAttr "flag" xpPrim) + ) + (xpElemNodes (Name "message" (Just testNS) Nothing) + (xpContent xpId)) + +invertPayload (Payload count flag message) = Payload (count + 1) (not flag) (Text.reverse message) + +iqResponder = do + (free, chan) <- listenIQChan Get testNS + unless free $ liftIO $ putStrLn "Channel was already taken" + >> error "hanging up" + forever $ do + next@(iq,_) <- liftIO . atomically $ readTChan chan + let payload = unpickleElem payloadP $ iqRequestPayload iq + let answerPayload = invertPayload payload + let answerBody = pickleElem payloadP answerPayload + answerIQ next (Right $ Just answerBody) + +autoAccept :: XMPPThread () +autoAccept = forever $ do + st <- waitForPresence isPresenceSubscribe + sendPresence $ presenceSubscribed (fromJust $ presenceFrom st) + +sendUser = sendMessage . simpleMessage supervisor . Text.pack + +expect debug x y | x == y = debug "Ok." + | otherwise = do + let failMSG = "failed" ++ show x ++ " /= " ++ show y + debug failMSG + sendUser failMSG + + +runMain :: (String -> STM ()) -> Int -> IO () +runMain debug number = do + let (we, them, active) = case number of + 1 -> (testUser1, testUser2,True) + 2 -> (testUser2, testUser1,False) + _ -> error "Need either 1 or 2" + sessionConnect "localhost" + "species64739.dyndns.org" + (fromJust $ node we) (resource we) $ do + let debug' = liftIO . atomically . debug . + (("Thread " ++ show number ++ ":") ++) + withConnection $ xmppSASL "pwd" + xmppThreadedBind (resource we) + withConnection $ xmppSession + sendPresence presenceOnline + forkXMPP autoAccept + forkXMPP iqResponder + -- sendS . SPresence $ Presence Nothing (Just them) Nothing (Just Subscribe) Nothing Nothing Nothing [] + let delay = if active then 1000000 else 5000000 + when active . void . forkXMPP $ do + forM [1..10] $ \count -> do + let message = Text.pack . show $ node we + let payload = Payload count (even count) (Text.pack $ show count) + let body = pickleElem payloadP payload + Right answer <- sendIQ' (Just them) Get Nothing body + let answerPayload = unpickleElem payloadP + (fromJust $ iqResultPayload answer) + expect debug' (invertPayload payload) answerPayload + liftIO $ threadDelay delay + sendUser "All tests done" + liftIO . forever $ threadDelay 10000000 + return () + return () + + +main = do + out <- newTChanIO + forkIO . forever $ atomically (readTChan out) >>= putStrLn + let debugOut = writeTChan out + forkIO $ runMain debugOut 1 + runMain debugOut 2 + diff --git a/src/Text/XML/Stream/Elements.hs b/src/Text/XML/Stream/Elements.hs new file mode 100644 index 0000000..3812752 --- /dev/null +++ b/src/Text/XML/Stream/Elements.hs @@ -0,0 +1,78 @@ +module Text.XML.Stream.Elements where + +import Control.Applicative ((<$>)) +import Control.Monad.Trans.Class +import Control.Monad.Trans.Resource as R + +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 :: R.MonadThrow m => C.Sink Event m Element +elementFromEvents = do + x <- CL.peek + case x of + Just (EventBeginElement n as) -> goE n as + _ -> lift $ R.monadThrow $ 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 $ R.monadThrow $ 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 + + +openElementToEvents :: Element -> [Event] +openElementToEvents (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 :: Element -> [Event] +elementToEvents e@(Element name _ _) = openElementToEvents e ++ [EventEndElement name] diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 index 0000000..ed4fd84 --- /dev/null +++ b/src/Utils.hs @@ -0,0 +1,7 @@ +module Utils where + +whileJust f = do + f' <- f + case f' of + Just x -> x : whileJust f + Nothing -> [] diff --git a/xml-types-pickle b/xml-types-pickle new file mode 160000 index 0000000..e417f9d --- /dev/null +++ b/xml-types-pickle @@ -0,0 +1 @@ +Subproject commit e417f9ddc6cc74dc06fabadad810da10b8e25d84