{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------
-- |
-- Module    : Codec.MIME.Pare
-- Copyright : (c) 2006-2009, Galois, Inc. 
-- License   : BSD3
--
-- Maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com>
-- Stability : provisional
-- Portability: portable
--
-- Parsing MIME content.
-- 
--------------------------------------------------------------------
module Codec.MIME.Parse
  ( parseMIMEBody    -- :: [(T.Text,T.Text)] -> T.Text -> MIMEValue
  , parseMIMEType    -- :: T.Text -> Maybe Type
  , parseMIMEMessage -- :: T.Text -> MIMEValue

  , parseHeaders     -- :: T.Text -> ([(T.Text,T.Text)], T.Text)
  , parseMultipart   -- :: Type -> T.Text -> (MIMEValue, T.Text)
  , parseContentType -- :: T.Text -> Maybe Type
  , splitMulti       -- :: T.Text -> T.Text -> ([MIMEValue], T.Text)
  , normalizeCRLF
  ) where

import Codec.MIME.Type
import Codec.MIME.Decode
import Control.Arrow(second)

import Data.Char
import Data.Maybe
import qualified Data.List as L
import Debug.Trace ( trace )
import qualified Data.Text as T
import Data.Monoid(Monoid(..), (<>))

enableTrace :: Bool
enableTrace :: Bool
enableTrace = Bool
False

doTrace :: String -> b -> b
doTrace :: forall b. [Char] -> b -> b
doTrace | Bool
enableTrace = [Char] -> b -> b
forall b. [Char] -> b -> b
trace
        | Bool
otherwise   = \[Char]
_ b
x -> b
x


parseMIMEBody :: [MIMEParam] -> T.Text -> MIMEValue
parseMIMEBody :: [MIMEParam] -> Text -> MIMEValue
parseMIMEBody [MIMEParam]
headers_in Text
body = MIMEValue
result { mime_val_headers = headers }
  where
  result :: MIMEValue
result = case Type -> MIMEType
mimeType Type
mty of
    Multipart{} -> (MIMEValue, Text) -> MIMEValue
forall a b. (a, b) -> a
fst (Type -> Text -> (MIMEValue, Text)
parseMultipart Type
mty Text
body)
    Message{}   -> (MIMEValue, Text) -> MIMEValue
forall a b. (a, b) -> a
fst (Type -> Text -> (MIMEValue, Text)
parseMultipart Type
mty Text
body)
    MIMEType
_           -> MIMEValue
nullMIMEValue { mime_val_type    = mty
                                 , mime_val_disp    = parseContentDisp headers
                                 , mime_val_content = Single (processBody headers body)
                                 }
  headers :: [MIMEParam]
headers = [ Text -> Text -> MIMEParam
MIMEParam (Text -> Text
T.toLower Text
k) Text
v | (MIMEParam Text
k Text
v) <- [MIMEParam]
headers_in ]
  mty :: Type
mty = Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe Type
defaultType
                       (Text -> Maybe Type
parseContentType (Text -> Maybe Type) -> Maybe Text -> Maybe Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> [(Text, Text)] -> Maybe Text
forall a. Text -> [(Text, a)] -> Maybe a
lookupField Text
"content-type" ([MIMEParam] -> [(Text, Text)]
paramPairs [MIMEParam]
headers))
defaultType :: Type
defaultType :: Type
defaultType = Type { mimeType :: MIMEType
mimeType   = Text -> MIMEType
Text Text
"plain"
                   , mimeParams :: [MIMEParam]
mimeParams = [Text -> Text -> MIMEParam
MIMEParam Text
"charset" Text
"us-ascii"]
                   }

parseContentDisp :: [MIMEParam] -> Maybe Disposition
parseContentDisp :: [MIMEParam] -> Maybe Disposition
parseContentDisp [MIMEParam]
headers =
    (Text -> Maybe Disposition
processDisp (Text -> Maybe Disposition)
-> (Text -> Text) -> Text -> Maybe Disposition
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
dropFoldingWSP) (Text -> Maybe Disposition) -> Maybe Text -> Maybe Disposition
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> [(Text, Text)] -> Maybe Text
forall a. Text -> [(Text, a)] -> Maybe a
lookupField Text
"content-disposition" ([MIMEParam] -> [(Text, Text)]
paramPairs [MIMEParam]
headers)
  where
    processDisp :: Text -> Maybe Disposition
processDisp Text
t | Text -> Bool
T.null Text
t  = Maybe Disposition
forall a. Maybe a
Nothing
                  | Text -> Bool
T.null Text
bs = Disposition -> Maybe Disposition
forall a. a -> Maybe a
Just (Disposition -> Maybe Disposition)
-> Disposition -> Maybe Disposition
forall a b. (a -> b) -> a -> b
$ Disposition { dispType :: DispType
dispType = Text -> DispType
toDispType (Text -> Text
T.toLower Text
as)
                                                   , dispParams :: [DispParam]
dispParams = []
                                                   }
                  | Bool
otherwise = Disposition -> Maybe Disposition
forall a. a -> Maybe a
Just (Disposition -> Maybe Disposition)
-> Disposition -> Maybe Disposition
forall a b. (a -> b) -> a -> b
$ Disposition { dispType :: DispType
dispType = Text -> DispType
toDispType (Text -> Text
T.toLower Text
as)
                                                   , dispParams :: [DispParam]
dispParams = [MIMEParam] -> [DispParam]
processParams (Text -> [MIMEParam]
parseParams Text
bs)
                                                   } 
      where (Text
as,Text
bs) = (Char -> Bool) -> Text -> (Text, Text)
T.break (\Char
ch -> Char -> Bool
isSpace Char
ch Bool -> Bool -> Bool
|| Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
';') Text
t

    processParams :: [MIMEParam] -> [DispParam]
processParams = (MIMEParam -> DispParam) -> [MIMEParam] -> [DispParam]
forall a b. (a -> b) -> [a] -> [b]
map MIMEParam -> DispParam
procP
      where
        procP :: MIMEParam -> DispParam
procP (MIMEParam Text
as Text
val)
            | Text
"name" Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
asl              = Text -> DispParam
Name Text
val
            | Text
"filename" Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
asl          = Text -> DispParam
Filename Text
val
            | Text
"creation-date" Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
asl     = Text -> DispParam
CreationDate Text
val
            | Text
"modification-date" Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
asl = Text -> DispParam
ModDate Text
val
            | Text
"read-date" Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
asl         = Text -> DispParam
ReadDate Text
val
            | Text
"size" Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
asl              = Text -> DispParam
Size Text
val
            | Bool
otherwise                  = Text -> Text -> DispParam
OtherParam Text
asl Text
val
          where asl :: Text
asl = Text -> Text
T.toLower Text
as

    toDispType :: Text -> DispType
toDispType Text
t = if Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"inline" then DispType
DispInline
                   else if Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"attachment" then DispType
DispAttachment
                   else if Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"form-data"  then DispType
DispFormData
                   else  Text -> DispType
DispOther Text
t

paramPairs :: [MIMEParam] -> [(T.Text, T.Text)]
paramPairs :: [MIMEParam] -> [(Text, Text)]
paramPairs = (MIMEParam -> (Text, Text)) -> [MIMEParam] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map MIMEParam -> (Text, Text)
paramPair
  where
    paramPair :: MIMEParam -> (Text, Text)
paramPair (MIMEParam Text
a Text
b) = (Text
a,Text
b)

processBody :: [MIMEParam] -> T.Text -> T.Text
processBody :: [MIMEParam] -> Text -> Text
processBody [MIMEParam]
headers Text
body =
  case Text -> [(Text, Text)] -> Maybe Text
forall a. Text -> [(Text, a)] -> Maybe a
lookupField Text
"content-transfer-encoding" ([(Text, Text)] -> Maybe Text) -> [(Text, Text)] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [MIMEParam] -> [(Text, Text)]
paramPairs [MIMEParam]
headers of
    Maybe Text
Nothing -> Text
body
    Just Text
v  -> [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char]
decodeBody (Text -> [Char]
T.unpack Text
v) ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
body

normalizeCRLF :: T.Text -> T.Text
normalizeCRLF :: Text -> Text
normalizeCRLF Text
t
    | Text -> Bool
T.null Text
t = Text
""
    | Text
"\r\n" Text -> Text -> Bool
`T.isPrefixOf` Text
t = Text
"\r\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
normalizeCRLF (Int -> Text -> Text
T.drop Int
2 Text
t)
    | (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`T.isPrefixOf` Text
t) [Text
"\r", Text
"\n"] = Text
"\r\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
normalizeCRLF (Int -> Text -> Text
T.drop Int
1 Text
t)
    | Bool
otherwise = let (Text
a,Text
b) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'\r',Char
'\n']) Text
t in Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
normalizeCRLF Text
b
  
