-- #hide

-----------------------------------------------------------------------------
-- |
-- Module      :  Network.CGI.Header
-- Copyright   :  (c) Peter Thiemann 2001,2002
--                (c) Bjorn Bringert 2005-2006
-- License     :  BSD-style
--
-- Maintainer  :  Anders Kaseorg <andersk@mit.edu>
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Parsing of HTTP headers (name, value pairs)
-- Partly based on code from WASHMail.
--
-----------------------------------------------------------------------------
module Network.Multipart.Header (
                              -- * Headers
                              Headers,
                              HeaderName(..),
                              HeaderValue(..),
                              pHeaders,

                              -- * Content-type
                              ContentType(..),
                              getContentType,
                              parseContentType,
                              showContentType,

                              -- * Content-transfer-encoding
                              ContentTransferEncoding(..),
                              getContentTransferEncoding,

                              -- * Content-disposition
                              ContentDisposition(..),
                              getContentDisposition,

                              -- * Utilities
                              parseM,
                              caseInsensitiveEq,
                              caseInsensitiveCompare,
                              lexeme, ws1, p_token
                          ) where

import Control.Monad
import Control.Monad.Fail as MFail
import Data.Char
import Data.List
import qualified Data.Monoid as M

import Text.ParserCombinators.Parsec

--
-- * Headers
--

-- | HTTP headers.
type Headers = [(HeaderName, String)]

-- | A string with case insensitive equality and comparisons.
newtype HeaderName = HeaderName String deriving (Int -> HeaderName -> ShowS
[HeaderName] -> ShowS
HeaderName -> String
(Int -> HeaderName -> ShowS)
-> (HeaderName -> String)
-> ([HeaderName] -> ShowS)
-> Show HeaderName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HeaderName] -> ShowS
$cshowList :: [HeaderName] -> ShowS
show :: HeaderName -> String
$cshow :: HeaderName -> String
showsPrec :: Int -> HeaderName -> ShowS
$cshowsPrec :: Int -> HeaderName -> ShowS
Show)

instance Eq HeaderName where
    HeaderName String
x == :: HeaderName -> HeaderName -> Bool
== HeaderName String
y = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
y

instance Ord HeaderName where
    HeaderName String
x compare :: HeaderName -> HeaderName -> Ordering
`compare` HeaderName String
y = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
x String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
y


class HeaderValue a where
    parseHeaderValue :: Parser a
    prettyHeaderValue :: a -> String

pHeaders :: Parser Headers
pHeaders :: Parser Headers
pHeaders = ParsecT String () Identity (HeaderName, String) -> Parser Headers
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT String () Identity (HeaderName, String)
pHeader

pHeader :: Parser (HeaderName, String)
pHeader :: ParsecT String () Identity (HeaderName, String)
pHeader =
    do String
name <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String () Identity Char
headerNameChar
       Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
':'
       String
_ <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT String () Identity Char
ws1
       String
line <- ParsecT String () Identity String
lineString
       String
_ <- ParsecT String () Identity String
crLf
       [String]
extraLines <- ParsecT String () Identity String
-> ParsecT String () Identity [String]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT String () Identity String
extraFieldLine
       (HeaderName, String)
-> ParsecT String () Identity (HeaderName, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> HeaderName
HeaderName String
name, [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String
lineString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
extraLines))

extraFieldLine :: Parser String
extraFieldLine :: ParsecT String () Identity String
extraFieldLine =
    do Char
sp <- ParsecT String () Identity Char
ws1
       String
line <- ParsecT String () Identity String
lineString
       String
_ <- ParsecT String () Identity String
crLf
       String -> ParsecT String () Identity String
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
spChar -> ShowS
forall a. a -> [a] -> [a]
:String
line)

