{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}

{-|
Module      : Irc.RawIrcMsg
Description : Low-level representation of IRC messages
Copyright   : (c) Eric Mertens, 2016
License     : ISC
Maintainer  : emertens@gmail.com

This module provides a parser and printer for the low-level IRC
message format. It handles splitting up IRC commands into the
prefix, command, and arguments.

-}
module Irc.RawIrcMsg
  (
  -- * Low-level IRC messages
    RawIrcMsg(..)
  , TagEntry(..)
  , rawIrcMsg
  , msgTags
  , msgPrefix
  , msgCommand
  , msgParams

  -- * Text format for IRC messages
  , parseRawIrcMsg
  , renderRawIrcMsg
  , prefixParser
  , simpleTokenParser

  -- * Permissive text decoder
  , asUtf8
  ) where

import           Control.Applicative
import           Data.Attoparsec.Text as P
import           Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import           Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Builder as Builder
import           Data.List
import           Data.Maybe
import           Data.Monoid
import           Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import           Data.Vector (Vector)
import qualified Data.Vector as Vector

import           Irc.UserInfo
import           View

-- | 'RawIrcMsg' breaks down the IRC protocol into its most basic parts.
-- The "trailing" parameter indicated in the IRC protocol with a leading
-- colon will appear as the last parameter in the parameter list.
--
-- Note that RFC 2812 specifies a maximum of 15 parameters.
--
-- This parser is permissive regarding spaces. It aims to parse carefully
-- constructed messages exactly and to make a best effort to recover from
-- extraneous spaces. It makes no effort to validate nicknames, usernames,
-- hostnames, commands, etc. Servers don't all agree on these things.
--
-- @:prefix COMMAND param0 param1 param2 .. paramN@
data RawIrcMsg = RawIrcMsg
  { RawIrcMsg -> [TagEntry]
_msgTags       :: [TagEntry]     -- ^ IRCv3.2 message tags
  , RawIrcMsg -> Maybe UserInfo
_msgPrefix     :: Maybe UserInfo -- ^ Optional sender of message
  , RawIrcMsg -> Text
_msgCommand    :: !Text          -- ^ Command
  , RawIrcMsg -> [Text]
_msgParams     :: [Text]         -- ^ Command parameters
  }
  deriving (RawIrcMsg -> RawIrcMsg -> Bool
(RawIrcMsg -> RawIrcMsg -> Bool)
-> (RawIrcMsg -> RawIrcMsg -> Bool) -> Eq RawIrcMsg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RawIrcMsg -> RawIrcMsg -> Bool
$c/= :: RawIrcMsg -> RawIrcMsg -> Bool
== :: RawIrcMsg -> RawIrcMsg -> Bool
$c== :: RawIrcMsg -> RawIrcMsg -> Bool
Eq, ReadPrec [RawIrcMsg]
ReadPrec RawIrcMsg
Int -> ReadS RawIrcMsg
ReadS [RawIrcMsg]
(Int -> ReadS RawIrcMsg)
-> ReadS [RawIrcMsg]
-> ReadPrec RawIrcMsg
-> ReadPrec [RawIrcMsg]
-> Read RawIrcMsg
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RawIrcMsg]
$creadListPrec :: ReadPrec [RawIrcMsg]
readPrec :: ReadPrec RawIrcMsg
$creadPrec :: ReadPrec RawIrcMsg
readList :: ReadS [RawIrcMsg]
$creadList :: ReadS [RawIrcMsg]
readsPrec :: Int -> ReadS RawIrcMsg
$creadsPrec :: Int -> ReadS RawIrcMsg
Read, Int -> RawIrcMsg -> ShowS
[RawIrcMsg] -> ShowS
RawIrcMsg -> String
(Int -> RawIrcMsg -> ShowS)
-> (RawIrcMsg -> String)
-> ([RawIrcMsg] -> ShowS)
-> Show RawIrcMsg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RawIrcMsg] -> ShowS
$cshowList :: [RawIrcMsg] -> ShowS
show :: RawIrcMsg -> String
$cshow :: RawIrcMsg -> String
showsPrec :: Int -> RawIrcMsg -> ShowS
$cshowsPrec :: Int -> RawIrcMsg -> ShowS
Show)

