src/Lib.hs

   1 module Lib
   2     ( runBirch
   3     ) where
   4
   5 import           System.IO                      -- base
   6 import qualified Network.Socket as N            -- network
   7 import           Control.Monad.Trans.Reader     -- transformers
   8 import           Data.List
   9 import           System.Exit
  10
  11 data Bot = Bot { botSocket :: Handle }
  12 type Net = ReaderT Bot IO
  13
  14 type Nick = String
  15 type User = String
  16 type Realname = String
  17
  18 -- Toplevel program
  19 runBirch :: String -> N.PortNumber -> String -> [String] -> IO ()
  20 runBirch myServer myPort myNick myChannels = do
  21     h <- connectTo myServer myPort
  22     register h myNick "tutorial bot"
  23     line <- hGetLine h
  24     putStrLn line
  25     let s = init line
  26     if isPing s then pong h s else eval h (clean s)
  27 --    map (write h "JOIN") myChannels
  28     write h "JOIN" (head myChannels)
  29     listen h
  30
  31 -- Connect to a server given its name and port number
  32 connectTo :: N.HostName -> N.PortNumber -> IO Handle
  33 connectTo host port = do
  34     addr : _ <- N.getAddrInfo Nothing (Just host) (Just (show port))
  35     sock <- N.socket (N.addrFamily addr) (N.addrSocketType addr) (N.addrProtocol addr)
  36     N.connect sock (N.addrAddress addr)
  37     N.socketToHandle sock ReadWriteMode
  38
  39 -- Send a message to a handle
  40 write :: Handle -> String -> String -> IO ()
  41 write h cmd args = do
  42     let msg = cmd ++ " " ++ args ++ "\r\n"
  43     hPutStr h msg          -- Send message on the wire
  44     putStr ("> " ++ msg)   -- Show sent message on the command line
  45
  46 -- Process each line from the server
  47 listen :: Handle -> IO ()
  48 listen h = forever $ do
  49     line <- hGetLine h
  50     putStrLn line
  51     let s = init line
  52     if isPing s then pong h s else eval h (clean s)
  53   where
  54     forever :: IO () -> IO ()
  55     forever a = do a; forever a
  56
  57 clean :: String -> String
  58 clean = drop 1 . dropWhile (/= ':') . drop 1
  59
  60 isPing :: String -> Bool
  61 isPing x = "PING :" `isPrefixOf` x
  62
  63 pong :: Handle -> String -> IO ()
  64 pong h x = write h "PONG" (':' : drop 6 x)
  65
  66 -- Dispatch a command
  67 eval :: Handle -> String -> IO ()
  68 eval h "!quit"                    = write h "QUIT" ":Exiting" >> exitSuccess
  69 eval h x | "!id " `isPrefixOf` x  = privmsg h (drop 4 x)
  70 eval _ _                          = return () -- ignore everything else
  71
  72 -- Send a privmsg to a channel
  73 privmsg :: Handle -> String -> IO ()
  74 privmsg h s = write h "PRIVMSG" ("#nais-testing" ++ " :" ++ s)
  75
  76 -- Register with the server
  77 register :: Handle -> Nick -> Realname -> IO ()
  78 register h nick realname = do
  79   sendNICK h nick
  80   sendUSER h nick realname
  81
  82 -- Send NICK command
  83 sendNICK :: Handle -> Nick -> IO ()
  84 sendNICK h nick = write h "NICK" nick
  85
  86 -- Send USER command
  87 sendUSER :: Handle -> Nick -> Realname -> IO ()
  88 sendUSER h nick realname = write h "USER" (nick ++ " 0 * :" ++ realname)