------------------------------------------------------------------------------
-- | 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
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
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
Ord)

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

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

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

instance Accept Language where
    parseAccept :: ByteString -> Maybe Language
parseAccept ByteString
"*" = forall a. a -> Maybe a
Just 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
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
pieces)
        [CI ByteString] -> Language
Language forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM 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
            forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Int
len forall a. Ord a => a -> a -> Bool
>= Int
1 Bool -> Bool -> Bool
&& Int
len 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 (HasCallStack => ByteString -> ByteString
BS.tail ByteString
part)
            forall (m :: * -> *) a. Monad m => a -> m a
return (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 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 forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [CI ByteString]
a Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Int
length [CI ByteString]
a forall a. Ord a => a -> a -> Bool
> 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
"-" (forall a b. (a -> b) -> [a] -> [b]
map forall s. CI s -> s
original [CI ByteString]
l)