1 files changed, 79 insertions, 0 deletions
diff --git a/Hirc/Bot.hs b/Hirc/Bot.hs
new file mode 100644
index 0000000..9cdeeaf
--- /dev/null
+++ b/Hirc/Bot.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Hirc.Bot where
+
+import Prelude hiding (read)
+import Network
+import System.IO
+import Control.Concurrent.STM
+import Control.Monad.Reader
+import Control.Exception
+import Hirc.Parser as P
+import Hirc.Types
+import Text.Parsec (parse)
+
+runBot :: Config -> Hooks -> IO ()
+runBot Config{..} Hooks{..} =
+    bracket (connect config_server) disconnect run
+  where
+    connect Server{..} = do
+      socket <- connectTo hostname (PortNumber (fromIntegral port))
+      nick <- atomically $ newTVar config_nick
+      chan <- atomically $ newTVar config_chan
+      hSetBuffering socket NoBuffering
+      return Bot {
+        bot_server = config_server,
+        bot_nick = nick,
+        bot_chan = chan,
+        bot_socket = socket
+      }
+
+    disconnect bot@Bot{bot_socket=h} = do
+        hClose h
+        runReaderT hooks_onDisconnect bot
+
+    run bot = do
+      runReaderT (hooks_onConnect >> receive hooks_onMessage hooks_onError) bot
+
+    receive :: (Message -> Net ()) -> (Error -> Net ()) -> Net ()
+    receive onMessage onError = do
+      server <- asks bot_server
+      socket <- asks bot_socket
+      forever $ do
+        s <- init <$> liftIO (hGetLine socket)
+        case parse P.message (show server) s of
+          Right m -> do
+              case m of
+                  Message _ "PING" [x] -> do
+                      h <- asks bot_socket
+                      liftIO $ hPutStr h $ "PONG :" ++ x ++ "\r\n"
+                  _ -> return ()
+              onMessage m
+          e -> onError $ BadMessage $ show e -- TODO
+
+atomic :: (Bot -> a) -> (a -> STM b) -> Net b
+atomic v f = asks v >>= liftIO . atomically . f
+
+read :: (Bot -> TVar a) -> Net a
+read v = atomic v readTVar
+
+write :: (Bot -> TVar a) -> a -> Net ()
+write v = atomic v . flip writeTVar
+
+
+bumpNick :: Net String
+bumpNick =
+    atomic bot_nick $ flip updateTVar $ \nick ->
+      case parse P.nickNum "bumpNick" nick of
+        Right (n,i) -> n ++ show (i+1)
+        _ -> nick ++ "_"
+
+
+-- Like modifyTVar but returns the new value.
+updateTVar :: TVar a -> (a -> a) -> STM a
+updateTVar v f = do
+    x <- readTVar v
+    let x' = f x
+    writeTVar v x'
+    return x'