{-# 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.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
$c== :: RawIrcMsg -> RawIrcMsg -> Bool
== :: RawIrcMsg -> RawIrcMsg -> Bool
$c/= :: RawIrcMsg -> RawIrcMsg -> Bool
/= :: 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
$creadsPrec :: Int -> ReadS RawIrcMsg
readsPrec :: Int -> ReadS RawIrcMsg
$creadList :: ReadS [RawIrcMsg]
readList :: ReadS [RawIrcMsg]
$creadPrec :: ReadPrec RawIrcMsg
readPrec :: ReadPrec RawIrcMsg
$creadListPrec :: ReadPrec [RawIrcMsg]
readListPrec :: ReadPrec [RawIrcMsg]
Read, Int -> RawIrcMsg -> ShowS
[RawIrcMsg] -> ShowS
RawIrcMsg -> [Char]
(Int -> RawIrcMsg -> ShowS)
-> (RawIrcMsg -> [Char])
-> ([RawIrcMsg] -> ShowS)
-> Show RawIrcMsg
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RawIrcMsg -> ShowS
showsPrec :: Int -> RawIrcMsg -> ShowS
$cshow :: RawIrcMsg -> [Char]
show :: RawIrcMsg -> [Char]
$cshowList :: [RawIrcMsg] -> ShowS
showList :: [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
$c== :: TagEntry -> TagEntry -> Bool
== :: TagEntry -> TagEntry -> Bool
$c/= :: TagEntry -> TagEntry -> Bool
/= :: 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
$creadsPrec :: Int -> ReadS TagEntry
readsPrec :: Int -> ReadS TagEntry
$creadList :: ReadS [TagEntry]
readList :: ReadS [TagEntry]
$creadPrec :: ReadPrec TagEntry
readPrec :: ReadPrec TagEntry
$creadListPrec :: ReadPrec [TagEntry]
readListPrec :: ReadPrec [TagEntry]
Read, Int -> TagEntry -> ShowS
[TagEntry] -> ShowS
TagEntry -> [Char]
(Int -> TagEntry -> ShowS)
-> (TagEntry -> [Char]) -> ([TagEntry] -> ShowS) -> Show TagEntry
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TagEntry -> ShowS
showsPrec :: Int -> TagEntry -> ShowS
$cshow :: TagEntry -> [Char]
show :: TagEntry -> [Char]
$cshowList :: [TagEntry] -> ShowS
showList :: [TagEntry] -> ShowS
Show)

-- | Lens for '_msgTags'
msgTags :: Functor f => ([TagEntry] -> f [TagEntry]) -> RawIrcMsg -> f RawIrcMsg
msgTags :: forall (f :: * -> *).
Functor f =>
([TagEntry] -> f [TagEntry]) -> RawIrcMsg -> f RawIrcMsg
msgTags [TagEntry] -> f [TagEntry]
f RawIrcMsg
m = (\[TagEntry]
x -> RawIrcMsg
m { _msgTags = 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 :: forall (f :: * -> *).
Functor f =>
(Maybe UserInfo -> f (Maybe UserInfo)) -> RawIrcMsg -> f RawIrcMsg
msgPrefix Maybe UserInfo -> f (Maybe UserInfo)
f RawIrcMsg
m = (\Maybe UserInfo
x -> RawIrcMsg
m { _msgPrefix = 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 :: forall (f :: * -> *).
Functor f =>
(Text -> f Text) -> RawIrcMsg -> f RawIrcMsg
msgCommand Text -> f Text
f RawIrcMsg
m = (\Text
x -> RawIrcMsg
m { _msgCommand = 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 :: forall (f :: * -> *).
Functor f =>
([Text] -> f [Text]) -> RawIrcMsg -> f RawIrcMsg
msgParams [Text] -> f [Text]
f RawIrcMsg
m = (\[Text]
x -> RawIrcMsg
m { _msgParams = 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 [Char] RawIrcMsg
forall a. Parser a -> Text -> Either [Char] 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 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
     prefix <- guarded ':' prefixParser
     cmd    <- simpleTokenParser
     params <- paramsParser maxMiddleParams
     return $! RawIrcMsg
       { _msgTags    = tags
       , _msgPrefix  = prefix
       , _msgCommand = cmd
       , _msgParams  = 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 end <- Parser Text Bool
forall t. Chunk t => Parser t Bool
P.atEnd
     if end
       then return []
       else do isColon <- optionalChar ':'
               if isColon || n == 0
                 then finalParam
                 else middleParam

  where

  finalParam :: Parser [Text]
finalParam =
    do x <- Parser Text
takeText
       let !x' = Text -> Text
Text.copy Text
x
       return [x']

  middleParam :: Parser [Text]
middleParam =
    do x  <- Parser Text
simpleTokenParser
       xs <- paramsParser (n-1)
       return (x: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 a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
spaces

tagParser :: Parser TagEntry
tagParser :: Parser TagEntry
tagParser =
  do key <- (Char -> Bool) -> Parser Text
P.takeWhile ([Char] -> Char -> Bool
notInClass [Char]
"=; ")
     _   <- optional (char '=')
     val <- P.takeWhile (notInClass "; ")
     return $! TagEntry key (unescapeTagVal val)


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

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 tok <- Parser Text
simpleTokenParser
     return $! parseUserInfo tok

-- | Take the next space-delimited lexeme
simpleTokenParser :: Parser Text
simpleTokenParser :: Parser Text
simpleTokenParser =
  do xs <- (Char -> Bool) -> Parser Text
P.takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ')
     spaces
     return $! Text.copy 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
   = LazyByteString -> ByteString
L.toStrict
   (LazyByteString -> ByteString) -> LazyByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> LazyByteString
Builder.toLazyByteString
   (Builder -> LazyByteString) -> Builder -> LazyByteString
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 :: forall b. Char -> Parser b -> Parser (Maybe b)
guarded Char
c Parser b
p =
  do success <- Char -> Parser Text Bool
optionalChar Char
c
     if success then Just <$> p else pure 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 a b. a -> Parser Text b -> Parser Text a
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 a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Parser Text Bool
forall a. a -> Parser Text a
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 = [Char] -> 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 = [Char] -> Vector Char
forall a. [a] -> Vector a
Vector.fromList
       ([Char] -> Vector Char) -> [Char] -> Vector Char
forall a b. (a -> b) -> a -> b
$ [Char
'\x00'..Char
'\x7f']
      [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"€\x81‚ƒ„…†‡ˆ‰Š‹Œ\x8dŽ\x8f\x90‘’“”•–—˜™š›œ\x9džŸ"
      [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'\xa0'..Char
'\xff']