parseMIMEMessage :: T.Text -> MIMEValue
parseMIMEMessage :: Text -> MIMEValue
parseMIMEMessage Text
entity =
  case Text -> ([MIMEParam], Text)
parseHeaders (Text -> Text
normalizeCRLF Text
entity) of
   ([MIMEParam]
as,Text
bs) -> [MIMEParam] -> Text -> MIMEValue
parseMIMEBody [MIMEParam]
as Text
bs

parseHeaders :: T.Text -> ([MIMEParam], T.Text)
parseHeaders :: Text -> ([MIMEParam], Text)
parseHeaders Text
str =
  case Text -> Text -> Either (Text, Text) Text
findFieldName Text
"" Text
str of
    Left (Text
nm, Text
rs) -> Text -> Text -> ([MIMEParam], Text)
parseFieldValue Text
nm (Text -> Text
dropFoldingWSP Text
rs)
    Right Text
body    -> ([],Text
body)
 where
  findFieldName :: Text -> Text -> Either (Text, Text) Text
findFieldName Text
acc Text
t 
    | Text -> Bool
T.null Text
t = Text -> Either (Text, Text) Text
forall a b. b -> Either a b
Right Text
""
    | Text
"\r\n" Text -> Text -> Bool
`T.isPrefixOf` Text
t = Text -> Either (Text, Text) Text
forall a b. b -> Either a b
Right (Text -> Either (Text, Text) Text)
-> Text -> Either (Text, Text) Text
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop Int
2 Text
t
    | Text