-- | Key value pair representing an IRCv3.2 message tag.
-- The value in this pair has had the message tag unescape
-- algorithm applied.
data TagEntry = TagEntry {-# UNPACK #-} !Text {-# UNPACK #-} !Text
  deriving (TagEntry -> TagEntry -> Bool
(TagEntry -> TagEntry -> Bool)
-> (TagEntry -> TagEntry -> Bool) -> Eq TagEntry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TagEntry -> TagEntry -> Bool
$c/= :: TagEntry -> TagEntry -> Bool
== :: TagEntry -> TagEntry -> Bool
$c== :: TagEntry -> TagEntry -> Bool
Eq, ReadPrec [TagEntry]
ReadPrec TagEntry
Int -> ReadS TagEntry
ReadS [TagEntry]
(Int -> ReadS TagEntry)
-> ReadS [TagEntry]
-> ReadPrec TagEntry
-> ReadPrec [TagEntry]
-> Read TagEntry
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [TagEntry]
$creadListPrec :: ReadPrec [TagEntry]
readPrec :: ReadPrec TagEntry
$creadPrec :: ReadPrec TagEntry
readList :: ReadS [TagEntry]
$creadList :: ReadS [TagEntry]
readsPrec :: Int -> ReadS TagEntry
$creadsPrec :: Int -> ReadS TagEntry
Read, Int -> TagEntry -> ShowS
[TagEntry] -> ShowS
TagEntry -> String
(Int -> TagEntry -> ShowS)
-> (TagEntry -> String) -> ([TagEntry] -> ShowS) -> Show TagEntry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TagEntry] -> ShowS
$cshowList :: [TagEntry] -> ShowS
show :: TagEntry -> String
$cshow :: TagEntry -> String
showsPrec :: Int -> TagEntry -> ShowS
$cshowsPrec :: Int -> TagEntry -> ShowS
Show)

-- | Lens for '_msgTags'
msgTags :: Functor f => ([TagEntry] -> f [TagEntry]) -> RawIrcMsg -> f RawIrcMsg
msgTags :: ([TagEntry] -> f [TagEntry]) -> RawIrcMsg -> f RawIrcMsg
msgTags [TagEntry] -> f [TagEntry]
f RawIrcMsg
m = (\[TagEntry]
x -> RawIrcMsg
m { _msgTags :: [TagEntry]
_msgTags = [TagEntry]
x }) ([TagEntry] -> RawIrcMsg) -> f [TagEntry] -> f RawIrcMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TagEntry] -> f [TagEntry]
f (RawIrcMsg -> [TagEntry]
_msgTags RawIrcMsg
m)

-- | Lens for '_msgPrefix'
msgPrefix :: Functor f => (Maybe UserInfo -> f (Maybe UserInfo)) -> RawIrcMsg -> f RawIrcMsg
msgPrefix :: (Maybe UserInfo -> f (Maybe UserInfo)) -> RawIrcMsg -> f RawIrcMsg
msgPrefix Maybe UserInfo -> f (Maybe UserInfo)
f RawIrcMsg
m = (\Maybe UserInfo
x -> RawIrcMsg
m { _msgPrefix :: Maybe UserInfo
_msgPrefix = Maybe UserInfo
x }) (Maybe UserInfo -> RawIrcMsg) -> f (Maybe UserInfo) -> f RawIrcMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe UserInfo -> f (Maybe UserInfo)
f (RawIrcMsg -> Maybe UserInfo
_msgPrefix RawIrcMsg
m)

-- | Lens for '_msgCommand'
msgCommand :: Functor f => (Text -> f Text) -> RawIrcMsg -> f RawIrcMsg
msgCommand :: (Text -> f Text) -> RawIrcMsg -> f RawIrcMsg
msgCommand Text -> f Text
f RawIrcMsg
m = (\Text
x -> RawIrcMsg
m { _msgCommand :: Text
_msgCommand = Text
x }) (Text -> RawIrcMsg) -> f Text -> f RawIrcMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> f Text
f (RawIrcMsg -> Text
_msgCommand RawIrcMsg
m)

-- | Lens for '_msgParams'
msgParams :: Functor f => ([Text] -> f [Text]) -> RawIrcMsg -> f RawIrcMsg
msgParams :: ([Text] -> f [Text]) -> RawIrcMsg -> f RawIrcMsg
msgParams [Text] -> f [Text]
f RawIrcMsg
m = (\[Text]
x -> RawIrcMsg
m { _msgParams :: [Text]
_msgParams = [Text]
x }) ([Text] -> RawIrcMsg) -> f [Text] -> f RawIrcMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> f [Text]
f (RawIrcMsg -> [Text]
_msgParams RawIrcMsg
m)

