http-accept-0.1: Network/HTTP/Accept.hs

module Network.HTTP.Accept (selectAcceptType) where

import Data.Char (isAscii)
import Data.Maybe (mapMaybe, listToMaybe)
import Control.Arrow (first)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS (singleton, split)
import qualified Data.ByteString.Char8 as Char8

data Pattern a = PatternAny | PatternExactly a

instance (Eq a) => Eq (Pattern a) where
	PatternAny == _ = True
	_ == PatternAny = True
	(PatternExactly a) == (PatternExactly b) = a == b

-- | Select which Accept type to use
selectAcceptType ::
	[String]        -- ^ List of supported MIME types, in preferred order
	-> [ByteString] -- ^ List of types from Accept, pre-sorted with no q
	-> Maybe String -- ^ Just the selected supported type, or else Nothing
selectAcceptType supported accept =
	listToMaybe $ mapMaybe (`lookup` supported') accept'
	where
	accept' = map (Just . parseAccept) accept
	supported' = map (first $ fmap parseAccept . stringAscii)
		(zip supported supported)
	parseAccept s = let (t:sub:_) = BS.split 0x2f s in
		(parsePattern t, parsePattern sub)

parsePattern :: ByteString -> Pattern ByteString
parsePattern s
	| s == BS.singleton 0x2a = PatternAny
	| otherwise = PatternExactly s

-- | Safely convert an ASCII 'String' to 'ByteString'
stringAscii :: String -> Maybe ByteString
stringAscii s
	| all isAscii s = Just $ Char8.pack s
	| otherwise     = Nothing