commit 41b457dd304d34e278d588830bf90f8d090610d8 Author: Levi Pearson Date: Mon Nov 11 23:56:23 2013 -0700 Initial checkin of pipes-based IRC server; work-in-progress Currently there's a network server that parses commands received on a connection and then renders them on all currently live connections. There are still a couple of bugs in the parser. There's an initial stab at types for managing the server's records for connections. users, and channels, but they will probably evolve a bit. diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..c12f1a1 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Levi Pearson + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Levi Pearson nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/notes.md b/notes.md new file mode 100644 index 0000000..ebff6af --- /dev/null +++ b/notes.md @@ -0,0 +1,220 @@ +ABNF from rfc2812: +------------------ + + message = [ ":" prefix SPACE ] command [ params ] crlf + prefix = servername / ( nickname [ [ "!" user ] "@" host ] ) + command = 1*letter / 3digit + params = *14( SPACE middle ) [ SPACE ":" trailing ] + =/ 14( SPACE middle ) [ SPACE [ ":" ] trailing ] + + nospcrlfcl = %x01-09 / %x0B-0C / %x0E-1F / %x21-39 / %x3B-FF + ; any octet except NUL, CR, LF, " " and ":" + middle = nospcrlfcl *( ":" / nospcrlfcl ) + trailing = *( ":" / " " / nospcrlfcl ) + + SPACE = %x20 ; space character + crlf = %x0D %x0A ; "carriage return" "linefeed" + + target = nickname / server + msgtarget = msgto *( "," msgto ) + msgto = channel / ( user [ "%" host ] "@" servername ) + msgto =/ ( user "%" host ) / targetmask + msgto =/ nickname / ( nickname "!" user "@" host ) + channel = ( "#" / "+" / ( "!" channelid ) / "&" ) chanstring + [ ":" chanstring ] + servername = hostname + host = hostname / hostaddr + hostname = shortname *( "." shortname ) + shortname = ( letter / digit ) *( letter / digit / "-" ) + *( letter / digit ) + ; as specified in RFC 1123 [HNAME] + hostaddr = ip4addr / ip6addr + ip4addr = 1*3digit "." 1*3digit "." 1*3digit "." 1*3digit + ip6addr = 1*hexdigit 7( ":" 1*hexdigit ) + ip6addr =/ "0:0:0:0:0:" ( "0" / "FFFF" ) ":" ip4addr + nickname = ( letter / special ) *8( letter / digit / special / "-" ) + targetmask = ( "$" / "#" ) mask + ; see details on allowed masks in section 3.3.1 + chanstring = %x01-07 / %x08-09 / %x0B-0C / %x0E-1F / %x21-2B + chanstring =/ %x2D-39 / %x3B-FF + ; any octet except NUL, BELL, CR, LF, " ", "," and ":" + channelid = 5( %x41-5A / digit ) ; 5( A-Z / 0-9 ) + + user = 1*( %x01-09 / %x0B-0C / %x0E-1F / %x21-3F / %x41-FF ) + ; any octet except NUL, CR, LF, " " and "@" + key = 1*23( %x01-05 / %x07-08 / %x0C / %x0E-1F / %x21-7F ) + ; any 7-bit US_ASCII character, + ; except NUL, CR, LF, FF, h/v TABs, and " " + letter = %x41-5A / %x61-7A ; A-Z / a-z + digit = %x30-39 ; 0-9 + hexdigit = digit / "A" / "B" / "C" / "D" / "E" / "F" + special = %x5B-60 / %x7B-7D + ; "[", "]", "\", "`", "_", "^", "{", "|", "}" + + mask = *( nowild / noesc wildone / noesc wildmany ) + wildone = %x3F + wildmany = %x2A + nowild = %x01-29 / %x2B-3E / %x40-FF + ; any octet except NUL, "*", "?" + noesc = %x01-5B / %x5D-FF + ; any octet except NUL and "\" + matchone = %x01-FF + ; matches wildone + matchmany = *matchone + ; matches wildmany + + Examples: + + a?c ; Matches any string of 3 characters in length starting + with "a" and ending with "c" + + a*c ; Matches any string of at least 2 characters in length + starting with "a" and ending with "c" + +Server State +------------ + +* List of local connections, which may belong to clients (users and + services) or other servers + +* List of servers in the network + * Server name, max of 63 chars + * Hostmasks can group servers with matching names into a 'virtual + server' seen by non-matching servers + * Hopcount + * Peer identifier token + * Link flags + +* List of clients in the network + * Network-unique identifier; format depends on type + * Server to which the client is connected + +* List of users in the network + * Has a unique nickname on the network (std says 9 chars max) + * Name of the host the user is running on + * Username of user on that host + * Server the user is connected to + +* List of services in the network known by the server + * Service name = nickname + server name + * Service type + +* List of channels in the network known by the server + * Channel name (prefix + up to 49 other chars) + * Channel members + * Channel modes + +* Recent nickname changes + +* Nickname re-use delay + +Connection State +---------------- + +* A new connection starts out as Unregistered + +* A password before registering is *optional* + +* Connection can register as a user, service, or server + +* Once registered, a client is told the id it was registered with + +* Idle connections are periodically sent a PING and are disconnected + if a PONG is not received in reply + +* Flood control applicability and timer information + +User State +---------- + +* User has a nickname that is first set during registration, but can + later change. + +* User has mode flags that can also be set during registration and + change during operation. + * a: away (set by AWAY, not MODE) + * i: invisible + * w: receives wallops + * r: restricted connection (can't be cleared with MODE, but can be set) + * o: operator (set by OPER, cleared with MODE) + * O: local operator (set by OPER, cleared with MODE) + * s: receives server notices + +* User has a user name, hostname, and real name. These are set at + registration and do not change thereafter. + +* User has a hopcount to determine distance from local server + +* Connection by which user can be sent messages + +Service State +------------- + +* Service name + +* Servertoken + +* Distribution mask + +* Hopcount + +* Type + +Channel State +------------- + +* Channels are typically created when users join them + +* Services cannot join channels + +* A channel has a name + * Up to 50 chars, first char is prefix + * &: local to single server + * #: normal distribution + * +: no channel modes + * !: safe channels + +* A channel (that is not a local-only channel) may have a channel mask + to limit distribution + +* A channel has a topic + +* A channel has a set of joined users + +* Channels may require keys to join + +* Channels have modes, some of which are flags and some of which are + records of management-related data, such as a list of channel ops. + +* Channels may keep track of users that have been invited when they + are set +i (invite-only) + +Connection Registration +----------------------- + +Valid combinations of registration commands are: + + NICK -> USER + PASS -> NICK -> USER + NICK -> PASS -> USER + PASS -> SERVICE + SERVICE + +When registration succeeds for a user, the server sends the following: + + RPL_WELCOME + RPL_YOURHOST + RPL_CREATED + RPL_MYINFO + LUSER + MOTD + +When registration succeds for a service, the server sends the +following: + + RPL_YOURESERVICE + RPL_YOURHOST + RPL_MYINFO + +The server then informs any other servers it is connected to of the +new client. diff --git a/pipes-irc-server.cabal b/pipes-irc-server.cabal new file mode 100644 index 0000000..ffb904a --- /dev/null +++ b/pipes-irc-server.cabal @@ -0,0 +1,37 @@ +-- Initial pipes-irc-server.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: pipes-irc-server +version: 0.1.0.0 +synopsis: IRC server based on pipes +-- description: +license: BSD3 +license-file: LICENSE +author: Levi Pearson +maintainer: levipearson@gmail.com +-- copyright: +category: Network +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +executable pipes-irc-server + main-is: Main.hs + -- other-modules: + -- other-extensions: + build-depends: base >= 4.6 && < 4.7 + , bytestring >= 0.10 && < 0.11 + , text >= 0.11.3 && < 0.12 + , attoparsec >= 0.10 && < 0.11 + , pipes >= 4 && < 5 + , pipes-concurrency >= 2 && < 3 + , pipes-bytestring >= 1.0 && < 2 + , pipes-parse >= 2.0 && < 3 + , pipes-attoparsec >= 0.3 && < 1 + , pipes-network >= 0.6 && < 1 + , stm >= 2 && < 3 + , async >= 2 && < 3 + , free >= 3 && < 4 + + hs-source-dirs: src + default-language: Haskell2010 \ No newline at end of file diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..e8c636c --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Concurrent.Async (wait) +import Pipes.IRC.Server (listenHandler, mkIrcServer, + startIrcServer) +import Pipes.IRC.Server.Types (HostPreference (Host), + IrcConfig (..)) + +main :: IO () +main = + let + ircConf = IrcConfig "6665" (Host "127.0.0.1") + in do + srv <- mkIrcServer ircConf + listener <- startIrcServer srv (listenHandler srv) + wait listener diff --git a/src/Pipes/IRC/Message.hs b/src/Pipes/IRC/Message.hs new file mode 100644 index 0000000..b68fcff --- /dev/null +++ b/src/Pipes/IRC/Message.hs @@ -0,0 +1,8 @@ +module Pipes.IRC.Message + ( parseMessage + , module Pipes.IRC.Message.Types + ) where + +import Pipes.IRC.Message.Types + +parseMessage = undefined diff --git a/src/Pipes/IRC/Message/Parse.hs b/src/Pipes/IRC/Message/Parse.hs new file mode 100644 index 0000000..29b5e87 --- /dev/null +++ b/src/Pipes/IRC/Message/Parse.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Pipes.IRC.Message.Parse where + +import Control.Applicative +import Data.Attoparsec.ByteString.Char8 as P +import qualified Data.ByteString as BS +import Data.ByteString.Char8 as C8 +import Data.Char as C +import Pipes.IRC.Message.Types + +-- +-- Parsers +-- + +parseMsgOrLine :: Parser (Either ByteString IrcMessage) +parseMsgOrLine = + Right <$> parseIrcMessage <|> + Left <$> parseToEOL + +parseToEOL :: Parser ByteString +parseToEOL = C8.append <$> P.takeWhile (not . isCRLFChar) + <*> P.takeWhile isCRLFChar + +parseIrcMessage :: Parser IrcMessage +parseIrcMessage = + IrcMessage <$> option Nothing (Just <$> parseMsgPrefix ) + <*> parseCommand + <*> parseParams + <* parseLineEnd + "parseIrcMessage" + +parseMsgPrefix :: Parser MsgPrefix +parseMsgPrefix = + Left <$ char ':' <*> parseServerName <* takeWhile1 (== ' ') <|> + Right <$ char ':' <*> parseNickName <* takeWhile1 (== ' ') + "parseMsgPrefix" + +parseServerName :: Parser ServerName +parseServerName = C8.intercalate "." <$> parseName `sepBy1` char '.' + "parseServerName" + +parseName :: Parser ByteString +parseName = C8.cons + <$> satisfy isLetOrDig + <*> parseHyphenated + "parseName" + +parseHyphenated :: Parser ByteString +parseHyphenated = + C8.intercalate "-" <$> P.takeWhile1 isLetOrDig `sepBy` char '-' + "parseHyphenated" + +parseNickName :: Parser NickName +parseNickName = + NickName <$> parseNick + <*> parseUser + <*> parseHost + "parseNickName" + +parseNick :: Parser ByteString +parseNick = takeWhile1 isNickChar "parseNick" + +parseUser :: Parser (Maybe ByteString) +parseUser = option Nothing + (Just <$ char '!' <*> takeWhile1 isUserChar + "parseUser") + +parseHost :: Parser (Maybe ByteString) +parseHost = option Nothing + (Just <$ char '@' <*> parseServerName + "parseHost") + +parseCommand :: Parser MsgCommand +parseCommand = + Right <$> parseIrcReply <|> + Left <$> parseIrcCommand + "parseCommand" + +parseIrcCommand :: Parser IrcCommand +parseIrcCommand = (toCmd . C8.map toUpper) <$> P.takeWhile isAlpha_ascii + "parseIrcCommand" + where + toCmd cmd = case cmd of + "PASS" -> PASS + "NICK" -> NICK + "USER" -> USER + "SERVER" -> SERVER + "OPER" -> OPER + "QUIT" -> QUIT + "SQUIT" -> SQUIT + "JOIN" -> JOIN + "PART" -> PART + "MODE" -> MODE + "TOPIC" -> TOPIC + "NAMES" -> NAMES + "LIST" -> LIST + "INVITE" -> INVITE + "KICK" -> KICK + "VERSION" -> VERSION + "STATS" -> STATS + "LINKS" -> LINKS + "TIME" -> TIME + "CONNECT" -> CONNECT + "TRACE" -> TRACE + "ADMIN" -> ADMIN + "INFO" -> INFO + "PRIVMSG" -> PRIVMSG + "NOTICE" -> NOTICE + "WHO" -> WHO + "WHOIS" -> WHOIS + "WHOWAS" -> WHOWAS + "KILL" -> KILL + "PING" -> PING + "PONG" -> PONG + "ERROR" -> ERROR + "AWAY" -> AWAY + "REHASH" -> REHASH + "RESTART" -> RESTART + "SUMMON" -> SUMMON + "USERS" -> USERS + "WALLOPS" -> WALLOPS + "USERHOST" -> USERHOST + "ISON" -> ISON + _ -> Unknown cmd + +parseIrcReply :: Parser IrcReply +parseIrcReply = toReply <$> digit <*> digit <*> digit + "ParseIrcReply" + where + toReply a b c = toEnum $ + 100 * digitToInt a + 10 * digitToInt b + digitToInt c + +parseParams :: Parser [IrcParam] +parseParams = takeWhile1 (== ' ') *> + option [] ( parseTrail <|> parseMiddle ) + where + parseTrail = (:[]) <$> parseTrailParam + parseMiddle = (:) <$> parseMiddleParam <*> parseParams + +parseTrailParam :: Parser IrcParam +parseTrailParam = C8.cons <$> satisfy (== ':') <*> P.takeWhile isTrailingChar + +parseMiddleParam :: Parser IrcParam +parseMiddleParam = C8.cons <$> satisfy (\c -> c /= ':' && isNonWhite c) + <*> P.takeWhile isNonWhite + "parseMiddleParam" + +parseLineEnd :: Parser () +parseLineEnd = const () <$> ("\r\n" <|> "\n" <|> "\r") + "parseLineEnd" + +-- +-- Character Predicates +-- + +isLetOrDig :: Char -> Bool +isLetOrDig c = P.isDigit c || isAlpha_ascii c + +isLetOrDigOrHyph :: Char -> Bool +isLetOrDigOrHyph c = isLetOrDig c || c == '-' + +isSpecial :: Char -> Bool +isSpecial c = c `C8.elem` "-[]\\`^{}" + +isNonWhite :: Char -> Bool +isNonWhite c = not $ c `C8.elem` BS.pack [0x00, 0x20, 0x0d, 0x0a] + +isTrailingChar :: Char -> Bool +isTrailingChar c = not $ c `C8.elem` BS.pack [0x00, 0x0d, 0x0a] + +isCRLFChar :: Char -> Bool +isCRLFChar c = c `C8.elem` BS.pack [0x0d, 0x0a] + +isNickChar :: Char -> Bool +isNickChar c = isLetOrDig c || isSpecial c + +isNickNameSep :: Char -> Bool +isNickNameSep c = c == '!' || c == '@' + +isUserChar :: Char -> Bool +isUserChar c = isNonWhite c && not (isNickNameSep c) diff --git a/src/Pipes/IRC/Message/Render.hs b/src/Pipes/IRC/Message/Render.hs new file mode 100644 index 0000000..5aa429a --- /dev/null +++ b/src/Pipes/IRC/Message/Render.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Pipes.IRC.Message.Render where + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as C8 +import Data.ByteString.Lazy.Builder +import Data.ByteString.Lazy.Builder.ASCII (intDec) +import Data.Monoid +import Pipes.IRC.Message.Types + +renderIrcMessage :: IrcMessage -> Builder +renderIrcMessage IrcMessage {..} = + renderMsgPrefix prefix + <> renderMsgCommand command + <> renderIrcParams params + <> byteString "\r\n" + +renderMsgPrefix :: Maybe MsgPrefix -> Builder +renderMsgPrefix Nothing = mempty +renderMsgPrefix mp = + char8 ':' + <> case mp of + Just (Left sn) -> renderServerName sn + Just (Right nn) -> renderNickName nn + _ -> mempty + <> char8 ' ' + +renderServerName :: ServerName -> Builder +renderServerName = byteString + +renderNickName :: NickName -> Builder +renderNickName NickName {..} = + byteString nick + <> renderUser user + <> renderHost host + +renderUser :: Maybe ByteString -> Builder +renderUser user = + case user of + Nothing -> mempty + Just name -> byteString "!" <> byteString name + +renderHost :: Maybe ByteString -> Builder +renderHost host = + case host of + Nothing -> mempty + Just name -> byteString "@" <> byteString name + +renderMsgCommand :: MsgCommand -> Builder +renderMsgCommand cmd = + case cmd of + Left ircCmd -> renderIrcCommand ircCmd + Right ircReply -> renderIrcReply ircReply + <> byteString " " + +renderIrcCommand :: IrcCommand -> Builder +renderIrcCommand cmd = + case cmd of + (Unknown name) -> byteString name + _ -> byteString . C8.pack . show $ cmd + +renderIrcReply :: IrcReply -> Builder +renderIrcReply IrcReply {..} = intDec replyCode + +renderIrcParams :: [IrcParam] -> Builder +renderIrcParams [] = mempty +renderIrcParams (p:ps) = + renderParam p <> mconcat [char8 ' ' <> renderParam p' | p' <- ps ] + +renderParam :: IrcParam -> Builder +renderParam = byteString diff --git a/src/Pipes/IRC/Message/Types.hs b/src/Pipes/IRC/Message/Types.hs new file mode 100644 index 0000000..2aa0f3b --- /dev/null +++ b/src/Pipes/IRC/Message/Types.hs @@ -0,0 +1,557 @@ +{-# LANGUAGE OverloadedStrings #-} +module Pipes.IRC.Message.Types where + +import qualified Data.ByteString as B + +data IrcMessage = + IrcMessage { prefix :: Maybe MsgPrefix + , command :: MsgCommand + , params :: [IrcParam] + } deriving (Show) + +type MsgPrefix = Either ServerName NickName + +type ServerName = B.ByteString + +data NickName = + NickName { nick :: B.ByteString + , user :: Maybe B.ByteString + , host :: Maybe B.ByteString + } deriving (Show) + +type MsgCommand = Either IrcCommand IrcReply + +type IrcParam = B.ByteString + +data IrcCommand = PASS + | NICK + | USER + | SERVER + | OPER + | QUIT + | SQUIT + | JOIN + | PART + | MODE + | TOPIC + | NAMES + | LIST + | INVITE + | KICK + | VERSION + | STATS + | LINKS + | TIME + | CONNECT + | TRACE + | ADMIN + | INFO + | PRIVMSG + | NOTICE + | WHO + | WHOIS + | WHOWAS + | KILL + | PING + | PONG + | ERROR + | AWAY + | REHASH + | RESTART + | SUMMON + | USERS + | WALLOPS + | USERHOST + | ISON + | Unknown B.ByteString + deriving (Show, Eq, Ord) + +data IrcReply = IrcReply + { replyCode :: !Int + , replyName :: !B.ByteString + } deriving (Show) + +instance Eq IrcReply where + IrcReply { replyCode = a } == IrcReply { replyCode = b } = a == b + +instance Ord IrcReply where + IrcReply { replyCode = a } `compare` IrcReply { replyCode = b } = + a `compare` b + +instance Enum IrcReply where + fromEnum = replyCode + toEnum 200 = rpl_tracelink + toEnum 201 = rpl_traceconnecting + toEnum 202 = rpl_tracehandshake + toEnum 203 = rpl_traceunknown + toEnum 204 = rpl_traceoperator + toEnum 205 = rpl_traceuser + toEnum 206 = rpl_traceserver + toEnum 208 = rpl_tracenewtype + toEnum 211 = rpl_statslinkinfo + toEnum 212 = rpl_statscommands + toEnum 213 = rpl_statscline + toEnum 214 = rpl_statsnline + toEnum 215 = rpl_statsiline + toEnum 216 = rpl_statskline + toEnum 218 = rpl_statsyline + toEnum 219 = rpl_endofstats + toEnum 221 = rpl_umodeis + toEnum 241 = rpl_statslline + toEnum 242 = rpl_statsuptime + toEnum 243 = rpl_statsoline + toEnum 244 = rpl_statshline + toEnum 251 = rpl_luserclient + toEnum 252 = rpl_luserop + toEnum 253 = rpl_luserunknown + toEnum 254 = rpl_luserchannels + toEnum 255 = rpl_luserme + toEnum 256 = rpl_adminme + toEnum 257 = rpl_adminloc1 + toEnum 258 = rpl_adminloc2 + toEnum 259 = rpl_adminemail + toEnum 261 = rpl_tracelog + toEnum 300 = rpl_none + toEnum 301 = rpl_away + toEnum 302 = rpl_userhost + toEnum 303 = rpl_ison + toEnum 305 = rpl_unaway + toEnum 306 = rpl_nowaway + toEnum 311 = rpl_whoisuser + toEnum 312 = rpl_whoisserver + toEnum 313 = rpl_whoisoperator + toEnum 314 = rpl_whowasuser + toEnum 315 = rpl_endofwho + toEnum 317 = rpl_whoisidle + toEnum 318 = rpl_endofwhois + toEnum 319 = rpl_whoischannels + toEnum 321 = rpl_liststart + toEnum 322 = rpl_list + toEnum 323 = rpl_listend + toEnum 324 = rpl_channelmodeis + toEnum 331 = rpl_notopic + toEnum 332 = rpl_topic + toEnum 341 = rpl_inviting + toEnum 342 = rpl_summoning + toEnum 351 = rpl_version + toEnum 352 = rpl_whoreply + toEnum 353 = rpl_namreply + toEnum 364 = rpl_links + toEnum 365 = rpl_endoflinks + toEnum 366 = rpl_endofnames + toEnum 367 = rpl_banlist + toEnum 368 = rpl_endofbanlist + toEnum 369 = rpl_endofwhowas + toEnum 371 = rpl_info + toEnum 374 = rpl_endofinfo + toEnum 375 = rpl_motdstart + toEnum 376 = rpl_endofmotd + toEnum 381 = rpl_youreoper + toEnum 382 = rpl_rehashing + toEnum 391 = rpl_time + toEnum 392 = rpl_usersstart + toEnum 393 = rpl_users + toEnum 394 = rpl_endofusers + toEnum 395 = rpl_nousers + toEnum 401 = err_nosuchnick + toEnum 402 = err_nosuchserver + toEnum 403 = err_nosuchchannel + toEnum 404 = err_cannotsendtochan + toEnum 405 = err_toomanychannels + toEnum 406 = err_wasnosuchnick + toEnum 407 = err_toomanytargets + toEnum 409 = err_noorigin + toEnum 411 = err_norecipient + toEnum 412 = err_notexttosend + toEnum 413 = err_notoplevel + toEnum 414 = err_wildtoplevel + toEnum 421 = err_unknowncommand + toEnum 422 = err_nomotd + toEnum 423 = err_noadmininfo + toEnum 424 = err_fileerror + toEnum 431 = err_nonicknamegiven + toEnum 432 = err_erroneusnickname + toEnum 433 = err_nicknameinuse + toEnum 436 = err_nickcollision + toEnum 441 = err_usernotinchannel + toEnum 442 = err_notonchannel + toEnum 443 = err_useronchannel + toEnum 444 = err_nologin + toEnum 445 = err_summondisabled + toEnum 446 = err_usersdisabled + toEnum 451 = err_notregistered + toEnum 461 = err_needmoreparams + toEnum 462 = err_alreadyregistered + toEnum 463 = err_nopermforhost + toEnum 464 = err_passwdmismatch + toEnum 465 = err_yourebannedcreep + toEnum 467 = err_keyset + toEnum 471 = err_channelisfull + toEnum 472 = err_unknownmode + toEnum 473 = err_inviteonlychan + toEnum 474 = err_bannedfromchan + toEnum 475 = err_badchannelkey + toEnum 481 = err_noprivileges + toEnum 482 = err_chanoprivsneeded + toEnum 483 = err_cantkillserver + toEnum 491 = err_nooperhost + toEnum 501 = err_umodeunknownflag + toEnum 502 = err_usersdontmatch + toEnum c = mkIrcReply c B.empty + +mkIrcReply :: Int -> B.ByteString -> IrcReply +mkIrcReply = IrcReply + +rpl_tracelink :: IrcReply +rpl_tracelink = mkIrcReply 200 "RPL_TRACELINK" + +rpl_traceconnecting :: IrcReply +rpl_traceconnecting = mkIrcReply 201 "RPL_TRACECONNECTING" + +rpl_tracehandshake :: IrcReply +rpl_tracehandshake = mkIrcReply 202 "RPL_TRACEHANDSHAKE" + +rpl_traceunknown :: IrcReply +rpl_traceunknown = mkIrcReply 203 "RPL_TRACEUNKNOWN" + +rpl_traceoperator :: IrcReply +rpl_traceoperator = mkIrcReply 204 "RPL_TRACEOPERATOR" + +rpl_traceuser :: IrcReply +rpl_traceuser = mkIrcReply 205 "RPL_TRACEUSER" + +rpl_traceserver :: IrcReply +rpl_traceserver = mkIrcReply 206 "RPL_TRACESERVER" + +rpl_tracenewtype :: IrcReply +rpl_tracenewtype = mkIrcReply 208 "RPL_TRACENEWTYPE" + +rpl_statslinkinfo :: IrcReply +rpl_statslinkinfo = mkIrcReply 211 "RPL_STATSLINKINFO" + +rpl_statscommands :: IrcReply +rpl_statscommands = mkIrcReply 212 "RPL_STATSCOMMANDS" + +rpl_statscline :: IrcReply +rpl_statscline = mkIrcReply 213 "RPL_STATSCLINE" + +rpl_statsnline :: IrcReply +rpl_statsnline = mkIrcReply 214 "RPL_STATSNLINE" + +rpl_statsiline :: IrcReply +rpl_statsiline = mkIrcReply 215 "RPL_STATSILINE" + +rpl_statskline :: IrcReply +rpl_statskline = mkIrcReply 216 "RPL_STATSKLINE" + +rpl_statsyline :: IrcReply +rpl_statsyline = mkIrcReply 218 "RPL_STATSYLINE" + +rpl_endofstats :: IrcReply +rpl_endofstats = mkIrcReply 219 "RPL_ENDOFSTATS" + +rpl_umodeis :: IrcReply +rpl_umodeis = mkIrcReply 221 "RPL_UMODEIS" + +rpl_statslline :: IrcReply +rpl_statslline = mkIrcReply 241 "RPL_STATSLLINE" + +rpl_statsuptime :: IrcReply +rpl_statsuptime = mkIrcReply 242 "RPL_STATSUPTIME" + +rpl_statsoline :: IrcReply +rpl_statsoline = mkIrcReply 243 "RPL_STATSOLINE" + +rpl_statshline :: IrcReply +rpl_statshline = mkIrcReply 244 "RPL_STATSHLINE" + +rpl_luserclient :: IrcReply +rpl_luserclient = mkIrcReply 251 "RPL_LUSERCLIENT" + +rpl_luserop :: IrcReply +rpl_luserop = mkIrcReply 252 "RPL_LUSEROP" + +rpl_luserunknown :: IrcReply +rpl_luserunknown = mkIrcReply 253 "RPL_LUSERUNKNOWN" + +rpl_luserchannels :: IrcReply +rpl_luserchannels = mkIrcReply 254 "RPL_LUSERCHANNELS" + +rpl_luserme :: IrcReply +rpl_luserme = mkIrcReply 255 "RPL_LUSERME" + +rpl_adminme :: IrcReply +rpl_adminme = mkIrcReply 256 "RPL_ADMINME" + +rpl_adminloc1 :: IrcReply +rpl_adminloc1 = mkIrcReply 257 "RPL_ADMINLOC1" + +rpl_adminloc2 :: IrcReply +rpl_adminloc2 = mkIrcReply 258 "RPL_ADMINLOC2" + +rpl_adminemail :: IrcReply +rpl_adminemail = mkIrcReply 259 "RPL_ADMINEMAIL" + +rpl_tracelog :: IrcReply +rpl_tracelog = mkIrcReply 261 "RPL_TRACELOG" + +rpl_none :: IrcReply +rpl_none = mkIrcReply 300 "RPL_NONE" + +rpl_away :: IrcReply +rpl_away = mkIrcReply 301 "RPL_AWAY" + +rpl_userhost :: IrcReply +rpl_userhost = mkIrcReply 302 "RPL_USERHOST" + +rpl_ison :: IrcReply +rpl_ison = mkIrcReply 303 "RPL_ISON" + +rpl_unaway :: IrcReply +rpl_unaway = mkIrcReply 305 "RPL_UNAWAY" + +rpl_nowaway :: IrcReply +rpl_nowaway = mkIrcReply 306 "RPL_NOWAWAY" + +rpl_whoisuser :: IrcReply +rpl_whoisuser = mkIrcReply 311 "RPL_WHOISUSER" + +rpl_whoisserver :: IrcReply +rpl_whoisserver = mkIrcReply 312 "RPL_WHOISSERVER" + +rpl_whoisoperator :: IrcReply +rpl_whoisoperator = mkIrcReply 313 "RPL_WHOISOPERATOR" + +rpl_whowasuser :: IrcReply +rpl_whowasuser = mkIrcReply 314 "RPL_WHOWASUSER" + +rpl_endofwho :: IrcReply +rpl_endofwho = mkIrcReply 315 "RPL_ENDOFWHO" + +rpl_whoisidle :: IrcReply +rpl_whoisidle = mkIrcReply 317 "RPL_WHOISIDLE" + +rpl_endofwhois :: IrcReply +rpl_endofwhois = mkIrcReply 318 "RPL_ENDOFWHOIS" + +rpl_whoischannels :: IrcReply +rpl_whoischannels = mkIrcReply 319 "RPL_WHOISCHANNELS" + +rpl_liststart :: IrcReply +rpl_liststart = mkIrcReply 321 "RPL_LISTSTART" + +rpl_list :: IrcReply +rpl_list = mkIrcReply 322 "RPL_LIST" + +rpl_listend :: IrcReply +rpl_listend = mkIrcReply 323 "RPL_LISTEND" + +rpl_channelmodeis :: IrcReply +rpl_channelmodeis = mkIrcReply 234 "RPL_CHANNELMODEIS" + +rpl_notopic :: IrcReply +rpl_notopic = mkIrcReply 331 "RPL_NOTOPIC" + +rpl_topic :: IrcReply +rpl_topic = mkIrcReply 332 "RPL_TOPIC" + +rpl_inviting :: IrcReply +rpl_inviting = mkIrcReply 341 "RPL_INVITING" + +rpl_summoning :: IrcReply +rpl_summoning = mkIrcReply 342 "RPL_SUMMONING" + +rpl_version :: IrcReply +rpl_version = mkIrcReply 351 "RPL_VERSION" + +rpl_whoreply :: IrcReply +rpl_whoreply = mkIrcReply 352 "RPL_WHOREPLY" + +rpl_namreply :: IrcReply +rpl_namreply = mkIrcReply 353 "RPL_NAMREPLY" + +rpl_links :: IrcReply +rpl_links = mkIrcReply 364 "RPL_LINKS" + +rpl_endoflinks :: IrcReply +rpl_endoflinks = mkIrcReply 365 "RPL_ENDOFLINKS" + +rpl_endofnames :: IrcReply +rpl_endofnames = mkIrcReply 366 "RPL_ENDOFNAMES" + +rpl_banlist :: IrcReply +rpl_banlist = mkIrcReply 367 "RPL_BANLIST" + +rpl_endofbanlist :: IrcReply +rpl_endofbanlist = mkIrcReply 368 "RPL_ENDOFBANLIST" + +rpl_endofwhowas :: IrcReply +rpl_endofwhowas = mkIrcReply 369 "RPL_ENDOFWHOWAS" + +rpl_info :: IrcReply +rpl_info = mkIrcReply 371 "RPL_INFO" + +rpl_endofinfo :: IrcReply +rpl_endofinfo = mkIrcReply 374 "RPL_ENDOFINFO" + +rpl_motdstart :: IrcReply +rpl_motdstart = mkIrcReply 375 "RPL_MOTDSTART" + +rpl_endofmotd :: IrcReply +rpl_endofmotd = mkIrcReply 376 "RPL_ENDOFMOTD" + +rpl_youreoper :: IrcReply +rpl_youreoper = mkIrcReply 381 "RPL_YOUREOPER" + +rpl_rehashing :: IrcReply +rpl_rehashing = mkIrcReply 382 "RPL_REHASHING" + +rpl_time :: IrcReply +rpl_time = mkIrcReply 391 "RPL_TIME" + +rpl_usersstart :: IrcReply +rpl_usersstart = mkIrcReply 392 "RPL_USERSSTART" + +rpl_users :: IrcReply +rpl_users = mkIrcReply 393 "RPL_USERS" + +rpl_endofusers :: IrcReply +rpl_endofusers = mkIrcReply 394 "RPL_ENDOFUSERS" + +rpl_nousers :: IrcReply +rpl_nousers = mkIrcReply 395 "RPL_NOUSERS" + +err_nosuchnick :: IrcReply +err_nosuchnick = mkIrcReply 401 "ERR_NOSUCHNICK" + +err_nosuchserver :: IrcReply +err_nosuchserver = mkIrcReply 402 "ERR_NOSUCHSERVER" + +err_nosuchchannel :: IrcReply +err_nosuchchannel = mkIrcReply 403 "ERR_NOSUCHCHANNEL" + +err_cannotsendtochan :: IrcReply +err_cannotsendtochan = mkIrcReply 404 "ERR_CANNOTSENDTOCHAN" + +err_toomanychannels :: IrcReply +err_toomanychannels = mkIrcReply 405 "ERR_TOOMANYCHANNELS" + +err_wasnosuchnick :: IrcReply +err_wasnosuchnick = mkIrcReply 406 "ERR_WASNOSUCHNICK" + +err_toomanytargets :: IrcReply +err_toomanytargets = mkIrcReply 407 "ERR_TOOMANYTARGETS" + +err_noorigin :: IrcReply +err_noorigin = mkIrcReply 409 "ERR_NOORIGIN" + +err_norecipient :: IrcReply +err_norecipient = mkIrcReply 411 "ERR_NORECIPIENT" + +err_notexttosend :: IrcReply +err_notexttosend = mkIrcReply 412 "ERR_NOTEXTTOSEND" + +err_notoplevel :: IrcReply +err_notoplevel = mkIrcReply 413 "ERR_NOTOPLEVEL" + +err_wildtoplevel :: IrcReply +err_wildtoplevel = mkIrcReply 414 "ERR_WILDTOPLEVEL" + +err_unknowncommand :: IrcReply +err_unknowncommand = mkIrcReply 421 "ERR_UNKNOWNCOMMAND" + +err_nomotd :: IrcReply +err_nomotd = mkIrcReply 422 "ERR_NOMOTD" + +err_noadmininfo :: IrcReply +err_noadmininfo = mkIrcReply 423 "ERR_NOADMININFO" + +err_fileerror :: IrcReply +err_fileerror = mkIrcReply 424 "ERR_FILEERROR" + +err_nonicknamegiven :: IrcReply +err_nonicknamegiven = mkIrcReply 431 "ERR_NONICKNAMEGIVEN" + +err_erroneusnickname :: IrcReply +err_erroneusnickname = mkIrcReply 432 "ERR_ERRONEUSNICKNAME" + +err_nicknameinuse :: IrcReply +err_nicknameinuse = mkIrcReply 433 "ERR_NICKNAMEINUSE" + +err_nickcollision :: IrcReply +err_nickcollision = mkIrcReply 436 "ERR_NICKCOLLISION" + +err_usernotinchannel :: IrcReply +err_usernotinchannel = mkIrcReply 441 "ERR_USERNOTINCHANNEL" + +err_notonchannel :: IrcReply +err_notonchannel = mkIrcReply 442 "ERR_NOTONCHANNEL" + +err_useronchannel :: IrcReply +err_useronchannel = mkIrcReply 443 "ERR_USERONCHANNEL" + +err_nologin :: IrcReply +err_nologin = mkIrcReply 444 "ERR_NOLOGIN" + +err_summondisabled :: IrcReply +err_summondisabled = mkIrcReply 445 "ERR_SUMMONDISABLED" + +err_usersdisabled :: IrcReply +err_usersdisabled = mkIrcReply 446 "ERR_USERSDISABLED" + +err_notregistered :: IrcReply +err_notregistered = mkIrcReply 451 "ERR_NOTREGISTERED" + +err_needmoreparams :: IrcReply +err_needmoreparams = mkIrcReply 461 "ERR_NEEDMOREPARAMS" + +err_alreadyregistered :: IrcReply +err_alreadyregistered = mkIrcReply 462 "ERR_ALREADYREGISTERED" + +err_nopermforhost :: IrcReply +err_nopermforhost = mkIrcReply 463 "ERR_NOPERMFORHOST" + +err_passwdmismatch :: IrcReply +err_passwdmismatch = mkIrcReply 464 "ERR_PASSWDMISMATCH" + +err_yourebannedcreep :: IrcReply +err_yourebannedcreep = mkIrcReply 465 "ERR_YOUREBANNEDCREEP" + +err_keyset :: IrcReply +err_keyset = mkIrcReply 467 "ERR_KEYSET" + +err_channelisfull :: IrcReply +err_channelisfull = mkIrcReply 471 "ERR_CHANNELISFULL" + +err_unknownmode :: IrcReply +err_unknownmode = mkIrcReply 472 "ERR_UNKNOWNMODE" + +err_inviteonlychan :: IrcReply +err_inviteonlychan = mkIrcReply 473 "ERR_INVITEONLYCHAN" + +err_bannedfromchan :: IrcReply +err_bannedfromchan = mkIrcReply 474 "ERR_BANNEDFROMCHAN" + +err_badchannelkey :: IrcReply +err_badchannelkey = mkIrcReply 475 "ERR_BADCHANNELKEY" + +err_noprivileges :: IrcReply +err_noprivileges = mkIrcReply 481 "ERR_NOPRIVILEGES" + +err_chanoprivsneeded :: IrcReply +err_chanoprivsneeded = mkIrcReply 482 "ERR_CHANOPRIVSNEEDED" + +err_cantkillserver :: IrcReply +err_cantkillserver = mkIrcReply 483 "ERR_CANTKILLSERVER" + +err_nooperhost :: IrcReply +err_nooperhost = mkIrcReply 491 "ERR_NOOPERHOST" + +err_umodeunknownflag :: IrcReply +err_umodeunknownflag = mkIrcReply 501 "ERR_UMODEUNKNOWNFLAG" + +err_usersdontmatch :: IrcReply +err_usersdontmatch = mkIrcReply 502 "ERR_USERSDONTMATCH" + +ircReplyIsErr :: IrcReply -> Bool +ircReplyIsErr (IrcReply {replyCode = c}) = c >= 400 && c <= 502 diff --git a/src/Pipes/IRC/Server.hs b/src/Pipes/IRC/Server.hs new file mode 100644 index 0000000..c20d7e6 --- /dev/null +++ b/src/Pipes/IRC/Server.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Pipes.IRC.Server + ( mkIrcServer + , startIrcServer + , listenHandler + , module Pipes.IRC.Server.Types + ) +where + +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Monad +import Data.ByteString.Char8 as BS +import Data.ByteString.Lazy as LB +import Data.ByteString.Lazy.Builder (toLazyByteString) +import Data.List as L +import Pipes +import Pipes.Attoparsec +import Pipes.Concurrent as PC +import Pipes.IRC.Message.Parse +import Pipes.IRC.Message.Render +import Pipes.IRC.Message.Types +import Pipes.IRC.Server.Types +import Pipes.Lift (runStateP) +import Pipes.Network.TCP +import Pipes.Parse as PP + +sendToMany :: a -> [Output a] -> IO () +sendToMany msg outs = do + resL <- forM outs $ \o -> + async $ atomically $ PC.send o msg + mapM_ wait resL + +publishStream :: TVar [IrcConnection a] -> Consumer a IO () +publishStream clients = forever $ do + msg <- await + cs <- lift $ atomically $ readTVar clients + let os = L.map out cs + lift $ sendToMany msg os + +spawnEcho :: TVar [IrcConnection a] -> IO (Output a) +spawnEcho clients = do + (writeEnd, readEnd) <- spawn Unbounded + _ <- async $ forever $ + runEffect $ fromInput readEnd >-> publishStream clients + return writeEnd + +logMsg :: IrcMessage -> IO () +logMsg msg = BS.putStr $ BS.concat + ["LOG: ", toStrict $ toLazyByteString (renderIrcMessage msg)] + +cmdHandler :: Output IrcMessage -> Consumer IrcMessage IO () +cmdHandler echoSrv = toOutput echoSrv + +filterMsgs :: Pipe (Either BS.ByteString IrcMessage) IrcMessage IO () +filterMsgs = forever $ do + cmd <- await + case cmd of + Left bs -> lift $ BS.putStr $ BS.concat ["BAD COMMAND: ", bs] + Right c -> do lift $ logMsg c + yield c + +addIrcConnection :: IrcConnection IrcMessage -> IrcServer -> IO () +addIrcConnection client server = do + let clients = ircConnections server + atomically $ modifyTVar clients $ \cs -> client : cs + +delIrcConnection :: IrcConnection IrcMessage -> IrcServer -> IO () +delIrcConnection client server = do + let clients = ircConnections server + atomically $ modifyTVar clients $ delete client + +parseMessage :: Producer BS.ByteString IO () + -> Producer (Either BS.ByteString IrcMessage) IO () +parseMessage prod = do + (me, src') <- runStateP prod go + case me of + Left e -> lift . print . show $ e + Right r -> return r + where + go = do + eof <- lift isEndOfParserInput + if eof + then do + liftIO $ BS.putStrLn "EOF Reached" + ra <- lift PP.draw + case ra of + Left r -> return (Right r) + Right _ -> error "parseMessage: impossible!!" + else do + eb <- lift (parse parseMsgOrLine) + case eb of + Left e -> return (Left e) + Right (_, b) -> yield b >> go + +renderMessage :: Pipe IrcMessage BS.ByteString IO () +renderMessage = forever $ do + msg <- await + let output = toIrcMessage msg + yield output + where + toIrcMessage = toStrict . toLazyByteString . renderIrcMessage + +listenHandler :: IrcServer -> IrcHandler +listenHandler server (lsock, _) = + forever $ acceptFork lsock $ \(csock, caddr) -> + let + sockWriter = toSocket csock + sockReader = fromSocket csock 4096 + handler = ircHandler server + in do + (writeEnd, readEnd) <- spawn Unbounded + let client = IrcConnection csock caddr writeEnd + + addIrcConnection client server + + r <- async $ runEffect $ + parseMessage sockReader >-> filterMsgs >-> handler + + w <- async $ runEffect $ + fromInput readEnd >-> renderMessage >-> sockWriter + + mapM_ wait [r,w] + + delIrcConnection client server + +mkIrcServer :: IrcConfig -> IO IrcServer +mkIrcServer config = do + conns <- atomically $ newTVar [] + users <- atomically $ newTVar [] + chans <- atomically $ newTVar [] + echoEnd <- spawnEcho conns + return $ IrcServer config conns users chans (cmdHandler echoEnd) + +startIrcServer :: IrcServer -> IrcHandler -> IO (Async ()) +startIrcServer server handler = + async $ listen sHost sPort handler + where + sHost = ircHost . ircConfig $ server + sPort = ircPort . ircConfig $ server diff --git a/src/Pipes/IRC/Server/Types.hs b/src/Pipes/IRC/Server/Types.hs new file mode 100644 index 0000000..fce573a --- /dev/null +++ b/src/Pipes/IRC/Server/Types.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE RecordWildCards #-} +module Pipes.IRC.Server.Types + ( HostPreference(..) + , IrcHandler + , IrcMessage + , IrcConnection(..) + , IrcConfig(..) + , IrcServer(..) + , IrcUser(..) + , IrcChannel(..) + ) where + +import Control.Concurrent.STM (TVar) +import Data.ByteString (ByteString) +import Pipes (Consumer) +import Pipes.Concurrent (Output) +import Pipes.IRC.Message.Types (IrcMessage) +import Pipes.Network.TCP (HostPreference (..), ServiceName, + SockAddr, Socket) + +data IrcServer = + IrcServer { ircConfig :: !IrcConfig + , ircConnections :: !(TVar [IrcConnection IrcMessage]) + , ircUsers :: !(TVar [IrcUser]) + , ircChannels :: !(TVar [IrcChannel]) + , ircHandler :: !(Consumer IrcMessage IO ()) + } + +data IrcConfig = + IrcConfig { ircPort :: !ServiceName + , ircHost :: !HostPreference + } deriving (Show) + +data IrcConnection a = + IrcConnection { sock :: !Socket + , addr :: !SockAddr + , out :: !(Output a) + } + +instance Eq (IrcConnection a) where + (IrcConnection s1 _ _) == (IrcConnection s2 _ _) = s1 == s2 + +instance Show (IrcConnection a) where + show IrcConnection {..} = + "IrcConnection " ++ show sock ++ " " ++ show addr + +type IrcHandler = (Socket, SockAddr) -> IO () + +data IrcUser = + IrcUser { userNick :: !ByteString + , userClientId :: !ByteString + , userServerName :: !ByteString + , userName :: !ByteString + , userHostName :: !ByteString + , userModes :: ![IrcUserMode] + , userConn :: !(IrcConnection IrcMessage) + } deriving (Show, Eq) + +data IrcUserMode = Away | Invisible | WallOps | Restricted + | Oper | LocalOper | ServerNotices + deriving (Show, Eq, Enum) + +data IrcChannel = + IrcChannel { chanName :: !ByteString + , chanTopic :: !ByteString + , chanModes :: ![IrcChanMode] + , chanUsers :: ![IrcUser] + } deriving (Show, Eq) + +data IrcChanMode = Anonymous | InviteOnly | Moderated | Quiet | Secret + deriving (Show, Eq, Enum)