blob: 773d0b7ea42f0a497764dd2f5bf31ea052e4f439 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
|
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.MIME.Extended
( module Data.MIME
) where
import Control.Lens hiding ((.=))
import Data.Aeson
import Data.ByteString (ByteString)
import Data.ByteString.Extended ()
import Data.CaseInsensitive (CI)
import Data.Either (fromRight)
import Data.List.NonEmpty (NonEmpty)
import Data.MIME
import Data.MIME.EncodedWord
import Data.Maybe (fromMaybe)
import qualified Data.ByteString.Char8 as C8
import qualified Data.CaseInsensitive as CI
import qualified Data.Vector
-- Data.MIME.Boundary.Extra
makeBoundaryUnsafe :: ByteString -> Boundary
makeBoundaryUnsafe = either (error . C8.unpack) id . makeBoundary
instance ToJSON (Message s MIME) where
toJSON (Message h b) =
object
[ "headers" .= toJSON h
, "body" .=
case b of
Part b' -> toJSON b'
Encapsulated b' -> toJSON b'
Multipart _ _ b' -> toJSON b'
FailedParse _ msg -> toJSON msg
]
instance FromJSON (Message s MIME) where
parseJSON =
withObject "MIMEMessage" $ \v -> do
h <- v .: "headers"
b <-
case h ^. contentType of
ContentType "message" "rfc822" _ ->
Encapsulated <$> v .: "body"
ContentType "multipart" _ _ ->
makeMultipart h <$> v .: "body"
_ ->
Part <$> v .: "body"
pure $ Message h b
instance ToJSON Headers where
toJSON (Headers h) =
Array . Data.Vector.fromList . map toJSON' $ h
where
toJSON' (k, v) =
object
[ "key" .= toJSON k
, "value" .= toJSON (decodeEncodedWords defaultCharsets v)
]
instance FromJSON Headers where
parseJSON =
withArray "Headers" $ \v -> do
x <- mapM parseJSON' $ Data.Vector.toList v
pure $ Headers x
where
parseJSON' =
withObject "Header" $ \v ->
(,) <$> v .: "key"
<*> encodeEncodedWords `fmap` (v .: "value")
makeMultipart :: HasHeaders s => s -> NonEmpty MIMEMessage -> MIME
makeMultipart h =
Multipart sub boundary
where
( sub, boundary ) =
either dummyPrep id $ prepMultipart (h ^. contentType)
dummyPrep :: (Show a) => a -> (MultipartSubtype, Boundary)
dummyPrep err =
( Unrecognised $ CI.mk $ C8.pack $ show err
, fromRight (makeBoundaryUnsafe "bad_boundary") $
makeBoundary $ fromMaybe "no_boundary_found" $
firstOf (contentType . mimeBoundary) h
)
-- Stuff below this line taken from Data.MIME.mime'
prepMultipart :: ContentType
-> Either MIMEParseError (MultipartSubtype, Boundary)
prepMultipart ct =
(,) <$> parseSubtype ct <*> parseBoundary ct
parseSubtype :: ContentType
-> Either MIMEParseError MultipartSubtype
parseSubtype ct = case view ctSubtype ct of
"mixed" -> pure Mixed
"alternative" -> pure Alternative
"digest" -> pure Digest
"parallel" -> pure Parallel
"multilingual" -> pure Multilingual
"report" -> Report <$> getRequiredParam "report-type" ct
"signed" -> Signed
<$> getRequiredParam "protocol" ct
<*> getRequiredParam "micalg" ct
"encrypted" -> Encrypted <$> getRequiredParam "protocol" ct
"related" -> Related
<$> ( getRequiredParam "type" ct
>>= \s ->
maybe
(Left $ InvalidParameterValue "type" s)
Right
(preview (parsed parseContentType) s)
)
<*> getOptionalParam "start" ct
<*> getOptionalParam "start-info" ct
unrecognised -> pure $ Unrecognised unrecognised
parseBoundary :: HasParameters s => s -> Either MIMEParseError Boundary
parseBoundary ct =
getRequiredParam "boundary" ct
>>= over _Left (InvalidParameterValue "boundary") . makeBoundary
getRequiredParam :: HasParameters s =>
CI ByteString -> s -> Either MIMEParseError ByteString
getRequiredParam k =
maybe (Left $ RequiredParameterMissing k) Right . preview (rawParameter k)
getOptionalParam :: HasParameters s =>
CI ByteString -> s -> Either a (Maybe ByteString)
getOptionalParam k =
Right . preview (rawParameter k)
data MIMEParseError
= RequiredParameterMissing (CI ByteString)
| InvalidParameterValue (CI ByteString) ByteString
| MultipartParseFail
| EncapsulatedMessageParseFail
deriving (Eq, Show)
|