-- | Attempt to split an IRC protocol message without its trailing newline
-- information into a structured message.
parseRawIrcMsg :: Text -> Maybe RawIrcMsg
parseRawIrcMsg :: Text -> Maybe RawIrcMsg
parseRawIrcMsg Text
x =
  case Parser RawIrcMsg -> Text -> Either String RawIrcMsg
forall a. Parser a -> Text -> Either String a
parseOnly Parser RawIrcMsg
rawIrcMsgParser Text
x of
    Left{}  -> Maybe RawIrcMsg
forall a. Maybe a
Nothing
    Right RawIrcMsg
r -> RawIrcMsg -> Maybe RawIrcMsg
forall a. a -> Maybe a
Just RawIrcMsg
r

-- | RFC 2812 specifies that there can only be up to
-- 14 "middle" parameters, after that the fifteenth is
-- the final parameter and the trailing : is optional!
maxMiddleParams :: Int
maxMiddleParams :: Int
maxMiddleParams = Int
14

--  Excerpt from https://tools.ietf.org/html/rfc2812#section-2.3.1

--  message    =  [ ":" prefix SPACE ] command [ params ] crlf
--  prefix     =  servername / ( nickname [ [ "!" user ] "@" host ] )
--  command    =  1*letter / 3digit
--  params     =  *14( SPACE middle ) [ SPACE ":" trailing ]
--             =/ 14( SPACE middle ) [ SPACE [ ":" ] trailing ]

--  nospcrlfcl =  %x01-09 / %x0B-0C / %x0E-1F / %x21-39 / %x3B-FF
--                  ; any octet except NUL, CR, LF, " " and ":"
--  middle     =  nospcrlfcl *( ":" / nospcrlfcl )
--  trailing   =  *( ":" / " " / nospcrlfcl )

--  SPACE      =  %x20        ; space character
--  crlf       =  %x0D %x0A   ; "carriage return" "linefeed"

-- | Parse a whole IRC message assuming that the trailing
-- newlines have already been removed. This parser will
-- parse valid messages correctly but will also accept some
-- invalid messages. Presumably the server isn't sending
-- invalid messages!
rawIrcMsgParser :: Parser RawIrcMsg
rawIrcMsgParser :: Parser RawIrcMsg
rawIrcMsgParser =
  do [TagEntry]
tags   <- [TagEntry] -> Maybe [TagEntry] -> [TagEntry]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [TagEntry] -> [TagEntry])
-> Parser Text (Maybe [TagEntry]) -> Parser Text [TagEntry]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Parser Text [TagEntry] -> Parser Text (Maybe [TagEntry])
forall b. Char -> Parser b -> Parser (Maybe b)
guarded Char
'@' Parser Text [TagEntry]
tagsParser
     Maybe UserInfo
prefix <- Char -> Parser UserInfo -> Parser (Maybe UserInfo)
forall b. Char -> Parser b -> Parser (Maybe b)
guarded Char
':' Parser UserInfo
prefixParser
     Text
cmd    <- Parser Text
simpleTokenParser
     [Text]
params <- Int -> Parser [Text]
paramsParser Int
maxMiddleParams
     RawIrcMsg -> Parser RawIrcMsg
forall (m :: * -> *) a. Monad m => a -> m a
return (RawIrcMsg -> Parser RawIrcMsg) -> RawIrcMsg -> Parser RawIrcMsg
forall a b. (a -> b) -> a -> b
$! RawIrcMsg :: [TagEntry] -> Maybe UserInfo -> Text -> [Text] -> RawIrcMsg
RawIrcMsg
       { _msgTags :: [TagEntry]
_msgTags    = [TagEntry]
tags
       , _msgPrefix :: Maybe UserInfo
_msgPrefix  = Maybe UserInfo
prefix
       , _msgCommand :: Text
_msgCommand = Text
cmd
       , _msgParams :: [Text]
_msgParams  = [Text]
params
       }

-- | Parse the list of parameters in a raw message. The RFC
-- allows for up to 15 parameters.
paramsParser ::
  Int {- ^ possible middle parameters -} -> Parser [Text]
