diff --git a/Web/Mime.hs b/Web/Mime.hs index deef197d..7c69e154 100644 --- a/Web/Mime.hs +++ b/Web/Mime.hs @@ -3,10 +3,14 @@ {-# LANGUAGE CPP #-} -- | Generic MIME type module. Could be spun off into its own package. module Web.Mime - ( ContentType (..) - , contentTypeFromBS + ( -- * Data type and conversions + ContentType (..) + , contentTypeFromString + , contentTypeToString + -- * File extensions , typeByExt , ext + -- * Utilities , simpleContentType #if TEST , testSuite @@ -14,8 +18,6 @@ module Web.Mime ) where import Data.Function (on) -import Data.Convertible.Text -import Data.ByteString.Char8 (pack, ByteString, unpack) #if TEST import Test.Framework (testGroup, Test) @@ -26,6 +28,11 @@ import Test.QuickCheck import Control.Monad (when) #endif +-- | Equality is determined by converting to a 'String' via +-- 'contentTypeToString'. This ensures that, for example, 'TypeJpeg' is the +-- same as 'TypeOther' \"image/jpeg\". However, note that 'TypeHtml' is *not* +-- the same as 'TypeOther' \"text/html\", since 'TypeHtml' is defined as UTF-8 +-- encoded. See 'contentTypeToString'. data ContentType = TypeHtml | TypePlain @@ -43,33 +50,41 @@ data ContentType = | TypeOther String deriving (Show) -instance ConvertSuccess ContentType ByteString where - convertSuccess = pack . cs +-- | This is simply a synonym for 'TypeOther'. However, equality works as +-- expected; see 'ContentType'. +contentTypeFromString :: String -> ContentType +contentTypeFromString = TypeOther -instance ConvertSuccess ContentType [Char] where - convertSuccess TypeHtml = "text/html; charset=utf-8" - convertSuccess TypePlain = "text/plain; charset=utf-8" - convertSuccess TypeJson = "application/json; charset=utf-8" - convertSuccess TypeXml = "text/xml" - convertSuccess TypeAtom = "application/atom+xml" - convertSuccess TypeJpeg = "image/jpeg" - convertSuccess TypePng = "image/png" - convertSuccess TypeGif = "image/gif" - convertSuccess TypeJavascript = "text/javascript; charset=utf-8" - convertSuccess TypeCss = "text/css; charset=utf-8" - convertSuccess TypeFlv = "video/x-flv" - convertSuccess TypeOgv = "video/ogg" - convertSuccess TypeOctet = "application/octet-stream" - convertSuccess (TypeOther s) = s +-- | This works as expected, with one caveat: the builtin textual content types +-- ('TypeHtml', 'TypePlain', etc) all include \"; charset=utf-8\" at the end of +-- their basic content-type. If another encoding is desired, please use +-- 'TypeOther'. +contentTypeToString :: ContentType -> String +contentTypeToString TypeHtml = "text/html; charset=utf-8" +contentTypeToString TypePlain = "text/plain; charset=utf-8" +contentTypeToString TypeJson = "application/json; charset=utf-8" +contentTypeToString TypeXml = "text/xml" +contentTypeToString TypeAtom = "application/atom+xml" +contentTypeToString TypeJpeg = "image/jpeg" +contentTypeToString TypePng = "image/png" +contentTypeToString TypeGif = "image/gif" +contentTypeToString TypeJavascript = "text/javascript; charset=utf-8" +contentTypeToString TypeCss = "text/css; charset=utf-8" +contentTypeToString TypeFlv = "video/x-flv" +contentTypeToString TypeOgv = "video/ogg" +contentTypeToString TypeOctet = "application/octet-stream" +contentTypeToString (TypeOther s) = s -simpleContentType :: ContentType -> String -simpleContentType = fst . span (/= ';') . cs +-- | Removes \"extra\" information at the end of a content type string. In +-- particular, removes everything after the semicolon, if present. +-- +-- For example, \"text/html; charset=utf-8\" is commonly used to specify the +-- character encoding for HTML data. This function would return \"text/html\". +simpleContentType :: String -> String +simpleContentType = fst . span (/= ';') instance Eq ContentType where - (==) = (==) `on` (cs :: ContentType -> String) - -contentTypeFromBS :: ByteString -> ContentType -contentTypeFromBS = TypeOther . unpack + (==) = (==) `on` contentTypeToString -- | Determine a mime-type based on the file extension. typeByExt :: String -> ContentType @@ -106,5 +121,4 @@ caseTypeByExt :: Assertion caseTypeByExt = do TypeJavascript @=? typeByExt (ext "foo.js") TypeHtml @=? typeByExt (ext "foo.html") - #endif diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 4afa3f3b..ba966463 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -141,7 +141,7 @@ cleanupSegments :: [B.ByteString] -> [String] cleanupSegments = decodePathInfo . intercalate "/" . map B.unpack httpAccept :: W.Request -> [ContentType] -httpAccept = map contentTypeFromBS +httpAccept = map (contentTypeFromString . B.unpack) . parseHttpAccept . fromMaybe B.empty . lookup W.Accept diff --git a/Yesod/Response.hs b/Yesod/Response.hs index 792092d2..66ff9b1d 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -133,12 +133,13 @@ instance HasReps () where instance HasReps [(ContentType, Content)] where chooseRep a cts = return $ - case filter (\(ct, _) -> simpleContentType ct `elem` - map simpleContentType cts) a of + case filter (\(ct, _) -> go ct `elem` map go cts) a of ((ct, c):_) -> (ct, c) _ -> case a of (x:_) -> x _ -> error "chooseRep [(ContentType, Content)] of empty" + where + go = simpleContentType . contentTypeToString -- | Data with a single representation. staticRep :: ConvertSuccess x Content @@ -227,7 +228,7 @@ headerToPair (Header key value) = responseToWaiResponse :: Response -> IO W.Response responseToWaiResponse (Response sc hs ct c) = do hs' <- mapM headerToPair hs - let hs'' = (W.ContentType, cs ct) : hs' + let hs'' = (W.ContentType, cs $ contentTypeToString ct) : hs' return $ W.Response sc hs'' $ case c of ContentFile fp -> Left fp ContentEnum e -> Right $ W.Enumerator e