-- #hide

-----------------------------------------------------------------------------
-- |
-- Module      :  Network.CGI.RFC822Headers
-- Copyright   :  (c) Peter Thiemann 2001,2002
--                (c) Bjorn Bringert 2005-2006
--                (c) Lemmih 2007
-- License     :  BSD-style
--
-- Maintainer  :  lemmih@vo.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Parsing of RFC822-style headers (name, value pairs)
-- Partly based on code from WASHMail.
--
-----------------------------------------------------------------------------
module Happstack.Server.Internal.RFC822Headers
    ( -- * Headers
      Header,
      pHeader,
      pHeaders,
      parseHeaders,

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

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

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

      -- * Utilities
      parseM
      ) where

import Control.Monad
import Control.Monad.Fail (MonadFail)
import Data.Char
import Data.List
import Text.ParserCombinators.Parsec

type Header = (String, String)

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

parseHeaders :: MonadFail m => SourceName -> String -> m [Header]
parseHeaders :: String -> String -> m [Header]
parseHeaders = Parser [Header] -> String -> String -> m [Header]
forall (m :: * -> *) a.
MonadFail m =>
Parser a -> String -> String -> m a
parseM Parser [Header]
pHeaders

pHeader :: Parser Header
pHeader :: ParsecT String () Identity Header
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
       ParsecT String () Identity Char -> ParsecT String () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT String () Identity Char -> ParsecT String () Identity ())
-> ParsecT String () Identity Char -> ParsecT String () Identity ()
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
':'
       ParsecT String () Identity String -> ParsecT String () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT String () Identity String
 -> ParsecT String () Identity ())
-> ParsecT String () Identity String
-> ParsecT String () Identity ()
forall a b. (a -> b) -> a -> b
$ 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
       ParsecT String () Identity String -> ParsecT String () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void 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
       Header -> ParsecT String () Identity Header
forall (m :: * -> *) a. Monad m => a -> m a
return ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower 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
       ParsecT String () Identity String -> ParsecT String () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT String () Identity String
 -> ParsecT String () Identity ())
-> ParsecT String () Identity String
-> ParsecT String () Identity ()
forall a b. (a -> b) -> a -> b
$ ParsecT String () Identity String
crLf
       String -> ParsecT String () Identity String
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
spChar -> String -> String
forall a. a -> [a] -> [a]
:String
line)

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

showParameters :: [(String,String)] -> String
showParameters :: [Header] -> String
showParameters = (Header -> String) -> [Header] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Header -> String
forall (t :: * -> *). Foldable t => (String, t Char) -> String
f
    where f :: (String, t Char) -> String
f (String
n,t Char
v) = String
"; " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"=\"" String -> String -> String
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 -> String -> String
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 -> String -> String
forall a. a -> [a] -> [a]
:[Char
c]
                | Bool
otherwise = [Char
c]

p_parameter :: Parser (String,String)
p_parameter :: ParsecT String () Identity Header
p_parameter =
  do ParsecT String () Identity Char -> ParsecT String () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT String () Identity Char -> ParsecT String () Identity ())
-> ParsecT String () Identity Char -> ParsecT String () Identity ()
forall a b. (a -> b) -> a -> b
$ 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
     ParsecT String () Identity Char -> ParsecT String () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT String () Identity Char -> ParsecT String () Identity ())
-> ParsecT String () Identity Char -> ParsecT String () Identity ()
forall a b. (a -> b) -> a -> b
$ 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]
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice [ ParsecT String () Identity String
-> ParsecT String () Identity String
forall tok st a. GenParser tok st a -> GenParser tok st a
try ((ParsecT String () Identity () -> ParsecT String () Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead (ParsecT String () Identity () -> ParsecT String () Identity ())
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall a b. (a -> b) -> a -> b
$ do
                                        ParsecT String () Identity Header -> ParsecT String () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT String () Identity String
literalString ParsecT String () Identity String
-> ParsecT String () Identity Header
-> ParsecT String () Identity Header
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                                              ParsecT String () Identity Header
p_parameter))
                                     ParsecT String () Identity ()
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String () Identity String
literalString)
                               , 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
     Header -> ParsecT String () Identity Header
