Significant refactoring and added parser tests

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

pipes-irc-server.cabal

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

src/Main.hs

@@ -3,16 +3,19 @@
 module Main where
 
 import           Control.Concurrent.Async (wait)
-import           Pipes.IRC.Server         (listenHandler, mkIrcServer,
+import           Pipes.IRC.Server         (startIrcServer)
-                                           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 ircConf
-    listener <- startIrcServer srv (listenHandler srv)
     wait listener

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

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)

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 -> C8.ByteString
-renderIrcMessage IrcMessage {..} =
+renderIrcMessage = toStrict . toLazyByteString . buildIrcMessage
-     renderMsgPrefix  prefix
+
-  <> renderMsgCommand command
+buildIrcMessage :: IrcMessage -> Builder
-  <> renderIrcParams  params
+buildIrcMessage IrcMessage {..} =
+     buildMsgPrefix  prefix
+  <> buildMsgCommand command
+  <> buildIrcParams  params
   <> byteString "\r\n"
 
-renderMsgPrefix :: Maybe MsgPrefix -> Builder
+buildMsgPrefix :: Maybe MsgPrefix -> Builder
-renderMsgPrefix Nothing = mempty
+buildMsgPrefix Nothing = mempty
-renderMsgPrefix mp =
+buildMsgPrefix mp =
      char8 ':'
   <> case mp of
-       Just (Left sn)  -> renderServerName sn
+       Just (Left sn)  -> buildServerName sn
-       Just (Right nn) -> renderNickName nn
+       Just (Right nn) -> buildNickName nn
        _               -> mempty
   <> char8 ' '
 
-renderServerName :: ServerName -> Builder
+buildServerName :: ServerName -> Builder
-renderServerName = byteString
+buildServerName = byteString
 
-renderNickName :: NickName -> Builder
+buildNickName :: NickName -> Builder
-renderNickName NickName {..} =
+buildNickName NickName {..} =
      byteString nick
-  <> renderUser user
+  <> buildUser user
-  <> renderHost host
+  <> buildHost host
 
-renderUser :: Maybe ByteString -> Builder
+buildUser :: Maybe ByteString -> Builder
-renderUser user =
+buildUser user =
   case user of
     Nothing   -> mempty
     Just name -> byteString "!" <> byteString name
 
-renderHost :: Maybe ByteString -> Builder
+buildHost :: Maybe ByteString -> Builder
-renderHost host =
+buildHost host =
   case host of
     Nothing   -> mempty
     Just name -> byteString "@" <> byteString name
 
-renderMsgCommand :: MsgCommand -> Builder
+buildMsgCommand :: MsgCommand -> Builder
-renderMsgCommand cmd =
+buildMsgCommand cmd =
   case cmd of
-    Left ircCmd    -> renderIrcCommand ircCmd
+    Left ircCmd    -> buildIrcCommand ircCmd
-    Right ircReply -> renderIrcReply ircReply
+    Right ircReply -> buildIrcReply ircReply
   <> byteString " "
 
-renderIrcCommand :: IrcCommand -> Builder
+buildIrcCommand :: IrcCommand -> Builder
-renderIrcCommand cmd =
+buildIrcCommand cmd =
   case cmd of
     (Unknown name) -> byteString name
     _              -> byteString . C8.pack . show $ cmd
 
-renderIrcReply :: IrcReply -> Builder
+buildIrcReply :: IrcReply -> Builder
-renderIrcReply IrcReply {..} = intDec replyCode
+buildIrcReply IrcReply {..} = intDec replyCode
 
-renderIrcParams :: [IrcParam] -> Builder
+buildIrcParams :: [IrcParam] -> Builder
-renderIrcParams []     = mempty
+buildIrcParams []     = mempty
-renderIrcParams (p:ps) =
+buildIrcParams (p:ps) =
-  renderParam p <> mconcat [char8 ' ' <> renderParam p' | p' <- ps ]
+  buildParam p <> mconcat [char8 ' ' <> buildParam p' | p' <- ps ]
 
-renderParam :: IrcParam -> Builder
+buildParam :: IrcParam -> Builder
-renderParam = byteString
+buildParam = byteString

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
 

src/Pipes/IRC/Server.hs

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

src/Pipes/IRC/Server/Connection.hs

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

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

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]

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

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)
 
-data IrcServer =
+type IrcEvents = [IrcEvent]
-  IrcServer { ircConfig      :: !IrcConfig
+
-            , ircConnections :: !(TVar [IrcConnection IrcMessage])
+newtype IrcMonad a =
-            , ircUsers       :: !(TVar [IrcUser])
+  IrcMonad { runIrc :: RWS IrcConfig IrcEvents ClientState a }
-            , ircChannels    :: !(TVar [IrcChannel])
+  deriving ( Monad
-            , ircHandler     :: !(Consumer IrcMessage IO ())
+           , 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
+  IrcUser { userNick       :: !(Maybe ByteString)
-          , userClientId   :: !ByteString
+          , userServerName :: !(Maybe ByteString)
-          , userServerName :: !ByteString
+          , userName       :: !(Maybe ByteString)
-          , userName       :: !ByteString
+          , userHostName   :: !(Maybe ByteString)
-          , userHostName   :: !ByteString
           , userModes      :: ![IrcUserMode]
-          , userConn       :: !(IrcConnection IrcMessage)
+          , userConn       :: !Int
           } deriving (Show, Eq)
 
 data IrcUserMode = Away | Invisible | WallOps | Restricted

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