{-# LANGUAGE DeriveFunctor #-}

------------------------------------------------------------------------------
-- | Defines the quality value data type.
module Network.HTTP.Media.Quality
    ( Quality (..)
    , quality
    , QualityOrder
    , qualityOrder
    , maxQuality
    , minQuality
    , mostSpecific
    , showQ
    , readQ
    ) where

import qualified Data.ByteString.Char8           as BS

import           Data.ByteString                 (ByteString)
import           Data.ByteString.UTF8            (toString)
import           Data.Char                       (isDigit)
import           Data.List                       (dropWhileEnd)
import           Data.Maybe                      (fromMaybe)
import           Data.Monoid                     ((<>))
import           Data.Word                       (Word16, Word32)

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


------------------------------------------------------------------------------
-- | Attaches a quality value to data.
data Quality a = Quality
    { Quality a -> a
qualityData  :: a
    , Quality a -> Word16
qualityValue :: Word16
    } deriving (Quality a -> Quality a -> Bool
(Quality a -> Quality a -> Bool)
-> (Quality a -> Quality a -> Bool) -> Eq (Quality a)
forall a. Eq a => Quality a -> Quality a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Quality a -> Quality a -> Bool
$c/= :: forall a. Eq a => Quality a -> Quality a -> Bool
== :: Quality a -> Quality a -> Bool
$c== :: forall a. Eq a => Quality a -> Quality a -> Bool
Eq, a -> Quality b -> Quality a
(a -> b) -> Quality a -> Quality b
(forall a b. (a -> b) -> Quality a -> Quality b)
-> (forall a b. a -> Quality b -> Quality a) -> Functor Quality
forall a b. a -> Quality b -> Quality a
forall a b. (a -> b) -> Quality a -> Quality b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Quality b -> Quality a
$c<$ :: forall a b. a -> Quality b -> Quality a
fmap :: (a -> b) -> Quality a -> Quality b
$cfmap :: forall a b. (a -> b) -> Quality a -> Quality b
Functor, Eq (Quality a)
Eq (Quality a) =>
(Quality a -> Quality a -> Ordering)
-> (Quality a -> Quality a -> Bool)
-> (Quality a -> Quality a -> Bool)
-> (Quality a -> Quality a -> Bool)
-> (Quality a -> Quality a -> Bool)
-> (Quality a -> Quality a -> Quality a)
-> (Quality a -> Quality a -> Quality a)
-> Ord (Quality a)
Quality a -> Quality a -> Bool
Quality a -> Quality a -> Ordering
Quality a -> Quality a -> Quality a
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
forall a. Ord a => Eq (Quality a)
forall a. Ord a => Quality a -> Quality a -> Bool
forall a. Ord a => Quality a -> Quality a -> Ordering
forall a. Ord a => Quality a -> Quality a -> Quality a
min :: Quality a -> Quality a -> Quality a
$cmin :: forall a. Ord a => Quality a -> Quality a -> Quality a
max :: Quality a -> Quality a -> Quality a
$cmax :: forall a. Ord a => Quality a -> Quality a -> Quality a
>= :: Quality a -> Quality a -> Bool
$c>= :: forall a. Ord a => Quality a -> Quality a -> Bool
> :: Quality a -> Quality a -> Bool
$c> :: forall a. Ord a => Quality a -> Quality a -> Bool
<= :: Quality a -> Quality a -> Bool
$c<= :: forall a. Ord a => Quality a -> Quality a -> Bool
< :: Quality a -> Quality a -> Bool
$c< :: forall a. Ord a => Quality a -> Quality a -> Bool
compare :: Quality a -> Quality a -> Ordering
$ccompare :: forall a. Ord a => Quality a -> Quality a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Quality a)
Ord)

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

instance RenderHeader h => RenderHeader (Quality h) where
    renderHeader :: Quality h -> ByteString
renderHeader (Quality a :: h
a q :: Word16
q) = h -> ByteString
forall h. RenderHeader h => h -> ByteString
renderHeader h
a ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ";q=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word16 -> ByteString
showQ Word16
q


