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.master
Levi Pearson
commit
41b457dd30
|
|
@ -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.
|
||||||
|
|
@ -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.
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -0,0 +1,8 @@
|
||||||
|
module Pipes.IRC.Message
|
||||||
|
( parseMessage
|
||||||
|
, module Pipes.IRC.Message.Types
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Pipes.IRC.Message.Types
|
||||||
|
|
||||||
|
parseMessage = undefined
|
||||||
|
|
@ -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)
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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)
|
||||||
Loading…
Reference in New Issue