{-# 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 Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
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 (..))
import Prelude hiding ((<>))

-- | 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
(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
$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
/= :: Quality a -> Quality a -> Bool
Eq, (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
$cfmap :: forall a b. (a -> b) -> Quality a -> Quality b
fmap :: forall a b. (a -> b) -> Quality a -> Quality b
$c<$ :: forall a b. a -> Quality b -> Quality a
<$ :: forall a b. a -> Quality b -> Quality a
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
$ccompare :: forall a. Ord a => Quality a -> Quality a -> Ordering
compare :: Quality a -> Quality a -> Ordering
$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
>= :: Quality a -> Quality a -> Bool
$cmax :: forall a. Ord a => Quality a -> Quality a -> Quality a
max :: Quality a -> Quality a -> Quality a
$cmin :: forall a. Ord a => Quality a -> Quality a -> Quality a
min :: Quality a -> Quality a -> 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 :: forall a. 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
$c== :: QualityOrder -> QualityOrder -> Bool
== :: QualityOrder -> QualityOrder -> Bool
$c/= :: QualityOrder -> QualityOrder -> Bool
/= :: 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
$ccompare :: QualityOrder -> QualityOrder -> Ordering
compare :: QualityOrder -> QualityOrder -> Ordering
$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
>= :: QualityOrder -> QualityOrder -> Bool
$cmax :: QualityOrder -> QualityOrder -> QualityOrder
max :: QualityOrder -> QualityOrder -> QualityOrder
$cmin :: QualityOrder -> QualityOrder -> QualityOrder
min :: QualityOrder -> QualityOrder -> QualityOrder
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 (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 :: forall a. 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 :: forall a. 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 :: forall a. Accept a => 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 a. [a] -> 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 = HasCallStack => ByteString -> ByteString
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 = HasCallStack => ByteString -> ByteString
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 = HasCallStack => ByteString -> ByteString
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