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 d36ff2714d5b36319784afa370e0f0d111d57ef1..0a30efa113c5aeb584785981a1e9e5494587ae44 100644 (file)
--- a/src/Lib.hs
+++ b/src/Lib.hs
@@ -1,6 +1,106 @@
 module Lib
-    ( someFunc
+    ( runBirch
     ) where
 
-someFunc :: IO ()
-someFunc = putStrLn "someFunc"
+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 = 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
+    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
+connectTo host port = do
+    addr : _ <- N.getAddrInfo Nothing (Just host) (Just (show port))
+    sock <- N.socket (N.addrFamily addr) (N.addrSocketType addr) (N.addrProtocol addr)
+    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 :: String -> String -> Net ()
+write cmd args = do
+    h <- asks botSocket
+    let msg = cmd ++ " " ++ args ++ "\r\n"
+    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 :: 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 :: 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)