getHeaderValue :: (MonadFail m, HeaderValue a) => String -> Headers -> m a
getHeaderValue :: forall (m :: * -> *) a.
(MonadFail m, HeaderValue a) =>
String -> Headers -> m a
getHeaderValue String
h Headers
hs = HeaderName -> Headers -> m String
forall (m :: * -> *) a b.
(MonadFail m, Eq a, Show a) =>
a -> [(a, b)] -> m b
lookupM (String -> HeaderName
HeaderName String
h) Headers
hs m String -> (String -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Parser a -> String -> String -> m a
forall (m :: * -> *) a.
MonadFail m =>
Parser a -> String -> String -> m a
parseM Parser a
forall a. HeaderValue a => Parser a
parseHeaderValue String
h

--
-- * Parameters (for Content-type etc.)
--

showParameters :: [(String,String)] -> String
showParameters :: [(String, String)] -> String
showParameters = ((String, String) -> String) -> [(String, String)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String, String) -> String
forall {t :: * -> *}. Foldable t => (String, t Char) -> String
f
    where f :: (String, t Char) -> String
f (String
n,t Char
v) = String
"; " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"=\"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Char -> String) -> t Char -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
esc t Char
v String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\""
          esc :: Char -> String
esc Char
'\\' = String
"\\\\"
          esc Char
'"'  = String
"\\\""
          esc Char
c | Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'\\',Char
'"'] = Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:[Char
c]
                | Bool
otherwise = [Char
c]

p_parameter :: Parser (String,String)
p_parameter :: Parser (String, String)
p_parameter = Parser (String, String) -> Parser (String, String)
forall tok st a. GenParser tok st a -> GenParser tok st a
try (Parser (String, String) -> Parser (String, String))
-> Parser (String, String) -> Parser (String, String)
forall a b. (a -> b) -> a -> b
$
  do Char
_ <- ParsecT String () Identity Char -> ParsecT String () Identity Char
forall a. Parser a -> Parser a
lexeme (ParsecT String () Identity Char
 -> ParsecT String () Identity Char)
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
';'
     String
p_name <- ParsecT String () Identity String
-> ParsecT String () Identity String
forall a. Parser a -> Parser a
lexeme (ParsecT String () Identity String
 -> ParsecT String () Identity String)
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall a b. (a -> b) -> a -> b
$ ParsecT String () Identity String
p_token
     -- Don't allow parameters named q. This is needed for parsing Accept-X
     -- headers. From RFC 2616 14.1:
     --    Note: Use of the "q" parameter name to separate media type
     --    parameters from Accept extension parameters is due to historical
     --    practice. Although this prevents any media type parameter named
     --    "q" from being used with a media range, such an event is believed
     --    to be unlikely given the lack of any "q" parameters in the IANA
     --    media type registry and the rare usage of any media type
     --    parameters in Accept. Future media types are discouraged from
     --    registering any parameter named "q".
     Bool
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
p_name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"q") ParsecT String () Identity ()
forall tok st a. GenParser tok st a
pzero
     Char
_ <- ParsecT String () Identity Char -> ParsecT String () Identity Char
forall a. Parser a -> Parser a
lexeme (ParsecT String () Identity Char
 -> ParsecT String () Identity Char)
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'='
     -- Workaround for seemingly standardized web browser bug
     -- where nothing is escaped in the filename parameter
     -- of the content-disposition header in multipart/form-data
     let litStr :: ParsecT String () Identity String
litStr = if String
p_name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"filename"
                   then ParsecT String () Identity String
buggyLiteralString
                   else ParsecT String () Identity String
literalString
     String
p_value <- ParsecT String () Identity String
litStr ParsecT String () Identity String
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String () Identity String
p_token
     (String, String) -> Parser (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
p_name, String
p_value)

--
-- * Content type
--