forall (m :: * -> *) a. Monad m => a -> m a
return ((Char -> Char) -> String -> String
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 -> [Header]
ctParameters :: [(String, String)]
                    }
    deriving (Int -> ContentType -> String -> String
[ContentType] -> String -> String
ContentType -> String
(Int -> ContentType -> String -> String)
-> (ContentType -> String)
-> ([ContentType] -> String -> String)
-> Show ContentType
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ContentType] -> String -> String
$cshowList :: [ContentType] -> String -> String
show :: ContentType -> String
$cshow :: ContentType -> String
showsPrec :: Int -> ContentType -> String -> String
$cshowsPrec :: Int -> ContentType -> String -> String
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, ContentType -> ContentType -> Bool
(ContentType -> ContentType -> Bool)
-> (ContentType -> ContentType -> Bool) -> Eq ContentType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ContentType -> ContentType -> Bool
$c/= :: ContentType -> ContentType -> Bool
== :: ContentType -> ContentType -> Bool
$c== :: ContentType -> ContentType -> Bool
Eq, Eq ContentType
Eq ContentType
-> (ContentType -> ContentType -> Ordering)
-> (ContentType -> ContentType -> Bool)
-> (ContentType -> ContentType -> Bool)
-> (ContentType -> ContentType -> Bool)
-> (ContentType -> ContentType -> Bool)
-> (ContentType -> ContentType -> ContentType)
-> (ContentType -> ContentType -> ContentType)
-> Ord ContentType
ContentType -> ContentType -> Bool
ContentType -> ContentType -> Ordering
ContentType -> ContentType -> ContentType
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 :: ContentType -> ContentType -> ContentType
$cmin :: ContentType -> ContentType -> ContentType
max :: ContentType -> ContentType -> ContentType
$cmax :: ContentType -> ContentType -> ContentType
>= :: ContentType -> ContentType -> Bool
$c>= :: ContentType -> ContentType -> Bool
> :: ContentType -> ContentType -> Bool
$c> :: ContentType -> ContentType -> Bool
<= :: ContentType -> ContentType -> Bool
$c<= :: ContentType -> ContentType -> Bool
< :: ContentType -> ContentType -> Bool
$c< :: ContentType -> ContentType -> Bool
compare :: ContentType -> ContentType -> Ordering
$ccompare :: ContentType -> ContentType -> Ordering
$cp1Ord :: Eq ContentType
Ord)

-- | Produce the standard string representation of a content-type,
--   e.g. \"text\/html; charset=ISO-8859-1\".
showContentType :: ContentType -> String
showContentType :: ContentType -> String
showContentType (ContentType String
x String
y [Header]
ps) = String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
y String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Header] -> String
showParameters [Header]
ps

pContentType :: Parser ContentType
pContentType :: Parser ContentType
pContentType =
  do ParsecT String () Identity String -> ParsecT String () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT String () Identity String
 -> ParsecT String () Identity ())
-> ParsecT String () Identity String
-> ParsecT String () Identity ()
forall a b. (a -> b) -> a -> b
$ 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
     ParsecT String () Identity Char -> ParsecT String () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT String () Identity Char -> ParsecT String () Identity ())
-> ParsecT String () Identity Char -> ParsecT String () Identity ()
forall a b. (a -> b) -> a -> b
$ 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
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
     [Header]
c_parameters <- ParsecT String () Identity Header -> Parser [Header]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT String () Identity Header
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 -> [Header] -> ContentType
ContentType ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
c_type) ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
c_subtype) [Header]
c_parameters

-- | 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 :: String -> m ContentType
parseContentType = Parser ContentType -> String -> String -> m ContentType
forall (m :: * -> *) a.
MonadFail m =>
Parser a -> String -> String -> m a
parseM Parser ContentType
pContentType String
"Content-type"

getContentType :: MonadFail m => [Header] -> m ContentType
getContentType :: [Header] -> m ContentType
getContentType [Header]
hs = String -> [Header] -> m String
forall (m :: * -> *) a b.
(MonadFail m, Eq a, Show a) =>
a -> [(a, b)] -> m b
lookupM String
"content-type" [Header]
hs m String -> (String -> m ContentType) -> m ContentType
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> m ContentType
forall (m :: * -> *). MonadFail m => String -> m ContentType
parseContentType

--
-- * Content transfer encoding
--

data ContentTransferEncoding =
        ContentTransferEncoding String
    deriving (Int -> ContentTransferEncoding -> String -> String
[ContentTransferEncoding] -> String -> String
ContentTransferEncoding -> String
(Int -> ContentTransferEncoding -> String -> String)
-> (ContentTransferEncoding -> String)
-> ([ContentTransferEncoding] -> String -> String)
-> Show ContentTransferEncoding
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ContentTransferEncoding] -> String -> String
$cshowList :: [ContentTransferEncoding] -> String -> String
show :: ContentTransferEncoding -> String
$cshow :: ContentTransferEncoding -> String
showsPrec :: Int -> ContentTransferEncoding -> String -> String
$cshowsPrec :: Int -> ContentTransferEncoding -> String -> String
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
$cp1Ord :: Eq ContentTransferEncoding
Ord)

pContentTransferEncoding :: Parser ContentTransferEncoding
pContentTransferEncoding :: Parser ContentTransferEncoding
pContentTransferEncoding =
  do ParsecT String () Identity String -> ParsecT String () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT String () Identity String
 -> ParsecT String () Identity ())
-> ParsecT String () Identity String
-> ParsecT String () Identity ()
forall a b. (a -> b) -> a -> b
$ 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) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
c_cte)

parseContentTransferEncoding :: MonadFail m => String -> m ContentTransferEncoding
parseContentTransferEncoding :: String -> m ContentTransferEncoding
parseContentTransferEncoding =
    Parser ContentTransferEncoding