------------------------------------------------------------------------------
-- | Manually construct a quality value.
quality :: a -> ByteString -> Quality a
quality :: a -> ByteString -> Quality a
quality x :: a
x q :: ByteString
q = a -> Word16 -> Quality a
forall a. a -> Word16 -> Quality a
Quality a
x (Word16 -> Quality a) -> Word16 -> Quality a
forall a b. (a -> b) -> a -> b
$ (Word16 -> Maybe Word16 -> Word16)
-> Maybe Word16 -> Word16 -> Word16
forall a b c. (a -> b -> c) -> b -> a -> c
flip Word16 -> Maybe Word16 -> Word16
forall a. a -> Maybe a -> a
fromMaybe (ByteString -> Maybe Word16
readQ ByteString
q) (Word16 -> Word16) -> Word16 -> Word16
forall a b. (a -> b) -> a -> b
$
    String -> Word16
forall a. HasCallStack => String -> a
error ("Invalid quality value " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
toString ByteString
q)


------------------------------------------------------------------------------
-- | An opaque ordered representation of quality values without attached data.
newtype QualityOrder = QualityOrder Word16
    deriving (QualityOrder -> QualityOrder -> Bool
(QualityOrder -> QualityOrder -> Bool)
-> (QualityOrder -> QualityOrder -> Bool) -> Eq QualityOrder
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: QualityOrder -> QualityOrder -> Bool
$c/= :: QualityOrder -> QualityOrder -> Bool
== :: QualityOrder -> QualityOrder -> Bool
$c== :: QualityOrder -> QualityOrder -> Bool
Eq, Eq QualityOrder
Eq QualityOrder =>
(QualityOrder -> QualityOrder -> Ordering)
-> (QualityOrder -> QualityOrder -> Bool)
-> (QualityOrder -> QualityOrder -> Bool)
-> (QualityOrder -> QualityOrder -> Bool)
-> (QualityOrder -> QualityOrder -> Bool)
-> (QualityOrder -> QualityOrder -> QualityOrder)
-> (QualityOrder -> QualityOrder -> QualityOrder)
-> Ord QualityOrder
QualityOrder -> QualityOrder -> Bool
QualityOrder -> QualityOrder -> Ordering
QualityOrder -> QualityOrder -> QualityOrder
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 :: QualityOrder -> QualityOrder -> QualityOrder
$cmin :: QualityOrder -> QualityOrder -> QualityOrder
max :: QualityOrder -> QualityOrder -> QualityOrder
$cmax :: QualityOrder -> QualityOrder -> QualityOrder
>= :: QualityOrder -> QualityOrder -> Bool
$c>= :: QualityOrder -> QualityOrder -> Bool
> :: QualityOrder -> QualityOrder -> Bool
$c> :: QualityOrder -> QualityOrder -> Bool
<= :: QualityOrder -> QualityOrder -> Bool
$c<= :: QualityOrder -> QualityOrder -> Bool
< :: QualityOrder -> QualityOrder -> Bool
$c< :: QualityOrder -> QualityOrder -> Bool
compare :: QualityOrder -> QualityOrder -> Ordering
$ccompare :: QualityOrder -> QualityOrder -> Ordering
$cp1Ord :: Eq QualityOrder
Ord)


------------------------------------------------------------------------------
-- | Remove the attached data from a quality value, retaining only the
-- priority of the quality parameter.
qualityOrder :: Quality a -> QualityOrder
qualityOrder :: Quality a -> QualityOrder
qualityOrder = Word16 -> QualityOrder
QualityOrder (Word16 -> QualityOrder)
-> (Quality a -> Word16) -> Quality a -> QualityOrder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Quality a -> Word16
forall a. Quality a -> Word16
qualityValue


------------------------------------------------------------------------------
-- | Attaches the quality value '1'.
maxQuality :: a -> Quality a
maxQuality :: a -> Quality a
maxQuality = (a -> Word16 -> Quality a) -> Word16 -> a -> Quality a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> Word16 -> Quality a
forall a. a -> Word16 -> Quality a
Quality 1000


------------------------------------------------------------------------------
-- | Attaches the quality value '0'.
minQuality :: a -> Quality a
minQuality :: a -> Quality a
minQuality = (a -> Word16 -> Quality a) -> Word16 -> a -> Quality a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> Word16 -> Quality a
forall a. a -> Word16 -> Quality a
Quality 0


