pinealservo
/
pipes-irc-server
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Significant refactoring and added parser tests

master
Levi Pearson 2013-11-22 00:57:40 -07:00
parent ab6359dc86
commit 6e2ceafe97
14 changed files with 1134 additions and 180 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

135
notes.md
View File

@ -1,3 +1,34 @@
Pipes Notes
===========
A set of monad transformers for streaming: Producers, Consumers,
Pipes, ListT
They provide two primitive actions:
* `await`
* `yield`
Producers `yield`, Consumers `await`
Pipes both `yield` and `await`
Effects neither `yield` nor `await`
Connectors:
* `for` handles `yield`
* `>~` handles `await`
* `>->` handles `yield` and `await`
* `>>=` (regular monad bind) handles return values
As connectors are applied to Producers, Consumers, and Pipes; the
return type changes until it becomes Effect, at which point all inputs
and outputs are handled and the resulting monad can be executed.
IRC Notes
=========
ABNF from rfc2812: ABNF from rfc2812:
------------------ ------------------
@ -218,3 +249,107 @@ following:
The server then informs any other servers it is connected to of the The server then informs any other servers it is connected to of the
new client. new client.
Commands
--------
### Connection Registration
* PASS <password>
Needs server env for password
Modifies connection state
Errors: ERR_NEEDMOREPARAMS, ERR_ALREADYREGISTERED
* NICK <nickname> [ <hopcount> ]
Hopcount should only be sent by servers
Needs currently registered nicks to check for uniqueness
Errors: ERR_NONICKNAMEGIVEN, ERR_ERRONEUSNICKNAME, ERR_NICKNAMEINUSE, ERR_NICKCOLLISION
* USER <username> <hostname> <servername> <:realname>
hostname and servername are ignored when coming from clients
Errors: ERR_NEEDMOREPARAMS, ERR_ALREADYREGISTERED
* SERVER <servername> <hopcount> <:info>
Errors: ERR_ALREADYREGISTERED
* OPER <user> <password>
Errors: ERR_NEEDMOREPARAMS, ERR_NOOPERHOST, ERR_PASSWDMISMATCH
Reply: RPL_YOUREOPER
* QUIT <:quit message>
* SQUIT <server> <:comment>
Errors: ERR_NOPRIVILEGES, ERR_NOSUCHSERVER
### Channel Operations
* JOIN <channel>{,<channel>} [<key>{,<key>}]
Errors: ERR_NEEDMOREPARAMS, ERR_BANNEDFROMCHAN, ERR_INVITEONLYCHAN, ERR_CHANNELISFULL,
ERR_BADCHANNELKEY, ERR_BADCHANMASK, ERR_NOSUCHCHANNEL, ERR_TOOMANYCHANNELS
Reply: RPL_TOPIC
* PART <channel>{,<channel>}
Errors: ERR_NEEDMOREPARAMS, ERR_NOSUCHCHANNEL, ERR_NOTONCHANNEL
* MODE <channel> {[+|-]o|p|s|i|t|n|b|v} [<limit>] [<user>] [<ban mask>]
Errors: ERR_NEEDMOREPARAMS, ERR_CHANOPRIVSNEEDED, ERR_NOTONCHANNEL, ERR_UNKNOWNMODE,
ERR_NOSUCHNICK, ERR_KEYSET, ERR_NOSUCHCHANNEL
Reply: RPL_CHANNELMODEIS, RPL_BANLIST, RPL_ENDOFBANLIST
* TOPIC <channel> [<:topic>]
Errors: ERR_NEEDMOREPARAMS, ERR_NOTONCHANNEL, ERR_CHANOPRIVSNEEDED
Reply: RPL_NOTOPIC, RPL_TOPIC
* NAMES [<channel>{,<channel>}]
Reply: RPL_NAMREPLY, RPL_ENDOFNAMES
* LIST [<channel>{,<channel>} [<server>]]
Errors: ERR_NOSUCHSERVER
Reply: RPL_LISTSTART, RPL_LIST, RPL_LISTEND
* INVITE <nickname> <channel>
Errors: ERR_NEEDMOREPARAMS, ERR_NOSUCHNICK, ERR_NOTONCHANNEL, ERR_USERONCHANNEL,
ERR_CHANOPRIVSNEEDED
Reply: RPL_INVITING, RPL_AWAY
* KICK <channel> <user> [<:comment>]
Errors: ERR_NEEDMOREPARAMS, ERR_NOSUCHCHANNEL, ERR_BADCHANMASK, ERR_CHANOPRIVSNEEDED,
ERR_NOTONCHANNEL
### User Operations
* MODE <nickname> {[+|-]i|w|s|o}
Errors: ERR_USERSDONTMATCH, ERR_UMODEUNKNOWNFLAG
Reply: RPL_UMODEIS
### Server Queries and Commands
* VERSION [<server>]
* STATS [<query> [<server>]]
* LINKS [[<remote server>] <server mask>]
* TIME [<server>]
* CONNECT <target server> [<port> [<remote server>]]
* TRACE [<server>]
* ADMIN [<server>]
* INFO [<server>]
### Sending Messages
* PRIVMSG <receiver>{,<receiver>} <:text to be sent>
* NOTICE <nickname> <:text>
### User Based Queries
* WHO [<name> [o]]
* WHOIS [<server>] <nickmask>[,<nickmask>[,...]]
* WHOWAS <nickname> [<count> [<server>]]
### Miscellaneous Messages
* KILL <nickname> <:comment>
* PING <server1> [<server2>]
* PONG <daemon> [<daemon2>]
* ERROR <:error message>
### Optional Messages
* AWAY [<:message>]
* REHASH
* RESTART
* SUMMON <user> [<server>]
* USERS [<server>]
* WALLOPS <:text for opers>
* USERHOST <nickname>{ <nickname>}
* ISON <nickname>{ <nickname>}

43
pipes-irc-server.cabal
View File

