hxmppc (empty) → 0.2
raw patch · 5 files changed
+234/−0 lines, 5 filesdep +basedep +fclabelsdep +networksetup-changed
Dependencies added: base, fclabels, network, network-protocol-xmpp, text, transformers, xml-types
Files
- EasyXMPP.hs +91/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- hxmppc.cabal +21/−0
- hxmppc.hs +90/−0
+ EasyXMPP.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE OverloadedStrings #-}+module EasyXMPP (+ runPersistentClient,+ mkMsg,+ extractMsg,++ -- more details+ (<>),+ pBody,+ contentText,+ extractBody,+ extractContent,+ p+ ) where++import Network.Protocol.XMPP hiding (Node)+import Data.Text (Text)+import qualified Data.Text as T+import Data.XML.Types (Element(..), Node(..), Content(..), Name(..))+import Network (PortID(..), HostName)+import Data.Maybe (catMaybes)+import Control.Monad+import Control.Monad.IO.Class+import Control.Concurrent+import Data.Functor+import Data.Monoid++(<>) :: Monoid m => m -> m -> m+(<>) = mappend++pBody :: [Node] -> Element+pBody = Element (Name "body" (Just "jabber:client") Nothing) []++contentText :: Text -> Node+contentText = NodeContent . ContentText++extractBody :: [Element] -> [Node]+extractBody [Element (Name "body" _ _) _ ns] = ns+extractBody _ = []++extractContent :: Node -> Maybe Text+extractContent (NodeContent (ContentText txt)) = Just txt+extractContent _ = Nothing++p :: Text -> Element+p = pBody . return . contentText++mkMsg :: JID -> Text -> Message+mkMsg toJID txt =+ Message { messageType = MessageNormal+ , messageTo = Just toJID+ , messageFrom = Nothing -- done by the server+ , messageID = Nothing+ , messageLang = Just "en"+ , messagePayloads = [p txt]+ }++extractMsg :: Message -> Text+extractMsg = T.concat . catMaybes . map extractContent . extractBody . messagePayloads++-- Send a "ping" occasionally, to prevent server timeouts from+-- closing the connection.+sendPings :: Integer -> Session -> IO ()+sendPings seconds s = forever send where+ send = do+ -- Ignore errors+ _ <- runXMPP s $ putStanza ping+ threadDelay $ fromInteger $ 1000000 * seconds+ ping = (emptyIQ IQGet)+ { iqPayload = Just (Element pingName [] []) }++pingName :: Name+pingName = Name "ping" (Just "urn:xmpp:ping") Nothing++runPersistentClient :: (JID, Text) -> (HostName, PortID) -> XMPP a -> IO (Either Error a)+runPersistentClient (myJID, pass) (hostname, port) act =+ runClient server myJID username pass $ do+ -- Some servers will close the XMPP connection after some period+ -- of inactivity. For this example, we'll simply send a "ping" every+ -- 60 seconds+ _ <- getSession >>= liftIO . forkIO . sendPings 60++ _ <- bindJID myJID+ act++ where+ server = Server (JID Nothing (jidDomain myJID) Nothing) hostname port+ username = case strNode <$> jidNode myJID of+ Just x -> x+ Nothing -> error $ "JID must include a username"+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2011, Nicolas Pouillard++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Nicolas Pouillard nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hxmppc.cabal view
@@ -0,0 +1,21 @@+Name: hxmppc+Version: 0.2++Synopsis: Haskell XMPP (Jabber Client) Command Line Interface (CLI)+Description: A simple command line interface to send and receive+ messages via XMPP++License: BSD3+License-file: LICENSE+Author: Nicolas Pouillard+Maintainer: nicolas.pouillard@gmail.com+Category: Network+Build-type: Simple+Cabal-version: >=1.6++Executable hxmppc+ Main-is: hxmppc.hs+ Build-depends: base==4.3.*, text, xml-types, transformers, network,+ network-protocol-xmpp==0.4.*, fclabels+ Other-modules: EasyXMPP+ GHC-options: -Wall
+ hxmppc.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE OverloadedStrings, TemplateHaskell, TypeOperators #-}+import Network.Protocol.XMPP (Message(..), MessageType(..), ReceivedStanza(..),+ parseJID, getStanza, putStanza)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Network (PortID(..), PortNumber)+import System.Environment (getArgs)+import System.Exit (exitSuccess, exitFailure)+import System.IO (stderr)+import Control.Monad+import Control.Monad.IO.Class+import Data.Functor+import EasyXMPP+import Data.Record.Label+-- import Control.Arrow+import System.Console.GetOpt++data Settings = Settings { _user :: T.Text+ , _pass :: T.Text+ , _host :: String+ , _port :: PortNumber+ , _help :: Bool+ }+$(mkLabels [''Settings])+type Flag = Settings -> Settings++defaultSettings :: Settings+defaultSettings = Settings { _user = ""+ , _pass = ""+ , _host = ""+ , _port = 5222+ , _help = False+ }++options :: [OptDescr Flag]+options =+ [ Option "u" ["user"] (ReqArg (setL user . T.pack) "USER") "Username (example: foo@jabber.org)"+ , Option "p" ["pass"] (ReqArg (setL pass . T.pack) "PASS") "Password"+ , Option "h" ["host"] (ReqArg (setL host) "HOST") "Hostname (example: jabber.org)"+ , Option "P" ["port"] (ReqArg (setL port . fromInteger . read) "PORT") "Port"+ , Option "?" ["help"] (NoArg (setL help True)) "Show this help message"+ ]++usage :: MonadIO m => T.Text -> m b+usage msg = liftIO $ T.hPutStrLn stderr msg' >> exitFailure+ where msg' = T.unlines [T.pack $ usageInfo "Usage: hxmppc [<option>*] <command>" options+ ,"command ::= tell <destination-user> <message>*"+ ," | wait"+ ,""+ ,msg+ ]++main :: IO ()+main = do+ (flags, nonopts, errs) <- getOpt Permute options <$> getArgs+ let opts = foldr ($) defaultSettings flags+ when (not . null $ errs) $ usage (T.concat . map T.pack $ errs)+ when (getL help opts) $ usage ""+ when (T.null $ getL user opts) $ usage "Missing username"+ when (T.null $ getL pass opts) $ usage "Missing password"+ when (null $ getL host opts) $ usage "Missing hostname"+ let Just botJID = parseJID (getL user opts)++ res <- runPersistentClient (botJID, getL pass opts) (getL host opts, PortNumber (getL port opts)) $ do+ case map T.pack nonopts of+ "tell" : args -> do+ case args of+ [] -> usage "`tell' expects a destination user and a message"+ [_] -> usage "`tell' expects a message as well"+ (to:msg) -> do+ toJID <- maybe (usage "`tell' bad format for destination user") return $ parseJID to+ putStanza $ mkMsg toJID (T.unwords msg)+ _ <- getStanza+ liftIO exitSuccess+ "wait" : args -> do+ case args of+ [] ->+ forever $ do+ message <- getStanza+ case message of+ ReceivedMessage msg | messageType msg /= MessageError ->+ let text = maybe "" ((<>": "). T.pack . show) (messageFrom msg) <> extractMsg msg in+ liftIO (T.putStrLn text >> exitSuccess)+ _ -> return ()+ _ -> usage "`wait' expects no arguments"+ [] -> usage $ "no command"+ cmd : _ -> usage $ "no such command " <> cmd+ case res of+ Left err -> usage $ "XMPP error:" <> T.pack (show err)+ Right _ -> return ()