@@ -1,67 +1,36 @@
1−{-# LANGUAGE ConstraintKinds #-}
21{-# LANGUAGE CPP #-}
3−{-# LANGUAGE DataKinds #-}
42{-# LANGUAGE DefaultSignatures #-}
53{-# LANGUAGE DeriveGeneric #-}
64{-# LANGUAGE FlexibleContexts #-}
75{-# LANGUAGE FlexibleInstances #-}
86{-# LANGUAGE GeneralizedNewtypeDeriving #-}
97{-# LANGUAGE KindSignatures #-}
10−{-# LANGUAGE MultiParamTypeClasses #-}
118{-# LANGUAGE OverloadedStrings #-}
129{-# LANGUAGE PolyKinds #-}
1310{-# LANGUAGE ScopedTypeVariables #-}
1411{-# LANGUAGE TypeFamilies #-}
1512{-# LANGUAGE TypeOperators #-}
16−{-# LANGUAGE UndecidableInstances #-}
17−#include "overlapping-compat.h"
1813module Web.Internal.FormUrlEncoded where
1914
20−import Prelude ()
21−import Prelude.Compat
22−
23−import Control.Applicative (Const(Const))
24−import Control.Arrow ((***))
25−import Control.Monad ((<=<))
26−import Data.ByteString.Builder (shortByteString, toLazyByteString)
27−import qualified Data.ByteString.Lazy as BSL
28−import qualified Data.ByteString.Lazy.Char8 as BSL8
29−import Data.Coerce (coerce)
30−import qualified Data.Foldable as F
31−import Data.Functor.Identity (Identity(Identity))
32−import Data.Hashable (Hashable)
33−import Data.HashMap.Strict (HashMap)
34−import qualified Data.HashMap.Strict as HashMap
35−import Data.Int (Int16, Int32, Int64, Int8)
36−import Data.IntMap (IntMap)
37−import qualified Data.IntMap as IntMap
38−import Data.List (intersperse, sortBy)
39−import Data.Map (Map)
40−import qualified Data.Map as Map
41−import Data.Monoid (All (..), Any (..), Dual (..),
42− Product (..), Sum (..))
43−import Data.Ord (comparing)
44−import Data.Proxy (Proxy (..))
45−import Data.Semigroup (Semigroup (..))
46−import qualified Data.Semigroup as Semi
47−import Data.Tagged (Tagged (..))
48−import Data.Text (Text)
49−import qualified Data.Text as Text
50−import qualified Data.Text.Encoding as Text
51−import Data.Text.Encoding.Error (lenientDecode)
52−import qualified Data.Text.Lazy as Lazy
53−import Data.Time.Compat (Day, LocalTime, NominalDiffTime,
54− UTCTime, ZonedTime)
55−import Data.Time.Calendar.Month.Compat (Month)
56−import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..))
57−import Data.Void (Void)
58−import Data.Word (Word16, Word32, Word64, Word8)
59−import GHC.Exts (Constraint, IsList (..))
15+#if __GLASGOW_HASKELL__ < 710
16+import Control.Applicative
17+#endif
18+
19+import Control.Arrow (first, second)
20+import Control.Monad.State
21+import qualified Data.ByteString.Lazy as BSL
22+import qualified Data.ByteString.Lazy.UTF8 as BSLUTF8
23+import qualified Data.Map as M
24+import Data.Monoid
25+import qualified Data.Text as T
26+import Data.Text.Encoding (decodeUtf8With)
27+import Data.Text.Encoding.Error (lenientDecode)
28+import GHC.Exts (IsList (..))
6029import GHC.Generics
61−import GHC.TypeLits
62−import Network.HTTP.Types.URI (urlDecode, urlEncodeBuilder)
63−import Numeric.Natural (Natural)
64−import Web.Internal.HttpApiData
30+import Network.URI (escapeURIString, isUnreserved,
31+ unEscapeString)
32+
33+import Web.Internal.HttpApiData
6534
6635-- $setup
6736-- >>> :set -XDeriveGeneric
@@ -70,165 +39,26 @@ import Web.Internal.HttpApiData
7039-- >>> :set -XFlexibleContexts
7140-- >>> :set -XScopedTypeVariables
7241-- >>> :set -XTypeFamilies
73−-- >>> import Data.Char (toLower)
74−--
42+-- >>> import Data.Either (isLeft)
43+-- >>> import Data.List (sort)
7544-- >>> data Person = Person { name :: String, age :: Int } deriving (Show, Generic)
7645-- >>> instance ToForm Person
7746-- >>> instance FromForm Person
78−--
79−-- >>> data Post = Post { title :: String, subtitle :: Maybe String, comments :: [String]} deriving (Generic, Show)
80−-- >>> instance ToForm Post
81−-- >>> instance FromForm Post
82−--
83−-- >>> data Project = Project { projectName :: String, projectSize :: Int } deriving (Generic, Show)
84−-- >>> let myOptions = FormOptions { fieldLabelModifier = map toLower . drop (length ("project" :: String)) }
85−-- >>> instance ToForm Project where toForm = genericToForm myOptions
86−-- >>> instance FromForm Project where fromForm = genericFromForm myOptions
87−
88−-- | Typeclass for types that can be used as keys in a 'Form'-like container (like 'Map').
89−class ToFormKey k where
90− -- | Render a key for a 'Form'.
91− toFormKey :: k -> Text
92−
93−instance ToFormKey () where toFormKey = toQueryParam
94−instance ToFormKey Char where toFormKey = toQueryParam
95−
96−instance ToFormKey Bool where toFormKey = toQueryParam
97−instance ToFormKey Ordering where toFormKey = toQueryParam
98−
99−instance ToFormKey Double where toFormKey = toQueryParam
100−instance ToFormKey Float where toFormKey = toQueryParam
101−instance ToFormKey Int where toFormKey = toQueryParam
102−instance ToFormKey Int8 where toFormKey = toQueryParam
103−instance ToFormKey Int16 where toFormKey = toQueryParam
104−instance ToFormKey Int32 where toFormKey = toQueryParam
105−instance ToFormKey Int64 where toFormKey = toQueryParam
106−instance ToFormKey Integer where toFormKey = toQueryParam
107−instance ToFormKey Word where toFormKey = toQueryParam
108−instance ToFormKey Word8 where toFormKey = toQueryParam
109−instance ToFormKey Word16 where toFormKey = toQueryParam
110−instance ToFormKey Word32 where toFormKey = toQueryParam
111−instance ToFormKey Word64 where toFormKey = toQueryParam
112−
113−instance ToFormKey Day where toFormKey = toQueryParam
114−instance ToFormKey LocalTime where toFormKey = toQueryParam
115−instance ToFormKey ZonedTime where toFormKey = toQueryParam
116−instance ToFormKey UTCTime where toFormKey = toQueryParam
117−instance ToFormKey NominalDiffTime where toFormKey = toQueryParam
118−instance ToFormKey Quarter where toFormKey = toQueryParam
119−instance ToFormKey QuarterOfYear where toFormKey = toQueryParam
120−instance ToFormKey Month where toFormKey = toQueryParam
121−
122−instance ToFormKey String where toFormKey = toQueryParam
123−instance ToFormKey Text where toFormKey = toQueryParam
124−instance ToFormKey Lazy.Text where toFormKey = toQueryParam
125−
126−instance ToFormKey All where toFormKey = toQueryParam
127−instance ToFormKey Any where toFormKey = toQueryParam
128−
129−instance ToFormKey a => ToFormKey (Dual a) where toFormKey = coerce (toFormKey :: a -> Text)
130−instance ToFormKey a => ToFormKey (Sum a) where toFormKey = coerce (toFormKey :: a -> Text)
131−instance ToFormKey a => ToFormKey (Product a) where toFormKey = coerce (toFormKey :: a -> Text)
132−
133−instance ToFormKey a => ToFormKey (Semi.Min a) where toFormKey = coerce (toFormKey :: a -> Text)
134−instance ToFormKey a => ToFormKey (Semi.Max a) where toFormKey = coerce (toFormKey :: a -> Text)
135−instance ToFormKey a => ToFormKey (Semi.First a) where toFormKey = coerce (toFormKey :: a -> Text)
136−instance ToFormKey a => ToFormKey (Semi.Last a) where toFormKey = coerce (toFormKey :: a -> Text)
137−
138−instance ToFormKey a => ToFormKey (Tagged b a) where toFormKey = coerce (toFormKey :: a -> Text)
139−
140−-- | @since 0.4.2
141−instance ToFormKey a => ToFormKey (Identity a) where toFormKey = coerce (toFormKey :: a -> Text)
142−
143−-- | @since 0.4.2
144−instance ToFormKey a => ToFormKey (Const a b) where
145− toFormKey = coerce (toFormKey :: a -> Text)
146−
147−instance ToFormKey Void where toFormKey = toQueryParam
148−instance ToFormKey Natural where toFormKey = toQueryParam
149−
150−-- | Typeclass for types that can be parsed from keys of a 'Form'. This is the reverse of 'ToFormKey'.
151−class FromFormKey k where
152− -- | Parse a key of a 'Form'.
153− parseFormKey :: Text -> Either Text k
154−
155−instance FromFormKey () where parseFormKey = parseQueryParam
156−instance FromFormKey Char where parseFormKey = parseQueryParam
157−
158−instance FromFormKey Bool where parseFormKey = parseQueryParam
159−instance FromFormKey Ordering where parseFormKey = parseQueryParam
160−
161−instance FromFormKey Double where parseFormKey = parseQueryParam
162−instance FromFormKey Float where parseFormKey = parseQueryParam
163−instance FromFormKey Int where parseFormKey = parseQueryParam
164−instance FromFormKey Int8 where parseFormKey = parseQueryParam
165−instance FromFormKey Int16 where parseFormKey = parseQueryParam
166−instance FromFormKey Int32 where parseFormKey = parseQueryParam
167−instance FromFormKey Int64 where parseFormKey = parseQueryParam
168−instance FromFormKey Integer where parseFormKey = parseQueryParam
169−instance FromFormKey Word where parseFormKey = parseQueryParam
170−instance FromFormKey Word8 where parseFormKey = parseQueryParam
171−instance FromFormKey Word16 where parseFormKey = parseQueryParam
172−instance FromFormKey Word32 where parseFormKey = parseQueryParam
173−instance FromFormKey Word64 where parseFormKey = parseQueryParam
174−
175−instance FromFormKey Day where parseFormKey = parseQueryParam
176−instance FromFormKey LocalTime where parseFormKey = parseQueryParam
177−instance FromFormKey ZonedTime where parseFormKey = parseQueryParam
178−instance FromFormKey UTCTime where parseFormKey = parseQueryParam
179−instance FromFormKey NominalDiffTime where parseFormKey = parseQueryParam
180−instance FromFormKey Quarter where parseFormKey = parseQueryParam
181−instance FromFormKey QuarterOfYear where parseFormKey = parseQueryParam
182−instance FromFormKey Month where parseFormKey = parseQueryParam
183−
184−instance FromFormKey String where parseFormKey = parseQueryParam
185−instance FromFormKey Text where parseFormKey = parseQueryParam
186−instance FromFormKey Lazy.Text where parseFormKey = parseQueryParam
187−
188−instance FromFormKey All where parseFormKey = parseQueryParam
189−instance FromFormKey Any where parseFormKey = parseQueryParam
190−
191−instance FromFormKey a => FromFormKey (Dual a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a)
192−instance FromFormKey a => FromFormKey (Sum a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a)
193−instance FromFormKey a => FromFormKey (Product a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a)
194−
195−instance FromFormKey a => FromFormKey (Semi.Min a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a)
196−instance FromFormKey a => FromFormKey (Semi.Max a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a)
197−instance FromFormKey a => FromFormKey (Semi.First a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a)
198−instance FromFormKey a => FromFormKey (Semi.Last a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a)
199−
200−instance FromFormKey a => FromFormKey (Tagged b a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a)
201−
202−-- | @since 0.4.2
203−instance FromFormKey a => FromFormKey (Identity a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a)
204−
205−-- | @since 0.4.2
206−instance FromFormKey a => FromFormKey (Const a b) where
207− parseFormKey = coerce (parseFormKey :: Text -> Either Text a)
208−
209−instance FromFormKey Void where parseFormKey = parseQueryParam
210−instance FromFormKey Natural where parseFormKey = parseQueryParam
21147
21248-- | The contents of a form, not yet URL-encoded.
21349--
214−-- 'Form' can be URL-encoded with 'urlEncodeForm' and URL-decoded with 'urlDecodeForm'.
215−newtype Form = Form { unForm :: HashMap Text [Text] }
216− deriving (Eq, Read, Generic, Semigroup, Monoid)
50+-- 'Form' can be URL-encoded with 'encodeForm' and URL-decoded with 'decodeForm'.
51+newtype Form = Form { unForm :: M.Map T.Text T.Text }
52+ deriving (Eq, Read, Generic, Monoid)
21753
21854instance Show Form where
21955 showsPrec d form = showParen (d > 10) $
220− showString "fromList " . shows (toListStable form)
56+ showString "fromList " . shows (toList form)
22157
222−-- | _NOTE:_ 'toList' is unstable and may result in different key order (but not values).
223−-- For a stable conversion use 'toListStable'.
22458instance IsList Form where
225− type Item Form = (Text, Text)
226− fromList = Form . HashMap.fromListWith (flip (<>)) . fmap (\(k, v) -> (k, [v]))
227− toList = concatMap (\(k, vs) -> map ((,) k) vs) . HashMap.toList . unForm
228−
229−-- | A stable version of 'toList'.
230−toListStable :: Form -> [(Text, Text)]
231−toListStable = sortOn fst . toList
59+ type Item Form = (T.Text, T.Text)
60+ fromList = Form . M.fromList
61+ toList = M.toList . unForm
23262
23363-- | Convert a value into 'Form'.
23464--
@@ -265,122 +95,59 @@ toListStable = sortOn fst . toList
26595-- instance 'ToForm' Person
26696-- @
26797--
268−-- The default implementation of 'toForm' is 'genericToForm'.
98+-- The default implementation will use 'toQueryParam' for each field's value.
26999class ToForm a where
270100 -- | Convert a value into 'Form'.
271101 toForm :: a -> Form
272− default toForm :: (Generic a, GToForm a (Rep a)) => a -> Form
273− toForm = genericToForm defaultFormOptions
102+ default toForm :: (Generic a, GToForm (Rep a)) => a -> Form
103+ toForm = genericToForm
274104
105+instance ToForm [(T.Text, T.Text)] where toForm = Form . M.fromList
106+instance ToForm (M.Map T.Text T.Text) where toForm = Form
275107instance ToForm Form where toForm = id
276108
277−instance (ToFormKey k, ToHttpApiData v) => ToForm [(k, v)] where
278− toForm = fromList . map (toFormKey *** toQueryParam)
279−
280−instance (ToFormKey k, ToHttpApiData v) => ToForm (Map k [v]) where
281− toForm = fromEntriesByKey . Map.toList
282−
283−instance (ToFormKey k, ToHttpApiData v) => ToForm (HashMap k [v]) where
284− toForm = fromEntriesByKey . HashMap.toList
285−
286−instance ToHttpApiData v => ToForm (IntMap [v]) where
287− toForm = fromEntriesByKey . IntMap.toList
288−
289−-- | Convert a list of entries groupped by key into a 'Form'.
290−--
291−-- >>> fromEntriesByKey [("name",["Nick"]),("color",["red","blue"])]
292−-- fromList [("color","red"),("color","blue"),("name","Nick")]
293−fromEntriesByKey :: (ToFormKey k, ToHttpApiData v) => [(k, [v])] -> Form
294−fromEntriesByKey = Form . HashMap.fromListWith (<>) . map (toFormKey *** map toQueryParam)
295−
296−data Proxy3 a b c = Proxy3
297−
298−type family NotSupported (cls :: k1) (a :: k2) (reason :: Symbol) :: Constraint where
299−#if __GLASGOW_HASKELL__ < 800
300− -- this is just a placeholder case for older GHCs to not freak out on an empty closed type family
301− NotSupported cls a "this type family is actually empty" = ()
302−#else
303− NotSupported cls a reason = TypeError
304− ( 'Text "Cannot derive a Generic-based " ':<>: 'ShowType cls ':<>: 'Text " instance for " ':<>: 'ShowType a ':<>: 'Text "." ':$$:
305− 'ShowType a ':<>: 'Text " " ':<>: 'Text reason ':<>: 'Text "," ':$$:
306− 'Text "but Generic-based " ':<>: 'ShowType cls ':<>: 'Text " instances can be derived only for records" ':$$:
307− 'Text "(i.e. product types with named fields)." )
308−#endif
309−
310109-- | A 'Generic'-based implementation of 'toForm'.
311110-- This is used as a default implementation in 'ToForm'.
312−--
313−-- Note that this only works for records (i.e. product data types with named fields):
314−--
315−-- @
316−-- data Person = Person
317−-- { name :: String
318−-- , age :: Int
319−-- } deriving ('Generic')
320−-- @
321−--
322−-- In this implementation each field's value gets encoded using `toQueryParam`.
323−-- Two field types are exceptions:
324−--
325−-- - for values of type @'Maybe' a@ an entry is added to the 'Form' only when it is @'Just' x@
326−-- and the encoded value is @'toQueryParam' x@; 'Nothing' values are omitted from the 'Form';
327−--
328−-- - for values of type @[a]@ (except @['Char']@) an entry is added for every item in the list;
329−-- if the list is empty no entries are added to the 'Form';
330−--
331−-- Here's an example:
332−--
333−-- @
334−-- data Post = Post
335−-- { title :: String
336−-- , subtitle :: Maybe String
337−-- , comments :: [String]
338−-- } deriving ('Generic', 'Show')
339−--
340−-- instance 'ToForm' Post
341−-- @
342−--
343−-- >>> urlEncodeAsFormStable Post { title = "Test", subtitle = Nothing, comments = ["Nice post!", "+1"] }
344−-- "comments=Nice%20post%21&comments=%2B1&title=Test"
345−genericToForm :: forall a. (Generic a, GToForm a (Rep a)) => FormOptions -> a -> Form
346−genericToForm opts = gToForm (Proxy :: Proxy a) opts . from
347−
348−class GToForm t (f :: * -> *) where
349− gToForm :: Proxy t -> FormOptions -> f x -> Form
350−
351−instance (GToForm t f, GToForm t g) => GToForm t (f :*: g) where
352− gToForm p opts (a :*: b) = gToForm p opts a <> gToForm p opts b
353−
354−instance (GToForm t f) => GToForm t (M1 D x f) where
355− gToForm p opts (M1 a) = gToForm p opts a
356−
357−instance (GToForm t f) => GToForm t (M1 C x f) where
358− gToForm p opts (M1 a) = gToForm p opts a
359−
360−instance OVERLAPPABLE_ (Selector s, ToHttpApiData c) => GToForm t (M1 S s (K1 i c)) where
361− gToForm _ opts (M1 (K1 c)) = fromList [(key, toQueryParam c)]
362− where
363− key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)
364−
365−instance (Selector s, ToHttpApiData c) => GToForm t (M1 S s (K1 i (Maybe c))) where
366− gToForm _ opts (M1 (K1 c)) =
367− case c of
368− Nothing -> mempty
369− Just x -> fromList [(key, toQueryParam x)]
370− where
371− key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)
372−
373−instance (Selector s, ToHttpApiData c) => GToForm t (M1 S s (K1 i [c])) where
374− gToForm _ opts (M1 (K1 cs)) = fromList (map (\c -> (key, toQueryParam c)) cs)
375− where
376− key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)
377−
378−instance OVERLAPPING_ (Selector s) => GToForm t (M1 S s (K1 i String)) where
379− gToForm _ opts (M1 (K1 c)) = fromList [(key, toQueryParam c)]
380− where
381− key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)
382−
383−instance NotSupported ToForm t "is a sum type" => GToForm t (f :+: g) where gToForm = error "impossible"
111+genericToForm :: (Generic a, GToForm (Rep a)) => a -> Form
112+genericToForm x = evalState (unGenericToFormS . gToForm $ from x) (Nothing, 0)
113+
114+-- | A datatype for generically generating forms. The state keeps track of the
115+-- record name currently being inspected (if any) and the field number.
116+newtype GenericToFormS a = GenericToFormS {
117+ unGenericToFormS :: State (Maybe T.Text, Int) a
118+ } deriving (Functor, Applicative, Generic, Monad, MonadState (Maybe T.Text, Int))
119+
120+class GToForm (f :: * -> *) where
121+ gToForm :: f x -> GenericToFormS Form
122+
123+instance (GToForm f, GToForm g) => GToForm (f :*: g) where
124+ gToForm (a :*: b) = do
125+ a' <- gToForm a
126+ modify $ second (+ 1)
127+ b' <- gToForm b
128+ return (a' <> b')
129+
130+instance (GToForm f, GToForm g) => GToForm (f :+: g) where
131+ gToForm (L1 a) = gToForm a
132+ gToForm (R1 a) = gToForm a
133+
134+instance (GToForm f) => GToForm (M1 D x f) where
135+ gToForm (M1 a) = gToForm a
136+
137+instance (GToForm f) => GToForm (M1 C x f) where
138+ gToForm (M1 a) = gToForm a
139+
140+instance {-# OVERLAPPABLE #-} (Selector sel, GToForm f)
141+ => GToForm (M1 S sel f) where
142+ gToForm (M1 a) = modify (first $ const sel) >> gToForm a
143+ where sel = Just . T.pack $ selName (Proxy3 :: Proxy3 sel g p)
144+
145+instance (ToHttpApiData f) => GToForm (K1 i f) where
146+ gToForm (K1 a) = do
147+ s <- get
148+ return . Form $ M.insert (name s) (toQueryParam a) $ mempty
149+ where name (Nothing, i) = T.pack $ show i
150+ name (Just x, _) = x
384151
385152-- | Parse 'Form' into a value.
386153--
@@ -392,9 +159,9 @@ instance NotSupported ToForm t "is a sum type" => GToForm t (f :+: g) where gToF
392159-- , age :: Int }
393160--
394161-- instance 'FromForm' Person where
395−-- 'fromForm' f = Person
396−-- '<$>' 'parseUnique' "name" f
397−-- '<*>' 'parseUnique' "age" f
162+-- 'fromForm' (Form m) = Person
163+-- '\<$\>' maybe (Left "key \"name\" not found") 'parseQueryParam' (lookup "name" m)
164+-- '\<*\>' maybe (Left "key \"age\" not found") 'parseQueryParam' (lookup "name" m)
398165-- @
399166--
400167-- Instead of manually writing @'FromForm'@ instances you can
@@ -415,382 +182,156 @@ instance NotSupported ToForm t "is a sum type" => GToForm t (f :+: g) where gToF
415182-- instance 'FromForm' Person
416183-- @
417184--
418−-- The default implementation of 'fromForm' is 'genericFromForm'.
419−-- It only works for records and it will use 'parseQueryParam' for each field's value.
185+-- The default implementation will use 'parseQueryParam' for each field's value.
420186class FromForm a where
421187 -- | Parse 'Form' into a value.
422− fromForm :: Form -> Either Text a
423− default fromForm :: (Generic a, GFromForm a (Rep a)) => Form -> Either Text a
424− fromForm = genericFromForm defaultFormOptions
425−
426−instance FromForm Form where fromForm = pure
427−
428−-- | _NOTE:_ this conversion is unstable and may result in different key order (but not values).
429−instance (FromFormKey k, FromHttpApiData v) => FromForm [(k, v)] where
430− fromForm = fmap (concatMap (\(k, vs) -> map ((,) k) vs)) . toEntriesByKey
431−
432−instance (Ord k, FromFormKey k, FromHttpApiData v) => FromForm (Map k [v]) where
433− fromForm = fmap (Map.fromListWith (<>)) . toEntriesByKey
188+ fromForm :: Form -> Either T.Text a
189+ default fromForm :: (Generic a, GFromForm (Rep a))
190+ => Form -> Either T.Text a
191+ fromForm = genericFromForm
434192
435−instance (Eq k, Hashable k, FromFormKey k, FromHttpApiData v) => FromForm (HashMap k [v]) where
436− fromForm = fmap (HashMap.fromListWith (<>)) . toEntriesByKey
437−
438−instance FromHttpApiData v => FromForm (IntMap [v]) where
439− fromForm = fmap (IntMap.fromListWith (<>)) . toEntriesByKey
440−
441−-- | Parse a 'Form' into a list of entries groupped by key.
442−--
443−-- _NOTE:_ this conversion is unstable and may result in different key order
444−-- (but not values). For a stable encoding see 'toEntriesByKeyStable'.
445−toEntriesByKey :: (FromFormKey k, FromHttpApiData v) => Form -> Either Text [(k, [v])]
446−toEntriesByKey = traverse parseGroup . HashMap.toList . unForm
447− where
448− parseGroup (k, vs) = (,) <$> parseFormKey k <*> traverse parseQueryParam vs
449−
450−-- | Parse a 'Form' into a list of entries groupped by key.
451−--
452−-- >>> toEntriesByKeyStable [("name", "Nick"), ("color", "red"), ("color", "white")] :: Either Text [(Text, [Text])]
453−-- Right [("color",["red","white"]),("name",["Nick"])]
454−--
455−-- For an unstable (but faster) conversion see 'toEntriesByKey'.
456−toEntriesByKeyStable :: (Ord k, FromFormKey k, FromHttpApiData v) => Form -> Either Text [(k, [v])]
457−toEntriesByKeyStable = fmap (sortOn fst) . toEntriesByKey
193+instance FromForm Form where fromForm = return
194+instance FromForm [(T.Text, T.Text)] where fromForm = return . M.toList . unForm
195+instance FromForm (M.Map T.Text T.Text) where fromForm = return . unForm
458196
459197-- | A 'Generic'-based implementation of 'fromForm'.
460198-- This is used as a default implementation in 'FromForm'.
461−--
462−-- Note that this only works for records (i.e. product data types with named fields):
463−--
464−-- @
465−-- data Person = Person
466−-- { name :: String
467−-- , age :: Int
468−-- } deriving ('Generic')
469−-- @
470−--
471−-- In this implementation each field's value gets decoded using `parseQueryParam`.
472−-- Two field types are exceptions:
473−--
474−-- - for values of type @'Maybe' a@ an entry is parsed if present in the 'Form'
475−-- and the is decoded with 'parseQueryParam'; if no entry is present result is 'Nothing';
476−--
477−-- - for values of type @[a]@ (except @['Char']@) all entries are parsed to produce a list of parsed values;
478−--
479−-- Here's an example:
480−--
481−-- @
482−-- data Post = Post
483−-- { title :: String
484−-- , subtitle :: Maybe String
485−-- , comments :: [String]
486−-- } deriving ('Generic', 'Show')
487−--
488−-- instance 'FromForm' Post
489−-- @
490−--
491−-- >>> urlDecodeAsForm "comments=Nice%20post%21&comments=%2B1&title=Test" :: Either Text Post
492−-- Right (Post {title = "Test", subtitle = Nothing, comments = ["Nice post!","+1"]})
493−genericFromForm :: forall a. (Generic a, GFromForm a (Rep a)) => FormOptions -> Form -> Either Text a
494−genericFromForm opts f = to <$> gFromForm (Proxy :: Proxy a) opts f
495−
496−class GFromForm t (f :: * -> *) where
497− gFromForm :: Proxy t -> FormOptions -> Form -> Either Text (f x)
498−
499−instance (GFromForm t f, GFromForm t g) => GFromForm t (f :*: g) where
500− gFromForm p opts f = (:*:) <$> gFromForm p opts f <*> gFromForm p opts f
501−
502−instance GFromForm t f => GFromForm t (M1 D x f) where
503− gFromForm p opts f = M1 <$> gFromForm p opts f
504−
505−instance GFromForm t f => GFromForm t (M1 C x f) where
506− gFromForm p opts f = M1 <$> gFromForm p opts f
507−
508−instance OVERLAPPABLE_ (Selector s, FromHttpApiData c) => GFromForm t (M1 S s (K1 i c)) where
509− gFromForm _ opts form = M1 . K1 <$> parseUnique key form
510− where
511− key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)
512−
513−instance (Selector s, FromHttpApiData c) => GFromForm t (M1 S s (K1 i (Maybe c))) where
514− gFromForm _ opts form = M1 . K1 <$> parseMaybe key form
515− where
516− key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)
517−
518−instance (Selector s, FromHttpApiData c) => GFromForm t (M1 S s (K1 i [c])) where
519− gFromForm _ opts form = M1 . K1 <$> parseAll key form
520− where
521− key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)
522−
523−instance OVERLAPPING_ (Selector s) => GFromForm t (M1 S s (K1 i String)) where
524− gFromForm _ opts form = M1 . K1 <$> parseUnique key form
525− where
526− key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)
527−
528−instance NotSupported FromForm t "is a sum type" => GFromForm t (f :+: g) where gFromForm = error "impossible"
529−
530−-- | Encode a 'Form' to an @application/x-www-form-urlencoded@ 'BSL.ByteString'.
531−--
532−-- _NOTE:_ this encoding is unstable and may result in different key order
533−-- (but not values). For a stable encoding see 'urlEncodeFormStable'.
534−urlEncodeForm :: Form -> BSL.ByteString
535−urlEncodeForm = urlEncodeParams . toList
199+genericFromForm :: (Generic a, GFromForm (Rep a))
200+ => Form -> Either T.Text a
201+genericFromForm f = to <$> gFromForm f
202+
203+class GFromForm (f :: * -> *) where
204+ gFromForm :: Form -> Either T.Text (f x)
205+
206+instance (GFromForm f, GFromForm g)
207+ => GFromForm (f :*: g) where
208+ gFromForm f = (:*:) <$> gFromForm f <*> gFromForm f
209+
210+instance (GFromForm f, GFromForm g)
211+ => GFromForm (f :+: g) where
212+ gFromForm f = case gFromForm f of
213+ Right a -> return $ L1 a
214+ Left e1 -> case gFromForm f of
215+ Right b -> return $ R1 b
216+ Left e2 -> Left (e1 <> e2)
217+
218+instance (Selector sel, FromHttpApiData f)
219+ => GFromForm (M1 S sel (K1 i f)) where
220+ gFromForm f = case M.lookup sel (unForm f) of
221+ Nothing -> Left $ "Could not find key " <> sel
222+ Just v -> M1 . K1 <$> parseQueryParam v
223+ where sel = T.pack $ selName (Proxy3 :: Proxy3 sel g p)
224+
225+instance (GFromForm f) => GFromForm (M1 D x f) where
226+ gFromForm f = M1 <$> gFromForm f
227+
228+instance (GFromForm f) => GFromForm (M1 C x f) where
229+ gFromForm f = M1 <$> gFromForm f
536230
537231-- | Encode a 'Form' to an @application/x-www-form-urlencoded@ 'BSL.ByteString'.
538232--
539−-- For an unstable (but faster) encoding see 'urlEncodeForm'.
540−--
541233-- Key-value pairs get encoded to @key=value@ and separated by @&@:
542234--
543−-- >>> urlEncodeFormStable [("name", "Julian"), ("lastname", "Arni")]
235+-- >>> encodeForm [("name", "Julian"), ("lastname", "Arni")]
544236-- "lastname=Arni&name=Julian"
545237--
546238-- Keys with empty values get encoded to just @key@ (without the @=@ sign):
547239--
548−-- >>> urlEncodeFormStable [("is_test", "")]
240+-- >>> encodeForm [("is_test", "")]
549241-- "is_test"
550242--
551243-- Empty keys are allowed too:
552244--
553−-- >>> urlEncodeFormStable [("", "foobar")]
245+-- >>> encodeForm [("", "foobar")]
554246-- "=foobar"
555247--
556−-- However, if both key and value are empty, the key-value pair is ignored.
557−-- (This prevents @'urlDecodeForm' . 'urlEncodeFormStable'@ from being a true isomorphism).
248+-- However, if not key and value are empty, the key-value pair is ignored.
249+-- (This prevents @'decodeForm' . 'encodeForm'@ from being a true isomorphism).
558250--
559−-- >>> urlEncodeFormStable [("", "")]
251+-- >>> encodeForm [("", "")]
560252-- ""
561253--
562254-- Everything is escaped with @'escapeURIString' 'isUnreserved'@:
563255--
564−-- >>> urlEncodeFormStable [("fullname", "Andres Löh")]
256+-- >>> encodeForm [("fullname", "Andres Löh")]
565257-- "fullname=Andres%20L%C3%B6h"
566−urlEncodeFormStable :: Form -> BSL.ByteString
567−urlEncodeFormStable = urlEncodeParams . sortOn fst . toList
568−
569−-- | Encode a list of key-value pairs to an @application/x-www-form-urlencoded@ 'BSL.ByteString'.
570−--
571−-- See also 'urlEncodeFormStable'.
572−urlEncodeParams :: [(Text, Text)] -> BSL.ByteString
573−urlEncodeParams = toLazyByteString . mconcat . intersperse (shortByteString "&") . map encodePair
574− where
575− escape = urlEncodeBuilder True . Text.encodeUtf8
576−
577− encodePair (k, "") = escape k
578− encodePair (k, v) = escape k <> shortByteString "=" <> escape v
258+encodeForm :: Form -> BSL.ByteString
259+encodeForm xs =
260+ let escape :: T.Text -> BSL.ByteString
261+ escape = BSLUTF8.fromString . escapeURIString isUnreserved . T.unpack
262+ encodePair :: (T.Text, T.Text) -> BSL.ByteString
263+ encodePair (k, "") = escape k
264+ encodePair (k, v) = escape k <> "=" <> escape v
265+ in BSL.intercalate "&" $ map encodePair $ toList xs
579266
580267-- | Decode an @application/x-www-form-urlencoded@ 'BSL.ByteString' to a 'Form'.
581268--
582269-- Key-value pairs get decoded normally:
583270--
584−-- >>> urlDecodeForm "name=Greg&lastname=Weber"
271+-- >>> decodeForm "name=Greg&lastname=Weber"
585272-- Right (fromList [("lastname","Weber"),("name","Greg")])
586273--
587274-- Keys with no values get decoded to pairs with empty values.
588275--
589−-- >>> urlDecodeForm "is_test"
276+-- >>> decodeForm "is_test"
590277-- Right (fromList [("is_test","")])
591278--
592279-- Empty keys are allowed:
593280--
594−-- >>> urlDecodeForm "=foobar"
281+-- >>> decodeForm "=foobar"
595282-- Right (fromList [("","foobar")])
596283--
597284-- The empty string gets decoded into an empty 'Form':
598285--
599−-- >>> urlDecodeForm ""
286+-- >>> decodeForm ""
600287-- Right (fromList [])
601288--
602289-- Everything is un-escaped with 'unEscapeString':
603290--
604−-- >>> urlDecodeForm "fullname=Andres%20L%C3%B6h"
291+-- >>> decodeForm "fullname=Andres%20L%C3%B6h"
605292-- Right (fromList [("fullname","Andres L\246h")])
606293--
607294-- Improperly formed strings result in an error:
608295--
609−-- >>> urlDecodeForm "this=has=too=many=equals"
296+-- >>> decodeForm "this=has=too=many=equals"
610297-- Left "not a valid pair: this=has=too=many=equals"
611−urlDecodeForm :: BSL.ByteString -> Either Text Form
612−urlDecodeForm = fmap toForm . urlDecodeParams
613−
614−-- | Decode an @application/x-www-form-urlencoded@ 'BSL.ByteString' to a list of key-value pairs.
615−--
616−-- See also 'urlDecodeForm'.
617−urlDecodeParams :: BSL.ByteString -> Either Text [(Text, Text)]
618−urlDecodeParams bs = traverse parsePair pairs
619− where
620− pairs = map (BSL8.split '=') (BSL8.split '&' bs)
621−
622− unescape = Text.decodeUtf8With lenientDecode . urlDecode True . BSL.toStrict
623−
624− parsePair p =
625− case map unescape p of
626− [k, v] -> return (k, v)
627− [k] -> return (k, "")
628− xs -> Left $ "not a valid pair: " <> Text.intercalate "=" xs
298+decodeForm :: BSL.ByteString -> Either T.Text Form
299+decodeForm "" = return mempty
300+decodeForm q = do
301+ let xs :: [T.Text]
302+ xs = T.splitOn "&" . decodeUtf8With lenientDecode . mconcat . BSL.toChunks $ q
303+ parsePair :: T.Text -> Either T.Text (T.Text, T.Text)
304+ parsePair p =
305+ case T.splitOn "=" p of
306+ [k,v] -> return ( unescape k
307+ , unescape v
308+ )
309+ [k] -> return ( unescape k, "" )
310+ _ -> Left $ "not a valid pair: " <> p
311+ unescape :: T.Text -> T.Text
312+ unescape = T.pack . unEscapeString . T.unpack . T.intercalate "%20" . T.splitOn "+"
313+ toForm <$> mapM parsePair xs
629314
315+data Proxy3 a b c = Proxy3
630316
631317-- | This is a convenience function for decoding a
632318-- @application/x-www-form-urlencoded@ 'BSL.ByteString' directly to a datatype
633319-- that has an instance of 'FromForm'.
634320--
635−-- This is effectively @'fromForm' '<=<' 'urlDecodeForm'@.
321+-- This is effectively @'fromForm' '<=<' 'decodeForm'@.
636322--
637−-- >>> urlDecodeAsForm "name=Dennis&age=22" :: Either Text Person
323+-- >>> decodeAsForm "name=Dennis&age=22" :: Either T.Text Person
638324-- Right (Person {name = "Dennis", age = 22})
639−urlDecodeAsForm :: FromForm a => BSL.ByteString -> Either Text a
640−urlDecodeAsForm = fromForm <=< urlDecodeForm
641−
642−-- | This is a convenience function for encoding a datatype that has instance
643−-- of 'ToForm' directly to a @application/x-www-form-urlencoded@
644−-- 'BSL.ByteString'.
645−--
646−-- This is effectively @'urlEncodeForm' . 'toForm'@.
647−--
648−-- _NOTE:_ this encoding is unstable and may result in different key order
649−-- (but not values). For a stable encoding see 'urlEncodeAsFormStable'.
650−urlEncodeAsForm :: ToForm a => a -> BSL.ByteString
651−urlEncodeAsForm = urlEncodeForm . toForm
325+decodeAsForm :: FromForm a => BSL.ByteString -> Either T.Text a
326+decodeAsForm = fromForm <=< decodeForm
652327
653328-- | This is a convenience function for encoding a datatype that has instance
654329-- of 'ToForm' directly to a @application/x-www-form-urlencoded@
655330-- 'BSL.ByteString'.
656331--
657−-- This is effectively @'urlEncodeFormStable' . 'toForm'@.
332+-- This is effectively @'encodeForm' . 'toForm'@.
658333--
659−-- >>> urlEncodeAsFormStable Person {name = "Dennis", age = 22}
334+-- >>> encodeAsForm Person {name = "Dennis", age = 22}
660335-- "age=22&name=Dennis"
661−urlEncodeAsFormStable :: ToForm a => a -> BSL.ByteString
662−urlEncodeAsFormStable = urlEncodeFormStable . toForm
663−
664−-- | Find all values corresponding to a given key in a 'Form'.
665−--
666−-- >>> lookupAll "name" []
667−-- []
668−-- >>> lookupAll "name" [("name", "Oleg")]
669−-- ["Oleg"]
670−-- >>> lookupAll "name" [("name", "Oleg"), ("name", "David")]
671−-- ["Oleg","David"]
672−lookupAll :: Text -> Form -> [Text]
673−lookupAll key = F.concat . HashMap.lookup key . unForm
674−
675−-- | Lookup an optional value for a key.
676−-- Fail if there is more than one value.
677−--
678−-- >>> lookupMaybe "name" []
679−-- Right Nothing
680−-- >>> lookupMaybe "name" [("name", "Oleg")]
681−-- Right (Just "Oleg")
682−-- >>> lookupMaybe "name" [("name", "Oleg"), ("name", "David")]
683−-- Left "Duplicate key \"name\""
684−lookupMaybe :: Text -> Form -> Either Text (Maybe Text)
685−lookupMaybe key form =
686− case lookupAll key form of
687− [] -> pure Nothing
688− [v] -> pure (Just v)
689− _ -> Left $ "Duplicate key " <> Text.pack (show key)
690−
691−-- | Lookup a unique value for a key.
692−-- Fail if there is zero or more than one value.
693−--
694−-- >>> lookupUnique "name" []
695−-- Left "Could not find key \"name\""
696−-- >>> lookupUnique "name" [("name", "Oleg")]
697−-- Right "Oleg"
698−-- >>> lookupUnique "name" [("name", "Oleg"), ("name", "David")]
699−-- Left "Duplicate key \"name\""
700−lookupUnique :: Text -> Form -> Either Text Text
701−lookupUnique key form = do
702− mv <- lookupMaybe key form
703− case mv of
704− Just v -> pure v
705− Nothing -> Left $ "Could not find key " <> Text.pack (show key)
706−
707−-- | Lookup all values for a given key in a 'Form' and parse them with 'parseQueryParams'.
708−--
709−-- >>> parseAll "age" [] :: Either Text [Word8]
710−-- Right []
711−-- >>> parseAll "age" [("age", "8"), ("age", "seven")] :: Either Text [Word8]
712−-- Left "could not parse: `seven' (input does not start with a digit)"
713−-- >>> parseAll "age" [("age", "8"), ("age", "777")] :: Either Text [Word8]
714−-- Left "out of bounds: `777' (should be between 0 and 255)"
715−-- >>> parseAll "age" [("age", "12"), ("age", "25")] :: Either Text [Word8]
716−-- Right [12,25]
717−parseAll :: FromHttpApiData v => Text -> Form -> Either Text [v]
718−parseAll key = parseQueryParams . lookupAll key
719−
720−-- | Lookup an optional value for a given key and parse it with 'parseQueryParam'.
721−-- Fail if there is more than one value for the key.
722−--
723−-- >>> parseMaybe "age" [] :: Either Text (Maybe Word8)
724−-- Right Nothing
725−-- >>> parseMaybe "age" [("age", "12"), ("age", "25")] :: Either Text (Maybe Word8)
726−-- Left "Duplicate key \"age\""
727−-- >>> parseMaybe "age" [("age", "seven")] :: Either Text (Maybe Word8)
728−-- Left "could not parse: `seven' (input does not start with a digit)"
729−-- >>> parseMaybe "age" [("age", "777")] :: Either Text (Maybe Word8)
730−-- Left "out of bounds: `777' (should be between 0 and 255)"
731−-- >>> parseMaybe "age" [("age", "7")] :: Either Text (Maybe Word8)
732−-- Right (Just 7)
733−parseMaybe :: FromHttpApiData v => Text -> Form -> Either Text (Maybe v)
734−parseMaybe key = parseQueryParams <=< lookupMaybe key
735−
736−-- | Lookup a unique value for a given key and parse it with 'parseQueryParam'.
737−-- Fail if there is zero or more than one value for the key.
738−--
739−-- >>> parseUnique "age" [] :: Either Text Word8
740−-- Left "Could not find key \"age\""
741−-- >>> parseUnique "age" [("age", "12"), ("age", "25")] :: Either Text Word8
742−-- Left "Duplicate key \"age\""
743−-- >>> parseUnique "age" [("age", "seven")] :: Either Text Word8
744−-- Left "could not parse: `seven' (input does not start with a digit)"
745−-- >>> parseUnique "age" [("age", "777")] :: Either Text Word8
746−-- Left "out of bounds: `777' (should be between 0 and 255)"
747−-- >>> parseUnique "age" [("age", "7")] :: Either Text Word8
748−-- Right 7
749−parseUnique :: FromHttpApiData v => Text -> Form -> Either Text v
750−parseUnique key form = lookupUnique key form >>= parseQueryParam
751−
752−-- | 'Generic'-based deriving options for 'ToForm' and 'FromForm'.
753−--
754−-- A common use case for non-default 'FormOptions'
755−-- is to strip a prefix off of field labels:
756−--
757−-- @
758−-- data Project = Project
759−-- { projectName :: String
760−-- , projectSize :: Int
761−-- } deriving ('Generic', 'Show')
762−--
763−-- myOptions :: 'FormOptions'
764−-- myOptions = 'FormOptions'
765−-- { 'fieldLabelModifier' = 'map' 'toLower' . 'drop' ('length' \"project\") }
766−--
767−-- instance 'ToForm' Project where
768−-- 'toForm' = 'genericToForm' myOptions
769−--
770−-- instance 'FromForm' Project where
771−-- 'fromForm' = 'genericFromForm' myOptions
772−-- @
773−--
774−-- >>> urlEncodeAsFormStable Project { projectName = "http-api-data", projectSize = 172 }
775−-- "name=http-api-data&size=172"
776−-- >>> urlDecodeAsForm "name=http-api-data&size=172" :: Either Text Project
777−-- Right (Project {projectName = "http-api-data", projectSize = 172})
778−data FormOptions = FormOptions
779− { -- | Function applied to field labels. Handy for removing common record prefixes for example.
780− fieldLabelModifier :: String -> String
781− }
782−
783−-- | Default encoding 'FormOptions'.
784−--
785−-- @
786−-- 'FormOptions'
787−-- { 'fieldLabelModifier' = id
788−-- }
789−-- @
790−defaultFormOptions :: FormOptions
791−defaultFormOptions = FormOptions
792− { fieldLabelModifier = id
793− }
794−
795−sortOn :: Ord b => (a -> b) -> [a] -> [a]
796−sortOn f = sortBy (comparing f)
336+encodeAsForm :: ToForm a => a -> BSL.ByteString
337+encodeAsForm = encodeForm . toForm