first commit

krobotkin.cabal

@@ -0,0 +1,37 @@
+cabal-version: 1.12
+
+name:       krobotkin
+version:    0.0.0.1
+license:    MIT
+build-type: Simple
+
+synopsis: xmpp muc bot
+description: xmpp bot for the cyberia muc
+
+author: Thorn Avery
+maintainer: ta@p7.co.nz
+
+executable krobotkin
+   main-is: Main.hs
+   ghc-options: -O2 -Wall
+   hs-source-dirs:
+      src
+   build-depends:
+      base
+    , pontarius-xmpp
+    , hslogger
+    , data-default
+    , xml-types
+    , text
+    , optparse-applicative
+    , random
+    , mtl
+   other-modules:
+      Krobotkin.Handlers
+    , Krobotkin.Monad
+    , Krobotkin.Muc
+    , Krobotkin.Options
+    , Krobotkin.Setup
+    , Krobotkin.Stanza
+    , Krobotkin.Types
+   default-language: Haskell2010

src/Krobotkin/Handlers.hs

@@ -0,0 +1,88 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Krobotkin.Handlers where
+
+import Krobotkin.Monad
+import Krobotkin.Muc
+import Krobotkin.Types
+
+import Data.Maybe
+import System.Random
+
+import Network.Xmpp
+
+import Control.Monad.Reader
+import Control.Monad.State
+
+import qualified Data.Text as T
+
+dispatchStanza :: PackedStanza -> BotMonad ()
+dispatchStanza (BotPresence fromUser ptype o) =
+   handlePresence fromUser ptype o
+dispatchStanza (BotMessage toUser fromUser content o) =
+   handleMessage toUser fromUser content o
+dispatchStanza _ = liftIO $ return ()
+
+handlePresence :: Jid -> PresenceType -> Presence -> BotMonad ()
+handlePresence fromUser Subscribe _ = approveSubscription fromUser
+handlePresence _ _ _ = liftIO $ return ()
+
+approveSubscription :: Jid -> BotMonad ()
+approveSubscription user = do
+   sess <- asks envXmppSess
+   _ <- liftIO $ sendPresence (presenceSubscribed user) sess
+   liftIO $ putStrLn $ "subscribed to " ++ (show user)
+
+handleMessage :: Jid -> Jid -> String -> Message -> BotMonad ()
+handleMessage _ fromUser "PING" _ =
+   sendMucMessage
+      "pong"
+      (toBare fromUser)
+handleMessage _ fromUser "BING" _ =
+   sendMucMessage
+      "cannabis smoking device"
+      (toBare fromUser)
+handleMessage _ fromUser "DING" _ =
+   sendMucMessage
+      "hehe penis 8==D~"
+      (toBare fromUser)
+handleMessage _ fromUser ('.':'8':'B':'A':'L':'L':' ':_) o = do
+   rng <- gets stateRNG
+   let (x,rng') = randomR (0,(length responses)-1) rng
+   modify (\s -> s { stateRNG = rng' })
+   sendMucMessage
+      (T.pack ("> "
+         ++ (drop 7 (T.unpack (fromMaybe ";0;" (getMucMessageBody o))))
+         ++ "\n" ++ responses !! x))
+      (toBare fromUser)
+   where
+      responses =
+         [ "it is certain"
+         , "without a doubt"
+         , "you may rely on it"
+         , "yes definitely"
+         , "it is decidedly so"
+         , "as i see it, yes"
+         , "most likely"
+         , "yes"
+         , "outlook good"
+         , "signs point to yes"
+         , "reply hazy try again"
+         , "better not tell you now"
+         , "ask again later"
+         , "cannot predict now"
+         , "concentrate and ask again"
+         , "dont count on it"
+         , "outlook not so good"
+         , "my sources say no"
+         , "very doubtful"
+         , "my reply is no"
+         ]
+handleMessage _ fromUser _ _ | T.toUpper (fromMaybe "no" (resourcepart fromUser)) == "ELFIE" = do
+   rng <- gets stateRNG
+   let (x,rng') = randomR (0,21) rng :: (Int,StdGen)
+   modify (\s -> s { stateRNG = rng' })
+   if x == 13
+   then sendMucMessage "shut up smellfie" (toBare fromUser)
+   else liftIO $ return ()
+handleMessage _ _ _ _ = liftIO $ return ()

src/Krobotkin/Handlers.hs~

@@ -0,0 +1,84 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Krobotkin.Handlers where
+
+import Krobotkin.Monad
+import Krobotkin.Muc
+import Krobotkin.Types
+
+import Data.Maybe
+import System.Random
+
+import Network.Xmpp
+
+import Control.Monad.Reader
+import Control.Monad.State
+
+import qualified Data.Text as T
+
+dispatchStanza :: PackedStanza -> BotMonad ()
+dispatchStanza (BotPresence fromUser ptype o) =
+   handlePresence fromUser ptype o
+dispatchStanza (BotMessage toUser fromUser content o) =
+   handleMessage toUser fromUser content o
+dispatchStanza _ = liftIO $ return ()
+
+handlePresence :: Jid -> PresenceType -> Presence -> BotMonad ()
+handlePresence fromUser Subscribe _ = approveSubscription fromUser
+handlePresence _ _ _ = liftIO $ return ()
+
+approveSubscription :: Jid -> BotMonad ()
+approveSubscription user = do
+   sess <- asks envXmppSess
+   _ <- liftIO $ sendPresence (presenceSubscribed user) sess
+   liftIO $ putStrLn $ "subscribed to " ++ (show user)
+
+handleMessage :: Jid -> Jid -> String -> Message -> BotMonad ()
+handleMessage _ fromUser "PING" _ =
+   sendMucMessage
+      "pong"
+      (toBare fromUser)
+handleMessage _ fromUser "BING" _ =
+   sendMucMessage
+      "cannabis smoking device"
+      (toBare fromUser)
+handleMessage _ fromUser ('.':'8':'B':'A':'L':'L':' ':_) o = do
+   rng <- gets stateRNG
+   let (x,rng') = randomR (0,(length responses)-1) rng
+   modify (\s -> s { stateRNG = rng' })
+   sendMucMessage
+      (T.pack ("> "
+         ++ (drop 7 (T.unpack (fromMaybe ";0;" (getMucMessageBody o))))
+         ++ "\n" ++ responses !! x))
+      (toBare fromUser)
+   where
+      responses =
+         [ "it is certain"
+         , "without a doubt"
+         , "you may rely on it"
+         , "yes definitely"
+         , "it is decidedly so"
+         , "as i see it, yes"
+         , "most likely"
+         , "yes"
+         , "outlook good"
+         , "signs point to yes"
+         , "reply hazy try again"
+         , "better not tell you now"
+         , "ask again later"
+         , "cannot predict now"
+         , "concentrate and ask again"
+         , "dont count on it"
+         , "outlook not so good"
+         , "my sources say no"
+         , "very doubtful"
+         , "my reply is no"
+         ]
+handleMessage _ fromUser _ _ | T.toUpper (fromMaybe "no" (resourcepart fromUser)) == "ELFIE" = do
+   rng <- gets stateRNG
+   let (x,rng') = randomR (0,21) rng :: (Int,StdGen)
+   modify (\s -> s { stateRNG = rng' })
+   if x == 13
+   then sendMucMessage "shut up smellfie" (toBare fromUser)
+   else liftIO $ return ()
+handleMessage _ _ _ _ = liftIO $ return ()

src/Krobotkin/Monad.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE ConstraintKinds            #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Krobotkin.Monad where
+
+import Krobotkin.Types
+
+import Control.Monad.Reader
+import Control.Monad.State
+
+newtype BotMonad a = BotMonad
+   (ReaderT AppEnv (StateT AppState IO) a)
+   deriving
+      ( Functor
+      , Applicative
+      , Monad
+      , MonadReader AppEnv
+      , MonadState AppState
+      , MonadIO
+      )
+
+runBotMonad :: AppEnv -> AppState -> BotMonad a -> IO a
+runBotMonad env appstate (BotMonad m) =
+   evalStateT (runReaderT m env) appstate

src/Krobotkin/Muc.hs

@@ -0,0 +1,80 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Krobotkin.Muc where
+
+import Krobotkin.Types
+import Krobotkin.Monad
+
+import Network.Xmpp
+import Data.XML.Types
+
+import Control.Monad.Reader
+
+import qualified Data.Text as T
+
+comeOnline :: BotMonad ()
+comeOnline = do
+   sess <- asks envXmppSess
+   liftIO $ sendPresence presenceOnline sess >> return ()
+
+joinMuc :: MucInfo -> BotMonad ()
+joinMuc muc = do
+   sess <- asks envXmppSess
+   me <- liftIO $ getJid sess
+   liftIO $ putStrLn $ "joining muc: " ++ show (mucJidNick muc)
+   case me of
+      Nothing -> liftIO $ putStrLn "error: failed to get jid from session"
+      Just n -> do
+         liftIO $ sendPresence
+            (Presence
+               { presenceID = Nothing
+               , presenceFrom = Just n
+               , presenceTo = Just $ mucJidNick muc
+               , presenceLangTag = Nothing
+               , presenceType = Available
+               , presencePayload = [(
+                  Element
+                     { elementName = "{http://jabber.org/protocol/muc}x"
+                     , elementAttributes = []
+                     , elementNodes = []
+                     }
+                  )]
+               , presenceAttributes = []
+            })
+            sess >> return ()
+
+sendMucMessage :: T.Text -> Jid -> BotMonad ()
+sendMucMessage content muc = do
+   sess <- asks envXmppSess
+   me <- liftIO $ getJid sess
+   stid <- liftIO $ newStanzaID sess
+   liftIO $ sendMessage
+      (Message
+         { messageID = Just stid
+         , messageFrom = me
+         , messageTo = Just muc
+         , messageLangTag = Nothing
+         , messageType = GroupChat
+         , messageAttributes = []
+         , messagePayload = [(
+            Element {
+               elementName = "body"
+             , elementAttributes = []
+             , elementNodes = [
+                 (NodeContent $ ContentText content)
+               ]
+            }
+         )]
+      })
+      sess >> return ()
+
+getMucMessageBody :: Message -> Maybe T.Text
+getMucMessageBody m =
+   if elements == []
+   then Nothing
+   else case head (elementNodes $ head elements) of
+      (NodeContent (ContentText content)) -> Just content
+      _ -> Nothing
+   where
+      elements = filter (\p -> (nameLocalName (elementName p)) == "body") pl
+      pl = messagePayload m

src/Krobotkin/Options.hs

@@ -0,0 +1,44 @@
+module Krobotkin.Options where
+
+import Options.Applicative
+
+data Flags = Flags
+   { flagUsername :: String
+   , flagServer   :: String
+   , flagPassword :: String
+   , flagMucs     :: [String]
+   } deriving Show
+
+options :: Parser Flags
+options = Flags
+   <$> strOption
+       ( long "username"
+      <> short 'u'
+      <> metavar "USERNAME"
+      <> help "xmpp username" )
+   <*> strOption
+       ( long "server"
+      <> short 's'
+      <> metavar "SERVER"
+      <> help "xmpp server" )
+   <*> strOption
+       ( long "password"
+      <> short 'p'
+      <> metavar "PASSWORD"
+      <> help "account password" )
+   <*> multiString
+       ( long "mucs"
+      <> short 'm'
+      <> metavar "MUC"
+      <> help "muc to join" )
+
+multiString :: Mod OptionFields [String] -> Parser [String]
+multiString desc = concat <$> many single
+   where
+      single = option (str >>= return . words) desc
+
+getOptions :: ParserInfo Flags
+getOptions = info (options <**> helper)
+    ( fullDesc
+   <> header "krobotkin - an xmpp muc bot"
+   <> progDesc "a friendly bot for your xmpp mucs :)" )

src/Krobotkin/Setup.hs

@@ -0,0 +1,53 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Krobotkin.Setup where
+
+import Krobotkin.Options
+import Krobotkin.Types
+
+import Network.Xmpp
+
+import Data.Maybe
+import System.Random
+
+import qualified Data.Text as T
+
+-- TODO: have this report errors
+createMucInfo :: Flags -> [MucInfo]
+createMucInfo opts = catMaybes $ map
+   (packMucInfo $ T.pack (flagUsername opts))
+   (map T.pack (flagMucs opts))
+
+packMucInfo :: T.Text -> T.Text -> Maybe MucInfo
+packMucInfo username muc =
+   case jidToTexts <$> jidFromText muc of
+      Nothing -> Nothing
+      Just (user, server, resource) ->
+         let n = jidFromTexts user server $ Just $ T.replace "_" " " (fromMaybe username resource)
+         in case n of
+            Nothing -> Nothing
+            Just o -> Just $ MucInfo (toBare o) o
+
+createXmppSession :: Flags -> IO Session
+createXmppSession opts = do
+   sess <- session server login config
+   case sess of
+      Left e -> error $ "xmpp-failure: " ++ show e
+      Right s -> return s
+   where
+      username = T.pack $ flagUsername opts
+      password = T.pack $ flagPassword opts
+      server = flagServer opts
+      login = (Just (\_ -> ([scramSha1 username Nothing password]), Nothing))
+      config = def { keepAlive = Just 60 }
+
+createEnv :: Flags -> IO AppEnv
+createEnv opts = do
+   sess <- createXmppSession opts
+   return $ AppEnv sess (createMucInfo opts)
+
+createState :: IO AppState
+createState = do
+   rng <- getStdGen
+   return $ AppState rng
+

src/Krobotkin/Stanza.hs

@@ -0,0 +1,35 @@
+module Krobotkin.Stanza where
+
+import Krobotkin.Muc
+import Krobotkin.Types
+
+import Network.Xmpp
+import Network.Xmpp.Internal
+
+import Data.Char
+
+import qualified Data.Text as T
+
+packStanza :: Stanza -> PackedStanza
+packStanza (MessageS m) = packMessage m
+packStanza (PresenceS p) = packPresence p
+packStanza _ = BotIgnore
+
+packPresence :: Presence -> PackedStanza
+packPresence p =
+   case (presenceFrom p) of
+      Just f -> BotPresence f (presenceType p) p
+      _ -> BotIgnore
+
+packMessage :: Message -> PackedStanza
+packMessage m =
+   let toUser = messageTo m
+       fromUser = messageFrom m
+   in case (messageType m) of
+      GroupChat -> case getMucMessageBody m of
+         Nothing -> BotIgnore
+         Just b -> case (toUser,fromUser) of
+            (Just t, Just f) -> BotMessage t f (map toUpper (T.unpack b)) m
+            _ -> BotIgnore
+      _ -> BotIgnore
+

src/Krobotkin/Types.hs

@@ -0,0 +1,24 @@
+module Krobotkin.Types where
+
+import Network.Xmpp
+import System.Random
+
+data AppEnv = AppEnv
+   { envXmppSess :: Session
+   , envMucInfo  :: [MucInfo]
+   }
+
+data MucInfo = MucInfo
+   { mucJid :: Jid
+   , mucJidNick :: Jid
+   }
+
+data AppState = AppState
+   { stateRNG :: StdGen
+   }
+
+data PackedStanza =
+     BotPresence Jid PresenceType Presence
+   | BotMessage Jid Jid String Message
+   | BotIgnore
+

src/Main.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE OverloadedStrings          #-}
+
+module Main where
+
+import Krobotkin.Handlers
+import Krobotkin.Monad
+import Krobotkin.Muc
+import Krobotkin.Options
+import Krobotkin.Setup
+import Krobotkin.Stanza
+import Krobotkin.Types
+
+import Control.Monad
+import Control.Monad.Reader
+
+import Network.Xmpp
+import Options.Applicative
+
+main :: IO ()
+main = do
+   opts <- execParser getOptions
+   env <- createEnv opts
+   state <- createState
+   runBotMonad env state $ do
+      mucs <- asks envMucInfo
+      mapM_ joinMuc mucs
+      mapM_ (sendMucMessage "greetings, comrades!") $ map mucJid mucs
+      sess <- asks envXmppSess
+      forever $ do
+        (st,_) <- liftIO $ getStanza sess
+        dispatchStanza $ packStanza st