Add ReaderT monad Net () to pass around network socket

[user/henk/code/haskell/birch.git] / src / Lib.hs

diff --git a/src/Lib.hs b/src/Lib.hs
index 12d4dbcb5e36ca56d1c77f0194b248cabac60c1e..0a30efa113c5aeb584785981a1e9e5494587ae44 100644 (file)
--- a/src/Lib.hs
+++ b/src/Lib.hs
@@ -2,18 +2,40 @@ module Lib
     ( runBirch
     ) where
 
-import           System.IO            -- base
-import qualified Network.Socket as N  -- network
+import           System.IO                      -- base
+import qualified Network.Socket as N            -- network
+import           Control.Monad.Trans.Reader     -- transformers
+import           Control.Monad.IO.Class
+import           Data.List
+import           System.Exit
+import           Control.Exception
+
+data Bot = Bot { botSocket :: Handle }
+type Net = ReaderT Bot IO
+
+type Nick = String
+type Realname = String
 
 -- Toplevel program
 runBirch :: String -> N.PortNumber -> String -> [String] -> IO ()
-runBirch myServer myPort myNick myChannels = do
+runBirch myServer myPort myNick myChannels = bracket
+    (connect myServer myPort)
+    disconnect
+    loop
+  where
+    disconnect = hClose . botSocket
+    loop st = runReaderT (run myNick "tutorial bot") st
+
+
+connect :: String -> N.PortNumber -> IO Bot
+connect myServer myPort = notify $ do
     h <- connectTo myServer myPort
-    write h "NICK" myNick
-    write h "USER" (myNick ++ " 0 * :tutorial bot")
---    map (write h "JOIN") myChannels
-    write h "JOIN" (head myChannels)
-    listen h
+    return (Bot h)
+  where
+    notify a = bracket_
+      (putStrLn ("Connecting to " ++ myServer ++ " ...") >> hFlush stdout)
+      (putStrLn "done.")
+      a
 
 -- Connect to a server given its name and port number
 connectTo :: N.HostName -> N.PortNumber -> IO Handle
@@ -23,18 +45,62 @@ connectTo host port = do
     N.connect sock (N.addrAddress addr)
     N.socketToHandle sock ReadWriteMode
 
+-- Join a channel, and start processing commands
+run :: Nick -> Realname -> Net ()
+run myNick myRealname = do
+    register myNick myRealname
+    listen
+
 -- Send a message to a handle
-write :: Handle -> String -> String -> IO ()
-write h cmd args = do
+write :: String -> String -> Net ()
+write cmd args = do
+    h <- asks botSocket
     let msg = cmd ++ " " ++ args ++ "\r\n"
-    hPutStr h msg          -- Send message on the wire
-    putStr ("> " ++ msg)   -- Show sent message on the command line
+    liftIO $ hPutStr h msg          -- Send message on the wire
+    liftIO $ putStr ("> " ++ msg)   -- Show sent message on the command line
 
 -- Process each line from the server
-listen :: Handle -> IO ()
-listen h = forever $ do
-    line <- hGetLine h
-    putStrLn line
+listen :: Net ()
+listen = forever $ do
+    h <- asks botSocket
+    line <- liftIO $ hGetLine h
+    liftIO $ putStrLn line
+    let s = init line
+    if isPing s then pong s else eval (clean s)
   where
-    forever :: IO () -> IO ()
+    forever :: Net () -> Net ()
     forever a = do a; forever a
+
+clean :: String -> String
+clean = drop 1 . dropWhile (/= ':') . drop 1
+
+isPing :: String -> Bool
+isPing x = "PING :" `isPrefixOf` x
+
+pong :: String -> Net ()
+pong x = write "PONG" (':' : drop 6 x)
+
+-- Dispatch a command
+eval :: String -> Net ()
+eval "!quit"              = write "QUIT" ":Exiting" >> liftIO exitSuccess
+eval x
+  | "!id " `isPrefixOf` x = privmsg (drop 4 x)
+eval _                    = return () -- ignore everything else
+
+-- Send a privmsg to a channel
+privmsg :: String -> Net ()
+privmsg msg = write "PRIVMSG" ("#nais-testing" ++ " :" ++ msg)
+
+-- Register with the server
+register :: Nick -> Realname -> Net ()
+register nick realname = do
+  sendNICK nick
+  sendUSER nick realname
+
+-- Send NICK command
+sendNICK :: Nick -> Net ()
+sendNICK = write "NICK"
+
+-- Send USER command
+sendUSER :: Nick -> Realname -> Net ()
+sendUSER nick realname = write "USER" (nick ++ " 0 * :" ++ realname)