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

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:
------------------
@ -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>}

View File

@ -17,12 +17,20 @@ 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
@ -35,3 +43,30 @@ executable pipes-irc-server
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
, 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
build-depends: tasty
, tasty-hspec
, tasty-hunit
, tasty-quickcheck
, tasty-smallcheck
hs-source-dirs: tests, src
default-language: Haskell2010

View File

@ -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

View File

@ -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

View File

@ -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)

View File

@ -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

View File

@ -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

View File

@ -1,9 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
module Pipes.IRC.Server
( mkIrcServer
, startIrcServer
, listenHandler
( startIrcServer
, module Pipes.IRC.Server.Types
)
where
@ -11,109 +9,103 @@ where
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Monad
import Control.Monad.RWS
import Data.ByteString.Char8 as BS
import Data.ByteString.Lazy as LB
import Data.ByteString.Lazy.Builder (toLazyByteString)
import Data.List as L
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.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
-- run the handler in the IrcMonad, returning new state and events
let (_, newState, events) =
runRWS (runIrc $ ircMessageHandler nextMsg) sConf cState
writeTVar (ircState srv) $ clientServer newState
return (clientReg newState, events)
-- handle resulting events
liftIO $ forM_ events $ ircEventHandler srv
-- loop for the next command
handle newReg
listenHandler :: ServerState -> (Socket, SockAddr) -> IO ()
listenHandler srv (lsock, _) =
forever $ acceptFork lsock $ \(csock, caddr) -> do
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
cid <- addIrcConnection srv client
let handler = cmdHandler srv cid
r <- async $ runEffect $
parseMessage sockReader >-> filterMsgs >-> handler
@ -123,19 +115,22 @@ listenHandler server (lsock, _) =
mapM_ wait [r,w]
delIrcConnection client server
delIrcConnection srv cid
mkIrcServer :: IrcConfig -> IO IrcServer
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)

View File

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

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

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]

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 ()

View File

@ -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)
data IrcServer =
IrcServer { ircConfig :: !IrcConfig
, ircConnections :: !(TVar [IrcConnection IrcMessage])
, ircUsers :: !(TVar [IrcUser])
, ircChannels :: !(TVar [IrcChannel])
, ircHandler :: !(Consumer IrcMessage IO ())
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 { 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

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
]
-}