Skip to content
Snippets Groups Projects
Verified Commit 97492adc authored by jan.hamal.dvorak's avatar jan.hamal.dvorak
Browse files

Fix & improve media handling

parent 8b1ba9bb
Branches
No related tags found
No related merge requests found
...@@ -72,6 +72,7 @@ common common ...@@ -72,6 +72,7 @@ common common
build-depends: build-depends:
, aeson >=1.4 && <1.6 , aeson >=1.4 && <1.6
, attoparsec >=0.13 && <0.15
, base >=4.13 && <5 , base >=4.13 && <5
, binary >=0.8 && <0.9 , binary >=0.8 && <0.9
, bytestring >=0.10 && <0.12 , bytestring >=0.10 && <0.12
......
...@@ -361,49 +361,76 @@ where ...@@ -361,49 +361,76 @@ where
-- | -- |
-- Obtain the Accept header value or the default value of @\"*/*\"@. -- Obtain the 'hAccept' header value or the default value of @\"*/*\"@.
--
-- Aborts with 'badRequest400' if the header fails to parse.
-- --
getAccept :: (MonadAction m) => m [Media] getAccept :: (MonadAction m) => m [Media]
getAccept = parseMedia <$> cs . fromMaybe "*/*" getAccept = do
<$> getHeaderMaybe hAccept value <- getHeaderDefault hAccept "*/*"
case parseMedia (cs value) of
Left _reason -> abort badRequest400 [] "Failed to parse Accept."
Right media -> return media
-- | -- |
-- Obtain the Accept-Charset header value or the default value of @\"*\"@. -- Obtain the Accept-Charset header value or the default value of @\"*\"@.
-- --
-- Aborts with 'badRequest400' if the header fails to parse.
--
getAcceptCharset :: (MonadAction m) => m [Media] getAcceptCharset :: (MonadAction m) => m [Media]
getAcceptCharset = parseMedia <$> cs . fromMaybe "*" getAcceptCharset = do
<$> getHeaderMaybe hAcceptCharset value <- getHeaderDefault hAcceptCharset "*"
case parseMedia (cs value) of
Left _reason -> abort badRequest400 [] "Failed to parse Accept-Charset."
Right media -> return media
-- | -- |
-- Obtain the Accept-Encoding header value or the default -- Obtain the Accept-Encoding header value or the default
-- value of @\"identity,*;q=0\"@. -- value of @\"identity,*;q=0\"@.
-- --
-- Aborts with 'badRequest400' if the header fails to parse.
--
getAcceptEncoding :: (MonadAction m) => m [Media] getAcceptEncoding :: (MonadAction m) => m [Media]
getAcceptEncoding = parseMedia <$> cs . fromMaybe "identity,*;q=0" getAcceptEncoding = do
<$> getHeaderMaybe hAcceptEncoding value <- getHeaderDefault hAcceptEncoding "identity,*;q=0"
case parseMedia (cs value) of
Left _reason -> abort badRequest400 [] "Failed to parse Accept-Encoding."
Right media -> return media
-- | -- |
-- Obtain the Accept-Language header value or the default value of @\"*\"@. -- Obtain the Accept-Language header value or the default value of @\"*\"@.
-- --
-- Aborts with 'badRequest400' if the header fails to parse.
--
getAcceptLanguage :: (MonadAction m) => m [Media] getAcceptLanguage :: (MonadAction m) => m [Media]
getAcceptLanguage = parseMedia <$> cs . fromMaybe "*/*" getAcceptLanguage = do
<$> getHeaderMaybe hAcceptLanguage value <- getHeaderDefault hAcceptLanguage "*"
case parseMedia (cs value) of
Left _reason -> abort badRequest400 [] "Failed to parse Accept-Language."
Right media -> return media
-- | -- |
-- Obtain the Content-Type header value or the default value of -- Obtain the Content-Type header value or the default value of
-- @\"application/octet-stream\"@ (always true, but meaningless). -- @\"application/octet-stream\"@ (always true, but meaningless).
-- --
-- Aborts with 'badRequest400' if the header fails to parse.
--
getContentType :: (MonadAction m) => m Media getContentType :: (MonadAction m) => m Media
getContentType = do getContentType = do
media <- fmap parseMedia <$> fmap cs <$> getHeaderMaybe hContentType value <- getHeaderDefault hContentType "application/octet-stream"
case media of case parseMedia (cs value) of
Just (x:_) -> return x Left _reason -> abort badRequest400 [] "Failed to parse Content-Type."
_else -> return "application/octet-stream" Right [] -> abort badRequest400 [] "Empty Content-Type."
Right (m:_) -> return m
-- | -- |
......
...@@ -138,21 +138,24 @@ where ...@@ -138,21 +138,24 @@ where
err :: Score -> Application err :: Score -> Application
err BadRequest = respond status400 err (BadRequest reason) = respond status400 (Just reason)
err NotFound = respond status404 err NotFound = respond status404 Nothing
err MethodNotAllowed = respond status405 err MethodNotAllowed = respond status405 Nothing
err UpgradeRequired = respond status426 err UpgradeRequired = respond status426 Nothing
err NotAcceptable = respond status406 err NotAcceptable = respond status406 Nothing
err LengthRequired = respond status411 err LengthRequired = respond status411 Nothing
err UnsupportedMediaType = respond status415 err UnsupportedMediaType = respond status415 Nothing
err (Suitable _) = error "BUG: errored out with a Suitable" err (Suitable _) = error "BUG: errored out with a Suitable"
respond :: Status -> Application respond :: Status -> Maybe Text -> Application
respond st@Status{..} _ sink = sink $ responseLBS st hdr msg respond st@Status{..} msg _ sink = sink $ responseLBS st hdr msg'
where where
hdr = [(hContentType, "text/plain")] hdr = [(hContentType, "text/plain")]
msg = cs (show statusCode) <> " " <> cs statusMessage
msg' = case msg of
Nothing -> cs (show statusCode) <> " " <> cs statusMessage
Just m -> cs m
handlerMW :: (h -> Application) -> [(Int, Response -> h)] -> Middleware handlerMW :: (h -> Application) -> [(Int, Response -> h)] -> Middleware
......
...@@ -25,13 +25,12 @@ module Hikaru.Media ...@@ -25,13 +25,12 @@ module Hikaru.Media
, selectMedia , selectMedia
) )
where where
import Praha hiding (many) import Praha
import Data.Text (toLower)
import Data.List (filter, lookup, sortOn) import Data.List (filter, lookup, sortOn)
import Text.ParserCombinators.ReadP
import Data.Char (isControl, isSpace) import Data.Char
import Data.Attoparsec.Text
-- | -- |
...@@ -57,13 +56,13 @@ where ...@@ -57,13 +56,13 @@ where
-- --
instance IsString Media where instance IsString Media where
fromString str = case parseMedia (cs str) of fromString str = case parseMedia (cs str) of
m:_ -> m Left reason -> error reason
_else -> error $ "Failed to parse media " <> show str Right [] -> error "no media given"
Right (m:_) -> m
-- | -- |
-- Try to parse a comma-separated media type list. -- Try to parse a comma-separated media type list.
-- Media that fail to parse are simply omitted.
-- --
-- Example: -- Example:
-- --
...@@ -72,24 +71,21 @@ where ...@@ -72,24 +71,21 @@ where
-- , Media { mainType = "text", subType = "plain", quality = 0.7, params = [] } -- , Media { mainType = "text", subType = "plain", quality = 0.7, params = [] }
-- ] -- ]
-- --
parseMedia :: Text -> [Media] parseMedia :: Text -> Either String [Media]
parseMedia text = case readP_to_S pMediaList (cs (toLower text)) of parseMedia = parseOnly (pMediaList <* endOfInput)
(m, ""):_ -> sortOn (negate . quality) m
_else -> []
-- | -- |
-- Parser for the media list coded mostly to the RFC 2045. -- Parser for the media list coded mostly to the RFC 2045.
-- Input is always lowercased and unicode is accepted.
-- --
pMediaList :: ReadP [Media] pMediaList :: Parser [Media]
pMediaList = sepBy pMedia pSeparator <* eof pMediaList = pMedia `sepBy` pSeparator
where where
pMedia :: Parser Media
pMedia = do pMedia = do
mainType <- cs <$> pToken mainType <- pToken
_ <- char '/' subType <- (char '/' *> pToken) <|> string ""
subType <- cs <$> pToken params <- many' pParameter
params <- many pParameter
let quality = fromMaybe 1.0 do let quality = fromMaybe 1.0 do
q <- lookup "q" params q <- lookup "q" params
...@@ -97,24 +93,42 @@ where ...@@ -97,24 +93,42 @@ where
return Media{..} return Media{..}
pParameter :: Parser (Text, Text)
pParameter = do pParameter = do
_ <- pSpaced $ char ';' _ <- pSpaced $ char ';'
name <- cs <$> pToken name <- pToken
_ <- pSpaced $ char '=' _ <- pSpaced $ char '='
value <- cs <$> pValue value <- pValue
return (name, value) return (name, value)
pToken :: Parser Text
pToken = do
pSpaced $ takeTill isSpecial
pSeparator :: Parser Char
pSeparator = pSpaced $ char ',' pSeparator = pSpaced $ char ','
pToken = pSpaced $ many1 (satisfy (not . quote))
pValue = pToken <++ pQuotedStr
pQuotedStr = pSpaced $ pQuoted $ many (pExcept '\\')
pExcept c = satisfy (c /=) pValue :: Parser Text
pSpaced p = skipSpaces *> p <* skipSpaces pValue = pToken <|> pQuotedStr
pQuotedStr :: Parser Text
pQuotedStr = pSpaced $ pQuoted $ takeTill (== '\\')
pSpaced :: Parser a -> Parser a
pSpaced p = skipSpace *> p <* skipSpace
pQuoted :: Parser a -> Parser a
pQuoted p = char '"' *> p <* char '"' pQuoted p = char '"' *> p <* char '"'
quote c = isControl c || isSpace c || c `elem` specials isSpecial :: (Char -> Bool)
specials = "()<>@,;:\\\"/[]?=" :: [Char] isSpecial c = isControl c || isSpace c
|| c == '(' || c == ')'
|| c == '<' || c == '>'
|| c == '@' || c == ',' || c == ';'
|| c == ':' || c == '\\'
|| c == '"' || c == '/'
|| c == '[' || c == ']'
|| c == '?' || c == '='
-- | -- |
......
...@@ -125,7 +125,7 @@ where ...@@ -125,7 +125,7 @@ where
-- route across multiple appraisals. -- route across multiple appraisals.
-- --
data Score data Score
= BadRequest = BadRequest Text
| NotFound | NotFound
| MethodNotAllowed | MethodNotAllowed
| UpgradeRequired | UpgradeRequired
...@@ -351,9 +351,9 @@ where ...@@ -351,9 +351,9 @@ where
acceptContent media = Appraisal {vary = [hContentType], score} acceptContent media = Appraisal {vary = [hContentType], score}
where where
score req = do score req = do
let header = parseMedia (cs $ getContentType req) case parseMedia (cs $ getContentType req) of
Left _reason -> BadRequest "Failed to parse Content-Type."
case selectMedia media header of Right header -> case selectMedia media header of
Just Media{..} -> Suitable quality Just Media{..} -> Suitable quality
Nothing -> UnsupportedMediaType Nothing -> UnsupportedMediaType
...@@ -398,9 +398,9 @@ where ...@@ -398,9 +398,9 @@ where
offerContent media = Appraisal {vary = [hAccept], score} offerContent media = Appraisal {vary = [hAccept], score}
where where
score req = do score req = do
let header = parseMedia (cs $ getAccept req) case parseMedia (cs $ getAccept req) of
Left _reason -> BadRequest "Failed to parse Accept."
case selectMedia media header of Right header -> case selectMedia media header of
Just Media{..} -> Suitable quality Just Media{..} -> Suitable quality
Nothing -> NotAcceptable Nothing -> NotAcceptable
...@@ -448,9 +448,9 @@ where ...@@ -448,9 +448,9 @@ where
offerEncoding media = Appraisal {vary = [hAcceptEncoding], score} offerEncoding media = Appraisal {vary = [hAcceptEncoding], score}
where where
score req = do score req = do
let header = parseMedia (cs $ getAcceptEncoding req) case parseMedia (cs $ getAcceptEncoding req) of
Left _reason -> BadRequest "Failed to parse Accept-Encoding."
case selectMedia media header of Right header -> case selectMedia media header of
Just Media{..} -> Suitable quality Just Media{..} -> Suitable quality
Nothing -> NotAcceptable Nothing -> NotAcceptable
...@@ -465,9 +465,9 @@ where ...@@ -465,9 +465,9 @@ where
offerLanguage media = Appraisal {vary = [hAcceptLanguage], score} offerLanguage media = Appraisal {vary = [hAcceptLanguage], score}
where where
score req = do score req = do
let header = parseMedia (cs $ getAcceptLanguage req) case parseMedia (cs $ getAcceptLanguage req) of
Left _reason -> BadRequest "Failed to parse Accept-Language."
case selectMedia media header of Right header -> case selectMedia media header of
Just Media{..} -> Suitable quality Just Media{..} -> Suitable quality
Nothing -> NotAcceptable Nothing -> NotAcceptable
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment