diff --git a/notes.md b/notes.md index ebff6af..ab2cdd3 100644 --- a/notes.md +++ b/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 + Needs server env for password + Modifies connection state + Errors: ERR_NEEDMOREPARAMS, ERR_ALREADYREGISTERED + +* NICK [ ] + 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 <:realname> + hostname and servername are ignored when coming from clients + Errors: ERR_NEEDMOREPARAMS, ERR_ALREADYREGISTERED + +* SERVER <:info> + Errors: ERR_ALREADYREGISTERED + +* OPER + Errors: ERR_NEEDMOREPARAMS, ERR_NOOPERHOST, ERR_PASSWDMISMATCH + Reply: RPL_YOUREOPER + +* QUIT <:quit message> + +* SQUIT <:comment> + Errors: ERR_NOPRIVILEGES, ERR_NOSUCHSERVER + +### Channel Operations +* JOIN {,} [{,}] + Errors: ERR_NEEDMOREPARAMS, ERR_BANNEDFROMCHAN, ERR_INVITEONLYCHAN, ERR_CHANNELISFULL, + ERR_BADCHANNELKEY, ERR_BADCHANMASK, ERR_NOSUCHCHANNEL, ERR_TOOMANYCHANNELS + Reply: RPL_TOPIC + +* PART {,} + Errors: ERR_NEEDMOREPARAMS, ERR_NOSUCHCHANNEL, ERR_NOTONCHANNEL + +* MODE {[+|-]o|p|s|i|t|n|b|v} [] [] [] + Errors: ERR_NEEDMOREPARAMS, ERR_CHANOPRIVSNEEDED, ERR_NOTONCHANNEL, ERR_UNKNOWNMODE, + ERR_NOSUCHNICK, ERR_KEYSET, ERR_NOSUCHCHANNEL + Reply: RPL_CHANNELMODEIS, RPL_BANLIST, RPL_ENDOFBANLIST + +* TOPIC [<:topic>] + Errors: ERR_NEEDMOREPARAMS, ERR_NOTONCHANNEL, ERR_CHANOPRIVSNEEDED + Reply: RPL_NOTOPIC, RPL_TOPIC + +* NAMES [{,}] + Reply: RPL_NAMREPLY, RPL_ENDOFNAMES + +* LIST [{,} []] + Errors: ERR_NOSUCHSERVER + Reply: RPL_LISTSTART, RPL_LIST, RPL_LISTEND + +* INVITE + Errors: ERR_NEEDMOREPARAMS, ERR_NOSUCHNICK, ERR_NOTONCHANNEL, ERR_USERONCHANNEL, + ERR_CHANOPRIVSNEEDED + Reply: RPL_INVITING, RPL_AWAY + +* KICK [<:comment>] + Errors: ERR_NEEDMOREPARAMS, ERR_NOSUCHCHANNEL, ERR_BADCHANMASK, ERR_CHANOPRIVSNEEDED, + ERR_NOTONCHANNEL + +### User Operations +* MODE {[+|-]i|w|s|o} + Errors: ERR_USERSDONTMATCH, ERR_UMODEUNKNOWNFLAG + Reply: RPL_UMODEIS + +### Server Queries and Commands +* VERSION [] +* STATS [ []] +* LINKS [[] ] +* TIME [] +* CONNECT [ []] +* TRACE [] +* ADMIN [] +* INFO [] + +### Sending Messages +* PRIVMSG {,} <:text to be sent> +* NOTICE <:text> + +### User Based Queries +* WHO [ [o]] +* WHOIS [] [,[,...]] +* WHOWAS [ []] + +### Miscellaneous Messages +* KILL <:comment> +* PING [] +* PONG [] +* ERROR <:error message> + +### Optional Messages +* AWAY [<:message>] +* REHASH +* RESTART +* SUMMON [] +* USERS [] +* WALLOPS <:text for opers> +* USERHOST { } +* ISON { } diff --git a/pipes-irc-server.cabal b/pipes-irc-server.cabal index ffb904a..c2d7464 100644 --- a/pipes-irc-server.cabal +++ b/pipes-irc-server.cabal @@ -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 \ No newline at end of file + build-depends: tasty + , tasty-hspec + , tasty-hunit + , tasty-quickcheck + , tasty-smallcheck + + hs-source-dirs: tests, src + default-language: Haskell2010 diff --git a/src/Main.hs b/src/Main.hs index e8c636c..87ae6b3 100644 --- a/src/Main.hs +++ b/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 diff --git a/src/Pipes/IRC/Message.hs b/src/Pipes/IRC/Message.hs index b68fcff..1ff1139 100644 --- a/src/Pipes/IRC/Message.hs +++ b/src/Pipes/IRC/Message.hs @@ -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 diff --git a/src/Pipes/IRC/Message/Parse.hs b/src/Pipes/IRC/Message/Parse.hs index 29b5e87..8fc888e 100644 --- a/src/Pipes/IRC/Message/Parse.hs +++ b/src/Pipes/IRC/Message/Parse.hs @@ -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) diff --git a/src/Pipes/IRC/Message/Render.hs b/src/Pipes/IRC/Message/Render.hs index 5aa429a..ea3a5af 100644 --- a/src/Pipes/IRC/Message/Render.hs +++ b/src/Pipes/IRC/Message/Render.hs @@ -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 diff --git a/src/Pipes/IRC/Message/Types.hs b/src/Pipes/IRC/Message/Types.hs index 2aa0f3b..9832448 100644 --- a/src/Pipes/IRC/Message/Types.hs +++ b/src/Pipes/IRC/Message/Types.hs @@ -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 diff --git a/src/Pipes/IRC/Server.hs b/src/Pipes/IRC/Server.hs index c20d7e6..652b591 100644 --- a/src/Pipes/IRC/Server.hs +++ b/src/Pipes/IRC/Server.hs @@ -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) diff --git a/src/Pipes/IRC/Server/Connection.hs b/src/Pipes/IRC/Server/Connection.hs new file mode 100644 index 0000000..b49e426 --- /dev/null +++ b/src/Pipes/IRC/Server/Connection.hs @@ -0,0 +1,3 @@ +module Pipes.IRC.Server.Connection where + +import Pipes.IRC.Server.Types diff --git a/src/Pipes/IRC/Server/EventHandler.hs b/src/Pipes/IRC/Server/EventHandler.hs new file mode 100644 index 0000000..b2f56f9 --- /dev/null +++ b/src/Pipes/IRC/Server/EventHandler.hs @@ -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 diff --git a/src/Pipes/IRC/Server/Log.hs b/src/Pipes/IRC/Server/Log.hs new file mode 100644 index 0000000..531b493 --- /dev/null +++ b/src/Pipes/IRC/Server/Log.hs @@ -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] diff --git a/src/Pipes/IRC/Server/MessageHandler.hs b/src/Pipes/IRC/Server/MessageHandler.hs new file mode 100644 index 0000000..6ea49fc --- /dev/null +++ b/src/Pipes/IRC/Server/MessageHandler.hs @@ -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 () diff --git a/src/Pipes/IRC/Server/Types.hs b/src/Pipes/IRC/Server/Types.hs index fce573a..c735e9b 100644 --- a/src/Pipes/IRC/Server/Types.hs +++ b/src/Pipes/IRC/Server/Types.hs @@ -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 diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 index 0000000..39583b4 --- /dev/null +++ b/tests/Main.hs @@ -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 + ] +-}