{-# 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
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