-- |Functions for encoding and decoding CTCPs.
module Network.IRC.CTCP
  ( -- *Types
    CTCPByteString
  , getUnderlyingByteString

  -- *Encoding and decoding
  , toCTCP
  , fromCTCP
  , encodeCTCP
  , decodeCTCP

  -- *Utilities
  , isCTCP
  , asCTCP
  , orCTCP
  ) where

import           Data.ByteString    (ByteString, pack, singleton, unpack)
import           Data.List          (mapAccumL)
import           Data.Maybe         (catMaybes, fromMaybe)
import           Data.Monoid        ((<>))
import           Data.Text          (Text, splitOn)
import           Data.Text.Encoding (decodeUtf8, encodeUtf8)
import           Data.Tuple         (swap)

import qualified Data.ByteString    as B
import qualified Data.Text          as T

-- |Type representing a CTCP-encoded bytestring.
newtype CTCPByteString = CBS ByteString
  deriving (CTCPByteString -> CTCPByteString -> Bool
(CTCPByteString -> CTCPByteString -> Bool)
-> (CTCPByteString -> CTCPByteString -> Bool) -> Eq CTCPByteString
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CTCPByteString -> CTCPByteString -> Bool
$c/= :: CTCPByteString -> CTCPByteString -> Bool
== :: CTCPByteString -> CTCPByteString -> Bool
$c== :: CTCPByteString -> CTCPByteString -> Bool
Eq, Int -> CTCPByteString -> ShowS
[CTCPByteString] -> ShowS
CTCPByteString -> String
(Int -> CTCPByteString -> ShowS)
-> (CTCPByteString -> String)
-> ([CTCPByteString] -> ShowS)
-> Show CTCPByteString
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CTCPByteString] -> ShowS
$cshowList :: [CTCPByteString] -> ShowS
show :: CTCPByteString -> String
$cshow :: CTCPByteString -> String
showsPrec :: Int -> CTCPByteString -> ShowS
$cshowsPrec :: Int -> CTCPByteString -> ShowS
Show)

-- |Get the underlying (encoded) bytestring from a CTCP bytestring.
getUnderlyingByteString :: CTCPByteString -> ByteString
getUnderlyingByteString :: CTCPByteString -> ByteString
getUnderlyingByteString (CBS ByteString
bs) = ByteString
bs

-- |Turn a command name and arguments into a CTCP-encoded bytestring.
--
-- This encodes the text with UTF-8. If another encoding is desired,
-- 'encodeCTCP' should be used directly.
toCTCP :: Text -> [Text] -> CTCPByteString
toCTCP :: Text -> [Text] -> CTCPByteString
toCTCP Text
cmd [Text]
args = ByteString -> CTCPByteString
encodeCTCP (ByteString -> CTCPByteString)
-> ([Text] -> ByteString) -> [Text] -> CTCPByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> ByteString) -> ([Text] -> Text) -> [Text] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unwords ([Text] -> CTCPByteString) -> [Text] -> CTCPByteString
forall a b. (a -> b) -> a -> b
$ Text
cmd Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
args

-- |Encode a bytestring according to the CTCP spec.
encodeCTCP :: ByteString -> CTCPByteString
encodeCTCP :: ByteString -> CTCPByteString
encodeCTCP ByteString
bs = ByteString -> CTCPByteString
CBS (ByteString -> CTCPByteString) -> ByteString -> CTCPByteString
forall a b. (a -> b) -> a -> b
$ Word8 -> ByteString
singleton Word8
forall i. Integral i => i
soh ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
escape ByteString
bs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word8 -> ByteString
singleton Word8
forall i. Integral i => i
soh

-- |Escape a bytestring according to the CTCP spec.
escape :: ByteString -> ByteString
escape :: ByteString -> ByteString
escape = (Word8 -> ByteString) -> ByteString -> ByteString
B.concatMap Word8 -> ByteString
escape'
  where
    escape' :: Word8 -> ByteString
escape' Word8
x =
      case Word8 -> [(Word8, Word8)] -> Maybe Word8
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Word8
x [(Word8, Word8)]
forall i. Integral i => [(i, i)]
encodings of
        -- If there is an encoding, escape it and use that.
        Just Word8