------------------------------------------------------------------------------
-- | Combines quality values by specificity. Selects the more specific of the
-- two arguments, but if they are the same returns the data of the left
-- argument with the two quality values of both arguments combined.
mostSpecific :: Accept a => Quality a -> Quality a -> Quality a
mostSpecific :: Quality a -> Quality a -> Quality a
mostSpecific (Quality a :: a
a q :: Word16
q) (Quality b :: a
b r :: Word16
r)
    | a
a a -> a -> Bool
forall a. Accept a => a -> a -> Bool
`moreSpecificThan` a
b = a -> Word16 -> Quality a
forall a. a -> Word16 -> Quality a
Quality a
a Word16
q
    | a
b a -> a -> Bool
forall a. Accept a => a -> a -> Bool
`moreSpecificThan` a
a = a -> Word16 -> Quality a
forall a. a -> Word16 -> Quality a
Quality a
b Word16
r
    | Bool
otherwise              = a -> Word16 -> Quality a
forall a. a -> Word16 -> Quality a
Quality a
a Word16
q'
  where
    q' :: Word16
q' = Word32 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
q Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word16 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
r Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`div` 1000 :: Word32)


------------------------------------------------------------------------------
-- | Converts the integral value into its standard quality representation.
showQ :: Word16 -> ByteString
showQ :: Word16 -> ByteString
showQ 1000 = "1"
showQ 0    = "0"
showQ q :: Word16
q    = "0." ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> ByteString
BS.replicate (3 Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) '0' ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
b
  where
    s :: String
s = Word16 -> String
forall a. Show a => a -> String
show Word16
q
    b :: ByteString
b = String -> ByteString
BS.pack ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '0') String
s)


------------------------------------------------------------------------------
-- | Reads the standard quality representation into an integral value.
readQ :: ByteString -> Maybe Word16
readQ :: ByteString -> Maybe Word16
readQ bs :: ByteString
bs
    | ByteString -> Bool
BS.null ByteString
bs = Maybe Word16
forall a. Maybe a
Nothing
    | Char
h Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '1'   = ByteString -> Maybe Word16
read1 ByteString
t
    | Char
h Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '0'   = ByteString -> Maybe Word16
read0 ByteString
t
    | Bool
otherwise  = Maybe Word16
forall a. Maybe a
Nothing
  where
    h :: Char
h = ByteString -> Char
BS.head ByteString
bs
    t :: ByteString
t = ByteString -> ByteString
BS.tail ByteString
bs

read1 :: ByteString -> Maybe Word16
read1 :: ByteString -> Maybe Word16
read1 bs :: ByteString
bs
    | ByteString -> Bool
BS.null ByteString
bs Bool -> Bool -> Bool
|| Char
h Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '.' Bool -> Bool -> Bool
&& ByteString -> Int
BS.length ByteString
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 4 Bool -> Bool -> Bool
&& (Char -> Bool) -> ByteString -> Bool
BS.all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '0') ByteString
t
                = Word16 -> Maybe Word16
forall a. a -> Maybe a
Just 1000
    | Bool
otherwise = Maybe Word16
forall a. Maybe a
Nothing
  where
    h :: Char
h = ByteString -> Char
BS.head ByteString
bs
    t :: ByteString
t = ByteString -> ByteString
BS.tail ByteString
bs

read0 :: ByteString -> Maybe Word16
read0 :: ByteString -> Maybe Word16
read0 bs :: ByteString
bs
    | ByteString -> Bool
BS.null ByteString
bs = Word16 -> Maybe Word16
forall a. a -> Maybe a
Just 0
    | Char
h Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '.' Bool -> Bool -> Bool
&& ByteString -> Int
BS.length ByteString
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 4 Bool -> Bool -> Bool
&& (Char -> Bool) -> ByteString -> Bool
BS.all Char -> Bool
isDigit ByteString
t
                = Word16 -> Maybe Word16
forall a. a -> Maybe a
Just (ByteString -> Word16
toWord (ByteString
t ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> ByteString
BS.replicate (3 Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
BS.length ByteString
t) '0'))
    | Bool
otherwise = Maybe Word16
forall a. Maybe a
Nothing
  where
    h :: Char
h = ByteString -> Char
BS.head ByteString
bs
    t :: ByteString
t = ByteString -> ByteString
BS.tail ByteString
bs
    toWord :: ByteString -> Word16
toWord = String -> Word16
forall a. Read a => String -> a
read (String -> Word16)
-> (ByteString -> String) -> ByteString -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BS.unpack