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           Control.Monad.IO.Class
   9 import           Data.List
  10 import           System.Exit
  11 import           Control.Exception
  12
  13 data Bot = Bot { botSocket :: Handle }
  14 type Net = ReaderT Bot IO
  15
  16 type Nick = String
  17 type Realname = String
  18
  19 -- Toplevel program
  20 runBirch :: String -> N.PortNumber -> String -> [String] -> IO ()
  21 runBirch myServer myPort myNick myChannels = bracket
  22     (connect myServer myPort)
  23     disconnect
  24     loop
  25   where
  26     disconnect = hClose . botSocket
  27     loop st = runReaderT (run myNick "tutorial bot") st
  28
  29
  30 connect :: String -> N.PortNumber -> IO Bot
  31 connect myServer myPort = notify $ do
  32     h <- connectTo myServer myPort
  33     return (Bot h)
  34   where
  35     notify a = bracket_
  36       (putStrLn ("Connecting to " ++ myServer ++ " ...") >> hFlush stdout)
  37       (putStrLn "done.")
  38       a
  39
  40 -- Connect to a server given its name and port number
  41 connectTo :: N.HostName -> N.PortNumber -> IO Handle
  42 connectTo host port = do
  43     addr : _ <- N.getAddrInfo Nothing (Just host) (Just (show port))
  44     sock <- N.socket (N.addrFamily addr) (N.addrSocketType addr) (N.addrProtocol addr)
  45     N.connect sock (N.addrAddress addr)
  46     N.socketToHandle sock ReadWriteMode
  47
  48 -- Join a channel, and start processing commands
  49 run :: Nick -> Realname -> Net ()
  50 run myNick myRealname = do
  51     register myNick myRealname
  52     listen
  53
  54 -- Send a message to a handle
  55 write :: String -> String -> Net ()
  56 write cmd args = do
  57     h <- asks botSocket
  58     let msg = cmd ++ " " ++ args ++ "\r\n"
  59     liftIO $ hPutStr h msg          -- Send message on the wire
  60     liftIO $ putStr ("> " ++ msg)   -- Show sent message on the command line
  61
  62 -- Process each line from the server
  63 listen :: Net ()
  64 listen = forever $ do
  65     h <- asks botSocket
  66     line <- liftIO $ hGetLine h
  67     liftIO $ putStrLn line
  68     let s = init line
  69     if isPing s then pong s else eval (clean s)
  70   where
  71     forever :: Net () -> Net ()
  72     forever a = do a; forever a
  73
  74 clean :: String -> String
  75 clean = drop 1 . dropWhile (/= ':') . drop 1
  76
  77 isPing :: String -> Bool
  78 isPing x = "PING :" `isPrefixOf` x
  79
  80 pong :: String -> Net ()
  81 pong x = write "PONG" (':' : drop 6 x)
  82
  83 -- Dispatch a command
  84 eval :: String -> Net ()
  85 eval "!quit"              = write "QUIT" ":Exiting" >> liftIO exitSuccess
  86 eval x
  87   | "!id " `isPrefixOf` x = privmsg (drop 4 x)
  88 eval _                    = return () -- ignore everything else
  89
  90 -- Send a privmsg to a channel
  91 privmsg :: String -> Net ()
  92 privmsg msg = write "PRIVMSG" ("#nais-testing" ++ " :" ++ msg)
  93
  94 -- Register with the server
  95 register :: Nick -> Realname -> Net ()
  96 register nick realname = do
  97   sendNICK nick
  98   sendUSER nick realname
  99
 100 -- Send NICK command
 101 sendNICK :: Nick -> Net ()
 102 sendNICK = write "NICK"
 103
 104 -- Send USER command
 105 sendUSER :: Nick -> Realname -> Net ()
 106 sendUSER nick realname = write "USER" (nick ++ " 0 * :" ++ realname)