":" Text -> Text -> Bool
`T.isPrefixOf` Text
t = (Text, Text) -> Either (Text, Text) Text
forall a b. a -> Either a b
Left (Text -> Text
T.reverse (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isHSpace Text
acc, Int -> Text -> Text
T.drop Int
1 Text
t)
    | Bool
otherwise = Text -> Text -> Either (Text, Text) Text
findFieldName (Int -> Text -> Text
T.take Int
1 Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
acc) (Text -> Either (Text, Text) Text)
-> Text -> Either (Text, Text) Text
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop Int
1 Text
t

  parseFieldValue :: Text -> Text -> ([MIMEParam], Text)
parseFieldValue Text
nm Text
xs 
      | Text -> Bool
T.null Text
bs = ([Text -> Text -> MIMEParam
MIMEParam Text
nm Text
as], Text
"")
      | Bool
otherwise = let ([MIMEParam]
zs,Text
ys) = Text -> ([MIMEParam], Text)
parseHeaders Text
bs in (Text -> Text -> MIMEParam
MIMEParam Text
nm Text
as MIMEParam -> [MIMEParam] -> [MIMEParam]
forall a. a -> [a] -> [a]
:[MIMEParam]
zs, Text
ys)
    where 
      (Text
as,Text
bs) = Text -> (Text, Text)
takeUntilCRLF Text
xs

parseMultipart :: Type -> T.Text -> (MIMEValue, T.Text)
parseMultipart :: Type -> Text -> (MIMEValue, Text)
parseMultipart Type
mty Text
body =
  case Text -> [(Text, Text)] -> Maybe Text
forall a. Text -> [(Text, a)] -> Maybe a
lookupField Text
"boundary" ([MIMEParam] -> [(Text, Text)]
paramPairs ([MIMEParam] -> [(Text, Text)]) -> [MIMEParam] -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ Type -> [MIMEParam]
mimeParams Type
mty) of
    Maybe Text
Nothing -> [Char] -> (MIMEValue, Text) -> (MIMEValue, Text)
forall b. [Char] -> b -> b
doTrace ([Char]
"Multipart mime type, " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack (Type -> Text
showType Type
mty) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
      [Char]
", has no required boundary parameter. Defaulting to text/plain") ((MIMEValue, Text) -> (MIMEValue, Text))
-> (MIMEValue, Text) -> (MIMEValue, Text)
forall a b. (a -> b) -> a -> b
$
      (MIMEValue
nullMIMEValue{ mime_val_type = defaultType
                    , mime_val_disp = Nothing
		    , mime_val_content = Single body
		    }, Text
"")
    Just Text
bnd -> (MIMEValue
nullMIMEValue { mime_val_type = mty
                               , mime_val_disp = Nothing
			       , mime_val_content = Multi vals
			       }, Text
rs)
      where ([MIMEValue]
vals,Text
rs) = Text -> Text -> ([MIMEValue], Text)
splitMulti Text
bnd Text
body

splitMulti :: T.Text -> T.Text -> ([MIMEValue], T.Text)
splitMulti :: Text -> Text -> ([MIMEValue], Text)
splitMulti Text
bnd Text
body_in =
  -- Note: we insert a CRLF if it looks as if the boundary string starts
  -- right off the bat.  No harm done if this turns out to be incorrect.
  let body :: Text
body | Text
"--" Text -> Text -> Bool
`T.isPrefixOf` Text
body_in = Text
"\r\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
body_in
           | Bool
otherwise  = Text
body_in
  in case Text -> Text -> Maybe Text
untilMatch Text
dashBoundary Text
body of
       Maybe Text
Nothing           -> ([MIMEValue], Text)
forall a. Monoid a => a
mempty
       Just Text
xs  | Text
"--" Text -> Text -> Bool
`T.isPrefixOf` Text
xs    -> ([], Int -> Text -> Text
T.drop Int
2 Text
xs)
                | Bool
otherwise                 -> Text -> ([MIMEValue], Text)
splitMulti1 (Text -> Text
dropTrailer Text
xs)

 where
  dashBoundary :: Text
dashBoundary = (Text
"\r\n--" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bnd)

  splitMulti1 :: Text -> ([MIMEValue], Text)
splitMulti1 Text
xs 
      | Text -> Bool
T.null Text
as Bool -> Bool -> Bool
&& Text -> Bool
T.null Text
bs = ([], Text
"")
      | Text -> Bool
T.null Text
bs = ([Text -> MIMEValue
parseMIMEMessage Text
as],Text
"")
      | Text -> Text -> Bool
T.isPrefixOf Text
"--" Text
bs    =  ([Text -> MIMEValue
parseMIMEMessage Text
as], Text -> Text
dropTrailer Text
bs)
      | Bool
otherwise   = let ([MIMEValue]
zs,Text
ys) = Text -> ([MIMEValue], Text)
splitMulti1 (Text -> Text
dropTrailer Text
bs)
                            in ((Text -> MIMEValue
parseMIMEMessage Text
as) MIMEValue -> [MIMEValue] -> [MIMEValue]
forall a. a -> [a] -> [a]
: [MIMEValue]
zs,Text
ys)

    where
      (Text
as,Text
bs) = Text -> Text -> (Text, Text)
matchUntil Text
dashBoundary Text
xs

  dropTrailer :: Text -> Text
dropTrailer Text
xs 
      | Text
"\r\n" Text -> Text -> Bool
`T.isPrefixOf` Text
xs1 = Int -> Text -> Text
T.drop Int
2 Text
xs1
      | Bool
otherwise   = Text
xs1 -- hmm, flag an error?
    where
       xs1 :: Text
xs1 = (Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isHSpace Text
xs 

parseMIMEType :: T.Text -> Maybe Type
parseMIMEType :: Text -> Maybe Type
parseMIMEType = Text -> Maybe Type
parseContentType

parseContentType :: T.Text -> Maybe Type
parseContentType :: Text -> Maybe Type
parseContentType Text
str
    | Text -> Bool
T.null Text
minor0 = [Char] -> Maybe Type -> Maybe Type
forall b. [Char] -> b -> b
doTrace ([Char]
"unable to parse content-type: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
str) (Maybe Type -> Maybe Type) -> Maybe Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ Maybe Type
forall a. Maybe a
Nothing
    | Bool
otherwise     = Type -> Maybe Type
forall a. a -> Maybe a
Just Type  { mimeType :: MIMEType
mimeType = Text -> Text -> MIMEType
toType Text
maj Text
as
                                 , mimeParams :: [MIMEParam]
mimeParams = Text -> [MIMEParam]
parseParams ((Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isHSpace Text
bs)
                                 }
  where
    (Text
maj, Text
minor0) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'/') (Text -> Text
dropFoldingWSP Text
str)
    minor :: Text
minor = Int -> Text -> Text
T.drop Int
1 Text
minor0
    (Text
as, Text
bs) = (Char -> Bool) -> Text -> (Text, Text)
T.break (\ Char
ch -> Char -> Bool
isHSpace Char
ch Bool -> Bool -> Bool
|| Char -> Bool
isTSpecial Char
ch) Text
minor 
    toType :: Text -> Text -> MIMEType
toType Text
a Text
b = case Text -> [(Text, Text -> MIMEType)] -> Maybe (Text -> MIMEType)
forall a. Text -> [(Text, a)] -> Maybe a
lookupField (Text -> Text
T.toLower Text
a) [(Text, Text -> MIMEType)]
mediaTypes of
         Just Text -> MIMEType
ctor -> Text -> MIMEType
ctor Text
b
         Maybe (Text -> MIMEType)
_ -> Text -> Text -> MIMEType
Other Text
a Text
b

parseParams :: T.Text -> [MIMEParam]
parseParams :: Text -> [MIMEParam]
parseParams Text
t   | Text -> Bool
T.null Text
t          = []
                | Char
';' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== HasCallStack => Text -> Char
Text -> Char
T.head Text
t   = let (Text
nm_raw, Text
vs0) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'=') (Text -> Text
dropFoldingWSP (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text
Text -> Text
T.tail Text
t) 
                                          nm :: Text
nm = Text -> Text
T.toLower Text
nm_raw in
                    if Text -> Bool
T.null Text
vs0 
                        then []
                        else let vs :: Text
vs = HasCallStack => Text -> Text
Text -> Text
T.tail Text
vs0 in
                            if Bool -> Bool
not (Text -> Bool
T.null Text
vs) Bool -> Bool -> Bool
&& HasCallStack => Text -> Char
Text -> Char
T.head Text
vs Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' 
                                then let vs1 :: Text
vs1 = HasCallStack => Text -> Text
Text -> Text
T.tail Text
vs 
                                         (Text
val, Text
zs0) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'"') Text
vs1 in
                                    if Text -> Bool
T.null Text
zs0 
                                        then [Text -> Text -> MIMEParam
MIMEParam Text
nm Text
val]
                                        else Text -> Text -> MIMEParam
MIMEParam Text
nm Text
val MIMEParam -> [MIMEParam] -> [MIMEParam]
forall a. a -> [a] -> [a]
: Text -> [MIMEParam]
parseParams ((Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isHSpace (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text
Text -> Text
T.tail Text
zs0)
                                else let (Text
val, Text
zs) = (Char -> Bool) -> Text -> (Text, Text)
T.break (\Char
ch -> Char -> Bool
isHSpace Char
ch Bool -> Bool -> Bool
|| Char -> Bool
isTSpecial Char
ch) Text
vs in
                                    Text -> Text -> MIMEParam
MIMEParam Text
nm Text
val MIMEParam -> [MIMEParam] -> [MIMEParam]
forall a. a -> [a] -> [a]
: Text -> [MIMEParam]
parseParams ((Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isHSpace Text
zs)
                | Bool
otherwise = [Char] -> [MIMEParam] -> [MIMEParam]
forall b. [Char] -> b -> b
doTrace ([Char]
"Codec.MIME.Parse.parseParams: curious param value -- " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
t) []

mediaTypes :: [(T.Text, T.Text -> MIMEType)]
mediaTypes :: [(Text, Text -> MIMEType)]
mediaTypes =
  [ (Text
"multipart",   (Multipart -> MIMEType
Multipart (Multipart -> MIMEType) -> (Text -> Multipart) -> Text -> MIMEType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Multipart
toMultipart))
  , (Text
"application", Text -> MIMEType
Application)
  , (Text
"audio",       Text -> MIMEType
Audio)
  , (Text
"image",       Text -> MIMEType
Image)
  , (Text
"message",     Text -> MIMEType
Message)
  , (Text
"model",       Text -> MIMEType
Model)
  , (Text
"text",        Text -> MIMEType
Text)
  , (Text
"video",       Text -> MIMEType
Video)
  ]
 where toMultipart :: Text -> Multipart
toMultipart Text
b = Multipart -> Maybe Multipart -> Multipart
forall a. a -> Maybe a -> a
fromMaybe Multipart
other (Text -> [(Text, Multipart)] -> Maybe Multipart
forall a. Text -> [(Text, a)] -> Maybe a
lookupField (Text -> Text
T.toLower Text
b) [(Text, Multipart)]
multipartTypes)
          where other :: Multipart
other | Text -> Text -> Bool
T.isPrefixOf Text
"x-" Text
b = Text -> Multipart
Extension Text
b
                      | Bool
otherwise           = Text -> Multipart
OtherMulti Text
b

multipartTypes :: [(T.Text, Multipart)]
multipartTypes :: [(Text, Multipart)]
multipartTypes =
  [ (Text
"alternative", Multipart
Alternative)
  , (Text
"byteranges",  Multipart
Byteranges)
  , (Text
"digest",      Multipart
Digest)
  , (Text
"encrypted",   Multipart
Encrypted)
  , (Text
"form-data",   Multipart
FormData)
  , (Text
"mixed",       Multipart
Mixed)
  , (Text
"parallel",    Multipart
Parallel)
  , (Text
"related",     Multipart
Related)
  , (Text
"signed",      Multipart
Signed)
  ]

untilMatch :: T.Text -> T.Text -> Maybe T.Text
untilMatch :: Text -> Text -> Maybe Text
untilMatch Text
a Text
b  | Text -> Bool
T.null Text
a  = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
b
                | Text -> Bool
T.null Text
b  = Maybe Text
forall a. Maybe a
Nothing
                | Text
a Text -> Text -> Bool
`T.isPrefixOf` Text
b = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop (Text -> Int
T.length Text
a) Text
b
                | Bool
otherwise = Text -> Text -> Maybe Text
untilMatch Text
a (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text
Text -> Text
T.tail Text
b

matchUntil :: T.Text -> T.Text -> (T.Text, T.Text)
-- searching str; returning parts before str and after str
matchUntil :: Text -> Text -> (Text, Text)
matchUntil Text
str = (Text -> Text) -> (Text, Text) -> (Text, Text)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Int -> Text -> Text
T.drop (Int -> Text -> Text) -> Int -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Int
T.length Text
str) ((Text, Text) -> (Text, Text))
-> (Text -> (Text, Text)) -> Text -> (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
str

{-
matchUntil' :: T.Text -> T.Text -> (T.Text, T.Text)
matchUntil' _   "" = ("", "")
matchUntil' str xs
    | T.null xs = mempty
    -- slow, but it'll do for now.
    | str `T.isPrefixOf` xs = ("", T.drop (T.length str) xs)
    | otherwise = let (as,bs) = matchUntil' str $ T.tail xs in (T.take 1 xs <> as, bs)
-}

isHSpace :: Char -> Bool
isHSpace :: Char -> Bool
isHSpace Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t'

isTSpecial :: Char -> Bool
isTSpecial :: Char -> Bool
isTSpecial Char
x = Char
x Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
"()<>@,;:\\\"/[]?="::String) -- "

dropFoldingWSP :: T.Text -> T.Text
dropFoldingWSP :: Text -> Text
dropFoldingWSP Text
t | Text -> Bool
T.null Text
t   = Text
""
                 | Char -> Bool
isHSpace (HasCallStack => Text -> Char
Text -> Char
T.head Text
t) = Text -> Text
dropFoldingWSP (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text
Text -> Text
T.tail Text
t
                 | Text
"\r\n" Text -> Text -> Bool
`T.isPrefixOf` Text
t Bool -> Bool -> Bool
&& Bool -> Bool
not (Text -> Bool
T.null (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop Int
2 Text
t) Bool -> Bool -> Bool
&& Char -> Bool
isHSpace (HasCallStack => Text -> Char
Text -> Char
T.head (Text -> Char) -> Text -> Char
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop Int
2 Text
t) 
                    = Text -> Text
dropFoldingWSP (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop Int
3 Text
t
                 | Bool
otherwise    = Text
t 

takeUntilCRLF :: T.Text -> (T.Text, T.Text)
takeUntilCRLF :: Text -> (Text, Text)
takeUntilCRLF Text
str = Text -> Text -> (Text, Text)
go Text
"" Text
str
 where
  go :: Text -> Text -> (Text, Text)
go Text
acc Text
t  | Text -> Bool
T.null Text
t  = (Text -> Text
T.reverse ((Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isHSpace Text
acc), Text
"")
            | Text
"\r\n" Text -> Text -> Bool
`T.isPrefixOf` Text
t Bool -> Bool -> Bool
&& Bool -> Bool
not (Text -> Bool
T.null (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop Int
2 Text
t) Bool -> Bool -> Bool
&& Char -> Bool
isHSpace (HasCallStack => Text -> Char
Text -> Char
T.head (Text -> Char) -> Text -> Char
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop Int
2 Text
t)  
                        = Text -> Text -> (Text, Text)
go (Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
acc) (Int -> Text -> Text
T.drop Int
3 Text
t)
            | Text
"\r\n" Text -> Text -> Bool
`T.isPrefixOf` Text
t Bool -> Bool -> Bool
&& Bool -> Bool
not (Text -> Bool
T.null (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop Int
2 Text
t)  
                        = (Text -> Text
T.reverse ((Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isHSpace Text
acc), Int -> Text -> Text
T.drop Int
2 Text
t)
            | Bool
otherwise = Text -> Text -> (Text, Text)
go (Int -> Text -> Text
T.take Int
1 Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
acc) (Text -> (Text, Text)) -> Text -> (Text, Text)
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text
Text -> Text
T.tail Text
t

-- case in-sensitive lookup of field names or attributes\/parameters.
lookupField :: T.Text -> [(T.Text,a)] -> Maybe a
lookupField :: forall a. Text -> [(Text, a)] -> Maybe a
lookupField Text
n [(Text, a)]
ns = 
   -- assume that inputs have been mostly normalized already 
   -- (i.e., lower-cased), but should the lookup fail fall back
   -- to a second try where we do normalize before giving up.
  case Text -> [(Text, a)] -> Maybe a
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
n [(Text, a)]
ns of
    x :: Maybe a
x@Just{} -> Maybe a
x
    Maybe a
Nothing  -> 
      let nl :: Text
nl = Text -> Text
T.toLower Text
n in
      ((Text, a) -> a) -> Maybe (Text, a) -> Maybe a
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, a) -> a
forall a b. (a, b) -> b
snd (Maybe (Text, a) -> Maybe a) -> Maybe (Text, a) -> Maybe a
forall a b. (a -> b) -> a -> b
$ ((Text, a) -> Bool) -> [(Text, a)] -> Maybe (Text, a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find ((Text
nlText -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==) (Text -> Bool) -> ((Text, a) -> Text) -> (Text, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower (Text -> Text) -> ((Text, a) -> Text) -> (Text, a) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, a) -> Text
forall a b. (a, b) -> a
fst) [(Text, a)]
ns