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