replace hirc.hs by main.hs

4 files changed, 145 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'
diff --git a/Hirc/Format.hs b/Hirc/Format.hs
new file mode 100644
index 0000000..bf6546a
--- /dev/null
+++ b/Hirc/Format.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+module Hirc.Format where
+
+import Hirc.Types
+
+formatMessage :: Message -> String
+formatMessage Message{..} =
+    maybe "" prefix m_prefix ++ m_command ++ params
+  where
+    prefix Prefix{..} =
+      ":" ++ p_name ++ maybe "" user p_user ++ maybe "" host p_host ++ " "
+    user x = "!" ++ x
+    host x = "@" ++ x
+    params = concatMap (" "++) (init m_params) ++ " :" ++ last m_params
diff --git a/Hirc/Parser.hs b/Hirc/Parser.hs
index f52564b..7014171 100644
--- a/Hirc/Parser.hs
+++ b/Hirc/Parser.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 module Hirc.Parser where
 
 import Data.Char
@@ -21,3 +22,10 @@ message =
     trailing = char ':' *> many anyChar
     middle = many1 nonspace
     nonspace = satisfy (not . isSpace)
+
+
+
+nickNum :: Parser (String, Int)
+nickNum =
+  (,) <$> (many1 (satisfy (not . isDigit)))
+      <*> ((digitToInt <$> digit) <|> pure 0)
diff --git a/Hirc/Types.hs b/Hirc/Types.hs
index 2567b53..c516ba7 100644
--- a/Hirc/Types.hs
+++ b/Hirc/Types.hs
@@ -1,5 +1,11 @@
+{-# LANGUAGE RecordWildCards #-}
+
 module Hirc.Types where
 
+import System.IO (Handle)
+import Control.Concurrent.STM (TVar)
+import Control.Monad.Reader (ReaderT)
+
 type Command = String
 type Param = String
 type Receiver = String
@@ -12,6 +18,10 @@ data Message =
   }
   deriving Show
 
+data Error =
+    BadMessage String
+  deriving Show
+
 data Prefix =
   Prefix {
     p_name :: String,
@@ -20,3 +30,36 @@ data Prefix =
   }
   deriving Show
 
+type Net = ReaderT Bot IO
+
+data Bot = Bot {
+  bot_server :: Server,
+  bot_nick :: TVar String,
+  bot_chan :: TVar String,
+  bot_socket :: Handle
+}
+
+data Config =
+    Config {
+      config_server :: Server,
+      config_nick :: String,
+      config_chan :: String
+    }
+  deriving Show
+
+data Hooks =
+    Hooks {
+      hooks_onConnect :: Net (),
+      hooks_onDisconnect :: Net (),
+      hooks_onError :: Error -> Net (),
+      hooks_onMessage :: Message -> Net ()
+      --hooks_shell :: Net()
+    }
+
+data Server =
+    Server {
+      hostname :: String,
+      port :: Int
+    }
+instance Show Server where
+    show Server{..} = hostname ++ ":" ++ show port