diff options
Diffstat (limited to 'Hirc')
| -rw-r--r-- | Hirc/Bot.hs | 79 | ||||
| -rw-r--r-- | Hirc/Format.hs | 15 | ||||
| -rw-r--r-- | Hirc/Parser.hs | 8 | ||||
| -rw-r--r-- | Hirc/Types.hs | 43 |
4 files changed, 145 insertions, 0 deletions
diff --git a/Hirc/Bot.hs b/Hirc/Bot.hs new file mode 100644 index 0000000..9cdeeaf --- /dev/null +++ b/Hirc/Bot.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + +module Hirc.Bot where + +import Prelude hiding (read) +import Network +import System.IO +import Control.Concurrent.STM +import Control.Monad.Reader +import Control.Exception +import Hirc.Parser as P +import Hirc.Types +import Text.Parsec (parse) + +runBot :: Config -> Hooks -> IO () +runBot Config{..} Hooks{..} = + bracket (connect config_server) disconnect run + where + connect Server{..} = do + socket <- connectTo hostname (PortNumber (fromIntegral port)) + nick <- atomically $ newTVar config_nick + chan <- atomically $ newTVar config_chan + hSetBuffering socket NoBuffering + return Bot { + bot_server = config_server, + bot_nick = nick, + bot_chan = chan, + bot_socket = socket + } + + disconnect bot@Bot{bot_socket=h} = do + hClose h + runReaderT hooks_onDisconnect bot + + run bot = do + runReaderT (hooks_onConnect >> receive hooks_onMessage hooks_onError) bot + + receive :: (Message -> Net ()) -> (Error -> Net ()) -> Net () + receive onMessage onError = do + server <- asks bot_server + socket <- asks bot_socket + forever $ do + s <- init <$> liftIO (hGetLine socket) + case parse P.message (show server) s of + Right m -> do + case m of + Message _ "PING" [x] -> do + h <- asks bot_socket + liftIO $ hPutStr h $ "PONG :" ++ x ++ "\r\n" + _ -> return () + onMessage m + e -> onError $ BadMessage $ show e -- TODO + +atomic :: (Bot -> a) -> (a -> STM b) -> Net b +atomic v f = asks v >>= liftIO . atomically . f + +read :: (Bot -> TVar a) -> Net a +read v = atomic v readTVar + +write :: (Bot -> TVar a) -> a -> Net () +write v = atomic v . flip writeTVar + + +bumpNick :: Net String +bumpNick = + atomic bot_nick $ flip updateTVar $ \nick -> + case parse P.nickNum "bumpNick" nick of + Right (n,i) -> n ++ show (i+1) + _ -> nick ++ "_" + + +-- Like modifyTVar but returns the new value. +updateTVar :: TVar a -> (a -> a) -> STM a +updateTVar v f = do + x <- readTVar v + let x' = f x + writeTVar v x' + return x' diff --git a/Hirc/Format.hs b/Hirc/Format.hs new file mode 100644 index 0000000..bf6546a --- /dev/null +++ b/Hirc/Format.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +module Hirc.Format where + +import Hirc.Types + +formatMessage :: Message -> String +formatMessage Message{..} = + maybe "" prefix m_prefix ++ m_command ++ params + where + prefix Prefix{..} = + ":" ++ p_name ++ maybe "" user p_user ++ maybe "" host p_host ++ " " + user x = "!" ++ x + host x = "@" ++ x + params = concatMap (" "++) (init m_params) ++ " :" ++ last m_params diff --git a/Hirc/Parser.hs b/Hirc/Parser.hs index f52564b..7014171 100644 --- a/Hirc/Parser.hs +++ b/Hirc/Parser.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} module Hirc.Parser where import Data.Char @@ -21,3 +22,10 @@ message = trailing = char ':' *> many anyChar middle = many1 nonspace nonspace = satisfy (not . isSpace) + + + +nickNum :: Parser (String, Int) +nickNum = + (,) <$> (many1 (satisfy (not . isDigit))) + <*> ((digitToInt <$> digit) <|> pure 0) diff --git a/Hirc/Types.hs b/Hirc/Types.hs index 2567b53..c516ba7 100644 --- a/Hirc/Types.hs +++ b/Hirc/Types.hs @@ -1,5 +1,11 @@ +{-# LANGUAGE RecordWildCards #-} + module Hirc.Types where +import System.IO (Handle) +import Control.Concurrent.STM (TVar) +import Control.Monad.Reader (ReaderT) + type Command = String type Param = String type Receiver = String @@ -12,6 +18,10 @@ data Message = } deriving Show +data Error = + BadMessage String + deriving Show + data Prefix = Prefix { p_name :: String, @@ -20,3 +30,36 @@ data Prefix = } deriving Show +type Net = ReaderT Bot IO + +data Bot = Bot { + bot_server :: Server, + bot_nick :: TVar String, + bot_chan :: TVar String, + bot_socket :: Handle +} + +data Config = + Config { + config_server :: Server, + config_nick :: String, + config_chan :: String + } + deriving Show + +data Hooks = + Hooks { + hooks_onConnect :: Net (), + hooks_onDisconnect :: Net (), + hooks_onError :: Error -> Net (), + hooks_onMessage :: Message -> Net () + --hooks_shell :: Net() + } + +data Server = + Server { + hostname :: String, + port :: Int + } +instance Show Server where + show Server{..} = hostname ++ ":" ++ show port |