module Network.HTTP.Media.Quality
( Quality (..)
, quality
, maxQuality
, minQuality
, 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)
import Network.HTTP.Media.RenderHeader (RenderHeader (..))
data Quality a = Quality
{ qualityData :: a
, qualityValue :: Word16
} deriving (Eq, Ord)
instance RenderHeader a => Show (Quality a) where
show = BS.unpack . renderHeader
instance RenderHeader h => RenderHeader (Quality h) where
renderHeader (Quality a q) = renderHeader a <> ";q=" <> showQ q
quality :: a -> ByteString -> Quality a
quality x q = Quality x $ flip fromMaybe (readQ q) $
error ("Invalid quality value " ++ toString q)
maxQuality :: a -> Quality a
maxQuality = flip Quality 1000
minQuality :: a -> Quality a
minQuality = flip Quality 0
showQ :: Word16 -> ByteString
showQ 1000 = "1"
showQ 0 = "0"
showQ q = "0." <> BS.replicate (3 length s) '0' <> b
where
s = show q
b = BS.pack (dropWhileEnd (== '0') s)
readQ :: ByteString -> Maybe Word16
readQ bs
| BS.null bs = Nothing
| h == '1' = read1 t
| h == '0' = read0 t
| otherwise = Nothing
where
h = BS.head bs
t = BS.tail bs
read1 :: ByteString -> Maybe Word16
read1 bs
| BS.null bs || h == '.' && BS.length t < 4 && BS.all (== '0') t
= Just 1000
| otherwise = Nothing
where
h = BS.head bs
t = BS.tail bs
read0 :: ByteString -> Maybe Word16
read0 bs
| BS.null bs = Just 0
| h == '.' && BS.length t < 4 && BS.all isDigit t
= Just (toWord (t <> BS.replicate (3 BS.length t) '0'))
| otherwise = Nothing
where
h = BS.head bs
t = BS.tail bs
toWord = read . BS.unpack