Significant refactoring and added parser tests
Levi Pearson
parent
ab6359dc86
commit
6e2ceafe97
135
notes.md
135
notes.md
|
|
@ -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:
|
||||
------------------
|
||||
|
||||
|
|
@ -218,3 +249,107 @@ following:
|
|||
|
||||
The server then informs any other servers it is connected to of the
|
||||
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>}
|
||||
|
|
|
|||
|
|
@ -17,9 +17,39 @@ cabal-version: >=1.10
|
|||
|
||||
executable pipes-irc-server
|
||||
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:
|
||||
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
|
||||
, text >= 0.11.3 && < 0.12
|
||||
, attoparsec >= 0.10 && < 0.11
|
||||
|
|
@ -32,6 +62,11 @@ executable pipes-irc-server
|
|||
, stm >= 2 && < 3
|
||||
, async >= 2 && < 3
|
||||
, free >= 3 && < 4
|
||||
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
build-depends: tasty
|
||||
, tasty-hspec
|
||||
, tasty-hunit
|
||||
, tasty-quickcheck
|
||||
, tasty-smallcheck
|
||||
|
||||
hs-source-dirs: tests, src
|
||||
default-language: Haskell2010
|
||||
|
|
|
|||
13
src/Main.hs
13
src/Main.hs
|
|
@ -3,16 +3,19 @@
|
|||
module Main where
|
||||
|
||||
import Control.Concurrent.Async (wait)
|
||||
import Pipes.IRC.Server (listenHandler, mkIrcServer,
|
||||
startIrcServer)
|
||||
import Pipes.IRC.Server (startIrcServer)
|
||||
import Pipes.IRC.Server.Types (HostPreference (Host),
|
||||
IrcConfig (..))
|
||||
|
||||
main :: IO ()
|
||||
main =
|
||||
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
|
||||
srv <- mkIrcServer ircConf
|
||||
listener <- startIrcServer srv (listenHandler srv)
|
||||
listener <- startIrcServer ircConf
|
||||
wait listener
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
module Pipes.IRC.Message
|
||||
( parseMessage
|
||||
( parseMsgOrLine
|
||||
, parseIrcMessage
|
||||
, module Pipes.IRC.Message.Types
|
||||
) where
|
||||
|
||||
import Pipes.IRC.Message.Parse
|
||||
import Pipes.IRC.Message.Types
|
||||
|
||||
parseMessage = undefined
|
||||
|
|
|
|||
|
|
@ -32,8 +32,8 @@ parseIrcMessage =
|
|||
|
||||
parseMsgPrefix :: Parser MsgPrefix
|
||||
parseMsgPrefix =
|
||||
Left <$ char ':' <*> parseServerName <* takeWhile1 (== ' ') <|>
|
||||
Right <$ char ':' <*> parseNickName <* takeWhile1 (== ' ')
|
||||
Right <$ char ':' <*> parseNickName <* takeWhile1 (== ' ') <|>
|
||||
Left <$ char ':' <*> parseServerName <* takeWhile1 (== ' ')
|
||||
<?> "parseMsgPrefix"
|
||||
|
||||
parseServerName :: Parser ServerName
|
||||
|
|
@ -78,7 +78,7 @@ parseCommand =
|
|||
<?> "parseCommand"
|
||||
|
||||
parseIrcCommand :: Parser IrcCommand
|
||||
parseIrcCommand = (toCmd . C8.map toUpper) <$> P.takeWhile isAlpha_ascii
|
||||
parseIrcCommand = (toCmd . C8.map toUpper) <$> takeWhile1 isAlpha_ascii
|
||||
<?> "parseIrcCommand"
|
||||
where
|
||||
toCmd cmd = case cmd of
|
||||
|
|
@ -134,12 +134,13 @@ parseIrcReply = toReply <$> digit <*> digit <*> digit
|
|||
parseParams :: Parser [IrcParam]
|
||||
parseParams = takeWhile1 (== ' ') *>
|
||||
option [] ( parseTrail <|> parseMiddle )
|
||||
<|> pure []
|
||||
where
|
||||
parseTrail = (:[]) <$> parseTrailParam
|
||||
parseMiddle = (:) <$> parseMiddleParam <*> parseParams
|
||||
|
||||
parseTrailParam :: Parser IrcParam
|
||||
parseTrailParam = C8.cons <$> satisfy (== ':') <*> P.takeWhile isTrailingChar
|
||||
parseTrailParam = C8.cons <$> satisfy (== ':') *> P.takeWhile isTrailingChar
|
||||
|
||||
parseMiddleParam :: Parser IrcParam
|
||||
parseMiddleParam = C8.cons <$> satisfy (\c -> c /= ':' && isNonWhite c)
|
||||
|
|
|
|||
|
|
@ -1,73 +1,79 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Pipes.IRC.Message.Render where
|
||||
module Pipes.IRC.Message.Render
|
||||
( renderIrcMessage )
|
||||
where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Char8 as C8
|
||||
import Data.ByteString.Lazy (toStrict)
|
||||
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
|
||||
renderIrcMessage :: IrcMessage -> C8.ByteString
|
||||
renderIrcMessage = toStrict . toLazyByteString . buildIrcMessage
|
||||
|
||||
buildIrcMessage :: IrcMessage -> Builder
|
||||
buildIrcMessage IrcMessage {..} =
|
||||
buildMsgPrefix prefix
|
||||
<> buildMsgCommand command
|
||||
<> buildIrcParams params
|
||||
<> byteString "\r\n"
|
||||
|
||||
renderMsgPrefix :: Maybe MsgPrefix -> Builder
|
||||
renderMsgPrefix Nothing = mempty
|
||||
renderMsgPrefix mp =
|
||||
buildMsgPrefix :: Maybe MsgPrefix -> Builder
|
||||
buildMsgPrefix Nothing = mempty
|
||||
buildMsgPrefix mp =
|
||||
char8 ':'
|
||||
<> case mp of
|
||||
Just (Left sn) -> renderServerName sn
|
||||
Just (Right nn) -> renderNickName nn
|
||||
Just (Left sn) -> buildServerName sn
|
||||
Just (Right nn) -> buildNickName nn
|
||||
_ -> mempty
|
||||
<> char8 ' '
|
||||
|
||||
renderServerName :: ServerName -> Builder
|
||||
renderServerName = byteString
|
||||
buildServerName :: ServerName -> Builder
|
||||
buildServerName = byteString
|
||||
|
||||
renderNickName :: NickName -> Builder
|
||||
renderNickName NickName {..} =
|
||||
buildNickName :: NickName -> Builder
|
||||
buildNickName NickName {..} =
|
||||
byteString nick
|
||||
<> renderUser user
|
||||
<> renderHost host
|
||||
<> buildUser user
|
||||
<> buildHost host
|
||||
|
||||
renderUser :: Maybe ByteString -> Builder
|
||||
renderUser user =
|
||||
buildUser :: Maybe ByteString -> Builder
|
||||
buildUser user =
|
||||
case user of
|
||||
Nothing -> mempty
|
||||
Just name -> byteString "!" <> byteString name
|
||||
|
||||
renderHost :: Maybe ByteString -> Builder
|
||||
renderHost host =
|
||||
buildHost :: Maybe ByteString -> Builder
|
||||
buildHost host =
|
||||
case host of
|
||||
Nothing -> mempty
|
||||
Just name -> byteString "@" <> byteString name
|
||||
|
||||
renderMsgCommand :: MsgCommand -> Builder
|
||||
renderMsgCommand cmd =
|
||||
buildMsgCommand :: MsgCommand -> Builder
|
||||
buildMsgCommand cmd =
|
||||
case cmd of
|
||||
Left ircCmd -> renderIrcCommand ircCmd
|
||||
Right ircReply -> renderIrcReply ircReply
|
||||
Left ircCmd -> buildIrcCommand ircCmd
|
||||
Right ircReply -> buildIrcReply ircReply
|
||||
<> byteString " "
|
||||
|
||||
renderIrcCommand :: IrcCommand -> Builder
|
||||
renderIrcCommand cmd =
|
||||
buildIrcCommand :: IrcCommand -> Builder
|
||||
buildIrcCommand cmd =
|
||||
case cmd of
|
||||
(Unknown name) -> byteString name
|
||||
_ -> byteString . C8.pack . show $ cmd
|
||||
|
||||
renderIrcReply :: IrcReply -> Builder
|
||||
renderIrcReply IrcReply {..} = intDec replyCode
|
||||
buildIrcReply :: IrcReply -> Builder
|
||||
buildIrcReply IrcReply {..} = intDec replyCode
|
||||
|
||||
renderIrcParams :: [IrcParam] -> Builder
|
||||
renderIrcParams [] = mempty
|
||||
renderIrcParams (p:ps) =
|
||||
renderParam p <> mconcat [char8 ' ' <> renderParam p' | p' <- ps ]
|
||||
buildIrcParams :: [IrcParam] -> Builder
|
||||
buildIrcParams [] = mempty
|
||||
buildIrcParams (p:ps) =
|
||||
buildParam p <> mconcat [char8 ' ' <> buildParam p' | p' <- ps ]
|
||||
|
||||
renderParam :: IrcParam -> Builder
|
||||
renderParam = byteString
|
||||
buildParam :: IrcParam -> Builder
|
||||
buildParam = byteString
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ data IrcMessage =
|
|||
IrcMessage { prefix :: Maybe MsgPrefix
|
||||
, command :: MsgCommand
|
||||
, params :: [IrcParam]
|
||||
} deriving (Show)
|
||||
} deriving (Show, Eq)
|
||||
|
||||
type MsgPrefix = Either ServerName NickName
|
||||
|
||||
|
|
@ -17,7 +17,7 @@ data NickName =
|
|||
NickName { nick :: B.ByteString
|
||||
, user :: Maybe B.ByteString
|
||||
, host :: Maybe B.ByteString
|
||||
} deriving (Show)
|
||||
} deriving (Show, Eq)
|
||||
|
||||
type MsgCommand = Either IrcCommand IrcReply
|
||||
|
||||
|
|
|
|||
|
|
@ -1,9 +1,7 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Pipes.IRC.Server
|
||||
( mkIrcServer
|
||||
, startIrcServer
|
||||
, listenHandler
|
||||
( startIrcServer
|
||||
, module Pipes.IRC.Server.Types
|
||||
)
|
||||
where
|
||||
|
|
@ -11,131 +9,128 @@ 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 Control.Monad.RWS
|
||||
import Data.ByteString.Char8 as BS
|
||||
import Data.Map as M
|
||||
import Data.Set as S
|
||||
import Network.Socket as NS
|
||||
import Pipes
|
||||
import Pipes.Attoparsec
|
||||
import Pipes.Concurrent as PC
|
||||
import Pipes.Concurrent as PC
|
||||
import Pipes.IRC.Message.Parse
|
||||
import Pipes.IRC.Message.Render
|
||||
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.Lift (runStateP)
|
||||
import Pipes.Network.TCP
|
||||
import Pipes.Parse as PP
|
||||
import Pipes.Network.TCP as PN
|
||||
|
||||
sendToMany :: a -> [Output a] -> IO ()
|
||||
sendToMany msg outs = do
|
||||
resL <- forM outs $ \o ->
|
||||
async $ atomically $ PC.send o msg
|
||||
mapM_ wait resL
|
||||
parseMessage :: Producer BS.ByteString IO ()
|
||||
-> Producer (Either BS.ByteString IrcMessage) IO ()
|
||||
parseMessage prod = do
|
||||
void $ for (parseMany parseMsgOrLine prod) $ \res ->
|
||||
case res of
|
||||
(_, Left _) -> yield $ Left "ERROR Bad Parse"
|
||||
(_, Right val) -> yield $ Right val
|
||||
return ()
|
||||
|
||||
publishStream :: TVar [IrcConnection a] -> Consumer a IO ()
|
||||
publishStream clients = forever $ do
|
||||
renderMessage :: Pipe IrcMessage BS.ByteString IO ()
|
||||
renderMessage = 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
|
||||
let output = renderIrcMessage msg
|
||||
yield output
|
||||
|
||||
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]
|
||||
Left bs -> liftIO $ 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
|
||||
addIrcConnection :: ServerState -> IrcConnection -> IO Int
|
||||
addIrcConnection srv client = do
|
||||
let clients = ircConnections srv
|
||||
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 client server = do
|
||||
let clients = ircConnections server
|
||||
atomically $ modifyTVar clients $ delete client
|
||||
delIrcConnection :: ServerState -> Int -> IO ()
|
||||
delIrcConnection srv cid = do
|
||||
let clients = ircConnections srv
|
||||
atomically $ modifyTVar' clients $ M.delete cid
|
||||
|
||||
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
|
||||
cmdHandler :: ServerState -> Int -> Consumer IrcMessage IO ()
|
||||
cmdHandler srv cid =
|
||||
let cReg = Unreg Nothing Nothing Nothing
|
||||
in handle cReg
|
||||
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
|
||||
handle userReg = do
|
||||
-- wait for the next command
|
||||
nextMsg <- await
|
||||
|
||||
renderMessage :: Pipe IrcMessage BS.ByteString IO ()
|
||||
renderMessage = forever $ do
|
||||
msg <- await
|
||||
let output = toIrcMessage msg
|
||||
yield output
|
||||
where
|
||||
toIrcMessage = toStrict . toLazyByteString . renderIrcMessage
|
||||
-- run the handler in a transaction
|
||||
(newReg, events) <- liftIO $ atomically $ do
|
||||
sState <- readTVar (ircState srv)
|
||||
let sConf = ircConfig srv
|
||||
let cState = ClientState { clientReg = userReg
|
||||
, clientServer = sState
|
||||
, clientConn = cid }
|
||||
|
||||
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
|
||||
-- run the handler in the IrcMonad, returning new state and events
|
||||
let (_, newState, events) =
|
||||
runRWS (runIrc $ ircMessageHandler nextMsg) sConf cState
|
||||
|
||||
addIrcConnection client server
|
||||
writeTVar (ircState srv) $ clientServer newState
|
||||
return (clientReg newState, events)
|
||||
|
||||
r <- async $ runEffect $
|
||||
parseMessage sockReader >-> filterMsgs >-> handler
|
||||
-- handle resulting events
|
||||
liftIO $ forM_ events $ ircEventHandler srv
|
||||
|
||||
w <- async $ runEffect $
|
||||
fromInput readEnd >-> renderMessage >-> sockWriter
|
||||
-- loop for the next command
|
||||
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
|
||||
conns <- atomically $ newTVar []
|
||||
users <- atomically $ newTVar []
|
||||
chans <- atomically $ newTVar []
|
||||
echoEnd <- spawnEcho conns
|
||||
return $ IrcServer config conns users chans (cmdHandler echoEnd)
|
||||
let nks = S.empty
|
||||
urs = M.empty
|
||||
chs = M.empty
|
||||
srv = IrcServer nks urs chs
|
||||
tvState <- newTVarIO srv
|
||||
tvCns <- newTVarIO M.empty
|
||||
tvRef <- newTVarIO 0
|
||||
return $ ServerState tvState config tvCns tvRef
|
||||
|
||||
startIrcServer :: IrcServer -> IrcHandler -> IO (Async ())
|
||||
startIrcServer server handler =
|
||||
async $ listen sHost sPort handler
|
||||
where
|
||||
sHost = ircHost . ircConfig $ server
|
||||
sPort = ircPort . ircConfig $ server
|
||||
startIrcServer :: IrcConfig -> IO (Async ())
|
||||
startIrcServer config = do
|
||||
srv <- mkIrcServer config
|
||||
let sHost = (ircHost . ircConfig) srv
|
||||
sPort = (ircPort . ircConfig) srv
|
||||
async $ PN.listen sHost sPort (listenHandler srv)
|
||||
|
|
|
|||
|
|
@ -0,0 +1,3 @@
|
|||
module Pipes.IRC.Server.Connection where
|
||||
|
||||
import Pipes.IRC.Server.Types
|
||||
|
|
@ -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
|
||||
|
|
@ -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]
|
||||
|
|
@ -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 ()
|
||||
|
|
@ -1,59 +1,93 @@
|
|||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
|
||||
module Pipes.IRC.Server.Types
|
||||
( HostPreference(..)
|
||||
, IrcHandler
|
||||
, IrcMessage
|
||||
, IrcEvent(..)
|
||||
, IrcEvents
|
||||
, IrcConnection(..)
|
||||
, IrcConfig(..)
|
||||
, IrcServer(..)
|
||||
, IrcUser(..)
|
||||
, IrcChannel(..)
|
||||
, IrcMonad(..)
|
||||
, ServerState(..)
|
||||
, ClientState(..)
|
||||
, RegState(..)
|
||||
) where
|
||||
|
||||
import Control.Concurrent.STM (TVar)
|
||||
import Control.Monad.RWS (MonadReader, MonadState, MonadWriter,
|
||||
RWS)
|
||||
import Data.ByteString (ByteString)
|
||||
import Pipes (Consumer)
|
||||
import Data.Map (Map)
|
||||
import Data.Set (Set)
|
||||
import Pipes.Concurrent (Output)
|
||||
import Pipes.IRC.Message.Types (IrcMessage)
|
||||
import Pipes.Network.TCP (HostPreference (..), ServiceName,
|
||||
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 =
|
||||
IrcServer { ircConfig :: !IrcConfig
|
||||
, ircConnections :: !(TVar [IrcConnection IrcMessage])
|
||||
, ircUsers :: !(TVar [IrcUser])
|
||||
, ircChannels :: !(TVar [IrcChannel])
|
||||
, ircHandler :: !(Consumer IrcMessage IO ())
|
||||
}
|
||||
IrcServer { ircNicks :: !(Set ByteString)
|
||||
, ircUsers :: !(Map ByteString IrcUser)
|
||||
, ircChannels :: !(Map ByteString IrcChannel)
|
||||
} deriving (Show)
|
||||
|
||||
data IrcConfig =
|
||||
IrcConfig { ircPort :: !ServiceName
|
||||
, ircHost :: !HostPreference
|
||||
, ircMotd :: ![ByteString]
|
||||
, ircPass :: !(Maybe ByteString)
|
||||
} deriving (Show)
|
||||
|
||||
data IrcConnection a =
|
||||
data IrcConnection =
|
||||
IrcConnection { sock :: !Socket
|
||||
, 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 =
|
||||
IrcUser { userNick :: !ByteString
|
||||
, userClientId :: !ByteString
|
||||
, userServerName :: !ByteString
|
||||
, userName :: !ByteString
|
||||
, userHostName :: !ByteString
|
||||
IrcUser { userNick :: !(Maybe ByteString)
|
||||
, userServerName :: !(Maybe ByteString)
|
||||
, userName :: !(Maybe ByteString)
|
||||
, userHostName :: !(Maybe ByteString)
|
||||
, userModes :: ![IrcUserMode]
|
||||
, userConn :: !(IrcConnection IrcMessage)
|
||||
, userConn :: !Int
|
||||
} deriving (Show, Eq)
|
||||
|
||||
data IrcUserMode = Away | Invisible | WallOps | Restricted
|
||||
|
|
|
|||
|
|
@ -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
|
||||
]
|
||||
-}
|
||||
Loading…
Reference in New Issue