Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

More specific matches are preferred

So if text/* comes after */*, then text/plain comes after other things
in preference.

As per: <http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html>
  • Loading branch information...
commit cb6ca70c73c855338c8cf73048db31f80e950483 1 parent b4981ee
@singpolyma authored
Showing with 38 additions and 9 deletions.
  1. +1 −1  Makefile
  2. +36 −7 Network/HTTP/Accept.hs
  3. +1 −1  http-accept.cabal
View
2  Makefile
@@ -1,6 +1,6 @@
GHCFLAGS=-Wall -XNoCPP -fno-warn-name-shadowing -XHaskell98 -O2
HLINTFLAGS=-XHaskell98 -XNoCPP -i 'Use camelCase' -i 'Use String' -i 'Use head' -i 'Use string literal' -i 'Use list comprehension' --utf8
-VERSION=0.1
+VERSION=0.2
.PHONY: all shell clean doc install
View
43 Network/HTTP/Accept.hs
@@ -1,7 +1,10 @@
module Network.HTTP.Accept (selectAcceptType) where
import Data.Char (isAscii)
-import Data.Maybe (mapMaybe, listToMaybe)
+import Data.Ord (comparing)
+import Data.List (maximumBy, minimumBy)
+import Data.Maybe (catMaybes, mapMaybe)
+import Control.Monad (liftM2)
import Control.Arrow (first)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS (singleton, split)
@@ -9,18 +12,44 @@ 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
+class Match a where
+ match :: a -> a -> Maybe Int
+
+instance (Eq a) => Match (Pattern a) where
+ match PatternAny _ = Just 0
+ match _ PatternAny = Just 0
+ match (PatternExactly a) (PatternExactly b)
+ | a == b = Just 1
+ | otherwise = Nothing
+
+instance (Match a, Match b) => Match (a, b) where
+ match (a1, a2) (b1, b2) = liftM2 (+) (match a1 b1) (match a2 b2)
+
+instance (Match a) => Match (Maybe a) where
+ match Nothing Nothing = Just 0
+ match Nothing _ = Nothing
+ match _ Nothing = Nothing
+ match (Just a) (Just b) = fmap (+1) (match a b)
+
+maxMatchIndex :: (Match a) => a -> [a] -> Maybe Int
+maxMatchIndex k xs = fmap fst $ maybeMax (comparing snd) $ catMaybes $
+ zipWith (\i x -> fmap ((,)i) (match k x)) [0..] xs
+
+maybeMax :: (a -> a -> Ordering) -> [a] -> Maybe a
+maybeMax _ [] = Nothing
+maybeMax cmp xs = Just (maximumBy cmp xs)
+
+maybeMin :: (a -> a -> Ordering) -> [a] -> Maybe a
+maybeMin _ [] = Nothing
+maybeMin cmp xs = Just (minimumBy cmp xs)
-- | 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'
+selectAcceptType supported accept = fmap fst $ maybeMin (comparing snd) $
+ mapMaybe (\(p,s) -> fmap ((,)s) (maxMatchIndex p accept')) supported'
where
accept' = map (Just . parseAccept) accept
supported' = map (first $ fmap parseAccept . stringAscii)
View
2  http-accept.cabal
@@ -1,5 +1,5 @@
name: http-accept
-version: 0.1
+version: 0.2
cabal-version: >= 1.8
license: OtherLicense
license-file: COPYING
Please sign in to comment.
Something went wrong with that request. Please try again.