pontarius-xmpp 0.1.0.0 → 0.1.0.1

raw patch · 5 files changed

+157/−3 lines, 5 files

Files

• examples/EchoClient.hs +58/−0
• pontarius-xmpp.cabal +3/−3
• source/Data/Conduit/BufferedSource.hs +34/−0
• source/Data/Conduit/TLS.hs +62/−0
• source/Network/Xmpp/Concurrent/Monad.hs binary

@@ -0,0 +1,58 @@+{-++Copyright © 2010-2012 Jon Kristensen.++This file (EchoClient.hs) illustrates how to connect, authenticate, set a simple+presence, receive message stanzas, and echo them back to whoever is sending+them, using Pontarius. The contents of this file may be used freely, as if it is+in the public domain.++-}+++{-# LANGUAGE OverloadedStrings #-}+++module Main (main) where++import Control.Monad (forever)+import Control.Monad.IO.Class (liftIO)+import Data.Maybe (fromJust, isJust)++import Network.Xmpp+import Network.Xmpp.IM+++-- Server and authentication details.++hostname = "localhost"++-- portNumber = 5222 -- TODO+username = ""+password = ""+resource = Nothing+++-- TODO: Incomplete code, needs documentation, etc.+main :: IO ()+main = do+    session <- newSession+    withConnection (simpleConnect hostname username password resource) session+    sendPresence presenceOnline session+    echo session+    return ()++-- Pull message stanzas, verify that they originate from a `full' XMPP+-- address, and, if so, `echo' the message back.+echo :: Session -> IO ()+echo session = forever $ do+    result <- pullMessage session+    case result of+        Right message ->+            if (isJust $ messageFrom message) &&+                   (isFull $ fromJust $ messageFrom message) then do+                -- TODO: May not set from.+                sendMessage (Message Nothing (messageTo message) (messageFrom message) Nothing (messageType message) (messagePayload message)) session+                liftIO $ putStrLn "Message echoed!"+            else liftIO $ putStrLn "Message sender is not set or is bare!"+        Left exception -> liftIO $ putStrLn "Error: "

@@ -1,5 +1,5 @@ Name: pontarius-xmpp-Version: 0.1.0.0+Version: 0.1.0.1 Cabal-Version: >= 1.6 Build-Type: Simple License: OtherLicense@@ -86,8 +86,8 @@   GHC-Options: -Wall  Executable pontarius-xmpp-echoclient-  hs-source-dirs: source-  Main-Is: ../examples/EchoClient.hs+  hs-source-dirs: examples+  Main-Is: EchoClient.hs  Source-Repository head   Type: git

@@ -0,0 +1,34 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Data.Conduit.BufferedSource where++import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Exception+import Data.IORef+import Data.Conduit+import Data.Typeable(Typeable)+import qualified Data.Conduit.Internal as DCI+import qualified Data.Conduit.List as CL++data SourceClosed = SourceClosed deriving (Show, Typeable)++instance Exception SourceClosed++-- | Buffered source from conduit 0.3+bufferSource :: MonadIO m => Source m o -> IO (Source m o)+bufferSource s = do+    srcRef <- newIORef . Just $ DCI.ResumableSource s (return ())+    return $ do+        src' <- liftIO $ readIORef srcRef+        src <- case src' of+            Just s -> return s+            Nothing -> liftIO $ throwIO SourceClosed+        let go src = do+            (src', res) <- lift $ src $$++ CL.head+            case res of+                Nothing -> liftIO $ writeIORef srcRef Nothing+                Just x -> do+                    liftIO (writeIORef srcRef $ Just src')+                    yield x+                    go src'+          in go src

@@ -0,0 +1,62 @@+{-# Language NoMonomorphismRestriction #-}+{-# OPTIONS_HADDOCK hide #-}+module Data.Conduit.TLS+       ( tlsinit+--       , conduitStdout+       , module TLS+       , module TLSExtra+       )+       where++import Control.Monad(liftM, when)+import Control.Monad.IO.Class++import Crypto.Random++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import Data.Conduit+import Control.Monad++import Network.TLS as TLS+import Network.TLS.Extra as TLSExtra++import System.IO(Handle)++client params gen handle = do+    contextNewOnHandle handle params gen++defaultParams = defaultParamsClient++tlsinit :: (MonadIO m, MonadIO m1) =>+        Bool+     -> TLSParams+     -> Handle -> m ( Source m1 BS.ByteString+                    , Sink BS.ByteString m1 ()+                    , BS.ByteString -> IO ()+                    , Context+                    )+tlsinit debug tlsParams handle = do+    when debug . liftIO $ putStrLn "TLS with debug mode enabled"+    gen <- liftIO $ (newGenIO :: IO SystemRandom) -- TODO: Find better random source?+    con <- client tlsParams gen handle+    handshake con+    let src = forever $ do+            dt <- liftIO $ recvData con+            when debug (liftIO $ putStr "in: " >> BS.putStrLn dt)+            yield dt+    let snk = do+            d <- await+            case d of+                Nothing -> return ()+                Just x -> do+                       sendData con (BL.fromChunks [x])+                       when debug (liftIO $ putStr "out: " >>  BS.putStrLn x)+                       snk+    return ( src+           , snk+           , \s -> do+               when debug (liftIO $ BS.putStrLn s)+               sendData con $ BL.fromChunks [s]+           , con+           )

binary file changed (9978 → 9978 bytes)