@ -17,9 +17,39 @@ cabal-version: >=1.10
executable pipes-irc-server executable pipes-irc-server
main-is: Main.hs main-is: Main.hs
-- other-modules: other-modules: Pipes.IRC.Message.Parse
, Pipes.IRC.Message.Render
, Pipes.IRC.Message.Types
, Pipes.IRC.Server.Types
, Pipes.IRC.Server.MessageHandler
-- other-extensions: -- other-extensions:
build-depends: base >= 4.6 && < 4.7 build-depends: base >= 4.6 && < 4.7
, mtl >= 2.1 && < 3
, mmorph >= 1 && < 2
, containers >= 0.5 && < 1
, bytestring >= 0.10 && < 0.11
, text >= 0.11.3 && < 0.12
, attoparsec >= 0.10 && < 0.11
, network >= 2.4 && < 2.5
, 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
test-suite tests
type: exitcode-stdio-1.0
main-is: Main.hs
build-depends: base >= 4.6 && < 4.7
, mtl >= 2.1 && < 3
, containers >= 0.5 && < 1
, bytestring >= 0.10 && < 0.11 , bytestring >= 0.10 && < 0.11
, text >= 0.11.3 && < 0.12 , text >= 0.11.3 && < 0.12
, attoparsec >= 0.10 && < 0.11 , attoparsec >= 0.10 && < 0.11
@ -32,6 +62,11 @@ executable pipes-irc-server
, stm >= 2 && < 3 , stm >= 2 && < 3
, async >= 2 && < 3 , async >= 2 && < 3
, free >= 3 && < 4 , free >= 3 && < 4
build-depends: tasty
hs-source-dirs: src , tasty-hspec
default-language: Haskell2010 , tasty-hunit
, tasty-quickcheck
, tasty-smallcheck
hs-source-dirs: tests, src
default-language: Haskell2010

13
src/Main.hs
View File

@ -3,16 +3,19 @@
module Main where module Main where
import Control.Concurrent.Async (wait) import Control.Concurrent.Async (wait)
import Pipes.IRC.Server (listenHandler, mkIrcServer, import Pipes.IRC.Server (startIrcServer)
startIrcServer)
import Pipes.IRC.Server.Types (HostPreference (Host), import Pipes.IRC.Server.Types (HostPreference (Host),
IrcConfig (..)) IrcConfig (..))
main :: IO () main :: IO ()
main = main =
let let
ircConf = IrcConfig "6665" (Host "127.0.0.1") ircConf =
IrcConfig { ircPort = "6665"
, ircHost = Host "127.0.0.1"
, ircMotd = ["Welcome to the IRC Server!"]
, ircPass = Nothing
}
in do in do
srv <- mkIrcServer ircConf listener <- startIrcServer ircConf
listener <- startIrcServer srv (listenHandler srv)
wait listener wait listener

6
src/Pipes/IRC/Message.hs
View File

@ -1,8 +1,8 @@
module Pipes.IRC.Message module Pipes.IRC.Message
( parseMessage ( parseMsgOrLine
, parseIrcMessage
, module Pipes.IRC.Message.Types , module Pipes.IRC.Message.Types
) where ) where
import Pipes.IRC.Message.Parse
import Pipes.IRC.Message.Types import Pipes.IRC.Message.Types
parseMessage = undefined

9
src/Pipes/IRC/Message/Parse.hs
View File

@ -32,8 +32,8 @@ parseIrcMessage =
parseMsgPrefix :: Parser MsgPrefix parseMsgPrefix :: Parser MsgPrefix
parseMsgPrefix = parseMsgPrefix =
Left <$ char ':' <*> parseServerName <* takeWhile1 (== ' ') <|> Right <$ char ':' <*> parseNickName <* takeWhile1 (== ' ') <|>
Right <$ char ':' <*> parseNickName <* takeWhile1 (== ' ') Left <$ char ':' <*> parseServerName <* takeWhile1 (== ' ')
<?> "parseMsgPrefix" <?> "parseMsgPrefix"
parseServerName :: Parser ServerName parseServerName :: Parser ServerName
@ -78,7 +78,7 @@ parseCommand =
<?> "parseCommand" <?> "parseCommand"
parseIrcCommand :: Parser IrcCommand parseIrcCommand :: Parser IrcCommand
parseIrcCommand = (toCmd . C8.map toUpper) <$> P.takeWhile isAlpha_ascii parseIrcCommand = (toCmd . C8.map toUpper) <$> takeWhile1 isAlpha_ascii
<?> "parseIrcCommand" <?> "parseIrcCommand"
where where
toCmd cmd = case cmd of toCmd cmd = case cmd of
@ -134,12 +134,13 @@ parseIrcReply = toReply <$> digit <*> digit <*> digit
parseParams :: Parser [IrcParam] parseParams :: Parser [IrcParam]
parseParams = takeWhile1 (== ' ') *> parseParams = takeWhile1 (== ' ') *>
option [] ( parseTrail <|> parseMiddle ) option [] ( parseTrail <|> parseMiddle )
<|> pure []
where where
parseTrail = (:[]) <$> parseTrailParam parseTrail = (:[]) <$> parseTrailParam
parseMiddle = (:) <$> parseMiddleParam <*> parseParams parseMiddle = (:) <$> parseMiddleParam <*> parseParams
parseTrailParam :: Parser IrcParam parseTrailParam :: Parser IrcParam
parseTrailParam = C8.cons <$> satisfy (== ':') <*> P.takeWhile isTrailingChar parseTrailParam = C8.cons <$> satisfy (== ':') *> P.takeWhile isTrailingChar
parseMiddleParam :: Parser IrcParam parseMiddleParam :: Parser IrcParam
parseMiddleParam = C8.cons <$> satisfy (\c -> c /= ':' && isNonWhite c) parseMiddleParam = C8.cons <$> satisfy (\c -> c /= ':' && isNonWhite c)

76
src/Pipes/IRC/Message/Render.hs
View File