-> String -> String -> m ContentTransferEncoding
forall (m :: * -> *) a.
MonadFail m =>
Parser a -> String -> String -> m a
parseM Parser ContentTransferEncoding
pContentTransferEncoding String
"Content-transfer-encoding"

getContentTransferEncoding :: MonadFail m => [Header] -> m ContentTransferEncoding
getContentTransferEncoding :: [Header] -> m ContentTransferEncoding
getContentTransferEncoding [Header]
hs =
    String -> [Header] -> m String
forall (m :: * -> *) a b.
(MonadFail m, Eq a, Show a) =>
a -> [(a, b)] -> m b
lookupM String
"content-transfer-encoding" [Header]
hs m String
-> (String -> m ContentTransferEncoding)
-> m ContentTransferEncoding
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> m ContentTransferEncoding
forall (m :: * -> *).
MonadFail m =>
String -> m ContentTransferEncoding
parseContentTransferEncoding

--
-- * Content disposition
--

data ContentDisposition =
        ContentDisposition String [(String, String)]
    deriving (Int -> ContentDisposition -> String -> String
[ContentDisposition] -> String -> String
ContentDisposition -> String
(Int -> ContentDisposition -> String -> String)
-> (ContentDisposition -> String)
-> ([ContentDisposition] -> String -> String)
-> Show ContentDisposition
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ContentDisposition] -> String -> String
$cshowList :: [ContentDisposition] -> String -> String
show :: ContentDisposition -> String
$cshow :: ContentDisposition -> String
showsPrec :: Int -> ContentDisposition -> String -> String
$cshowsPrec :: Int -> ContentDisposition -> String -> String
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
$cp1Ord :: Eq ContentDisposition
Ord)

pContentDisposition :: Parser ContentDisposition
pContentDisposition :: Parser ContentDisposition
pContentDisposition =
  do ParsecT String () Identity String -> ParsecT String () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT String () Identity String
 -> ParsecT String () Identity ())
-> ParsecT String () Identity String
-> ParsecT String () Identity ()
forall a b. (a -> b) -> a -> b
$ 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
     [Header]
c_parameters <- ParsecT String () Identity Header -> Parser [Header]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT String () Identity Header
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 -> [Header] -> ContentDisposition
ContentDisposition ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
c_cd) [Header]
c_parameters

parseContentDisposition :: MonadFail m => String -> m ContentDisposition
parseContentDisposition :: String -> m ContentDisposition
parseContentDisposition = Parser ContentDisposition
-> String -> String -> m ContentDisposition
forall (m :: * -> *) a.
MonadFail m =>
Parser a -> String -> String -> m a
parseM Parser ContentDisposition
pContentDisposition String
"Content-disposition"

getContentDisposition :: MonadFail m => [Header] -> m ContentDisposition
getContentDisposition :: [Header] -> m ContentDisposition
getContentDisposition [Header]
hs =
    String -> [Header] -> m String
forall (m :: * -> *) a b.
(MonadFail m, Eq a, Show a) =>
a -> [(a, b)] -> m b
lookupM String
"content-disposition" [Header]
hs  m String
-> (String -> m ContentDisposition) -> m ContentDisposition
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> m ContentDisposition
forall (m :: * -> *). MonadFail m => String -> m ContentDisposition
parseContentDisposition

--
-- * Utilities
--

parseM :: MonadFail m => Parser a -> SourceName -> String -> m a
parseM :: 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
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 :: 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
fail (String
"No such field: " String -> String -> String
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

--
-- * 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 :: Parser a -> Parser a
lexeme Parser a
p = do a
x <- Parser a
p; ParsecT String () Identity String -> ParsecT String () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT String () Identity String
 -> ParsecT String () Identity ())
-> ParsecT String () Identity String
-> ParsecT String () Identity ()
forall a b. (a -> b) -> a -> b
$ 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 ParsecT String () Identity Char -> ParsecT String () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT String () Identity Char -> ParsecT String () Identity ())
-> ParsecT String () Identity Char -> ParsecT String () Identity ()
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
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)
                   ParsecT String () Identity Char -> ParsecT String () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT String () Identity Char -> ParsecT String () Identity ())
-> ParsecT String () Identity Char -> ParsecT String () Identity ()
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 -> 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 ParsecT String () Identity Char -> ParsecT String () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT String () Identity Char -> ParsecT String () Identity ())
-> ParsecT String () Identity Char -> ParsecT String () Identity ()
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
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 ParsecT String u Identity Char -> ParsecT String u Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT String u Identity Char -> ParsecT String u Identity ())
-> ParsecT String u Identity Char -> ParsecT String u Identity ()
forall a b. (a -> b) -> a -> b
$ 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
"()<>@,;:\\\"/[]?="  -- RFC2045
tokenchar :: String
tokenchar = String
"!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" String -> String -> String
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 ParsecT String () Identity Char -> ParsecT String () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT String () Identity Char -> ParsecT String () Identity ())
-> ParsecT String () Identity Char -> ParsecT String () Identity ()
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
'\\'
                 ParsecT String () Identity Char
p_text