-- | Code for parsing extensions headers.
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
module Network.WebSockets.Extensions.Description
    ( ExtensionParam
    , ExtensionDescription (..)
    , ExtensionDescriptions

    , parseExtensionDescriptions
    , encodeExtensionDescriptions
    ) where

import           Control.Applicative              ((*>), (<*))
import qualified Data.Attoparsec.ByteString       as A
import qualified Data.Attoparsec.ByteString.Char8 as AC8
import qualified Data.ByteString                  as B
import           Data.Monoid                      (mconcat, mappend)
import           Prelude

type ExtensionParam = (B.ByteString, Maybe B.ByteString)

data ExtensionDescription = ExtensionDescription
    { ExtensionDescription -> ByteString
extName   :: !B.ByteString
    , ExtensionDescription -> [ExtensionParam]
extParams :: ![ExtensionParam]
    } deriving (ExtensionDescription -> ExtensionDescription -> Bool
(ExtensionDescription -> ExtensionDescription -> Bool)
-> (ExtensionDescription -> ExtensionDescription -> Bool)
-> Eq ExtensionDescription
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExtensionDescription -> ExtensionDescription -> Bool
$c/= :: ExtensionDescription -> ExtensionDescription -> Bool
== :: ExtensionDescription -> ExtensionDescription -> Bool
$c== :: ExtensionDescription -> ExtensionDescription -> Bool
Eq, Int -> ExtensionDescription -> ShowS
[ExtensionDescription] -> ShowS
ExtensionDescription -> String
(Int -> ExtensionDescription -> ShowS)
-> (ExtensionDescription -> String)
-> ([ExtensionDescription] -> ShowS)
-> Show ExtensionDescription
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExtensionDescription] -> ShowS
$cshowList :: [ExtensionDescription] -> ShowS
show :: ExtensionDescription -> String
$cshow :: ExtensionDescription -> String
showsPrec :: Int -> ExtensionDescription -> ShowS
$cshowsPrec :: Int -> ExtensionDescription -> ShowS
Show)

parseExtensionDescription :: A.Parser ExtensionDescription
parseExtensionDescription :: Parser ExtensionDescription
parseExtensionDescription = do
    ByteString
extName   <- Parser ByteString ByteString
parseIdentifier
    [ExtensionParam]
extParams <- Parser ByteString ExtensionParam
-> Parser ByteString [ExtensionParam]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
A.many' (Char -> Parser ByteString Word8
token Char
';' Parser ByteString Word8
-> Parser ByteString ExtensionParam
-> Parser ByteString ExtensionParam
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ExtensionParam
parseParam)
    ExtensionDescription -> Parser ExtensionDescription
forall (m :: * -> *) a. Monad m => a -> m a
return ExtensionDescription :: ByteString -> [ExtensionParam] -> ExtensionDescription
ExtensionDescription {[ExtensionParam]
ByteString
extParams :: [ExtensionParam]
extName :: ByteString
extParams :: [ExtensionParam]
extName :: ByteString
..}
  where
    parseIdentifier :: Parser ByteString ByteString
parseIdentifier = (Char -> Bool) -> Parser ByteString ByteString
AC8.takeWhile Char -> Bool
isIdentifierChar Parser ByteString ByteString
-> Parser ByteString () -> Parser ByteString ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
AC8.skipSpace

    token :: Char -> Parser ByteString Word8
token Char
c = Char -> Parser ByteString Word8
AC8.char8 Char
c Parser ByteString Word8
-> Parser ByteString () -> Parser ByteString Word8
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
AC8.skipSpace

    isIdentifierChar :: Char -> Bool
isIdentifierChar Char
c =
        (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'z') Bool -> Bool -> Bool
||
        (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'Z') Bool -> Bool -> Bool
