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
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
|
{-# LANGUAGE QuasiQuotes #-}
module Multipart2 where
import Control.Monad.Logger (MonadLogger)
import Control.Selective (Selective)
import Data.ByteString.Lazy qualified as Lazy
import Data.DList (DList)
import Data.DList qualified as DList
import Data.Error.Tree
import Data.Functor.Compose
import Data.List qualified as List
import FieldParser
import Label
import Network.Wai qualified as Wai
import Network.Wai.Parse qualified as Wai
import PossehlAnalyticsPrelude
import ValidationParseT
data FormFields = FormFields
{ inputs :: [Wai.Param],
files :: [MultipartFile Lazy.ByteString]
}
-- | A parser for a HTTP multipart form (a form sent by the browser)
newtype MultipartParseT backend m a = MultipartParseT
{ unMultipartParseT ::
FormFields ->
m (Validation (NonEmpty Error) a)
}
deriving
(Functor, Applicative, Selective)
via (ValidationParseT FormFields m)
-- | After parsing a form, either we get the result or a list of form fields that failed
newtype FormValidation a
= FormValidation
(DList FormValidationResult, Maybe a)
deriving (Functor, Applicative, Selective) via (Compose ((,) (DList FormValidationResult)) Maybe)
deriving stock (Show)
data FormValidationResult = FormValidationResult
{ hasError :: Maybe Error,
formFieldName :: ByteString,
originalValue :: ByteString
}
deriving stock (Show)
mkFormValidationResult ::
( HasField "formFieldName" form ByteString,
HasField "originalValue" form ByteString
) =>
form ->
Maybe Error ->
FormValidationResult
mkFormValidationResult form err =
FormValidationResult
{ hasError = err,
formFieldName = form.formFieldName,
originalValue = form.originalValue
}
eitherToFormValidation ::
( HasField "formFieldName" form ByteString,
HasField "originalValue" form ByteString
) =>
form ->
Either Error a ->
FormValidation a
eitherToFormValidation form = \case
Left err ->
FormValidation $ (DList.singleton $ mkFormValidationResult form (Just err), Nothing)
Right a ->
FormValidation $ ((DList.singleton $ mkFormValidationResult form Nothing), Just a)
failFormValidation ::
( HasField "formFieldName" form ByteString,
HasField "originalValue" form ByteString
) =>
form ->
Error ->
FormValidation a
failFormValidation form err =
FormValidation (DList.singleton $ mkFormValidationResult form (Just err), Nothing)
-- | Parse the multipart form or throw a user error with a descriptive error message.
parseMultipartOrThrow ::
(MonadLogger m, MonadIO m) =>
(ErrorTree -> m a) ->
MultipartParseT backend m a ->
Wai.Request ->
m a
parseMultipartOrThrow throwF parser req = do
-- TODO: this throws all errors with `error`, so leads to 500 on bad input …
formFields <-
liftIO $
Wai.parseRequestBodyEx
Wai.defaultParseRequestBodyOptions
Wai.lbsBackEnd
req
parser.unMultipartParseT
FormFields
{ inputs = fst formFields,
files = map fileDataToMultipartFile $ snd formFields
}
>>= \case
Failure errs -> throwF (errorTree "Cannot parse the multipart form" errs)
Success a -> pure a
-- | Parse the field out of the multipart message
field :: Applicative m => ByteString -> FieldParser ByteString a -> MultipartParseT backend m a
field fieldName fieldParser = MultipartParseT $ \mp ->
mp.inputs
& findMaybe (\input -> if fst input == fieldName then Just (snd input) else Nothing)
& annotate [fmt|Field "{fieldName}" does not exist in the multipart form|]
>>= runFieldParser fieldParser
& eitherToListValidation
& pure
-- | Parse the field out of the multipart message
field' :: Applicative m => ByteString -> FieldParser ByteString a -> MultipartParseT backend m (FormValidation a)
field' fieldName fieldParser = MultipartParseT $ \mp ->
mp.inputs
& findMaybe (\input -> if fst input == fieldName then Just $ snd input else Nothing)
& annotate [fmt|Field "{fieldName}" does not exist in the multipart form|]
<&> ( \originalValue ->
originalValue
& runFieldParser fieldParser
& eitherToFormValidation
( T2
(label @"formFieldName" fieldName)
(label @"originalValue" originalValue)
)
)
& eitherToListValidation
& pure
-- | Parse the field out of the multipart message, and into a 'Label' of the given name.
fieldLabel :: forall lbl backend m a. Applicative m => ByteString -> FieldParser ByteString a -> MultipartParseT backend m (Label lbl a)
fieldLabel fieldName fieldParser = label @lbl <$> field fieldName fieldParser
-- | Parse the field out of the multipart message, and into a 'Label' of the given name.
fieldLabel' :: forall lbl backend m a. Applicative m => ByteString -> FieldParser ByteString a -> MultipartParseT backend m (FormValidation (Label lbl a))
fieldLabel' fieldName fieldParser = fmap (label @lbl) <$> field' fieldName fieldParser
-- | parse all fields out of the multipart message, with the same parser
allFields :: Applicative m => FieldParser (T2 "key" ByteString "value" ByteString) b -> MultipartParseT backend m [b]
allFields fieldParser = MultipartParseT $ \mp ->
mp.inputs
<&> tupToT2 @"key" @"value"
& traverseValidate (runFieldParser fieldParser)
& eitherToValidation
& pure
tupToT2 :: forall l1 l2 t1 t2. (t1, t2) -> T2 l1 t1 l2 t2
tupToT2 (a, b) = T2 (label a) (label b)
-- | Parse a file by name out of the multipart message
file ::
Applicative m =>
ByteString ->
MultipartParseT backend m (MultipartFile Lazy.ByteString)
file fieldName = MultipartParseT $ \mp ->
mp.files
& List.find (\input -> input.multipartNameAttribute == fieldName)
& annotate [fmt|File "{fieldName}" does not exist in the multipart form|]
& ( \case
Left err -> Failure (singleton err)
Right filePath -> Success filePath
)
& pure
-- | Return all files from the multipart message
allFiles ::
Applicative m =>
MultipartParseT backend m [MultipartFile Lazy.ByteString]
allFiles = MultipartParseT $ \mp -> do
pure $ Success $ mp.files
-- | Ensure there is exactly one file and return it (ignoring the field name)
exactlyOneFile ::
Applicative m =>
MultipartParseT backend m (MultipartFile Lazy.ByteString)
exactlyOneFile = MultipartParseT $ \mp ->
mp.files
& \case
[] -> pure $ failParse "Expected to receive a file, but the multipart form did not contain any files"
[file_] -> pure $ Success file_
more -> pure $ failParse [fmt|Expected to receive exactly one file, but the multipart form contained {List.length more} files|]
where
-- \| Fail to parse the multipart form with the given error message.
failParse :: Text -> Validation (NonEmpty Error) a
failParse = Failure . singleton . newError
newtype GetFileContent backend m content = GetFileContent
{unGetFileContent :: (Wai.Request -> m (Either Error content))}
-- | A file field in a multipart message.
data MultipartFile content = MultipartFile
{ -- | @name@ attribute of the corresponding HTML @\<input\>@
multipartNameAttribute :: ByteString,
-- | name of the file on the client's disk
fileNameOnDisk :: ByteString,
-- | MIME type for the file
fileMimeType :: ByteString,
-- | Content of the file
content :: content
}
-- | Convert the multipart library struct of a multipart file to our own.
fileDataToMultipartFile ::
Wai.File Lazy.ByteString ->
(MultipartFile Lazy.ByteString)
fileDataToMultipartFile (multipartNameAttribute, file_) = do
MultipartFile
{ multipartNameAttribute,
fileNameOnDisk = file_.fileName,
fileMimeType = file_.fileContentType,
content = file_.fileContent
}
|