x' -> [Word8] -> ByteString
pack [Word8
forall i. Integral i => i
esc, Word8
x']

        -- Otherwise, just return the original character.
        Maybe Word8
Nothing -> Word8 -> ByteString
singleton Word8
x

-- |Decode a CTCP-encoded bytestring and turn it into a command name
-- and arguments.
--
-- This decodes the text with UTF-8. If another encoding is desired,
-- 'decodeCTCP' should be used directly.
fromCTCP :: CTCPByteString -> (Text, [Text])
fromCTCP :: CTCPByteString -> (Text, [Text])
fromCTCP CTCPByteString
bs =
  case Text -> Text -> [Text]
splitOn (String -> Text
T.pack String
" ") (Text -> [Text])
-> (CTCPByteString -> Text) -> CTCPByteString -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (CTCPByteString -> ByteString) -> CTCPByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CTCPByteString -> ByteString
decodeCTCP (CTCPByteString -> [Text]) -> CTCPByteString -> [Text]
forall a b. (a -> b) -> a -> b
$ CTCPByteString
bs of
    (Text
cmd : [Text]
args) -> (Text
cmd, [Text]
args)
    [Text]
_            -> (String -> Text
T.pack String
"", [])

-- |Decode a CTCP bytestring. Extraeneous escapes are dropped.
decodeCTCP :: CTCPByteString -> ByteString
decodeCTCP :: CTCPByteString -> ByteString
decodeCTCP (CBS ByteString
bs) = ByteString -> ByteString
unescape (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B.tail (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B.init (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
bs

-- |Unescape a bytestring according to the CTCP spec. Extraeneous escapes are dropped.
unescape :: ByteString -> ByteString
unescape :: ByteString -> ByteString
unescape = [Word8] -> ByteString
pack ([Word8] -> ByteString)
-> (ByteString -> [Word8]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Word8] -> [Word8]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Word8] -> [Word8])
-> (ByteString -> [Maybe Word8]) -> ByteString -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, [Maybe Word8]) -> [Maybe Word8]
forall a b. (a, b) -> b
snd ((Bool, [Maybe Word8]) -> [Maybe Word8])
-> (ByteString -> (Bool, [Maybe Word8]))
-> ByteString
-> [Maybe Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Word8 -> (Bool, Maybe Word8))
-> Bool -> [Word8] -> (Bool, [Maybe Word8])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL Bool -> Word8 -> (Bool, Maybe Word8)
forall a. Integral a => Bool -> a -> (Bool, Maybe a)
step Bool
False ([Word8] -> (Bool, [Maybe Word8]))
-> (ByteString -> [Word8]) -> ByteString -> (Bool, [Maybe Word8])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
unpack
  where
    -- If we fail to find a decoding, ignore the escape.
    step :: Bool -> a -> (Bool, Maybe a)
step Bool
True a
x = (Bool
False, a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> (Maybe a -> a) -> Maybe a -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
x (Maybe a -> Maybe a) -> Maybe a -> Maybe a
forall a b. (a -> b) -> a -> b
$ a -> [(a, a)] -> Maybe a
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
x [(a, a)]
forall i. Integral i => [(i, i)]
decodings)

    -- Enter escape mode, this doesn't add a character to the output.
    step Bool
False a
0o020 = (Bool
True, Maybe a
forall a. Maybe a
Nothing)

    step Bool
_ a
x = (Bool
False, a -> Maybe a
forall a. a -> Maybe a
Just a
x)

soh :: Integral i => i
soh :: i
soh = i
0o001

esc :: Integral i => i
esc :: i
esc = i
0o020

encodings :: Integral i => [(i, i)]
encodings :: [(i, i)]
encodings =
  [ (i
0o000, i
0o060)
  , (i
0o012, i
0o156)
  , (i
0o015, i
0o162)
  , (i
0o020, i
0o020)
  ]

decodings :: Integral i => [(i, i)]
decodings :: [(i, i)]
decodings = ((i, i) -> (i, i)) -> [(i, i)] -> [(i, i)]
forall a b. (a -> b) -> [a] -> [b]
map (i, i) -> (i, i)
forall a b. (a, b) -> (b, a)
swap [(i, i)]
forall i. Integral i => [(i, i)]
encodings

-- |Check if a bytestring represents a CTCP.
--
-- This is intentionally very lenient, in particular it doesn't check
-- that there are no extra escape characters. This is because the spec
-- states that misplaced escape characters should be discarded by the
-- decoding process.
isCTCP :: ByteString -> Bool
isCTCP :: ByteString -> Bool
isCTCP ByteString
bs = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: (ByteString -> Word8
B.head ByteString
bs Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
forall i. Integral i => i
soh) Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: (ByteString -> Word8
B.last ByteString
bs Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
forall i. Integral i => i
soh) Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: ((Word8, Word8) -> Bool) -> [(Word8, Word8)] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map ((Word8 -> ByteString -> Bool) -> ByteString -> Word8 -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Word8 -> ByteString -> Bool
B.notElem ByteString
bs (Word8 -> Bool)
-> ((Word8, Word8) -> Word8) -> (Word8, Word8) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8, Word8) -> Word8
forall a b. (a, b) -> a
fst) [(Word8, Word8)]
forall i. Integral i => [(i, i)]
encodings

-- |Check if a bytestring looks like a CTCP, and if so, wrap it up in
-- the 'CTCPByteString' type.
--
-- This uses 'isCTCP', and so is lenient with escapes.
asCTCP :: ByteString -> Maybe CTCPByteString
asCTCP :: ByteString -> Maybe CTCPByteString
asCTCP ByteString
bs =
  if ByteString -> Bool
isCTCP ByteString
bs
  then CTCPByteString -> Maybe CTCPByteString
forall a. a -> Maybe a
Just (CTCPByteString -> Maybe CTCPByteString)
-> CTCPByteString -> Maybe CTCPByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> CTCPByteString
CBS ByteString
bs
  else Maybe CTCPByteString
forall a. Maybe a
Nothing

-- |Apply one of two functions depending on whether the bytestring
-- looks like a CTCP or not.
--
-- This uses 'asCTCP', and so is lenient with escapes.
orCTCP :: (ByteString -> a) -> (CTCPByteString -> a) -> ByteString -> a
orCTCP :: (ByteString -> a) -> (CTCPByteString -> a) -> ByteString -> a
orCTCP ByteString -> a
f CTCPByteString -> a
g ByteString
bs = a -> (CTCPByteString -> a) -> Maybe CTCPByteString -> a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ByteString -> a
f ByteString
bs) CTCPByteString -> a
g (ByteString -> Maybe CTCPByteString
asCTCP ByteString
bs)