{-# LANGUAGE OverloadedStrings #-}
module Codec.MIME.Parse
( parseMIMEBody
, parseMIMEType
, parseMIMEMessage
, parseHeaders
, parseMultipart
, parseContentType
, splitMulti
, 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)
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 =
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
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)
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
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
lookupField :: T.Text -> [(T.Text,a)] -> Maybe a
lookupField :: forall a. Text -> [(Text, a)] -> Maybe a
lookupField Text
n [(Text, a)]
ns =
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