Add ReaderT monad Net () to pass around network socket

diff --git a/src/Lib.hs b/src/Lib.hs
index 43da951ceae339ec899b690c4ab39042552c6f01..0a30efa113c5aeb584785981a1e9e5494587ae44 100644 (file)
--- a/src/Lib.hs
+++ b/src/Lib.hs
@@ -5,28 +5,37 @@ module Lib
 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 User = 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
-    register h myNick "tutorial bot"
-    line <- hGetLine h
-    putStrLn line
-    let s = init line
-    if isPing s then pong h s else eval h (clean s)
---    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
@@ -36,22 +45,30 @@ 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 h s else eval h (clean s)
+    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
@@ -60,29 +77,30 @@ clean = drop 1 . dropWhile (/= ':') . drop 1
 isPing :: String -> Bool
 isPing x = "PING :" `isPrefixOf` x
 
-pong :: Handle -> String -> IO ()
-pong h x = write h "PONG" (':' : drop 6 x)
+pong :: String -> Net ()
+pong x = write "PONG" (':' : drop 6 x)
 
 -- Dispatch a command
-eval :: Handle -> String -> IO ()
-eval h "!quit"                    = write h "QUIT" ":Exiting" >> exitSuccess
-eval h x | "!id " `isPrefixOf` x  = privmsg h (drop 4 x)
-eval _ _                          = return () -- ignore everything else
+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 :: Handle -> String -> IO ()
-privmsg h s = write h "PRIVMSG" ("#nais-testing" ++ " :" ++ s)
+privmsg :: String -> Net ()
+privmsg msg = write "PRIVMSG" ("#nais-testing" ++ " :" ++ msg)
 
 -- Register with the server
-register :: Handle -> Nick -> Realname -> IO ()
-register h nick realname = do
-  sendNICK h nick
-  sendUSER h nick realname
+register :: Nick -> Realname -> Net ()
+register nick realname = do
+  sendNICK nick
+  sendUSER nick realname
 
 -- Send NICK command
-sendNICK :: Handle -> Nick -> IO ()
-sendNICK h nick = write h "NICK" nick
+sendNICK :: Nick -> Net ()
+sendNICK = write "NICK"
 
 -- Send USER command
-sendUSER :: Handle -> Nick -> Realname -> IO ()
-sendUSER h nick realname = write h "USER" (nick ++ " 0 * :" ++ realname)
+sendUSER :: Nick -> Realname -> Net ()
+sendUSER nick realname = write "USER" (nick ++ " 0 * :" ++ realname)