@ -1,73 +1,79 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
module Pipes.IRC.Message.Render where module Pipes.IRC.Message.Render
( renderIrcMessage )
where
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Char8 as C8
import Data.ByteString.Lazy (toStrict)
import Data.ByteString.Lazy.Builder import Data.ByteString.Lazy.Builder
import Data.ByteString.Lazy.Builder.ASCII (intDec) import Data.ByteString.Lazy.Builder.ASCII (intDec)
import Data.Monoid import Data.Monoid
import Pipes.IRC.Message.Types import Pipes.IRC.Message.Types
renderIrcMessage :: IrcMessage -> Builder renderIrcMessage :: IrcMessage -> C8.ByteString
renderIrcMessage IrcMessage {..} = renderIrcMessage = toStrict . toLazyByteString . buildIrcMessage
renderMsgPrefix prefix
<> renderMsgCommand command buildIrcMessage :: IrcMessage -> Builder
<> renderIrcParams params buildIrcMessage IrcMessage {..} =
buildMsgPrefix prefix
<> buildMsgCommand command
<> buildIrcParams params
<> byteString "\r\n" <> byteString "\r\n"
renderMsgPrefix :: Maybe MsgPrefix -> Builder buildMsgPrefix :: Maybe MsgPrefix -> Builder
renderMsgPrefix Nothing = mempty buildMsgPrefix Nothing = mempty
renderMsgPrefix mp = buildMsgPrefix mp =
char8 ':' char8 ':'
<> case mp of <> case mp of
Just (Left sn) -> renderServerName sn Just (Left sn) -> buildServerName sn
Just (Right nn) -> renderNickName nn Just (Right nn) -> buildNickName nn
_ -> mempty _ -> mempty
<> char8 ' ' <> char8 ' '
renderServerName :: ServerName -> Builder buildServerName :: ServerName -> Builder
renderServerName = byteString buildServerName = byteString
renderNickName :: NickName -> Builder buildNickName :: NickName -> Builder
renderNickName NickName {..} = buildNickName NickName {..} =
byteString nick byteString nick
<> renderUser user <> buildUser user
<> renderHost host <> buildHost host
renderUser :: Maybe ByteString -> Builder buildUser :: Maybe ByteString -> Builder
renderUser user = buildUser user =
case user of case user of
Nothing -> mempty Nothing -> mempty
Just name -> byteString "!" <> byteString name Just name -> byteString "!" <> byteString name
renderHost :: Maybe ByteString -> Builder buildHost :: Maybe ByteString -> Builder
renderHost host = buildHost host =
case host of case host of
Nothing -> mempty Nothing -> mempty
Just name -> byteString "@" <> byteString name Just name -> byteString "@" <> byteString name
renderMsgCommand :: MsgCommand -> Builder buildMsgCommand :: MsgCommand -> Builder
renderMsgCommand cmd = buildMsgCommand cmd =
case cmd of case cmd of
Left ircCmd -> renderIrcCommand ircCmd Left ircCmd -> buildIrcCommand ircCmd
Right ircReply -> renderIrcReply ircReply Right ircReply -> buildIrcReply ircReply
<> byteString " " <> byteString " "
renderIrcCommand :: IrcCommand -> Builder buildIrcCommand :: IrcCommand -> Builder
renderIrcCommand cmd = buildIrcCommand cmd =
case cmd of case cmd of
(Unknown name) -> byteString name (Unknown name) -> byteString name
_ -> byteString . C8.pack . show $ cmd _ -> byteString . C8.pack . show $ cmd
renderIrcReply :: IrcReply -> Builder buildIrcReply :: IrcReply -> Builder
renderIrcReply IrcReply {..} = intDec replyCode buildIrcReply IrcReply {..} = intDec replyCode
renderIrcParams :: [IrcParam] -> Builder buildIrcParams :: [IrcParam] -> Builder
renderIrcParams [] = mempty buildIrcParams [] = mempty
renderIrcParams (p:ps) = buildIrcParams (p:ps) =
renderParam p <> mconcat [char8 ' ' <> renderParam p' | p' <- ps ] buildParam p <> mconcat [char8 ' ' <> buildParam p' | p' <- ps ]
renderParam :: IrcParam -> Builder buildParam :: IrcParam -> Builder
renderParam = byteString buildParam = byteString

4
src/Pipes/IRC/Message/Types.hs
View File

@ -7,7 +7,7 @@ data IrcMessage =
IrcMessage { prefix :: Maybe MsgPrefix IrcMessage { prefix :: Maybe MsgPrefix
, command :: MsgCommand , command :: MsgCommand
, params :: [IrcParam] , params :: [IrcParam]
} deriving (Show) } deriving (Show, Eq)
type MsgPrefix = Either ServerName NickName type MsgPrefix = Either ServerName NickName
@ -17,7 +17,7 @@ data NickName =
NickName { nick :: B.ByteString NickName { nick :: B.ByteString
, user :: Maybe B.ByteString , user :: Maybe B.ByteString
, host :: Maybe B.ByteString , host :: Maybe B.ByteString
} deriving (Show) } deriving (Show, Eq)
type MsgCommand = Either IrcCommand IrcReply type MsgCommand = Either IrcCommand IrcReply

197
src/Pipes/IRC/Server.hs
View File

