From b7da959c069598382298de0bc166236d0b0389ce Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 27 Mar 2021 06:06:34 +0100 Subject: [PATCH] monadize --- parrotbot.cabal | 3 +- shell.nix | 4 +- src/Main.hs | 103 +++++++++++++++++++++++++++++++----------------- src/Types.hs | 11 ++++++ 4 files changed, 82 insertions(+), 39 deletions(-) create mode 100644 src/Types.hs diff --git a/parrotbot.cabal b/parrotbot.cabal index f79f8bf..bad8563 100644 --- a/parrotbot.cabal +++ b/parrotbot.cabal @@ -23,11 +23,12 @@ executable parrotbot main-is: Main.hs -- Modules included in this executable, other than Main. - -- other-modules: + other-modules: Types -- LANGUAGE extensions used by modules in this package. -- other-extensions: build-depends: base >=4.14.1.0 , network + , mtl hs-source-dirs: src default-language: Haskell2010 diff --git a/shell.nix b/shell.nix index 8495c72..6336261 100644 --- a/shell.nix +++ b/shell.nix @@ -4,14 +4,14 @@ let inherit (nixpkgs) pkgs; - f = { mkDerivation, base, lib, network }: + f = { mkDerivation, base, lib, mtl, network }: mkDerivation { pname = "parrotbot"; version = "0.0.0.0"; src = ./.; isLibrary = false; isExecutable = true; - executableHaskellDepends = [ base network ]; + executableHaskellDepends = [ base mtl network ]; description = "polly wanna cracker"; license = lib.licenses.gpl3Plus; }; diff --git a/src/Main.hs b/src/Main.hs index f1d67be..b82df1b 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -4,30 +4,62 @@ module Main where import System.IO import System.Exit (exitSuccess) +import Control.Exception (bracket, bracket_) + +import Control.Monad.Reader +import Control.Monad.IO.Class (liftIO) + import Data.List (intercalate, isPrefixOf) import qualified Network.Socket as N +-- internal imports +import Types + -- configuration options (TODO: Move to yaml and read from there) server = "irc.freenode.org" port = 6667 chan = "#parrotbot-testing" nick = "parrotbot" +-- | Entry point main :: IO () -main = do - handle <- connect server port - write handle "NICK" nick - write handle "USER" (nick <> " 0 * :parrot bot") - write handle "JOIN" chan - listen handle +main = + bracket connect disconnect loop + where + disconnect = hClose . botSocket + loop st = runReaderT run st --- | Connect to an IRC server given domain name and port +-- | Process bot comands inside of its monad +run + :: Net () +run = do + write "NICK" nick + write "USER" (nick <> " 0 * :parrot bot") + write "JOIN" chan + listen + +-- | Connect to the server und return the initial bot state connect + :: IO Bot +connect = notify $ do + handle <- connectTo server port + return (Bot handle) + where + notify a = bracket_ + (do + putStrLn ("Connecting to " <> server <> "…") + hFlush stdout + ) + (putStrLn "done.") + a + +-- | Connect to an IRC server given domain name and port (Helper for 'connect' +connectTo :: N.HostName -- ^ Domain to connect to -> N.PortNumber -- ^ Port to connect to -> IO Handle -- ^ Handle for the connection -connect chost cport = do +connectTo chost cport = do (addr:_) <- N.getAddrInfo Nothing (Just chost) (Just (show cport)) sock <- N.socket (N.addrFamily addr) @@ -38,37 +70,37 @@ connect chost cport = do -- | Send messages to IRC write - :: Handle -- ^ Connection handle - -> String -- ^ Command to issue + :: String -- ^ Command to issue -> String -- ^ Command argument(s) - -> IO () -write handle cmd args = do + -> Net () +write cmd args = do let msg = intercalate " " [cmd, args, "\r\n"] - hPutStr handle msg - print ("> " <> msg) + handle <- asks botSocket + liftIO $ do + hPutStr handle msg + putStr ("> " <> msg) -- | Send Messages via PRIVMSG to the connected Channel privmsg - :: Handle -- ^ Connection handle - -> String -- ^ Message Content - -> IO () -privmsg handle msg = write handle "PRIVMSG" (chan <> " :" <> msg) + :: String -- ^ Message Content + -> Net () +privmsg msg = write "PRIVMSG" (chan <> " :" <> msg) -- | Listen to and process messages from IRC listen - :: Handle -- ^ Connection handle - -> IO () -listen handle = forever $ do - line <- hGetLine handle - putStrLn line + :: Net () +listen = forever $ do + handle <- asks botSocket + line <- liftIO $ hGetLine handle + liftIO $ putStrLn line let s = init line if isPing s then pong s else - evaluate handle (clean s) + evaluate (clean s) where - forever :: IO () -> IO () + forever :: Net () -> Net () forever a = do a forever a @@ -79,18 +111,17 @@ listen handle = forever $ do isPing :: String -> Bool isPing s = "PING" `isPrefixOf` s - pong :: String -> IO () - pong x = write handle "PONG" (':' : drop 6 x) + pong :: String -> Net () + pong x = write "PONG" (':' : drop 6 x) -- | Evaluate input from IRC evaluate - :: Handle -- ^ Connection handle - -> String -- ^ Input to be processed - -> IO () -evaluate handle "!quit" = do - write handle "QUIT" ":I have been orderd to go" - exitSuccess -evaluate handle text | "!say " `isPrefixOf` text = - privmsg handle (drop 4 text) -evaluate _ _ = + :: String -- ^ Input to be processed + -> Net () +evaluate "!quit" = do + write "QUIT" ":I have been orderd to go" + liftIO exitSuccess +evaluate text | "!say " `isPrefixOf` text = + privmsg (drop 5 text) +evaluate _ = return () diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 index 0000000..3dd0dc6 --- /dev/null +++ b/src/Types.hs @@ -0,0 +1,11 @@ +module Types where + +import Control.Monad.Reader (ReaderT(..)) + +import System.IO (Handle) + +data Bot = Bot + { botSocket :: Handle + } + +type Net = ReaderT Bot IO