diff --git a/EasyXMPP.hs b/EasyXMPP.hs new file mode 100644 --- /dev/null +++ b/EasyXMPP.hs @@ -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" + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hxmppc.cabal b/hxmppc.cabal new file mode 100644 --- /dev/null +++ b/hxmppc.cabal @@ -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 diff --git a/hxmppc.hs b/hxmppc.hs new file mode 100644 --- /dev/null +++ b/hxmppc.hs @@ -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 [