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

import Control.Monad (guard)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.CaseInsensitive (CI, original)
import qualified Data.CaseInsensitive as CI
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)