{-# LANGUAGE DeriveFunctor #-}

------------------------------------------------------------------------------
-- | Defines the quality value data type.
module Network.HTTP.Media.Quality
    ( Quality (..)
    , quality
    , QualityOrder
    , qualityOrder
    , isAcceptable
    , 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
    { forall a. Quality a -> a
qualityData  :: a
    , forall a. Quality a -> Word16
qualityValue :: Word16
    } deriving (Quality a -> Quality a -> Bool
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, 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
<$ :: forall a b. a -> Quality b -> Quality a
$c<$ :: forall a b. a -> Quality b -> Quality a
fmap :: forall a b. (a -> b) -> Quality a -> Quality b
$cfmap :: forall a b. (a -> b) -> Quality a -> Quality b
Functor, Quality a -> Quality a -> Bool
Quality a -> Quality a -> Ordering
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
Ord)

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

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


------------------------------------------------------------------------------
-- | Manually construct a quality value.
quality :: a -> ByteString -> Quality a
quality :: forall a. a -> ByteString -> Quality a
quality a
x ByteString
q = forall a. a -> Word16 -> Quality a
Quality a
x forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. a -> Maybe a -> a
fromMaybe (ByteString -> Maybe Word16
readQ ByteString
q) forall a b. (a -> b) -> a -> b
$
    forall a. HasCallStack => String -> a
error (String
"Invalid quality value " 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
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
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
Ord)

------------------------------------------------------------------------------
-- | Whether the quality value is greater than zero; otherwise the value
-- should never be accepted, even when no other options are available.
isAcceptable :: Quality a -> Bool
isAcceptable :: forall a. Quality a -> Bool
isAcceptable (Quality a
_ Word16
0) = Bool
False
isAcceptable (Quality a
_ Word16
_) = Bool
True

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


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


------------------------------------------------------------------------------
-- | Attaches the quality value '0'.
minQuality :: a -> Quality a
minQuality :: forall a. a -> Quality a
minQuality = forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 :: forall a. Accept a => Quality a -> Quality a -> Quality a
mostSpecific (Quality a
a Word16
q) (Quality a
b Word16
r)
    | a
a forall a. Accept a => a -> a -> Bool
`moreSpecificThan` a
b = forall a. a -> Word16 -> Quality a
Quality a
a Word16
q
    | a
b forall a. Accept a => a -> a -> Bool
`moreSpecificThan` a
a = forall a. a -> Word16 -> Quality a
Quality a
b Word16
r
    | Bool
otherwise              = forall a. a -> Word16 -> Quality a
Quality a
a Word16
q'
  where
    q' :: Word16
q' = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
q forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
r 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." forall a. Semigroup a => a -> a -> a
<> Int -> Char -> ByteString
BS.replicate (Int
3 forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) Char
'0' forall a. Semigroup a => a -> a -> a
<> ByteString
b
  where
    s :: String
s = forall a. Show a => a -> String
show Word16
q
    b :: ByteString
b = String -> ByteString
BS.pack (forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd (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 = forall a. Maybe a
Nothing
    | Char
h forall a. Eq a => a -> a -> Bool
== Char
'1'   = ByteString -> Maybe Word16
read1 ByteString
t
    | Char
h forall a. Eq a => a -> a -> Bool
== Char
'0'   = ByteString -> Maybe Word16
read0 ByteString
t
    | Bool
otherwise  = forall a. Maybe a
Nothing
  where
    h :: Char
h = ByteString -> Char
BS.head ByteString
bs
    t :: ByteString
t = HasCallStack => 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 forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
&& ByteString -> Int
BS.length ByteString
t forall a. Ord a => a -> a -> Bool
< Int
4 Bool -> Bool -> Bool
&& (Char -> Bool) -> ByteString -> Bool
BS.all (forall a. Eq a => a -> a -> Bool
== Char
'0') ByteString
t
                = forall a. a -> Maybe a
Just Word16
1000
    | Bool
otherwise = forall a. Maybe a
Nothing
  where
    h :: Char
h = ByteString -> Char
BS.head ByteString
bs
    t :: ByteString
t = HasCallStack => ByteString -> ByteString
BS.tail ByteString
bs

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