||
        (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9') Bool -> Bool -> Bool
||
        Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'

    parseParam :: A.Parser ExtensionParam
    parseParam :: Parser ByteString ExtensionParam
parseParam = do
        ByteString
name <- Parser ByteString ByteString
parseIdentifier
        Maybe ByteString
val  <- Maybe ByteString
-> Parser ByteString (Maybe ByteString)
-> Parser ByteString (Maybe ByteString)
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option Maybe ByteString
forall a. Maybe a
Nothing (Parser ByteString (Maybe ByteString)
 -> Parser ByteString (Maybe ByteString))
-> Parser ByteString (Maybe ByteString)
-> Parser ByteString (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ (ByteString -> Maybe ByteString)
-> Parser ByteString ByteString
-> Parser ByteString (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Parser ByteString ByteString
 -> Parser ByteString (Maybe ByteString))
-> Parser ByteString ByteString
-> Parser ByteString (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Char -> Parser ByteString Word8
token Char
'=' Parser ByteString Word8
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ByteString
parseIdentifier
        ExtensionParam -> Parser ByteString ExtensionParam
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
name, Maybe ByteString
val)

encodeExtensionDescription :: ExtensionDescription -> B.ByteString
encodeExtensionDescription :: ExtensionDescription -> ByteString
encodeExtensionDescription ExtensionDescription {[ExtensionParam]
ByteString
extParams :: [ExtensionParam]
extName :: ByteString
extParams :: ExtensionDescription -> [ExtensionParam]
extName :: ExtensionDescription -> ByteString
..} =
    [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat (ByteString
extName ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: (ExtensionParam -> ByteString) -> [ExtensionParam] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ExtensionParam -> ByteString
forall a. (Monoid a, IsString a) => (a, Maybe a) -> a
encodeParam [ExtensionParam]
extParams)
  where
    encodeParam :: (a, Maybe a) -> a
encodeParam (a
key, Maybe a
Nothing)  = a
";" a -> a -> a
forall a. Monoid a => a -> a -> a
`mappend` a
key
    encodeParam (a
key, Just a
val) = a
";" a -> a -> a
forall a. Monoid a => a -> a -> a
`mappend` a
key a -> a -> a
forall a. Monoid a => a -> a -> a
`mappend` a
"=" a -> a -> a
forall a. Monoid a => a -> a -> a
`mappend` a
val

type ExtensionDescriptions = [ExtensionDescription]

parseExtensionDescriptions :: B.ByteString -> Either String ExtensionDescriptions
parseExtensionDescriptions :: ByteString -> Either String [ExtensionDescription]
parseExtensionDescriptions = Parser [ExtensionDescription]
-> ByteString -> Either String [ExtensionDescription]
forall a. Parser a -> ByteString -> Either String a
A.parseOnly (Parser [ExtensionDescription]
 -> ByteString -> Either String [ExtensionDescription])
-> Parser [ExtensionDescription]
-> ByteString
-> Either String [ExtensionDescription]
forall a b. (a -> b) -> a -> b
$
    Parser ByteString ()
AC8.skipSpace Parser ByteString ()
-> Parser [ExtensionDescription] -> Parser [ExtensionDescription]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
    Parser ExtensionDescription
-> Parser ByteString Word8 -> Parser [ExtensionDescription]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
A.sepBy Parser ExtensionDescription
parseExtensionDescription (Char -> Parser ByteString Word8
AC8.char8 Char
',' Parser ByteString Word8
-> Parser ByteString () -> Parser ByteString Word8
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
AC8.skipSpace) Parser [ExtensionDescription]
-> Parser ByteString () -> Parser [ExtensionDescription]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*
    Parser ByteString ()
forall t. Chunk t => Parser t ()
A.endOfInput

encodeExtensionDescriptions :: ExtensionDescriptions -> B.ByteString
encodeExtensionDescriptions :: [ExtensionDescription] -> ByteString
encodeExtensionDescriptions = ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
"," ([ByteString] -> ByteString)
-> ([ExtensionDescription] -> [ByteString])
-> [ExtensionDescription]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExtensionDescription -> ByteString)
-> [ExtensionDescription] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ExtensionDescription -> ByteString
encodeExtensionDescription