{-# 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 :: String -> b -> b
doTrace | Bool
enableTrace = String -> b -> b
forall a. String -> a -> a
trace
| Bool
otherwise = \_ x :: b
x -> b
x
parseMIMEBody :: [MIMEParam] -> T.Text -> MIMEValue
parseMIMEBody :: [MIMEParam] -> Text -> MIMEValue
parseMIMEBody headers_in :: [MIMEParam]
headers_in body :: Text
body = MIMEValue
result { mime_val_headers :: [MIMEParam]
mime_val_headers = [MIMEParam]
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)
_ -> MIMEValue
nullMIMEValue { mime_val_type :: Type
mime_val_type = Type
mty
, mime_val_disp :: Maybe Disposition
mime_val_disp = [MIMEParam] -> Maybe Disposition
parseContentDisp [MIMEParam]
headers
, mime_val_content :: MIMEContent
mime_val_content = Text -> MIMEContent
Single ([MIMEParam] -> Text -> Text
processBody [MIMEParam]
headers Text
body)
}
headers :: [MIMEParam]
headers = [ Text -> Text -> MIMEParam
MIMEParam (Text -> Text
T.toLower Text
k) Text
v | (MIMEParam k :: Text
k v :: 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 "content-type" ([MIMEParam] -> [(Text, Text)]
paramPairs [MIMEParam]
headers))
defaultType :: Type
defaultType :: Type
defaultType = Type :: MIMEType -> [MIMEParam] -> Type
Type { mimeType :: MIMEType
mimeType = Text -> MIMEType
Text "plain"
, mimeParams :: [MIMEParam]
mimeParams = [Text -> Text -> MIMEParam
MIMEParam "charset" "us-ascii"]
}
parseContentDisp :: [MIMEParam] -> Maybe Disposition
parseContentDisp :: [MIMEParam] -> Maybe Disposition
parseContentDisp headers :: [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 "content-disposition" ([MIMEParam] -> [(Text, Text)]
paramPairs [MIMEParam]
headers)
where
processDisp :: Text -> Maybe Disposition
processDisp t :: 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 -> [DispParam] -> Disposition
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 -> [DispParam] -> Disposition
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 (as :: Text
as,bs :: Text
bs) = (Char -> Bool) -> Text -> (Text, Text)
T.break (\ch :: Char
ch -> Char -> Bool
isSpace Char
ch Bool -> Bool -> Bool
|| Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ';') 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 as :: Text
as val :: Text
val)
| "name" Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
asl = Text -> DispParam
Name Text
val
| "filename" Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
asl = Text -> DispParam
Filename Text
val
| "creation-date" Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
asl = Text -> DispParam
CreationDate Text
val
| "modification-date" Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
asl = Text -> DispParam
ModDate Text
val
| "read-date" Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
asl = Text -> DispParam
ReadDate Text
val
| "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 t :: Text
t = if Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "inline" then DispType
DispInline
else if Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "attachment" then DispType
DispAttachment
else if Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "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 a :: Text
a b :: Text
b) = (Text
a,Text
b)
processBody :: [MIMEParam] -> T.Text -> T.Text
processBody :: [MIMEParam] -> Text -> Text
processBody headers :: [MIMEParam]
headers body :: Text
body =
case Text -> [(Text, Text)] -> Maybe Text
forall a. Text -> [(Text, a)] -> Maybe a
lookupField "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
Nothing -> Text
body
Just v :: Text
v -> String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> String -> String
decodeBody (Text -> String
T.unpack Text
v) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
body
normalizeCRLF :: T.Text -> T.Text
normalizeCRLF :: Text -> Text
normalizeCRLF t :: Text
t
| Text -> Bool
T.null Text
t = ""
| "\r\n" Text -> Text -> Bool
`T.isPrefixOf` Text
t = "\r\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
normalizeCRLF (Int -> Text -> Text
T.drop 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) ["\r", "\n"] = "\r\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
normalizeCRLF (Int -> Text -> Text
T.drop 1 Text
t)
| Bool
otherwise = let (a :: Text
a,b :: Text
b) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ['\r','\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 entity :: Text
entity =
case Text -> ([MIMEParam], Text)
parseHeaders (Text -> Text
normalizeCRLF Text
entity) of
(as :: [MIMEParam]
as,bs :: Text
bs) -> [MIMEParam] -> Text -> MIMEValue
parseMIMEBody [MIMEParam]
as Text
bs
parseHeaders :: T.Text -> ([MIMEParam], T.Text)
str :: Text
str =
case Text -> Text -> Either (Text, Text) Text
findFieldName "" Text
str of
Left (nm :: Text
nm, rs :: Text
rs) -> Text -> Text -> ([MIMEParam], Text)
parseFieldValue Text
nm (Text -> Text
dropFoldingWSP Text
rs)
Right body :: Text
body -> ([],Text
body)
where
findFieldName :: Text -> Text -> Either (Text, Text) Text
findFieldName acc :: Text
acc t :: Text
t
| Text -> Bool
T.null Text
t = Text -> Either (Text, Text) Text
forall a b. b -> Either a b
Right ""
| "\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 2 Text
t
| ":" 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 1 Text
t)
| Bool
otherwise = Text -> Text -> Either (Text, Text) Text
findFieldName (Int -> Text -> Text
T.take 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 1 Text
t
parseFieldValue :: Text -> Text -> ([MIMEParam], Text)
parseFieldValue nm :: Text
nm xs :: Text
xs
| Text -> Bool
T.null Text
bs = ([Text -> Text -> MIMEParam
MIMEParam Text
nm Text
as], "")
| Bool
otherwise = let (zs :: [MIMEParam]
zs,ys :: 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
(as :: Text
as,bs :: Text
bs) = Text -> (Text, Text)
takeUntilCRLF Text
xs
parseMultipart :: Type -> T.Text -> (MIMEValue, T.Text)
parseMultipart :: Type -> Text -> (MIMEValue, Text)
parseMultipart mty :: Type
mty body :: Text
body =
case Text -> [(Text, Text)] -> Maybe Text
forall a. Text -> [(Text, a)] -> Maybe a
lookupField "boundary" ([MIMEParam] -> [(Text, Text)]
paramPairs ([MIMEParam] -> [(Text, Text)]) -> [MIMEParam] -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ Type -> [MIMEParam]
mimeParams Type
mty) of
Nothing -> String -> (MIMEValue, Text) -> (MIMEValue, Text)
forall a. String -> a -> a
doTrace ("Multipart mime type, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (Type -> Text
showType Type
mty) String -> String -> String
forall a. [a] -> [a] -> [a]
++
", 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 :: Type
mime_val_type = Type
defaultType
, mime_val_disp :: Maybe Disposition
mime_val_disp = Maybe Disposition
forall a. Maybe a
Nothing
, mime_val_content :: MIMEContent
mime_val_content = Text -> MIMEContent
Single Text
body
}, "")
Just bnd :: Text
bnd -> (MIMEValue
nullMIMEValue { mime_val_type :: Type
mime_val_type = Type
mty
, mime_val_disp :: Maybe Disposition
mime_val_disp = Maybe Disposition
forall a. Maybe a
Nothing
, mime_val_content :: MIMEContent
mime_val_content = [MIMEValue] -> MIMEContent
Multi [MIMEValue]
vals
}, Text
rs)
where (vals :: [MIMEValue]
vals,rs :: 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 bnd :: Text
bnd body_in :: Text
body_in =
let body :: Text
body | "--" Text -> Text -> Bool
`T.isPrefixOf` Text
body_in = "\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
Nothing -> ([MIMEValue], Text)
forall a. Monoid a => a
mempty
Just xs :: Text
xs | "--" Text -> Text -> Bool
`T.isPrefixOf` Text
xs -> ([], Int -> Text -> Text
T.drop 2 Text
xs)
| Bool
otherwise -> Text -> ([MIMEValue], Text)
splitMulti1 (Text -> Text
dropTrailer Text
xs)
where
dashBoundary :: Text
dashBoundary = ("\r\n--" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bnd)
splitMulti1 :: Text -> ([MIMEValue], Text)
splitMulti1 xs :: Text
xs
| Text -> Bool
T.null Text
as Bool -> Bool -> Bool
&& Text -> Bool
T.null Text
bs = ([], "")
| Text -> Bool
T.null Text
bs = ([Text -> MIMEValue
parseMIMEMessage Text
as],"")
| Text -> Text -> Bool
T.isPrefixOf "--" Text
bs = ([Text -> MIMEValue
parseMIMEMessage Text
as], Text -> Text
dropTrailer Text
bs)
| Bool
otherwise = let (zs :: [MIMEValue]
zs,ys :: 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
(as :: Text
as,bs :: Text
bs) = Text -> Text -> (Text, Text)
matchUntil Text
dashBoundary Text
xs
dropTrailer :: Text -> Text
dropTrailer xs :: Text
xs
| "\r\n" Text -> Text -> Bool
`T.isPrefixOf` Text
xs1 = Int -> Text -> Text
T.drop 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 str :: Text
str
| Text -> Bool
T.null Text
minor0 = String -> Maybe Type -> Maybe Type
forall a. String -> a -> a
doTrace ("unable to parse content-type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
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 -> [MIMEParam] -> Type
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
(maj :: Text
maj, minor0 :: Text
minor0) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='/') (Text -> Text
dropFoldingWSP Text
str)
minor :: Text
minor = Int -> Text -> Text
T.drop 1 Text
minor0
(as :: Text
as, bs :: Text
bs) = (Char -> Bool) -> Text -> (Text, Text)
T.break (\ ch :: Char
ch -> Char -> Bool
isHSpace Char
ch Bool -> Bool -> Bool
|| Char -> Bool
isTSpecial Char
ch) Text
minor
toType :: Text -> Text -> MIMEType
toType a :: Text
a b :: 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 ctor :: Text -> MIMEType
ctor -> Text -> MIMEType
ctor Text
b
_ -> Text -> Text -> MIMEType
Other Text
a Text
b
parseParams :: T.Text -> [MIMEParam]
parseParams :: Text -> [MIMEParam]
parseParams t :: Text
t | Text -> Bool
T.null Text
t = []
| ';' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Char
T.head Text
t = let (nm_raw :: Text
nm_raw, vs0 :: Text
vs0) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='=') (Text -> Text
dropFoldingWSP (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ 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 = Text -> Text
T.tail Text
vs0 in
if Bool -> Bool
not (Text -> Bool
T.null Text
vs) Bool -> Bool -> Bool
&& Text -> Char
T.head Text
vs Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '"'
then let vs1 :: Text
vs1 = Text -> Text
T.tail Text
vs
(val :: Text
val, zs0 :: Text
zs0) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='"') 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
$ Text -> Text
T.tail Text
zs0)
else let (val :: Text
val, zs :: Text
zs) = (Char -> Bool) -> Text -> (Text, Text)
T.break (\ch :: 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 = String -> [MIMEParam] -> [MIMEParam]
forall a. String -> a -> a
doTrace ("Codec.MIME.Parse.parseParams: curious param value -- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
t) []
mediaTypes :: [(T.Text, T.Text -> MIMEType)]
mediaTypes :: [(Text, Text -> MIMEType)]
mediaTypes =
[ ("multipart", (Multipart -> MIMEType
Multipart (Multipart -> MIMEType) -> (Text -> Multipart) -> Text -> MIMEType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Multipart
toMultipart))
, ("application", Text -> MIMEType
Application)
, ("audio", Text -> MIMEType
Audio)
, ("image", Text -> MIMEType
Image)
, ("message", Text -> MIMEType
Message)
, ("model", Text -> MIMEType
Model)
, ("text", Text -> MIMEType
Text)
, ("video", Text -> MIMEType
Video)
]
where toMultipart :: Text -> Multipart
toMultipart b :: 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 "x-" Text
b = Text -> Multipart
Extension Text
b
| Bool
otherwise = Text -> Multipart
OtherMulti Text
b
multipartTypes :: [(T.Text, Multipart)]
multipartTypes :: [(Text, Multipart)]
multipartTypes =
[ ("alternative", Multipart
Alternative)
, ("byteranges", Multipart
Byteranges)
, ("digest", Multipart
Digest)
, ("encrypted", Multipart
Encrypted)
, ("form-data", Multipart
FormData)
, ("mixed", Multipart
Mixed)
, ("parallel", Multipart
Parallel)
, ("related", Multipart
Related)
, ("signed", Multipart
Signed)
]
untilMatch :: T.Text -> T.Text -> Maybe T.Text
untilMatch :: Text -> Text -> Maybe Text
untilMatch a :: Text
a b :: 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
$ Text -> Text
T.tail Text
b
matchUntil :: T.Text -> T.Text -> (T.Text, T.Text)
matchUntil :: Text -> Text -> (Text, Text)
matchUntil str :: Text
str = (Text -> Text) -> (Text, Text) -> (Text, Text)
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
. Text -> Text -> (Text, Text)
T.breakOn Text
str
isHSpace :: Char -> Bool
isHSpace :: Char -> Bool
isHSpace c :: Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\t'
isTSpecial :: Char -> Bool
isTSpecial :: Char -> Bool
isTSpecial x :: Char
x = Char
x Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ("()<>@,;:\\\"/[]?="::String)
dropFoldingWSP :: T.Text -> T.Text
dropFoldingWSP :: Text -> Text
dropFoldingWSP t :: Text
t | Text -> Bool
T.null Text
t = ""
| Char -> Bool
isHSpace (Text -> Char
T.head Text
t) = Text -> Text
dropFoldingWSP (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.tail Text
t
| "\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 2 Text
t) Bool -> Bool -> Bool
&& Char -> Bool
isHSpace (Text -> Char
T.head (Text -> Char) -> Text -> Char
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop 2 Text
t)
= Text -> Text
dropFoldingWSP (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop 3 Text
t
| Bool
otherwise = Text
t
takeUntilCRLF :: T.Text -> (T.Text, T.Text)
takeUntilCRLF :: Text -> (Text, Text)
takeUntilCRLF str :: Text
str = Text -> Text -> (Text, Text)
go "" Text
str
where
go :: Text -> Text -> (Text, Text)
go acc :: Text
acc t :: Text
t | Text -> Bool
T.null Text
t = (Text -> Text
T.reverse ((Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isHSpace Text
acc), "")
| "\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 2 Text
t) Bool -> Bool -> Bool
&& Char -> Bool
isHSpace (Text -> Char
T.head (Text -> Char) -> Text -> Char
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop 2 Text
t)
= Text -> Text -> (Text, Text)
go (" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
acc) (Int -> Text -> Text
T.drop 3 Text
t)
| "\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 2 Text
t)
= (Text -> Text
T.reverse ((Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isHSpace Text
acc), Int -> Text -> Text
T.drop 2 Text
t)
| Bool
otherwise = Text -> Text -> (Text, Text)
go (Int -> Text -> Text
T.take 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
$ Text -> Text
T.tail Text
t
lookupField :: T.Text -> [(T.Text,a)] -> Maybe a
lookupField :: Text -> [(Text, a)] -> Maybe a
lookupField n :: Text
n ns :: [(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
Nothing ->
let nl :: Text
nl = Text -> Text
T.toLower Text
n in
((Text, a) -> a) -> Maybe (Text, a) -> Maybe a
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