irc-core-2.7.0: test/Main.hs

{-# Language OverloadedStrings #-}
{-|
Module      : Main
Description : Tests for the irc-core library
Copyright   : (c) Eric Mertens, 2016
License     : ISC
Maintainer  : emertens@gmail.com

This module test IRC message parsing.

-}
module Main (main) where

import qualified Data.Text as Text
import           Data.Hashable
import           Data.Semigroup
import           Irc.RawIrcMsg
import           Irc.UserInfo
import           Irc.Identifier
import           System.Exit
import           Test.HUnit
import           Text.Read

main :: IO a
main =
  do outcome <- runTestTT tests
     if errors outcome == 0 && failures outcome == 0
       then exitSuccess
       else exitFailure

tests :: Test
tests = test [ irc0, irc2, irc15, ircWithPrefix, ircWithTags,
               parseUserInfos, renderUserInfos, renderIrc,
               badRawMsgs, userInfoFields, identifierInstances ]

-- | Check that we can handle commands without parameters
irc0 :: Test
irc0 = test [ assertEqual "" goal (parseRawIrcMsg alt) | alt <- alternatives ]
  where
    goal = Just (rawIrcMsg "COMMAND" [])
    alternatives =
      [ "COMMAND"
      , "COMMAND "
      , "COMMAND  "
      ]

-- | Check that we can handle commands with two parameters and an assortment of spacing
irc2 :: Test
irc2 = test [ assertEqual "" goal (parseRawIrcMsg alt) | alt <- alternatives ]
  where
    goal = Just (rawIrcMsg "COMMAND" ["param1","param2"])
    alternatives =
      [ "COMMAND param1 param2"
      , "COMMAND   param1 param2"
      , "COMMAND   param1   param2"
      , "COMMAND param1   param2"
      , "COMMAND param1   param2   "
      , "COMMAND param1   :param2"
      , "COMMAND param1 :param2"
      ]

-- | Check that we max out at 15 parameters
irc15 :: Test
irc15 = test
  [ assertEqual "" goal (parseRawIrcMsg raw1)
  , assertEqual "" goal (parseRawIrcMsg raw2)
  ]
  where
    goal   = Just (rawIrcMsg "001" (params ++ ["last  two"]))
    params = map (Text.pack . show) [1 .. 14 :: Int]
    raw1 = "001 " <> Text.unwords params <> " last  two"
    raw2 = "001 " <> Text.unwords params <> "  :last  two"

ircWithPrefix :: Test
ircWithPrefix = test
  [ assertEqual ""
      (Just (rawIrcMsg "254" ["glguytest", "57555", "channels formed"])
            { _msgPrefix = Just (UserInfo "morgan.freenode.net" "" "") })
      (parseRawIrcMsg ":morgan.freenode.net 254 glguytest 57555 :channels formed")
  ]

ircWithTags :: Test
ircWithTags = test
  [ assertEqual "without prefix"
      (Just (rawIrcMsg "CMD" [])
            { _msgTags = [TagEntry "time" "value"] })
      (parseRawIrcMsg "@time=value CMD")

  , assertEqual "with prefix"
      (Just (rawIrcMsg "CMD" [])
            { _msgTags = [TagEntry "time" "value"]
            , _msgPrefix = Just (UserInfo "prefix" "user" "host") })
      (parseRawIrcMsg "@time=value :prefix!user@host CMD")

  , assertEqual "two tags"
      (Just (rawIrcMsg "CMD" [])
            { _msgTags = [TagEntry "time" "value", TagEntry "this" "\n\rand\\ ;that"] })
      (parseRawIrcMsg "@time=value;this=\\n\\rand\\\\\\s\\:that CMD")

  , assertEqual "don't escape keys"
      (Just (rawIrcMsg "CMD" [])
            { _msgTags = [TagEntry "this\\s" "value"] })
      (parseRawIrcMsg "@this\\s=value CMD")

  , assertEqual "optional key"
      (Just (rawIrcMsg "CMD" [])
            { _msgTags = [TagEntry "this" ""] })
      (parseRawIrcMsg "@this CMD")

  , assertEqual "optional keys"
      (Just (rawIrcMsg "CMD" [])
            { _msgTags = [TagEntry "this" "", TagEntry "that" ""] })
      (parseRawIrcMsg "@this;that CMD")

  ]

renderUserInfos :: Test
renderUserInfos = test

  [ assertEqual "missing user and hostname"
      "glguy"
      (renderUserInfo (UserInfo "glguy" "" ""))

  , assertEqual "freenode cloak"
      "glguy!~glguy@haskell/developer/glguy"
      (renderUserInfo (UserInfo "glguy" "~glguy" "haskell/developer/glguy"))

  , assertEqual "missing user"
      "glguy@haskell/developer/glguy"
      (renderUserInfo (UserInfo "glguy" "" "haskell/developer/glguy"))

  , assertEqual "missing host"
      "glguy!~glguy"
      (renderUserInfo (UserInfo "glguy" "~glguy" ""))

  , assertEqual "extra @ goes into host"
      "nick!user@server@name"
      (renderUserInfo (UserInfo "nick" "user" "server@name"))

  , assertEqual "servername in nick"
      "morgan.freenode.net"
      (renderUserInfo (UserInfo "morgan.freenode.net" "" ""))
  ]

userInfoFields :: Test
userInfoFields = test
  [ assertEqual "nickfield" "nick" (userNick (UserInfo "nick" "user" "host"))
  , assertEqual "userfield" "user" (userName (UserInfo "nick" "user" "host"))
  , assertEqual "hostfield" "host" (userHost (UserInfo "nick" "user" "host"))
  ]

parseUserInfos :: Test
parseUserInfos = test

  [ assertEqual "missing user and hostname"
      (UserInfo "glguy" "" "")
      (parseUserInfo "glguy")

  , assertEqual "freenode cloak"
      (UserInfo "glguy" "~glguy" "haskell/developer/glguy")
      (parseUserInfo "glguy!~glguy@haskell/developer/glguy")

  , assertEqual "missing user"
      (UserInfo "glguy" "" "haskell/developer/glguy")
      (parseUserInfo "glguy@haskell/developer/glguy")

  , assertEqual "missing host"
      (UserInfo "glguy" "~glguy" "")
      (parseUserInfo "glguy!~glguy")

  , assertEqual "extra @ goes into host"
      (UserInfo "nick" "user" "server@name")
      (parseUserInfo "nick!user@server@name")

  , assertEqual "servername in nick"
      (UserInfo "morgan.freenode.net" "" "")
      (parseUserInfo "morgan.freenode.net")
  ]

renderIrc :: Test
renderIrc = test
  [ assertEqual ""
      ":morgan.freenode.net 254 glguytest 57555 :channels formed\r\n"
      (renderRawIrcMsg
          (rawIrcMsg "254" ["glguytest", "57555", "channels formed"])
          { _msgPrefix = Just (UserInfo "morgan.freenode.net" "" "") })

  , assertEqual ""
      "254 glguytest 57555 :channels formed\r\n"
      (renderRawIrcMsg
          (rawIrcMsg "254" ["glguytest", "57555", "channels formed"]))

  , assertEqual ""
      "CMD param:with:colon\r\n"
      (renderRawIrcMsg (rawIrcMsg "CMD" ["param:with:colon"]))

  , assertEqual ""
      "CMD ::param\r\n"
      (renderRawIrcMsg (rawIrcMsg "CMD" [":param"]))

  , assertEqual ""
      "CMD\r\n"
      (renderRawIrcMsg (rawIrcMsg "CMD" []))

  , assertEqual "two tags"
      "@time=value;this=\\n\\rand\\\\\\s\\:that CMD\r\n"
      (renderRawIrcMsg (rawIrcMsg "CMD" [])
            { _msgTags = [TagEntry "time" "value",
                          TagEntry "this" "\n\rand\\ ;that"] })

  , assertEqual "empty tags"
      "@time;magic CMD\r\n"
      (renderRawIrcMsg (rawIrcMsg "CMD" [])
            { _msgTags = [TagEntry "time" "",
                          TagEntry "magic" ""] })

  , assertEqual "empty last argument 1"
      "CMD :\r\n"
      (renderRawIrcMsg (rawIrcMsg "CMD" [""]))

  , assertEqual "empty last argument 2"
      "CMD X :\r\n"
      (renderRawIrcMsg (rawIrcMsg "CMD" ["X", ""]))

  ]

badRawMsgs :: Test
badRawMsgs = test
  [ assertEqual "bad prefix"
      Nothing
      (parseRawIrcMsg ": CMD")
  , assertEqual "empty string"
      Nothing
      (parseRawIrcMsg "")
  , assertEqual "whitespace"
      Nothing
      (parseRawIrcMsg "   ")
  , assertEqual "only prefix"
      Nothing
      (parseRawIrcMsg ":glguy!glguy@glguy")
  , assertEqual "only tags"
      Nothing
      (parseRawIrcMsg "@glguy=tester")
  ]

identifierInstances :: Test
identifierInstances = test
  [ assertEqual "read" (Just ("GLGUY"::Identifier)) (readMaybe "\"glguy\"")
  , assertEqual "read2" (Just ("Glguy"::Identifier)) (readMaybe "\"glguy\"")
  , assertEqual "show1" "\"GLguy\"" (show ("GLguy"::Identifier))
  , assertEqual "show2" "\"glguy\"" (show ("glguy"::Identifier))
  , assertBool "hash"  $ hash ("glguy"::Identifier) ==
                         hash ("GLGUY"::Identifier)
  , assertBool "lt1"   $ "glguy"  < ("tester" :: Identifier)
  , assertBool "gt1"   $ "tester" > ("glguy" :: Identifier)
  , assertBool "lt2"   $ "GLGUY"  < ("tester" :: Identifier)
  , assertBool "gt2"   $ "TESTER" > ("glguy" :: Identifier)
  , assertBool "pre"   $ idPrefix "gl" "GLGUY"
  , assertBool "pre"   $ not $ idPrefix "glguy" "gl"
  ]