------------------------------------------------------------------------------
-- | Defines the 'Language' accept header with an 'Accept' instance for use in
-- language negotiation.
module Network.HTTP.Media.Language.Internal
    ( Language (..)
    ) where

import qualified Data.ByteString.Char8           as BS
import qualified Data.CaseInsensitive            as CI

import           Control.Monad                   (guard)
import           Data.ByteString                 (ByteString)
import           Data.CaseInsensitive            (CI, original)
import           Data.Char                       (isAlpha, isAlphaNum)
import           Data.List                       (isPrefixOf)
import           Data.Maybe                      (fromMaybe)
import           Data.String                     (IsString (..))

import           Network.HTTP.Media.Accept       (Accept (..))
import           Network.HTTP.Media.RenderHeader (RenderHeader (..))


------------------------------------------------------------------------------
-- | Suitable for HTTP language-ranges as defined in
-- <https://tools.ietf.org/html/rfc4647#section-2.1 RFC4647>.
--
-- Specifically:
--
-- > language-range = (1*8ALPHA *("-" 1*8alphanum)) / "*"
newtype Language = Language [CI ByteString]
    deriving (Language -> Language -> Bool
(Language -> Language -> Bool)
-> (Language -> Language -> Bool) -> Eq Language
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Language -> Language -> Bool
$c/= :: Language -> Language -> Bool
== :: Language -> Language -> Bool
$c== :: Language -> Language -> Bool
Eq, Eq Language
Eq Language
-> (Language -> Language -> Ordering)
-> (Language -> Language -> Bool)
-> (Language -> Language -> Bool)
-> (Language -> Language -> Bool)
-> (Language -> Language -> Bool)
-> (Language -> Language -> Language)
-> (Language -> Language -> Language)
-> Ord Language
Language -> Language -> Bool
Language -> Language -> Ordering
Language -> Language -> Language
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Language -> Language -> Language
$cmin :: Language -> Language -> Language
max :: Language -> Language -> Language
$cmax :: Language -> Language -> Language
>= :: Language -> Language -> Bool
$c>= :: Language -> Language -> Bool
> :: Language -> Language -> Bool
$c> :: Language -> Language -> Bool
<= :: Language -> Language -> Bool
$c<= :: Language -> Language -> Bool
< :: Language -> Language -> Bool
$c< :: Language -> Language -> Bool
compare :: Language -> Language -> Ordering
$ccompare :: Language -> Language -> Ordering
$cp1Ord :: Eq Language
Ord)

-- Note that internally, Language [] equates to *.

instance Show Language where
    show :: Language -> String
show = ByteString -> String
BS.unpack (ByteString -> String)
-> (Language -> ByteString) -> Language -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Language -> ByteString
forall h. RenderHeader h => h -> ByteString
renderHeader

instance IsString Language where
    fromString :: String -> Language
fromString String
"*" = [CI ByteString] -> Language
Language []
    fromString String
str = (Language -> Maybe Language -> Language)
-> Maybe Language -> Language -> Language
forall a b c. (a -> b -> c) -> b -> a -> c
flip Language -> Maybe Language -> Language
forall a. a -> Maybe a -> a
fromMaybe (ByteString -> Maybe Language
forall a. Accept a => ByteString -> Maybe a
parseAccept (ByteString -> Maybe Language) -> ByteString -> Maybe Language
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BS.pack String
str) (Language -> Language) -> Language -> Language
forall a b. (a -> b) -> a -> b
$
        String -> Language
forall a. HasCallStack => String -> a
error (String -> Language) -> String -> Language
forall a b. (a -> b) -> a -> b
$ String
"Invalid language literal " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str

instance Accept Language where
    parseAccept :: ByteString -> Maybe Language
parseAccept ByteString
"*" = Language -> Maybe Language
forall a. a -> Maybe a
Just (Language -> Maybe Language) -> Language -> Maybe Language
forall a b. (a -> b) -> a -> b
$ [CI ByteString] -> Language
Language []
    parseAccept ByteString
bs = do
        let pieces :: [ByteString]
pieces = Char -> ByteString -> [ByteString]
BS.split Char
'-' ByteString
bs
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not ([ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
pieces)
        [CI ByteString] -> Language
Language ([CI ByteString] -> Language)
-> Maybe [CI ByteString] -> Maybe Language
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> Maybe (CI ByteString))
-> [ByteString] -> Maybe [CI ByteString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ByteString -> Maybe (CI ByteString)
forall (m :: * -> *).
(Monad m, Alternative m) =>
ByteString -> m (CI ByteString)
check [ByteString]
pieces
      where
        check :: ByteString -> m (CI ByteString)
check ByteString
part = do
            let len :: Int
len = ByteString -> Int
BS.length ByteString
part
            Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> m ()) -> Bool -> m ()
forall a b. (a -> b) -> a -> b
$ Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 Bool -> Bool -> Bool
&& Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
8 Bool -> Bool -> Bool
&&
                Char -> Bool
isAlpha (ByteString -> Char
BS.head ByteString
part) Bool -> Bool -> Bool
&&
                (Char -> Bool) -> ByteString -> Bool
BS.all Char -> Bool
isAlphaNum (ByteString -> ByteString
BS.tail ByteString
part)
            CI ByteString -> m (CI ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
part)

    -- Languages match if the right argument is a prefix of the left.
    matches :: Language -> Language -> Bool
matches (Language [CI ByteString]
a) (Language [CI ByteString]
b)  = [CI ByteString]
b [CI ByteString] -> [CI ByteString] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [CI ByteString]
a

    -- The left language is more specific than the right if the right
    -- arguments is a strict prefix of the left.
    moreSpecificThan :: Language -> Language -> Bool
moreSpecificThan (Language [CI ByteString]
a) (Language [CI ByteString]
b) =
        [CI ByteString]
b [CI ByteString] -> [CI ByteString] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [CI ByteString]
a Bool -> Bool -> Bool
&& [CI ByteString] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CI ByteString]
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [CI ByteString] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CI ByteString]
b

instance RenderHeader Language where
    renderHeader :: Language -> ByteString
renderHeader (Language []) = ByteString
"*"
    renderHeader (Language [CI ByteString]
l)  = ByteString -> [ByteString] -> ByteString
BS.intercalate ByteString
"-" ((CI ByteString -> ByteString) -> [CI ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map CI ByteString -> ByteString
forall s. CI s -> s
original [CI ByteString]
l)