@ -1,9 +1,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Pipes.IRC.Server module Pipes.IRC.Server
( mkIrcServer ( startIrcServer
, startIrcServer
, listenHandler
, module Pipes.IRC.Server.Types , module Pipes.IRC.Server.Types
) )
where where
@ -11,131 +9,128 @@ where
import Control.Concurrent.Async import Control.Concurrent.Async
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Monad import Control.Monad
import Data.ByteString.Char8 as BS import Control.Monad.RWS
import Data.ByteString.Lazy as LB import Data.ByteString.Char8 as BS
import Data.ByteString.Lazy.Builder (toLazyByteString) import Data.Map as M
import Data.List as L import Data.Set as S
import Network.Socket as NS
import Pipes import Pipes
import Pipes.Attoparsec import Pipes.Attoparsec
import Pipes.Concurrent as PC import Pipes.Concurrent as PC
import Pipes.IRC.Message.Parse import Pipes.IRC.Message.Parse
import Pipes.IRC.Message.Render import Pipes.IRC.Message.Render
import Pipes.IRC.Message.Types import Pipes.IRC.Message.Types
import Pipes.IRC.Server.EventHandler
import Pipes.IRC.Server.Log
import Pipes.IRC.Server.MessageHandler
import Pipes.IRC.Server.Types import Pipes.IRC.Server.Types
import Pipes.Lift (runStateP) import Pipes.Network.TCP as PN
import Pipes.Network.TCP
import Pipes.Parse as PP
sendToMany :: a -> [Output a] -> IO () parseMessage :: Producer BS.ByteString IO ()
sendToMany msg outs = do -> Producer (Either BS.ByteString IrcMessage) IO ()
resL <- forM outs $ \o -> parseMessage prod = do
async $ atomically $ PC.send o msg void $ for (parseMany parseMsgOrLine prod) $ \res ->
mapM_ wait resL case res of
(_, Left _) -> yield $ Left "ERROR Bad Parse"
(_, Right val) -> yield $ Right val
return ()
publishStream :: TVar [IrcConnection a] -> Consumer a IO () renderMessage :: Pipe IrcMessage BS.ByteString IO ()
publishStream clients = forever $ do renderMessage = forever $ do
msg <- await msg <- await
cs <- lift $ atomically $ readTVar clients let output = renderIrcMessage msg
let os = L.map out cs yield output
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 :: Pipe (Either BS.ByteString IrcMessage) IrcMessage IO ()
filterMsgs = forever $ do filterMsgs = forever $ do
cmd <- await cmd <- await
case cmd of case cmd of
Left bs -> lift $ BS.putStr $ BS.concat ["BAD COMMAND: ", bs] Left bs -> liftIO $ BS.putStr $ BS.concat ["BAD COMMAND: ", bs]
Right c -> do lift $ logMsg c Right c -> do lift $ logMsg c
yield c yield c
addIrcConnection :: IrcConnection IrcMessage -> IrcServer -> IO () addIrcConnection :: ServerState -> IrcConnection -> IO Int
addIrcConnection client server = do addIrcConnection srv client = do
let clients = ircConnections server let clients = ircConnections srv
atomically $ modifyTVar clients $ \cs -> client : cs ids = ircConnIds srv
cid <- atomically $ do
lastId <- readTVar ids
let newId = lastId + 1
writeTVar ids newId
return newId
atomically $ modifyTVar' clients $ M.insert cid client
return cid
delIrcConnection :: IrcConnection IrcMessage -> IrcServer -> IO () delIrcConnection :: ServerState -> Int -> IO ()
delIrcConnection client server = do delIrcConnection srv cid = do
let clients = ircConnections server let clients = ircConnections srv
atomically $ modifyTVar clients $ delete client atomically $ modifyTVar' clients $ M.delete cid
parseMessage :: Producer BS.ByteString IO () cmdHandler :: ServerState -> Int -> Consumer IrcMessage IO ()
-> Producer (Either BS.ByteString IrcMessage) IO () cmdHandler srv cid =
parseMessage prod = do let cReg = Unreg Nothing Nothing Nothing
(me, src') <- runStateP prod go in handle cReg
case me of
Left e -> lift . print . show $ e
Right r -> return r
where where
go = do handle userReg = do
eof <- lift isEndOfParserInput -- wait for the next command
if eof nextMsg <- await
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 () -- run the handler in a transaction
renderMessage = forever $ do (newReg, events) <- liftIO $ atomically $ do
msg <- await sState <- readTVar (ircState srv)
let output = toIrcMessage msg let sConf = ircConfig srv
yield output let cState = ClientState { clientReg = userReg
where , clientServer = sState
toIrcMessage = toStrict . toLazyByteString . renderIrcMessage , clientConn = cid }
listenHandler :: IrcServer -> IrcHandler -- run the handler in the IrcMonad, returning new state and events
listenHandler server (lsock, _) = let (_, newState, events) =
forever $ acceptFork lsock $ \(csock, caddr) -> runRWS (runIrc $ ircMessageHandler nextMsg) sConf cState
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 writeTVar (ircState srv) $ clientServer newState
return (clientReg newState, events)
r <- async $ runEffect $ -- handle resulting events
parseMessage sockReader >-> filterMsgs >-> handler liftIO $ forM_ events $ ircEventHandler srv
w <- async $ runEffect $ -- loop for the next command
fromInput readEnd >-> renderMessage >-> sockWriter handle newReg
mapM_ wait [r,w] listenHandler :: ServerState -> (Socket, SockAddr) -> IO ()
listenHandler srv (lsock, _) =
forever $ acceptFork lsock $ \(csock, caddr) -> do
let sockWriter = toSocket csock
sockReader = fromSocket csock 4096
(writeEnd, readEnd) <- spawn Unbounded
let client = IrcConnection csock caddr writeEnd
delIrcConnection client server cid <- addIrcConnection srv client
let handler = cmdHandler srv cid
mkIrcServer :: IrcConfig -> IO IrcServer r <- async $ runEffect $
parseMessage sockReader >-> filterMsgs >-> handler
w <- async $ runEffect $
fromInput readEnd >-> renderMessage >-> sockWriter
mapM_ wait [r,w]
delIrcConnection srv cid
mkIrcServer :: IrcConfig -> IO ServerState
mkIrcServer config = do mkIrcServer config = do
conns <- atomically $ newTVar [] let nks = S.empty
users <- atomically $ newTVar [] urs = M.empty
chans <- atomically $ newTVar [] chs = M.empty
echoEnd <- spawnEcho conns srv = IrcServer nks urs chs
return $ IrcServer config conns users chans (cmdHandler echoEnd) tvState <- newTVarIO srv
tvCns <- newTVarIO M.empty
tvRef <- newTVarIO 0
return $ ServerState tvState config tvCns tvRef
startIrcServer :: IrcServer -> IrcHandler -> IO (Async ()) startIrcServer :: IrcConfig -> IO (Async ())
startIrcServer server handler = startIrcServer config = do
async $ listen sHost sPort handler srv <- mkIrcServer config
where let sHost = (ircHost . ircConfig) srv
sHost = ircHost . ircConfig $ server sPort = (ircPort . ircConfig) srv
sPort = ircPort . ircConfig $ server async $ PN.listen sHost sPort (listenHandler srv)

3
src/Pipes/IRC/Server/Connection.hs Normal file
View File

@ -0,0 +1,3 @@
module Pipes.IRC.Server.Connection where
import Pipes.IRC.Server.Types

33
src/Pipes/IRC/Server/EventHandler.hs Normal file
View File

@ -0,0 +1,33 @@
{-# LANGUAGE RecordWildCards #-}
module Pipes.IRC.Server.EventHandler
( ircEventHandler )
where
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Monad
import Data.Map as M
import Data.Maybe as DM
import Network.Socket as NS
import Pipes.Concurrent as PC
import Pipes.IRC.Server.Types
sendToMany :: a -> [Output a] -> IO ()
sendToMany msg outs = do
resL <- forM outs $ \o ->
async $ atomically $ PC.send o msg
mapM_ wait resL
ircEventHandler :: ServerState -> IrcEvent -> IO ()
ircEventHandler srv evt =
case evt of
Close connId -> do
outConns <- readTVarIO $ ircConnections srv
case M.lookup connId outConns of
Just IrcConnection{..} -> NS.close sock
_ -> return ()
Msg {..} -> do
outConns <- readTVarIO $ ircConnections srv
let os = fmap out $ DM.mapMaybe (`M.lookup` outConns) outDest
sendToMany outMsg os

13
src/Pipes/IRC/Server/Log.hs Normal file
View File

@ -0,0 +1,13 @@
{-# LANGUAGE OverloadedStrings #-}
module Pipes.IRC.Server.Log
( logMsg )
where
import Data.ByteString as BS
import Pipes.IRC.Message.Render
import Pipes.IRC.Message.Types ()
import Pipes.IRC.Server.Types
logMsg :: IrcMessage -> IO ()
logMsg msg = BS.putStr $ BS.concat ["LOG: ", renderIrcMessage msg]

39
src/Pipes/IRC/Server/MessageHandler.hs Normal file
View File

@ -0,0 +1,39 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Pipes.IRC.Server.MessageHandler
( ircMessageHandler )
where
import Control.Applicative
import Control.Monad.RWS
import Pipes.IRC.Message.Types
import Pipes.IRC.Server.Types
ircMessageHandler :: IrcMessage -> IrcMonad ()
ircMessageHandler msg = do
reg <- clientReg <$> get
case reg of
Unreg {} -> unregHandler msg
RegUser {} -> regHandler msg
return ()
unregHandler :: IrcMessage -> IrcMonad ()
unregHandler IrcMessage{..} =
case command of
Left PASS -> undefined
Left NICK -> undefined
Left USER -> undefined
Left QUIT -> undefined
_ -> return ()
regHandler :: IrcMessage -> IrcMonad ()
regHandler IrcMessage{..} =
case command of
Left PRIVMSG -> undefined
Left JOIN -> undefined
Left PART -> undefined
Left LIST -> undefined
Left NICK -> undefined
Left QUIT -> undefined
_ -> return ()

86
src/Pipes/IRC/Server/Types.hs
View File

@ -1,59 +1,93 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Pipes.IRC.Server.Types module Pipes.IRC.Server.Types
( HostPreference(..) ( HostPreference(..)
, IrcHandler
, IrcMessage , IrcMessage
, IrcEvent(..)
, IrcEvents
, IrcConnection(..) , IrcConnection(..)
, IrcConfig(..) , IrcConfig(..)
, IrcServer(..) , IrcServer(..)
, IrcUser(..) , IrcUser(..)
, IrcChannel(..) , IrcChannel(..)
, IrcMonad(..)
, ServerState(..)
, ClientState(..)
, RegState(..)
) where ) where
import Control.Concurrent.STM (TVar) import Control.Concurrent.STM (TVar)
import Control.Monad.RWS (MonadReader, MonadState, MonadWriter,
RWS)
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Pipes (Consumer) import Data.Map (Map)
import Data.Set (Set)
import Pipes.Concurrent (Output) import Pipes.Concurrent (Output)
import Pipes.IRC.Message.Types (IrcMessage) import Pipes.IRC.Message.Types (IrcMessage)
import Pipes.Network.TCP (HostPreference (..), ServiceName, import Pipes.Network.TCP (HostPreference (..), ServiceName,
SockAddr, Socket) SockAddr, Socket)
type IrcEvents = [IrcEvent]
newtype IrcMonad a =
IrcMonad { runIrc :: RWS IrcConfig IrcEvents ClientState a }
deriving ( Monad
, Functor
, MonadReader IrcConfig
, MonadWriter IrcEvents
, MonadState ClientState)
data IrcEvent = Msg { outMsg :: !IrcMessage
, outDest :: ![Int]
}
| Close Int
deriving (Show)
data ServerState =
ServerState { ircState :: !(TVar IrcServer)
, ircConfig :: !IrcConfig
, ircConnections :: !(TVar (Map Int IrcConnection))
, ircConnIds :: !(TVar Int)
}
data RegState = Unreg { rcvdPass :: !(Maybe ByteString)
, rcvdNick :: !(Maybe ByteString)
, rcvdName :: !(Maybe ByteString) }
| RegUser { regdNick :: !ByteString }
deriving (Show)
data ClientState =
ClientState { clientReg :: !RegState
, clientServer :: !IrcServer
, clientConn :: !Int
} deriving (Show)
data IrcServer = data IrcServer =
IrcServer { ircConfig :: !IrcConfig IrcServer { ircNicks :: !(Set ByteString)
, ircConnections :: !(TVar [IrcConnection IrcMessage]) , ircUsers :: !(Map ByteString IrcUser)
, ircUsers :: !(TVar [IrcUser]) , ircChannels :: !(Map ByteString IrcChannel)
, ircChannels :: !(TVar [IrcChannel]) } deriving (Show)
, ircHandler :: !(Consumer IrcMessage IO ())
}
data IrcConfig = data IrcConfig =
IrcConfig { ircPort :: !ServiceName IrcConfig { ircPort :: !ServiceName
, ircHost :: !HostPreference , ircHost :: !HostPreference
, ircMotd :: ![ByteString]
, ircPass :: !(Maybe ByteString)
} deriving (Show) } deriving (Show)
data IrcConnection a = data IrcConnection =
IrcConnection { sock :: !Socket IrcConnection { sock :: !Socket
, addr :: !SockAddr , addr :: !SockAddr
, out :: !(Output a) , out :: !(Output IrcMessage)
} }
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 = data IrcUser =
IrcUser { userNick :: !ByteString IrcUser { userNick :: !(Maybe ByteString)
, userClientId :: !ByteString , userServerName :: !(Maybe ByteString)
, userServerName :: !ByteString , userName :: !(Maybe ByteString)
, userName :: !ByteString , userHostName :: !(Maybe ByteString)
, userHostName :: !ByteString
, userModes :: ![IrcUserMode] , userModes :: ![IrcUserMode]
, userConn :: !(IrcConnection IrcMessage) , userConn :: !Int
} deriving (Show, Eq) } deriving (Show, Eq)
data IrcUserMode = Away | Invisible | WallOps | Restricted data IrcUserMode = Away | Invisible | WallOps | Restricted

657
tests/Main.hs Normal file
View File

@ -0,0 +1,657 @@
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Test.Tasty
import Test.Tasty.Hspec as HS
--import Test.Tasty.HUnit as HU
--import Test.Tasty.QuickCheck as QC
--import Test.Tasty.SmallCheck as SC
import Data.Attoparsec.ByteString.Char8 as P
import Data.ByteString.Char8 as C8
import Data.List
import Data.Ord
import Pipes.IRC.Message.Parse
import Pipes.IRC.Message.Render
import Pipes.IRC.Message.Types
main :: IO ()
main = defaultMain tests
tests :: TestTree
tests = testGroup "Tests" [specs]
--tests = testGroup "Tests" [specs, properties, unitTests]
-- Hspec Tests
specs :: TestTree
specs = testGroup "Specifications"
[ HS.testCase "Message Parsing" msgParseSpec
-- , HS.testCase "Message Rendering" msgRenderSpec
]
msgParseSpec :: Spec
msgParseSpec = do
describe "Parsing" $ do
describe "parseMsgOrLine" $ do
it "succeeds parsing an empty line, returning a Left value" $
pMsgOrLine "\r\n"
`shouldBe`
Right (Left "\r\n")
it "succeeds parsing an IRC message, returning a Right value" $
pMsgOrLine "PRIVMSG #haskell :Hi, guys!\r\n"
`shouldBe`
Right
(Right (IrcMessage Nothing (Left PRIVMSG) ["#haskell", "Hi, guys!"]))
describe "parseIrcMessage" $ do
context "Messages with no prefix" $ do
it "matches with no parameters" $
pMsg "NAMES\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left NAMES) [])
it "matches with one parameter (without spaces)" $
pMsg "NICK WiZ\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left NICK) ["WiZ"])
it "matches with one parameter (with spaces)" $
pMsg "QUIT :Goodbye, cruel world!\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left QUIT) ["Goodbye, cruel world!"])
context "Messages with server name prefix" $ do
it "matches with server name prefixes" $
pMsg ":foo.domain.com ERROR :Oh no!\r\n"
`shouldBe`
Right (IrcMessage (Just (Left "foo.domain.com"))
(Left ERROR)
["Oh no!"] )
it "matches with hyphenated server name prefixes" $
pMsg ":my-domain.org ERROR :Oh no!\r\n"
`shouldBe`
Right (IrcMessage (Just (Left "my-domain.org"))
(Left ERROR)
["Oh no!"] )
context "Messages with nickname prefix" $ do
it "matches with just nick" $
pMsg ":WiZ PRIVMSG #haskell :Hello\r\n"
`shouldBe`
Right (IrcMessage (Just (Right (NickName "WiZ" Nothing Nothing)))
(Left PRIVMSG)
["#haskell", "Hello"] )
it "matches with nick and user" $
pMsg ":WiZ!wiz PRIVMSG #haskell :Hello\r\n"
`shouldBe`
Right (IrcMessage (Just (Right (NickName "WiZ" (Just "wiz") Nothing)))
(Left PRIVMSG)
["#haskell", "Hello"] )
it "matches with nick, user, and host" $
pMsg ":WiZ!wiz@wiz-host.com PRIVMSG #haskell :Hello\r\n"
`shouldBe`
Right (IrcMessage (Just (Right
(NickName
"WiZ"
(Just "wiz")
(Just "wiz-host.com"))))
(Left PRIVMSG)
["#haskell", "Hello"] )
context "Examples from RFC1459" $ do
it "matches PASS example" $
pMsg "PASS secretpasswordhere\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left PASS) ["secretpasswordhere"])
it "matches NICK example 1" $
pMsg "NICK Wiz\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left NICK) ["Wiz"])
it "matches NICK example 2" $
pMsg ":WiZ NICK Kilroy\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "WiZ" Nothing Nothing)))
(Left NICK) ["Kilroy"])
it "matches USER example 1" $
pMsg "USER guest tolmoon tolsun :Ronnie Reagan\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left USER)
["guest", "tolmoon", "tolsun", "Ronnie Reagan"])
it "matches USER example 2" $
pMsg ":testnick USER guest tolmoon tolsun :Ronnie Reagan\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "testnick" Nothing Nothing)))
(Left USER) ["guest", "tolmoon", "tolsun", "Ronnie Reagan"])
it "matches SERVER example 1" $
pMsg "SERVER test.oulu.fi 1 :[tolsun.oulu.fi] Experimental server\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left SERVER)
["test.oulu.fi", "1", "[tolsun.oulu.fi] Experimental server"])
it "matches SERVER example 2" $
pMsg ":tolsun.oulu.fi SERVER csd.bu.edu 5 :BU Central Server\r\n"
`shouldBe`
Right (IrcMessage
(Just (Left "tolsun.oulu.fi"))
(Left SERVER) ["csd.bu.edu", "5", "BU Central Server"])
it "matches OPER example" $
pMsg "OPER foo bar\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left OPER) ["foo", "bar"])
it "matches QUIT example" $
pMsg "QUIT :Gone to have lunch\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left QUIT) ["Gone to have lunch"])
it "matches SQUIT example 1" $
pMsg "SQUIT tolsun.oulu.fi :Bad Link ?\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left SQUIT)
["tolsun.oulu.fi", "Bad Link ?"])
it "matches SQUIT example 2" $
pMsg ":Trillian SQUIT cm22.eng.umd.edu :Server out of control\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "Trillian" Nothing Nothing)))
(Left SQUIT) ["cm22.eng.umd.edu", "Server out of control"])
it "matches JOIN example 1" $
pMsg "JOIN #foobar\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left JOIN) ["#foobar"])
it "matches JOIN example 2" $
pMsg "JOIN &foo fubar\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left JOIN) ["&foo", "fubar"])
it "matches JOIN example 3" $
pMsg "JOIN #foo,&bar fubar\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left JOIN) ["#foo,&bar", "fubar"])
it "matches JOIN example 4" $
pMsg "JOIN #foo,&bar fubar,foobar\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left JOIN) ["#foo,&bar", "fubar,foobar"])
it "matches JOIN example 5" $
pMsg "JOIN #foo,#bar\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left JOIN) ["#foo,#bar"])
it "matches JOIN example 6" $
pMsg ":WiZ JOIN #Twilight_zone\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "WiZ" Nothing Nothing)))
(Left JOIN) ["#Twilight_zone"])
it "matches PART example 1" $
pMsg "PART #twilight_zone\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left PART) ["#twilight_zone"])
it "matches PART example 2" $
pMsg "PART #oz-ops,&group5\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left PART) ["#oz-ops,&group5"])
it "matches MODE example 1" $
pMsg "MODE #Finnish +im\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["#Finnish", "+im"])
it "matches MODE example 2" $
pMsg "MODE #Finnish +o Kilroy\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["#Finnish", "+o", "Kilroy"])
it "matches MODE example 3" $
pMsg "MODE #Finnish +v Wiz\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["#Finnish", "+v", "Wiz"])
it "matches MODE example 4" $
pMsg "MODE #Fins -s\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["#Fins", "-s"])
it "matches MODE example 5" $
pMsg "MODE #42 +k oulu\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["#42", "+k", "oulu"])
it "matches MODE example 6" $
pMsg "MODE #eu-opers +l 10\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["#eu-opers", "+l", "10"])
it "matches MODE example 7" $
pMsg "MODE &oulu +b\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["&oulu", "+b"])
it "matches MODE example 8" $
pMsg "MODE &oulu +b *!*@*\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["&oulu", "+b", "*!*@*"])
it "matches MODE example 9" $
pMsg "MODE &oulu +b *!*@*.edu\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["&oulu", "+b", "*!*@*.edu"])
it "matches MODE example 10" $
pMsg "MODE WiZ -w\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["WiZ", "-w"])
it "matches MODE example 11" $
pMsg ":Angel MODE Angel +i\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "Angel" Nothing Nothing)))
(Left MODE) ["Angel", "+i"])
it "matches MODE example 12" $
pMsg "MODE WiZ -o\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["WiZ", "-o"])
it "matches TOPIC example 1" $
pMsg ":WiZ TOPIC #test :New topic\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "WiZ" Nothing Nothing)))
(Left TOPIC) ["#test", "New topic"])
it "matches TOPIC example 2" $
pMsg "TOPIC #test :another topic\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left TOPIC) ["#test", "another topic"])
it "matches TOPIC example 3" $
pMsg "TOPIC #test\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left TOPIC) ["#test"])
it "matches NAMES example 1" $
pMsg "NAMES #twilight_zone,#42\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left NAMES) ["#twilight_zone,#42"])
it "matches NAMES example 2" $
pMsg "NAMES\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left NAMES) [])
it "matches LIST example 1" $
pMsg "LIST\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left LIST) [])
it "matches LIST example 2" $
pMsg "LIST #twilight_zone,#42\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left LIST) ["#twilight_zone,#42"])
it "matches INVITE example 1" $
pMsg ":Angel INVITE Wiz #Dust\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "Angel" Nothing Nothing)))
(Left INVITE) ["Wiz", "#Dust"])
it "matches INVITE example 2" $
pMsg "INVITE Wiz #Twilight_Zone\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left INVITE) ["Wiz", "#Twilight_Zone"])
it "matches KICK example 1" $
pMsg "KICK &Melbourne Matthew\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left KICK) ["&Melbourne", "Matthew"])
it "matches KICK example 2" $
pMsg "KICK #Finnish John :Speaking English\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left KICK)
["#Finnish", "John", "Speaking English"])
it "matches KICK example 3" $
pMsg ":WiZ KICK #Finnish John\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "WiZ" Nothing Nothing)))
(Left KICK) ["#Finnish", "John"])
it "matches VERSION example 1" $
pMsg ":WiZ VERSION *.se\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "WiZ" Nothing Nothing)))
(Left VERSION) ["*.se"])
it "matches VERSION example 2" $
pMsg "VERSION tolsun.oulu.fi\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left VERSION) ["tolsun.oulu.fi"])
it "matches STATS example 1" $
pMsg "STATS m\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left STATS) ["m"])
it "matches STATS example 2" $
pMsg ":Wiz STATS c eff.org\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "Wiz" Nothing Nothing)))
(Left STATS) ["c", "eff.org"])
it "matches LINKS example 1" $
pMsg "LINKS *.au\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left LINKS) ["*.au"])
it "matches LINKS example 2" $
pMsg ":WiZ LINKS *.bu.edu *.edu\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "WiZ" Nothing Nothing)))
(Left LINKS) ["*.bu.edu", "*.edu"])
it "matches TIME example 1" $
pMsg "TIME tolsun.oulu.fi\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left TIME) ["tolsun.oulu.fi"])
it "matches TIME example 2" $
pMsg ":Angel TIME *.au\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "Angel" Nothing Nothing)))
(Left TIME) ["*.au"])
it "matches CONNECT example 1" $
pMsg "CONNECT tolsun.oulu.fi\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left CONNECT) ["tolsun.oulu.fi"])
it "matches CONNECT example 2" $
pMsg ":WiZ CONNECT eff.org 6667 csd.bu.edu\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "WiZ" Nothing Nothing)))
(Left CONNECT) ["eff.org", "6667", "csd.bu.edu"])
it "matches TRACE example 1" $
pMsg "TRACE *.oulu.fi\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left TRACE) ["*.oulu.fi"])
it "matches TRACE example 2" $
pMsg ":WiZ TRACE AngelDust\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "WiZ" Nothing Nothing)))
(Left TRACE) ["AngelDust"])
it "matches ADMIN example 1" $
pMsg "ADMIN tolsun.oulu.fi\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left ADMIN) ["tolsun.oulu.fi"])
it "matches ADMIN example 2" $
pMsg ":WiZ ADMIN *.edu\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "WiZ" Nothing Nothing)))
(Left ADMIN) ["*.edu"])
it "matches INFO example 1" $
pMsg "INFO csd.bu.edu\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left INFO) ["csd.bu.edu"])
it "matches INFO example 2" $
pMsg ":Avalon INFO *.fi\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "Avalon" Nothing Nothing)))
(Left INFO) ["*.fi"])
it "matches INFO example 3" $
pMsg "INFO Angel\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left INFO) ["Angel"])
it "matches PRIVMSG example 1" $
pMsg ":Angel PRIVMSG Wiz :Hello are you receiving this message ?\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "Angel" Nothing Nothing)))
(Left PRIVMSG)
["Wiz", "Hello are you receiving this message ?"])
it "matches PRIVMSG example 2" $
pMsg "PRIVMSG Angel :yes I'm receiving it!\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left PRIVMSG)
["Angel", "yes I'm receiving it!"])
it "matches PRIVMSG example 3" $
pMsg "PRIVMSG jto@tolsun.oulu.fi :Hello !\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left PRIVMSG)
["jto@tolsun.oulu.fi", "Hello !"])
it "matches PRIVMSG example 4" $
pMsg "PRIVMSG $*.fi :Server tolsun.oulu.fi rebooting.\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left PRIVMSG)
["$*.fi", "Server tolsun.oulu.fi rebooting."])
it "matches PRIVMSG example 5" $
pMsg "PRIVMSG #*.edu :NSFNet is undergoing work, expect interruptions\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left PRIVMSG)
["#*.edu", "NSFNet is undergoing work, expect interruptions"])
it "matches WHO example 1" $
pMsg "WHO *.fi\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left WHO) ["*.fi"])
it "matches WHO example 2" $
pMsg "WHO jto* o\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left WHO) ["jto*", "o"])
it "matches WHOIS example 1" $
pMsg "WHOIS wiz\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left WHOIS) ["wiz"])
it "matches WHOIS example 2" $
pMsg "WHOIS eff.org trillian\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left WHOIS) ["eff.org", "trillian"])
it "matches WHOWAS example 1" $
pMsg "WHOWAS Wiz\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left WHOWAS) ["Wiz"])
it "matches WHOWAS example 2" $
pMsg "WHOWAS Mermaid 9\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left WHOWAS) ["Mermaid", "9"])
it "matches WHOWAS example 3" $
pMsg "WHOWAS Trillian 1 *.edu\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left WHOWAS) ["Trillian", "1", "*.edu"])
it "matches KILL example" $
pMsg "KILL David :(csd.bu.edu <- tolsun.oulu.fi)\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left KILL)
["David", "(csd.bu.edu <- tolsun.oulu.fi)"])
it "matches PING example 1" $
pMsg "PING tolsun.oulu.fi\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left PING) ["tolsun.oulu.fi"])
it "matches PING example 2" $
pMsg "PING WiZ\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left PING) ["WiZ"])
it "matches PONG example" $
pMsg "PONG csd.bu.edu tolsun.oulu.fi\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left PONG)
["csd.bu.edu", "tolsun.oulu.fi"])
it "matches ERROR example" $
pMsg "ERROR :Server *.fi already exists\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left ERROR)
["Server *.fi already exists"])
it "matches AWAY example 1" $
pMsg "AWAY :Gone to lunch. Back in 5\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left AWAY)
["Gone to lunch. Back in 5"])
it "matches AWAY example 2" $
pMsg ":WiZ AWAY\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "WiZ" Nothing Nothing)))
(Left AWAY) [])
it "matches REHASH example" $
pMsg "REHASH\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left REHASH) [])
it "matches RESTART example" $
pMsg "RESTART\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left RESTART) [])
it "matches SUMMON example 1" $
pMsg "SUMMON jto\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left SUMMON) ["jto"])
it "matches SUMMON example 2" $
pMsg "SUMMON jto tolsun.oulu.fi\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left SUMMON) ["jto", "tolsun.oulu.fi"])
it "matches USERS example 1" $
pMsg "USERS eff.org\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left USERS) ["eff.org"])
it "matches USERS example 2" $
pMsg ":John USERS tolsun.oulu.fi\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "John" Nothing Nothing)))
(Left USERS) ["tolsun.oulu.fi"])
it "matches WALLOPS example" $
pMsg ":csd.bu.edu WALLOPS :Connect '*.uiuc.edu 6667' from Joshua\r\n"
`shouldBe`
Right (IrcMessage
(Just (Left "csd.bu.edu"))
(Left WALLOPS) ["Connect '*.uiuc.edu 6667' from Joshua"])
it "matches USERHOST example" $
pMsg "USERHOST Wiz Michael Marty p\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left USERHOST)
["Wiz", "Michael", "Marty", "p"])
it "matches ISON example" $
pMsg "ISON phone trillian WiZ jarlek Avalon Angel Monstah\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left ISON)
["phone", "trillian", "WiZ", "jarlek", "Avalon"
, "Angel", "Monstah"])
where
pMsgOrLine = parseOnly parseMsgOrLine
pMsg = parseOnly parseIrcMessage
msgRenderSpec :: Spec
msgRenderSpec = undefined
-- QuickCheck and SmallCheck properties
{-
properties :: TestTree
properties = testGroup "Properties" [qcProps, scProps]
scProps :: TestTree
scProps = testGroup "(Checked by SmallCheck)"
[ SC.testProperty "sort == sort . reverse" $
\list -> sort (list :: [Int]) == sort (reverse list)
, SC.testProperty "Fermat's little theorem" $
\x -> ((x :: Integer)^7 - x) `mod` 7 == 0
-- the following property does not hold
, SC.testProperty "Fermat's last theorem" $
\x y z n ->
(n :: Integer) >= 3 SC.==> x^n + y^n /= (z^n :: Integer)
]
qcProps = testGroup "(checked by QuickCheck)"
[ QC.testProperty "sort == sort . reverse" $
\list -> sort (list :: [Int]) == sort (reverse list)
, QC.testProperty "Fermat's little theorem" $
\x -> ((x :: Integer)^7 - x) `mod` 7 == 0
-- the following property does not hold
, QC.testProperty "Fermat's last theorem" $
\x y z n ->
(n :: Integer) >= 3 QC.==> x^n + y^n /= (z^n :: Integer)
]
-- HUnit tests
unitTests = testGroup "Unit tests"
[ HS.testCase "List comparison (different length)" $
[1, 2, 3] `compare` [1,2] @?= GT
-- the following test does not hold
, HS.testCase "List comparison (same length)" $
[1, 2, 3] `compare` [1,2,2] @?= LT
]
-}