paramsParser :: Int -> Parser [Text]
paramsParser !Int
n =
  do Bool
end <- Parser Text Bool
forall t. Chunk t => Parser t Bool
P.atEnd
     if Bool
end
       then [Text] -> Parser [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return []
       else do Bool
isColon <- Char -> Parser Text Bool
optionalChar Char
':'
               if Bool
isColon Bool -> Bool -> Bool
|| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                 then Parser [Text]
finalParam
                 else Parser [Text]
middleParam

  where

  finalParam :: Parser [Text]
finalParam =
    do Text
x <- Parser Text
takeText
       let !x' :: Text
x' = Text -> Text
Text.copy Text
x
       [Text] -> Parser [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return [Text
x']

  middleParam :: Parser [Text]
middleParam =
    do Text
x  <- Parser Text
simpleTokenParser
       [Text]
xs <- Int -> Parser [Text]
paramsParser (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
       [Text] -> Parser [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
xText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
xs)

tagsParser :: Parser [TagEntry]
tagsParser :: Parser Text [TagEntry]
tagsParser = Parser TagEntry
tagParser Parser TagEntry -> Parser Text Char -> Parser Text [TagEntry]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Char -> Parser Text Char
char Char
';' Parser Text [TagEntry] -> Parser Text () -> Parser Text [TagEntry]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
spaces

tagParser :: Parser TagEntry
tagParser :: Parser TagEntry
tagParser =
  do Text
key <- (Char -> Bool) -> Parser Text
P.takeWhile (String -> Char -> Bool
notInClass String
"=; ")
     Maybe Char
_   <- Parser Text Char -> Parser Text (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Char -> Parser Text Char
char Char
'=')
     Text
val <- (Char -> Bool) -> Parser Text
P.takeWhile (String -> Char -> Bool
notInClass String
"; ")
     TagEntry -> Parser TagEntry
forall (m :: * -> *) a. Monad m => a -> m a
return (TagEntry -> Parser TagEntry) -> TagEntry -> Parser TagEntry
forall a b. (a -> b) -> a -> b
$! Text -> Text -> TagEntry
TagEntry Text
key (Text -> Text
unescapeTagVal Text
val)


unescapeTagVal :: Text -> Text
unescapeTagVal :: Text -> Text
unescapeTagVal = String -> Text
Text.pack (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
aux ShowS -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack
  where
    aux :: ShowS
aux (Char
'\\':Char
':':String
xs) = Char
';'Char -> ShowS
forall a. a -> [a] -> [a]
:ShowS
aux String
xs
    aux (Char
'\\':Char
's':String
xs) = Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:ShowS
aux String
xs
    aux (Char
'\\':Char
'\\':String
xs) = Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:ShowS
aux String
xs
    aux (Char
'\\':Char
'r':String
xs) = Char
'\r'Char -> ShowS
forall a. a -> [a] -> [a]
:ShowS
aux String
xs
    aux (Char
'\\':Char
'n':String
xs) = Char
'\n'Char -> ShowS
forall a. a -> [a] -> [a]
:ShowS
aux String
xs
    aux (Char
x:String
xs)        = Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
aux String
xs
    aux String
""            = String
""

escapeTagVal :: Text -> Text
escapeTagVal :: Text -> Text
escapeTagVal = (Char -> Text) -> Text -> Text
Text.concatMap Char -> Text
aux
  where
    aux :: Char -> Text
aux Char
';'  = Text
"\\:"
    aux Char
' '  = Text
"\\s"
    aux Char
'\\' = Text
"\\\\"
    aux Char
'\r' = Text
"\\r"
    aux Char
'\n' = Text
"\\n"
    aux Char
x = Char -> Text
Text.singleton Char
x

-- | Parse a rendered 'UserInfo' token.
prefixParser :: Parser UserInfo
prefixParser :: Parser UserInfo
prefixParser =
  do Text
tok <- Parser Text
simpleTokenParser
     UserInfo -> Parser UserInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (UserInfo -> Parser UserInfo) -> UserInfo -> Parser UserInfo
forall a b. (a -> b) -> a -> b
$! Text -> UserInfo
parseUserInfo Text
tok

-- | Take the next space-delimited lexeme
simpleTokenParser :: Parser Text
simpleTokenParser :: Parser Text
simpleTokenParser =
  do Text
xs <- (Char -> Bool) -> Parser Text
P.takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ')
     Parser Text ()
spaces
     Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$! Text -> Text
Text.copy Text
xs

spaces :: Parser ()
spaces :: Parser Text ()
spaces = (Char -> Bool) -> Parser Text ()
P.skipWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')

-- | Serialize a structured IRC protocol message back into its wire
-- format. This command adds the required trailing newline.
renderRawIrcMsg :: RawIrcMsg -> ByteString
renderRawIrcMsg :: RawIrcMsg -> ByteString
renderRawIrcMsg !RawIrcMsg
m
   = ByteString -> ByteString
L.toStrict
   (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
Builder.toLazyByteString
   (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ [TagEntry] -> Builder
renderTags ((([TagEntry] -> Const [TagEntry] [TagEntry])
 -> RawIrcMsg -> Const [TagEntry] RawIrcMsg)
-> RawIrcMsg -> [TagEntry]
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view ([TagEntry] -> Const [TagEntry] [TagEntry])
-> RawIrcMsg -> Const [TagEntry] RawIrcMsg
forall (f :: * -> *).
Functor f =>
([TagEntry] -> f [TagEntry]) -> RawIrcMsg -> f RawIrcMsg
msgTags RawIrcMsg
m)
  Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> (UserInfo -> Builder) -> Maybe UserInfo -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
forall a. Monoid a => a
mempty UserInfo -> Builder
renderPrefix (((Maybe UserInfo -> Const (Maybe UserInfo) (Maybe UserInfo))
 -> RawIrcMsg -> Const (Maybe UserInfo) RawIrcMsg)
-> RawIrcMsg -> Maybe UserInfo
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view (Maybe UserInfo -> Const (Maybe UserInfo) (Maybe UserInfo))
-> RawIrcMsg -> Const (Maybe UserInfo) RawIrcMsg
forall (f :: * -> *).
Functor f =>
(Maybe UserInfo -> f (Maybe UserInfo)) -> RawIrcMsg -> f RawIrcMsg
msgPrefix RawIrcMsg
m)
  Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.encodeUtf8Builder (((Text -> Const Text Text) -> RawIrcMsg -> Const Text RawIrcMsg)
-> RawIrcMsg -> Text
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view (Text -> Const Text Text) -> RawIrcMsg -> Const Text RawIrcMsg
forall (f :: * -> *).
Functor f =>
(Text -> f Text) -> RawIrcMsg -> f RawIrcMsg
msgCommand RawIrcMsg
m)
  Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Text] -> Builder
buildParams ((([Text] -> Const [Text] [Text])
 -> RawIrcMsg -> Const [Text] RawIrcMsg)
-> RawIrcMsg -> [Text]
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view ([Text] -> Const [Text] [Text])
-> RawIrcMsg -> Const [Text] RawIrcMsg
forall (f :: * -> *).
Functor f =>
([Text] -> f [Text]) -> RawIrcMsg -> f RawIrcMsg
msgParams RawIrcMsg
m)
  Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.char8 Char
'\r'
  Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.char8 Char
'\n'

-- | Construct a new 'RawIrcMsg' without a time or prefix.
rawIrcMsg ::
  Text {- ^ command -} ->
  [Text] {- ^ parameters -} -> RawIrcMsg
rawIrcMsg :: Text -> [Text] -> RawIrcMsg
rawIrcMsg = [TagEntry] -> Maybe UserInfo -> Text -> [Text] -> RawIrcMsg
RawIrcMsg [] Maybe UserInfo
forall a. Maybe a
Nothing

renderTags :: [TagEntry] -> Builder
renderTags :: [TagEntry] -> Builder
renderTags [] = Builder
forall a. Monoid a => a
mempty
renderTags [TagEntry]
xs
    = Char -> Builder
Builder.char8 Char
'@'
   Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat (Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse (Char -> Builder
Builder.char8 Char
';') ((TagEntry -> Builder) -> [TagEntry] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map TagEntry -> Builder
renderTag [TagEntry]
xs))
   Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.char8 Char
' '

renderTag :: TagEntry -> Builder
renderTag :: TagEntry -> Builder
renderTag (TagEntry Text
key Text
val)
  | Text -> Bool
Text.null Text
val = Text -> Builder
Text.encodeUtf8Builder Text
key
  | Bool
otherwise     = Text -> Builder
Text.encodeUtf8Builder Text
key
                 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.char8 Char
'='
                 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.encodeUtf8Builder (Text -> Text
escapeTagVal Text
val)

renderPrefix :: UserInfo -> Builder
renderPrefix :: UserInfo -> Builder
renderPrefix UserInfo
u
   = Char -> Builder
Builder.char8 Char
':'
  Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.encodeUtf8Builder (UserInfo -> Text
renderUserInfo UserInfo
u)
  Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.char8 Char
' '

-- | Concatenate a list of parameters into a single, space-delimited
-- bytestring. Use a colon for the last parameter if it starts with
-- a colon or contains a space.
buildParams :: [Text] -> Builder
buildParams :: [Text] -> Builder
buildParams [Text
x]
  | Text
" " Text -> Text -> Bool
`Text.isInfixOf` Text
x Bool -> Bool -> Bool
|| Text
":" Text -> Text -> Bool
`Text.isPrefixOf` Text
x Bool -> Bool -> Bool
|| Text -> Bool
Text.null Text
x
  = Char -> Builder
Builder.char8 Char
' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.char8 Char
':' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.encodeUtf8Builder Text
x
buildParams (Text
x:[Text]
xs)
  | Text -> Bool
Text.null Text
x = Char -> Builder
Builder.char8 Char
' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.encodeUtf8Builder Text
"*" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Text] -> Builder
buildParams [Text]
xs
  | Bool
otherwise   = Char -> Builder
Builder.char8 Char
' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.encodeUtf8Builder Text
x   Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Text] -> Builder
buildParams [Text]
xs
buildParams [] = Builder
forall a. Monoid a => a
mempty

-- | When the current input matches the given character parse
-- using the given parser.
guarded :: Char -> Parser b -> Parser (Maybe b)
guarded :: Char -> Parser b -> Parser (Maybe b)
guarded Char
c Parser b
p =
  do Bool
success <- Char -> Parser Text Bool
optionalChar Char
c
     if Bool
success then b -> Maybe b
forall a. a -> Maybe a
Just (b -> Maybe b) -> Parser b -> Parser (Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser b
p else Maybe b -> Parser (Maybe b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe b
forall a. Maybe a
Nothing


-- | Returns 'True' iff next character in stream matches argument.
optionalChar :: Char -> Parser Bool
optionalChar :: Char -> Parser Text Bool
optionalChar Char
c = Bool
True Bool -> Parser Text Char -> Parser Text Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Text Char
char Char
c Parser Text Bool -> Parser Text Bool -> Parser Text Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Parser Text Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False


-- | Try to decode a message as UTF-8. If that fails interpret it as Windows
-- CP1252 This helps deal with clients like XChat that get clever and otherwise
-- misconfigured clients.
asUtf8 :: ByteString -> Text
asUtf8 :: ByteString -> Text
asUtf8 ByteString
x = case ByteString -> Either UnicodeException Text
Text.decodeUtf8' ByteString
x of
             Right Text
txt -> Text
txt
             Left{}    -> ByteString -> Text
decodeCP1252 ByteString
x

-- | Decode a 'ByteString' as CP1252
decodeCP1252 :: ByteString -> Text
decodeCP1252 :: ByteString -> Text
decodeCP1252 ByteString
bs = String -> Text
Text.pack [ Vector Char
cp1252 Vector Char -> Int -> Char
forall a. Vector a -> Int -> a
Vector.! Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x | Word8
x <- ByteString -> [Word8]
B.unpack ByteString
bs ]

-- | This character encoding is a superset of ISO 8859-1 in terms of printable
-- characters, but differs from the IANA's ISO-8859-1 by using displayable
-- characters rather than control characters in the 80 to 9F (hex) range.
cp1252 :: Vector Char
cp1252 :: Vector Char
cp1252 = String -> Vector Char
forall a. [a] -> Vector a
Vector.fromList
       (String -> Vector Char) -> String -> Vector Char
forall a b. (a -> b) -> a -> b
$ [Char
'\x00'..Char
'\x7f']
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"€\x81‚ƒ„…†‡ˆ‰Š‹Œ\x8dŽ\x8f\x90‘’“”•–—˜™š›œ\x9džŸ"
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'\xa0'..Char
'\xff']