-- | A MIME media type value.
--   The 'Show' instance is derived automatically.
--   Use 'showContentType' to obtain the standard
--   string representation.
--   See <http://www.ietf.org/rfc/rfc2046.txt> for more
--   information about MIME media types.
data ContentType =
    ContentType {
                     -- | The top-level media type, the general type
                     --   of the data. Common examples are
                     --   \"text\", \"image\", \"audio\", \"video\",
                     --   \"multipart\", and \"application\".
                     ContentType -> String
ctType :: String,
                     -- | The media subtype, the specific data format.
                     --   Examples include \"plain\", \"html\",
                     --   \"jpeg\", \"form-data\", etc.
                     ContentType -> String
ctSubtype :: String,
                     -- | Media type parameters. On common example is
                     --   the charset parameter for the \"text\"
                     --   top-level type, e.g. @(\"charset\",\"ISO-8859-1\")@.
                     ContentType -> [(String, String)]
ctParameters :: [(String, String)]
                    }
    deriving (Int -> ContentType -> ShowS
[ContentType] -> ShowS
ContentType -> String
(Int -> ContentType -> ShowS)
-> (ContentType -> String)
-> ([ContentType] -> ShowS)
-> Show ContentType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ContentType] -> ShowS
$cshowList :: [ContentType] -> ShowS
show :: ContentType -> String
$cshow :: ContentType -> String
showsPrec :: Int -> ContentType -> ShowS
$cshowsPrec :: Int -> ContentType -> ShowS
Show, ReadPrec [ContentType]
ReadPrec ContentType
Int -> ReadS ContentType
ReadS [ContentType]
(Int -> ReadS ContentType)
-> ReadS [ContentType]
-> ReadPrec ContentType
-> ReadPrec [ContentType]
-> Read ContentType
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ContentType]
$creadListPrec :: ReadPrec [ContentType]
readPrec :: ReadPrec ContentType
$creadPrec :: ReadPrec ContentType
readList :: ReadS [ContentType]
$creadList :: ReadS [ContentType]
readsPrec :: Int -> ReadS ContentType
$creadsPrec :: Int -> ReadS ContentType
Read)

instance Eq ContentType where
    ContentType
x == :: ContentType -> ContentType -> Bool
== ContentType
y = ContentType -> String
ctType ContentType
x String -> String -> Bool
`caseInsensitiveEq` ContentType -> String
ctType ContentType
y
             Bool -> Bool -> Bool
&& ContentType -> String
ctSubtype ContentType
x String -> String -> Bool
`caseInsensitiveEq` ContentType -> String
ctSubtype ContentType
y
             Bool -> Bool -> Bool
&& ContentType -> [(String, String)]
ctParameters ContentType
x [(String, String)] -> [(String, String)] -> Bool
forall a. Eq a => a -> a -> Bool
== ContentType -> [(String, String)]
ctParameters ContentType
y

instance Ord ContentType where
    ContentType
