initial commit

app/Main.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module Main where
 
 import Lib
@@ -9,6 +11,22 @@ import Network.Socket hiding (recv)
 import Network.Socket.ByteString as S
 import qualified Data.ByteString.Lazy as L
 import Control.Concurrent (threadDelay, forkIO)
+import Data.Text (isInfixOf)
+
+getNick (Message source _ _) = maybe "" id (sourceNick <$> source)
+
+react sock msg = do
+  case (ircCommand msg) of
+    "PING" -> sendMany sock (buildCommand <$> [pong (head $ ircCommandArgs msg)])
+    "PRIVMSG" -> if ("crapbot" `isInfixOf` (head $ tail $ ircCommandArgs msg)) then
+                        sendMany sock
+                          (buildCommand <$>
+                            [privmsg (head $ ircCommandArgs msg) (mconcat ["Hello there ", getNick msg, "!"])])
+                else
+                  return ()
+
+    command -> print command
+  return ()
 
 channel = "#thisisatestwhatever"
 
@@ -24,7 +42,11 @@ getIRCSock addr = socket (addrFamily addr) Stream defaultProtocol
 
 recvLoop sock = do
   msg <- recv sock 4096
-  print $ runParseMessage msg
+  case runParseMessage msg of
+    Left _ -> return ()
+    Right msg -> do
+                  _ <- react sock msg
+                  print msg
   threadDelay 1000000
   recvLoop sock
 
@@ -36,4 +58,7 @@ sendIRCConnect host = do
   threadDelay 1000000
   sendMany sock (buildCommand <$> [userCmd, nickCmd, joinCmd, initMsgCmd])
 
-main = undefined
+main = do
+  _ <- sendIRCConnect "irc.freenode.org"
+  _ <- getLine
+  return ()

package.yaml

@@ -25,6 +25,7 @@ dependencies:
 - bytestring
 - network
 - attoparsec
+- either
 
 library:
   source-dirs: src

src/IRCParser.hs

@@ -1,24 +1,47 @@
 {-# LANGUAGE OverloadedStrings #-}
 module IRCParser where
 
+import Data.Text (strip)
+import Data.Text.Encoding (decodeUtf8)
 import Data.ByteString (pack)
 import Data.Attoparsec.ByteString
 import Control.Applicative
+import Data.Either.Combinators (rightToMaybe)
+import Types
 
--- :nisstyre!wes@oftn/oswg-member/Nisstyre PRIVMSG #thisisatestwhatever :yay\r\n
+stripWhitespace = filter $ (all id) . (sequence $ map (/=) [" ", "\r", "\n", ""])
--- :nisstyre!wes@oftn/oswg-member/Nisstyre PART #thisisatestwhatever :\"WeeChat 2.2\"\r\n
--- :nisstyre!wes@oftn/oswg-member/Nisstyre JOIN #thisisatestwhatever\r\n
--- :nisstyre!wes@oftn/oswg-member/Nisstyre QUIT :Quit: WeeChat 2.2\r\n
--- PING :asimov.freenode.net\r\n
 
 space = word8 32
 notSpace = notWord8 32
+colon = word8 58 -- :
 
 -- 13 = \r, 10 = \n
 crlf c = c == 13 || c == 10
 
--- :
+bang = (== 33) -- !
-colon = word8 58
+atsign = (== 64) -- @
+isSpace = (== 32)
+
+parseNick = takeWhile1 (not . bang)
+
+parseUsername = do
+  _ <- word8 33
+  username <- takeWhile1 (not . atsign)
+  return username
+
+parseHostmask = do
+  _ <- word8 64
+  hostmask <- takeWhile1 (not . isSpace)
+  return hostmask
+
+parseSource = do
+  nickname <- parseNick
+  username <- parseUsername
+  hostmask <- parseHostmask
+  return $ Source
+            (decodeUtf8 nickname)
+            (decodeUtf8 username)
+            (decodeUtf8 hostmask)
 
 command = choice $ map string ["PRIVMSG", "PART", "JOIN", "QUIT", "PING"]
 
@@ -33,7 +56,7 @@ parseArgs = do
   args <- (argument `sepBy` space) <|> alwaysMatch []
   _ <- space <|> (alwaysMatch 0)
   finalArg <- parseFinalArg <|> (alwaysMatch "")
-  return (args, finalArg)
+  return $ args ++ [finalArg]
 
 source = do
   _ <- colon
@@ -49,6 +72,12 @@ parseMessage = do
   commandName <- command
   _ <- space
   arguments <- parseArgs
-  return (pack sourceName, commandName, arguments)
+
+  let source = parseOnly parseSource $ pack sourceName
+
+  return $ Message
+            (rightToMaybe source)
+            (decodeUtf8 commandName)
+            (map strip $ stripWhitespace $ map decodeUtf8 arguments)
 
 runParseMessage = parseOnly parseMessage

src/Lib.hs

@@ -7,15 +7,18 @@ import qualified Data.Text.Encoding as TE
 import Data.ByteString
 import Types
 
-user name desc = Message "USER" [" ", name, " * * :", desc]
+user name desc = Message Nothing "USER" [" ", name, " * * :", desc]
 
-nick name = Message "NICK" [" ", name]
+nick name = Message Nothing "NICK" [" ", name]
 
-join channel = Message "JOIN" [" ", channel]
+join channel = Message Nothing "JOIN" [" ", channel]
 
-privmsg channel message = Message "PRIVMSG" [" ", channel, " :", message]
+privmsg channel message = Message Nothing "PRIVMSG" [" ", channel, " :", message]
 
-quit = Message "QUIT" []
+pong message = Message Nothing "PONG" [":", message]
+
+quit = Message Nothing "QUIT" []
 
 buildCommand :: Message -> ByteString
-buildCommand (Message cmd args) = TE.encodeUtf8 $ (cmd `T.append` (mconcat args)) `T.append` "\r\n"
+buildCommand (Message Nothing cmd args) = TE.encodeUtf8 $ (cmd `T.append` (mconcat args)) `T.append` "\r\n"
+buildCommand (Message (Just source) cmd args) = TE.encodeUtf8 $ (cmd `T.append` (mconcat args)) `T.append` "\r\n"

src/Types.hs

@@ -2,7 +2,14 @@ module Types where
 
 import qualified Data.Text as T
 
+data Source = Source {
+                sourceNick :: T.Text,
+                sourceUsername :: T.Text,
+                sourceHostmask :: T.Text
+              } deriving (Show)
+
 data Message = Message {
+                ircSource :: Maybe Source,
                 ircCommand :: T.Text,
                 ircCommandArgs :: [T.Text]
               } deriving (Show)