{-# 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 h
a Word16
q) = h -> ByteString
forall h. RenderHeader h => h -> ByteString
renderHeader h
a ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
";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 a
x 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 (String
"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 Word16
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 Word16
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 Word16
q) (Quality a
b 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` Word32
1000 :: Word32)


------------------------------------------------------------------------------
-- | Converts the integral value into its standard quality representation.
showQ :: Word16 -> ByteString
showQ :: Word16 -> ByteString
showQ Word16
1000 = ByteString
"1"
showQ Word16
0    = ByteString
"0"
showQ Word16
q    = ByteString
"0." ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> ByteString
BS.replicate (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) Char
'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
== Char
'0') String
s)


------------------------------------------------------------------------------
-- | Reads the standard quality representation into an integral value.
readQ :: ByteString -> Maybe Word16
readQ :: ByteString -> Maybe Word16
readQ 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
== Char
'1'   = ByteString -> Maybe Word16
read1 ByteString
t
    | Char
h Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'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 ByteString
bs
    | ByteString -> Bool
BS.null ByteString
bs Bool -> Bool -> Bool
|| Char
h Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
&& ByteString -> Int
BS.length ByteString
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
4 Bool -> Bool -> Bool
&& (Char -> Bool) -> ByteString -> Bool
BS.all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'0') ByteString
t
                = Word16 -> Maybe Word16
forall a. a -> Maybe a
Just Word16
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 ByteString
bs
    | ByteString -> Bool
BS.null ByteString
bs = Word16 -> Maybe Word16
forall a. a -> Maybe a
Just Word16
0
    | Char
h Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
&& ByteString -> Int
BS.length ByteString
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
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 (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
BS.length ByteString
t) Char
'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