x compare :: ContentType -> ContentType -> Ordering
`compare` ContentType
y = [Ordering] -> Ordering
forall a. Monoid a => [a] -> a
M.mconcat [ContentType -> String
ctType ContentType
x String -> String -> Ordering
`caseInsensitiveCompare` ContentType -> String
ctType ContentType
y,
                               ContentType -> String
ctSubtype ContentType
x String -> String -> Ordering
`caseInsensitiveCompare` ContentType -> String
ctSubtype ContentType
y,
                               ContentType -> [(String, String)]
ctParameters ContentType
x [(String, String)] -> [(String, String)] -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` ContentType -> [(String, String)]
ctParameters ContentType
y]

instance HeaderValue ContentType where
    parseHeaderValue :: Parser ContentType
parseHeaderValue =
        do String
_ <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT String () Identity Char
ws1
           String
c_type <- ParsecT String () Identity String
p_token
           Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'/'
           String
c_subtype <- ParsecT String () Identity String
-> ParsecT String () Identity String
forall a. Parser a -> Parser a
lexeme (ParsecT String () Identity String
 -> ParsecT String () Identity String)
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall a b. (a -> b) -> a -> b
$ ParsecT String () Identity String
p_token
           [(String, String)]
c_parameters <- Parser (String, String)
-> ParsecT String () Identity [(String, String)]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many Parser (String, String)
p_parameter
           ContentType -> Parser ContentType
forall (m :: * -> *) a. Monad m => a -> m a
return (ContentType -> Parser ContentType)
-> ContentType -> Parser ContentType
forall a b. (a -> b) -> a -> b
$ String -> String -> [(String, String)] -> ContentType
ContentType ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
c_type) ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
c_subtype) [(String, String)]
c_parameters
    prettyHeaderValue :: ContentType -> String
prettyHeaderValue (ContentType String
x String
y [(String, String)]
ps) = String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
y String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(String, String)] -> String
showParameters [(String, String)]
ps


-- | Parse the standard representation of a content-type.
--   If the input cannot be parsed, this function calls
--   'fail' with a (hopefully) informative error message.
parseContentType :: MonadFail m => String -> m ContentType
parseContentType :: forall (m :: * -> *). MonadFail m => String -> m ContentType
parseContentType = Parser ContentType -> String -> String -> m ContentType
forall (m :: * -> *) a.
MonadFail m =>
Parser a -> String -> String -> m a
parseM Parser ContentType
forall a. HeaderValue a => Parser a
parseHeaderValue String
"Content-type"

showContentType :: ContentType -> String
showContentType :: ContentType -> String
showContentType = ContentType -> String
forall a. HeaderValue a => a -> String
prettyHeaderValue

getContentType :: MonadFail m => Headers -> m ContentType
getContentType :: forall (m :: * -> *). MonadFail m => Headers -> m ContentType
getContentType = String -> Headers -> m ContentType
forall (m :: * -> *) a.
(MonadFail m, HeaderValue a) =>
String -> Headers -> m a
getHeaderValue String
"content-type"

--
-- * Content transfer encoding
--

data ContentTransferEncoding =
    ContentTransferEncoding String
    deriving (Int -> ContentTransferEncoding -> ShowS
[ContentTransferEncoding] -> ShowS
ContentTransferEncoding -> String
(Int -> ContentTransferEncoding -> ShowS)
-> (ContentTransferEncoding -> String)
-> ([ContentTransferEncoding] -> ShowS)
-> Show ContentTransferEncoding
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ContentTransferEncoding] -> ShowS
$cshowList :: [ContentTransferEncoding] -> ShowS
show :: ContentTransferEncoding -> String
$cshow :: ContentTransferEncoding -> String
showsPrec :: Int -> ContentTransferEncoding -> ShowS
$cshowsPrec :: Int -> ContentTransferEncoding -> ShowS
Show, ReadPrec [ContentTransferEncoding]
ReadPrec ContentTransferEncoding
Int -> ReadS ContentTransferEncoding
ReadS [ContentTransferEncoding]
(Int -> ReadS ContentTransferEncoding)
-> ReadS [ContentTransferEncoding]
-> ReadPrec ContentTransferEncoding
-> ReadPrec [ContentTransferEncoding]
-> Read ContentTransferEncoding
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ContentTransferEncoding]
$creadListPrec :: ReadPrec [ContentTransferEncoding]
readPrec :: ReadPrec ContentTransferEncoding
$creadPrec :: ReadPrec ContentTransferEncoding
readList :: ReadS [ContentTransferEncoding]
$creadList :: ReadS [ContentTransferEncoding]
readsPrec :: Int -> ReadS ContentTransferEncoding
$creadsPrec :: Int -> ReadS ContentTransferEncoding
Read, ContentTransferEncoding -> ContentTransferEncoding -> Bool
(ContentTransferEncoding -> ContentTransferEncoding -> Bool)
-> (ContentTransferEncoding -> ContentTransferEncoding -> Bool)
-> Eq ContentTransferEncoding
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ContentTransferEncoding -> ContentTransferEncoding -> Bool
$c/= :: ContentTransferEncoding -> ContentTransferEncoding -> Bool
== :: ContentTransferEncoding -> ContentTransferEncoding -> Bool
$c== :: ContentTransferEncoding -> ContentTransferEncoding -> Bool
Eq, Eq ContentTransferEncoding
Eq ContentTransferEncoding
-> (ContentTransferEncoding -> ContentTransferEncoding -> Ordering)
-> (ContentTransferEncoding -> ContentTransferEncoding -> Bool)
-> (ContentTransferEncoding -> ContentTransferEncoding -> Bool)
-> (ContentTransferEncoding -> ContentTransferEncoding -> Bool)
-> (ContentTransferEncoding -> ContentTransferEncoding -> Bool)
-> (ContentTransferEncoding
    -> ContentTransferEncoding -> ContentTransferEncoding)
-> (ContentTransferEncoding
    -> ContentTransferEncoding -> ContentTransferEncoding)
-> Ord ContentTransferEncoding
ContentTransferEncoding -> ContentTransferEncoding -> Bool
ContentTransferEncoding -> ContentTransferEncoding -> Ordering
ContentTransferEncoding
-> ContentTransferEncoding -> ContentTransferEncoding
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ContentTransferEncoding
-> ContentTransferEncoding -> ContentTransferEncoding
$cmin :: ContentTransferEncoding
-> ContentTransferEncoding -> ContentTransferEncoding
max :: ContentTransferEncoding
-> ContentTransferEncoding -> ContentTransferEncoding
$cmax :: ContentTransferEncoding
-> ContentTransferEncoding -> ContentTransferEncoding
>= :: ContentTransferEncoding -> ContentTransferEncoding -> Bool
$c>= :: ContentTransferEncoding -> ContentTransferEncoding -> Bool
> :: ContentTransferEncoding -> ContentTransferEncoding -> Bool
$c> :: ContentTransferEncoding -> ContentTransferEncoding -> Bool
<= :: ContentTransferEncoding -> ContentTransferEncoding -> Bool
$c<= :: ContentTransferEncoding -> ContentTransferEncoding -> Bool
< :: ContentTransferEncoding -> ContentTransferEncoding -> Bool
$c< :: ContentTransferEncoding -> ContentTransferEncoding -> Bool
compare :: ContentTransferEncoding -> ContentTransferEncoding -> Ordering
$ccompare :: ContentTransferEncoding -> ContentTransferEncoding -> Ordering
Ord)

instance HeaderValue ContentTransferEncoding where
    parseHeaderValue :: Parser ContentTransferEncoding
parseHeaderValue =
        do String
_ <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT String () Identity Char
ws1
           String
c_cte <- ParsecT String () Identity String
p_token
           ContentTransferEncoding -> Parser ContentTransferEncoding
forall (m :: * -> *) a. Monad m => a -> m a
return (ContentTransferEncoding -> Parser ContentTransferEncoding)
-> ContentTransferEncoding -> Parser ContentTransferEncoding
forall a b. (a -> b) -> a -> b
$ String -> ContentTransferEncoding
ContentTransferEncoding ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
c_cte)
    prettyHeaderValue :: ContentTransferEncoding -> String
prettyHeaderValue (ContentTransferEncoding String
s) = String
s

getContentTransferEncoding :: MonadFail m => Headers -> m ContentTransferEncoding
getContentTransferEncoding :: forall (m :: * -> *).
MonadFail m =>
Headers -> m ContentTransferEncoding
getContentTransferEncoding = String -> Headers -> m ContentTransferEncoding
forall (m :: * -> *) a.
(MonadFail m, HeaderValue a) =>
String -> Headers -> m a
getHeaderValue String
"content-transfer-encoding"

--
-- * Content disposition
--

data ContentDisposition =
    ContentDisposition String [(String, String)]
    deriving (Int -> ContentDisposition -> ShowS
[ContentDisposition] -> ShowS
ContentDisposition -> String
(Int -> ContentDisposition -> ShowS)
-> (ContentDisposition -> String)
-> ([ContentDisposition] -> ShowS)
-> Show ContentDisposition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ContentDisposition] -> ShowS
$cshowList :: [ContentDisposition] -> ShowS
show :: ContentDisposition -> String
$cshow :: ContentDisposition -> String
showsPrec :: Int -> ContentDisposition -> ShowS
$cshowsPrec :: Int -> ContentDisposition -> ShowS
Show, ReadPrec [ContentDisposition]
ReadPrec ContentDisposition
Int -> ReadS ContentDisposition
ReadS [ContentDisposition]
(Int -> ReadS ContentDisposition)
-> ReadS [ContentDisposition]
-> ReadPrec ContentDisposition
-> ReadPrec [ContentDisposition]
-> Read ContentDisposition
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ContentDisposition]
$creadListPrec :: ReadPrec [ContentDisposition]
readPrec :: ReadPrec ContentDisposition
$creadPrec :: ReadPrec ContentDisposition
readList :: ReadS [ContentDisposition]
$creadList :: ReadS [ContentDisposition]
readsPrec :: Int -> ReadS ContentDisposition
$creadsPrec :: Int -> ReadS ContentDisposition
Read, ContentDisposition -> ContentDisposition -> Bool
(ContentDisposition -> ContentDisposition -> Bool)
-> (ContentDisposition -> ContentDisposition -> Bool)
-> Eq ContentDisposition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ContentDisposition -> ContentDisposition -> Bool
$c/= :: ContentDisposition -> ContentDisposition -> Bool
== :: ContentDisposition -> ContentDisposition -> Bool
$c== :: ContentDisposition -> ContentDisposition -> Bool
Eq, Eq ContentDisposition
Eq ContentDisposition
-> (ContentDisposition -> ContentDisposition -> Ordering)
-> (ContentDisposition -> ContentDisposition -> Bool)
-> (ContentDisposition -> ContentDisposition -> Bool)
-> (ContentDisposition -> ContentDisposition -> Bool)
-> (ContentDisposition -> ContentDisposition -> Bool)
-> (ContentDisposition -> ContentDisposition -> ContentDisposition)
-> (ContentDisposition -> ContentDisposition -> ContentDisposition)
-> Ord ContentDisposition
ContentDisposition -> ContentDisposition -> Bool
ContentDisposition -> ContentDisposition -> Ordering
ContentDisposition -> ContentDisposition -> ContentDisposition
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ContentDisposition -> ContentDisposition -> ContentDisposition
$cmin :: ContentDisposition -> ContentDisposition -> ContentDisposition
max :: ContentDisposition -> ContentDisposition -> ContentDisposition
$cmax :: ContentDisposition -> ContentDisposition -> ContentDisposition
>= :: ContentDisposition -> ContentDisposition -> Bool
$c>= :: ContentDisposition -> ContentDisposition -> Bool
> :: ContentDisposition -> ContentDisposition -> Bool
$c> :: ContentDisposition -> ContentDisposition -> Bool
<= :: ContentDisposition -> ContentDisposition -> Bool
$c<= :: ContentDisposition -> ContentDisposition -> Bool
< :: ContentDisposition -> ContentDisposition -> Bool
$c< :: ContentDisposition -> ContentDisposition -> Bool
compare :: ContentDisposition -> ContentDisposition -> Ordering
$ccompare :: ContentDisposition -> ContentDisposition -> Ordering
Ord)

instance HeaderValue ContentDisposition where
    parseHeaderValue :: Parser ContentDisposition
parseHeaderValue =
        do String
_ <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT String () Identity Char
ws1
           String
c_cd <- ParsecT String () Identity String
p_token
           [(String, String)]
c_parameters <- Parser (String, String)
-> ParsecT String () Identity [(String, String)]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many Parser (String, String)
p_parameter
           ContentDisposition -> Parser ContentDisposition
forall (m :: * -> *) a. Monad m => a -> m a
return (ContentDisposition -> Parser ContentDisposition)
-> ContentDisposition -> Parser ContentDisposition
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> ContentDisposition
ContentDisposition ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
c_cd) [(String, String)]
c_parameters
    prettyHeaderValue :: ContentDisposition -> String
prettyHeaderValue (ContentDisposition String
t [(String, String)]
hs) =
        String
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"; " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
quote String
v | (String
n,String
v) <- [(String, String)]
hs]
            where quote :: ShowS
quote String
x = String
"\"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\"" -- NOTE: silly, but de-facto standard

getContentDisposition :: MonadFail m => Headers -> m ContentDisposition
getContentDisposition :: forall (m :: * -> *).
MonadFail m =>
Headers -> m ContentDisposition
getContentDisposition = String -> Headers -> m ContentDisposition
forall (m :: * -> *) a.
(MonadFail m, HeaderValue a) =>
String -> Headers -> m a
getHeaderValue String
"content-disposition"

--
-- * Utilities
--

parseM :: MonadFail m => Parser a -> SourceName -> String -> m a
parseM :: forall (m :: * -> *) a.
MonadFail m =>
Parser a -> String -> String -> m a
parseM Parser a
p String
n String
inp =
  case Parser a -> String -> String -> Either ParseError a
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parser a
p String
n String
inp of
    Left ParseError
e -> String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
MFail.fail (ParseError -> String
forall a. Show a => a -> String
show ParseError
e)
    Right a
x -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

lookupM :: (MonadFail m, Eq a, Show a) => a -> [(a,b)] -> m b
lookupM :: forall (m :: * -> *) a b.
(MonadFail m, Eq a, Show a) =>
a -> [(a, b)] -> m b
lookupM a
n = m b -> (b -> m b) -> Maybe b -> m b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m b
forall (m :: * -> *) a. MonadFail m => String -> m a
MFail.fail (String
"No such field: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n)) b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe b -> m b) -> ([(a, b)] -> Maybe b) -> [(a, b)] -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [(a, b)] -> Maybe b
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
n

caseInsensitiveEq :: String -> String -> Bool
caseInsensitiveEq :: String -> String -> Bool
caseInsensitiveEq String
x String
y = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
y

caseInsensitiveCompare :: String -> String -> Ordering
caseInsensitiveCompare :: String -> String -> Ordering
caseInsensitiveCompare String
x String
y = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
x String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
y

--
-- * Parsing utilities
--

-- | RFC 822 LWSP-char
ws1 :: Parser Char
ws1 :: ParsecT String () Identity Char
ws1 = String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
" \t"

lexeme :: Parser a -> Parser a
lexeme :: forall a. Parser a -> Parser a
lexeme Parser a
p = do a
x <- Parser a
p; String
_ <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT String () Identity Char
ws1; a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

-- | RFC 822 CRLF (but more permissive)
crLf :: Parser String
crLf :: ParsecT String () Identity String
crLf = ParsecT String () Identity String
-> ParsecT String () Identity String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"\n\r" ParsecT String () Identity String
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"\r\n") ParsecT String () Identity String
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"\n" ParsecT String () Identity String
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"\r"

-- | One line
lineString :: Parser String
lineString :: ParsecT String () Identity String
lineString = ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"\n\r")

literalString :: Parser String
literalString :: ParsecT String () Identity String
literalString = do Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\"'
                   String
str <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"\"\\" ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String () Identity Char
quoted_pair)
                   Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\"'
                   String -> ParsecT String () Identity String
forall (m :: * -> *) a. Monad m => a -> m a
return String
str

-- No web browsers seem to implement RFC 2046 correctly,
-- since they do not escape double quotes and backslashes
-- in the filename parameter in multipart/form-data.
--
-- Note that this eats everything until the last double quote on the line.
buggyLiteralString :: Parser String
buggyLiteralString :: ParsecT String () Identity String
buggyLiteralString =
    do Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\"'
       String
str <- ParsecT String () Identity Char
-> ParsecT String () Identity ()
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (ParsecT String () Identity () -> ParsecT String () Identity ()
forall tok st a. GenParser tok st a -> GenParser tok st a
try ParsecT String () Identity ()
forall {u}. ParsecT String u Identity ()
lastQuote)
       String -> ParsecT String () Identity String
forall (m :: * -> *) a. Monad m => a -> m a
return String
str
  where lastQuote :: ParsecT String u Identity ()
lastQuote = do Char
_ <- Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\"'
                       ParsecT String u Identity Char -> ParsecT String u Identity ()
forall s (m :: * -> *) t a u.
(Stream s m t, Show a) =>
ParsecT s u m a -> ParsecT s u m ()
notFollowedBy (ParsecT String u Identity Char -> ParsecT String u Identity Char
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT String u Identity Char -> ParsecT String u Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (String -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"\"") ParsecT String u Identity String
-> ParsecT String u Identity Char -> ParsecT String u Identity Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\"'))

headerNameChar :: Parser Char
headerNameChar :: ParsecT String () Identity Char
headerNameChar = String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"\n\r:"

tspecials, tokenchar :: [Char]
tspecials :: String
tspecials = String
"()<>@,;:\\\"/[]?="
tokenchar :: String
tokenchar = String
"!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" String -> ShowS
forall a. Eq a => [a] -> [a] -> [a]
\\ String
tspecials

p_token :: Parser String
p_token :: ParsecT String () Identity String
p_token = ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
tokenchar)

text_chars :: [Char]
text_chars :: String
text_chars = (Int -> Char) -> [Int] -> String
forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
chr ([Int
1..Int
9] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
11,Int
12] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
14..Int
127])

p_text :: Parser Char
p_text :: ParsecT String () Identity Char
p_text = String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
text_chars

quoted_pair :: Parser Char
quoted_pair :: ParsecT String () Identity Char
quoted_pair = do Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\\'
                 ParsecT String () Identity Char
p_text