@@ -1,53 +1,67 @@
1+{-# LANGUAGE ConstraintKinds #-}
12{-# LANGUAGE CPP #-}
3+{-# LANGUAGE DataKinds #-}
24{-# LANGUAGE DefaultSignatures #-}
35{-# LANGUAGE DeriveGeneric #-}
46{-# LANGUAGE FlexibleContexts #-}
57{-# LANGUAGE FlexibleInstances #-}
68{-# LANGUAGE GeneralizedNewtypeDeriving #-}
79{-# LANGUAGE KindSignatures #-}
10+{-# LANGUAGE MultiParamTypeClasses #-}
811{-# LANGUAGE OverloadedStrings #-}
912{-# LANGUAGE PolyKinds #-}
1013{-# LANGUAGE ScopedTypeVariables #-}
1114{-# LANGUAGE TypeFamilies #-}
1215{-# LANGUAGE TypeOperators #-}
16+{-# LANGUAGE UndecidableInstances #-}
17+#include "overlapping-compat.h"
1318module Web.Internal.FormUrlEncoded where
1419
15−#if __GLASGOW_HASKELL__ < 710
16−import Control.Applicative
17−import Data.Traversable
18−#endif
20+import Prelude ()
21+import Prelude.Compat
1922
23+import Control.Applicative (Const(Const))
2024import Control.Arrow ((***))
2125import Control.Monad ((<=<))
22−import Data.ByteString.Builder (toLazyByteString, shortByteString)
26+import Data.ByteString.Builder (shortByteString, toLazyByteString)
2327import qualified Data.ByteString.Lazy as BSL
2428import qualified Data.ByteString.Lazy.Char8 as BSL8
29+import Data.Coerce (coerce)
2530import qualified Data.Foldable as F
31+import Data.Functor.Identity (Identity(Identity))
2632import Data.Hashable (Hashable)
2733import Data.HashMap.Strict (HashMap)
2834import qualified Data.HashMap.Strict as HashMap
29−import Data.Int
35+import Data.Int (Int16, Int32, Int64, Int8)
3036import Data.IntMap (IntMap)
3137import qualified Data.IntMap as IntMap
32−import Data.List (intersperse)
38+import Data.List (intersperse, sortBy)
3339import Data.Map (Map)
3440import qualified Data.Map as Map
35−import Data.Monoid
36−
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 (..))
3748import Data.Text (Text)
3849import qualified Data.Text as Text
39−import qualified Data.Text.Lazy as Lazy
40−import Data.Text.Encoding as Text
50+import qualified Data.Text.Encoding as Text
4151import Data.Text.Encoding.Error (lenientDecode)
42−
43−import Data.Time
44−import Data.Word
45−
46−import GHC.Exts (IsList (..))
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 (..))
4760import GHC.Generics
48−import URI.ByteString (urlEncodeQuery, urlDecodeQuery)
49−
50−import Web.Internal.HttpApiData
61+import GHC.TypeLits
62+import Network.HTTP.Types.URI (urlDecode, urlEncodeBuilder)
63+import Numeric.Natural (Natural)
64+import Web.Internal.HttpApiData
5165
5266-- $setup
5367-- >>> :set -XDeriveGeneric
@@ -56,11 +70,20 @@ import Web.Internal.HttpApiData
5670-- >>> :set -XFlexibleContexts
5771-- >>> :set -XScopedTypeVariables
5872-- >>> :set -XTypeFamilies
59−-- >>> import Data.Either (isLeft)
60−-- >>> import Data.List (sort)
73+-- >>> import Data.Char (toLower)
74+--
6175-- >>> data Person = Person { name :: String, age :: Int } deriving (Show, Generic)
6276-- >>> instance ToForm Person
6377-- >>> 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
6487
6588-- | Typeclass for types that can be used as keys in a 'Form'-like container (like 'Map').
6689class ToFormKey k where
@@ -92,6 +115,9 @@ instance ToFormKey LocalTime where toFormKey = toQueryParam
92115instance ToFormKey ZonedTime where toFormKey = toQueryParam
93116instance ToFormKey UTCTime where toFormKey = toQueryParam
94117instance 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
95121
96122instance ToFormKey String where toFormKey = toQueryParam
97123instance ToFormKey Text where toFormKey = toQueryParam
@@ -100,9 +126,26 @@ instance ToFormKey Lazy.Text where toFormKey = toQueryParam
100126instance ToFormKey All where toFormKey = toQueryParam
101127instance ToFormKey Any where toFormKey = toQueryParam
102128
103−instance ToFormKey a => ToFormKey (Dual a) where toFormKey = toFormKey . getDual
104−instance ToFormKey a => ToFormKey (Sum a) where toFormKey = toFormKey . getSum
105−instance ToFormKey a => ToFormKey (Product a) where toFormKey = toFormKey . getProduct
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
106149
107150-- | Typeclass for types that can be parsed from keys of a 'Form'. This is the reverse of 'ToFormKey'.
108151class FromFormKey k where
@@ -134,6 +177,9 @@ instance FromFormKey LocalTime where parseFormKey = parseQueryParam
134177instance FromFormKey ZonedTime where parseFormKey = parseQueryParam
135178instance FromFormKey UTCTime where parseFormKey = parseQueryParam
136179instance 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
137183
138184instance FromFormKey String where parseFormKey = parseQueryParam
139185instance FromFormKey Text where parseFormKey = parseQueryParam
@@ -142,25 +188,48 @@ instance FromFormKey Lazy.Text where parseFormKey = parseQueryParam
142188instance FromFormKey All where parseFormKey = parseQueryParam
143189instance FromFormKey Any where parseFormKey = parseQueryParam
144190
145−instance FromFormKey a => FromFormKey (Dual a) where parseFormKey = fmap Dual . parseFormKey
146−instance FromFormKey a => FromFormKey (Sum a) where parseFormKey = fmap Sum . parseFormKey
147−instance FromFormKey a => FromFormKey (Product a) where parseFormKey = fmap Product . parseFormKey
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
148211
149212-- | The contents of a form, not yet URL-encoded.
150213--
151214-- 'Form' can be URL-encoded with 'urlEncodeForm' and URL-decoded with 'urlDecodeForm'.
152215newtype Form = Form { unForm :: HashMap Text [Text] }
153− deriving (Eq, Read, Generic, Monoid)
216+ deriving (Eq, Read, Generic, Semigroup, Monoid)
154217
155218instance Show Form where
156219 showsPrec d form = showParen (d > 10) $
157− showString "fromList " . shows (toList form)
220+ showString "fromList " . shows (toListStable form)
158221
222+-- | _NOTE:_ 'toList' is unstable and may result in different key order (but not values).
223+-- For a stable conversion use 'toListStable'.
159224instance IsList Form where
160225 type Item Form = (Text, Text)
161226 fromList = Form . HashMap.fromListWith (flip (<>)) . fmap (\(k, v) -> (k, [v]))
162227 toList = concatMap (\(k, vs) -> map ((,) k) vs) . HashMap.toList . unForm
163228
229+-- | A stable version of 'toList'.
230+toListStable :: Form -> [(Text, Text)]
231+toListStable = sortOn fst . toList
232+
164233-- | Convert a value into 'Form'.
165234--
166235-- An example type and instance:
@@ -196,12 +265,12 @@ instance IsList Form where
196265-- instance 'ToForm' Person
197266-- @
198267--
199−-- The default implementation will use 'toQueryParam' for each field's value.
268+-- The default implementation of 'toForm' is 'genericToForm'.
200269class ToForm a where
201270 -- | Convert a value into 'Form'.
202271 toForm :: a -> Form
203− default toForm :: (Generic a, GToForm (Rep a)) => a -> Form
204− toForm = genericToForm
272+ default toForm :: (Generic a, GToForm a (Rep a)) => a -> Form
273+ toForm = genericToForm defaultFormOptions
205274
206275instance ToForm Form where toForm = id
207276
@@ -218,30 +287,100 @@ instance ToHttpApiData v => ToForm (IntMap [v]) where
218287 toForm = fromEntriesByKey . IntMap.toList
219288
220289-- | 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")]
221293fromEntriesByKey :: (ToFormKey k, ToHttpApiData v) => [(k, [v])] -> Form
222294fromEntriesByKey = Form . HashMap.fromListWith (<>) . map (toFormKey *** map toQueryParam)
223295
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+
224310-- | A 'Generic'-based implementation of 'toForm'.
225311-- This is used as a default implementation in 'ToForm'.
226−genericToForm :: (Generic a, GToForm (Rep a)) => a -> Form
227−genericToForm = gToForm . from
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
228353
229−class GToForm (f :: * -> *) where
230− gToForm :: f x -> Form
354+instance (GToForm t f) => GToForm t (M1 D x f) where
355+ gToForm p opts (M1 a) = gToForm p opts a
231356
232−instance (GToForm f, GToForm g) => GToForm (f :*: g) where
233− gToForm (a :*: b) = gToForm a <> gToForm b
357+instance (GToForm t f) => GToForm t (M1 C x f) where
358+ gToForm p opts (M1 a) = gToForm p opts a
234359
235−instance (GToForm f) => GToForm (M1 D x f) where
236− gToForm (M1 a) = gToForm a
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)
237364
238−instance (GToForm f) => GToForm (M1 C x f) where
239− gToForm (M1 a) = gToForm a
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)
240372
241−instance (Selector s, ToHttpApiData c) => GToForm (M1 S s (K1 i c)) where
242− gToForm (M1 (K1 c)) = fromList [(key, toQueryParam c)]
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)
243375 where
244− key = Text.pack $ selName (Proxy3 :: Proxy3 s g p)
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"
245384
246385-- | Parse 'Form' into a value.
247386--
@@ -253,9 +392,9 @@ instance (Selector s, ToHttpApiData c) => GToForm (M1 S s (K1 i c)) where
253392-- , age :: Int }
254393--
255394-- instance 'FromForm' Person where
256−-- 'fromForm' (Form m) = Person
257−-- '<$>' 'parseUnique' "name" m
258−-- '<*>' 'parseUnique' "age" m
395+-- 'fromForm' f = Person
396+-- '<$>' 'parseUnique' "name" f
397+-- '<*>' 'parseUnique' "age" f
259398-- @
260399--
261400-- Instead of manually writing @'FromForm'@ instances you can
@@ -276,16 +415,17 @@ instance (Selector s, ToHttpApiData c) => GToForm (M1 S s (K1 i c)) where
276415-- instance 'FromForm' Person
277416-- @
278417--
279−-- The default implementation will use 'parseQueryParam' for each field's value.
418+-- The default implementation of 'fromForm' is 'genericFromForm'.
419+-- It only works for records and it will use 'parseQueryParam' for each field's value.
280420class FromForm a where
281421 -- | Parse 'Form' into a value.
282422 fromForm :: Form -> Either Text a
283− default fromForm :: (Generic a, GFromForm (Rep a))
284− => Form -> Either Text a
285− fromForm = genericFromForm
423+ default fromForm :: (Generic a, GFromForm a (Rep a)) => Form -> Either Text a
424+ fromForm = genericFromForm defaultFormOptions
286425
287426instance FromForm Form where fromForm = pure
288427
428+-- | _NOTE:_ this conversion is unstable and may result in different key order (but not values).
289429instance (FromFormKey k, FromHttpApiData v) => FromForm [(k, v)] where
290430 fromForm = fmap (concatMap (\(k, vs) -> map ((,) k) vs)) . toEntriesByKey
291431
@@ -299,69 +439,143 @@ instance FromHttpApiData v => FromForm (IntMap [v]) where
299439 fromForm = fmap (IntMap.fromListWith (<>)) . toEntriesByKey
300440
301441-- | 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'.
302445toEntriesByKey :: (FromFormKey k, FromHttpApiData v) => Form -> Either Text [(k, [v])]
303446toEntriesByKey = traverse parseGroup . HashMap.toList . unForm
304447 where
305448 parseGroup (k, vs) = (,) <$> parseFormKey k <*> traverse parseQueryParam vs
306449
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
458+
307459-- | A 'Generic'-based implementation of 'fromForm'.
308460-- This is used as a default implementation in 'FromForm'.
309−genericFromForm :: (Generic a, GFromForm (Rep a))
310− => Form -> Either Text a
311−genericFromForm f = to <$> gFromForm f
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
312501
313−class GFromForm (f :: * -> *) where
314− gFromForm :: Form -> Either Text (f x)
502+instance GFromForm t f => GFromForm t (M1 D x f) where
503+ gFromForm p opts f = M1 <$> gFromForm p opts f
315504
316−instance (GFromForm f, GFromForm g) => GFromForm (f :*: g) where
317− gFromForm f = (:*:) <$> gFromForm f <*> gFromForm f
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)
318522
319−instance (Selector s, FromHttpApiData f) => GFromForm (M1 S s (K1 i f)) where
320− gFromForm form = M1 . K1 <$> parseUnique key form
523+instance OVERLAPPING_ (Selector s) => GFromForm t (M1 S s (K1 i String)) where
524+ gFromForm _ opts form = M1 . K1 <$> parseUnique key form
321525 where
322− key = Text.pack $ selName (Proxy3 :: Proxy3 s g p)
526+ key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)
323527
324−instance (GFromForm f) => GFromForm (M1 D x f) where
325− gFromForm f = M1 <$> gFromForm f
528+instance NotSupported FromForm t "is a sum type" => GFromForm t (f :+: g) where gFromForm = error "impossible"
326529
327−instance (GFromForm f) => GFromForm (M1 C x f) where
328− gFromForm f = M1 <$> gFromForm f
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
329536
330537-- | Encode a 'Form' to an @application/x-www-form-urlencoded@ 'BSL.ByteString'.
331538--
539+-- For an unstable (but faster) encoding see 'urlEncodeForm'.
540+--
332541-- Key-value pairs get encoded to @key=value@ and separated by @&@:
333542--
334−-- >>> urlEncodeForm [("name", "Julian"), ("lastname", "Arni")]
543+-- >>> urlEncodeFormStable [("name", "Julian"), ("lastname", "Arni")]
335544-- "lastname=Arni&name=Julian"
336545--
337546-- Keys with empty values get encoded to just @key@ (without the @=@ sign):
338547--
339−-- >>> urlEncodeForm [("is_test", "")]
548+-- >>> urlEncodeFormStable [("is_test", "")]
340549-- "is_test"
341550--
342551-- Empty keys are allowed too:
343552--
344−-- >>> urlEncodeForm [("", "foobar")]
553+-- >>> urlEncodeFormStable [("", "foobar")]
345554-- "=foobar"
346555--
347−-- However, if not key and value are empty, the key-value pair is ignored.
348−-- (This prevents @'urlDecodeForm' . 'urlEncodeForm'@ from being a true isomorphism).
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).
349558--
350−-- >>> urlEncodeForm [("", "")]
559+-- >>> urlEncodeFormStable [("", "")]
351560-- ""
352561--
353562-- Everything is escaped with @'escapeURIString' 'isUnreserved'@:
354563--
355−-- >>> urlEncodeForm [("fullname", "Andres Löh")]
564+-- >>> urlEncodeFormStable [("fullname", "Andres Löh")]
356565-- "fullname=Andres%20L%C3%B6h"
357−urlEncodeForm :: Form -> BSL.ByteString
358−urlEncodeForm = toLazyByteString . mconcat . intersperse (shortByteString "&") . map encodePair . toList
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
359574 where
360− escape = urlEncodeQuery . Text.encodeUtf8
575+ escape = urlEncodeBuilder True . Text.encodeUtf8
361576
362577 encodePair (k, "") = escape k
363− encodePair (k, v) = escape k <> shortByteString "=" <> escape v
364−
578+ encodePair (k, v) = escape k <> shortByteString "=" <> escape v
365579
366580-- | Decode an @application/x-www-form-urlencoded@ 'BSL.ByteString' to a 'Form'.
367581--
@@ -395,11 +609,17 @@ urlEncodeForm = toLazyByteString . mconcat . intersperse (shortByteString "&") .
395609-- >>> urlDecodeForm "this=has=too=many=equals"
396610-- Left "not a valid pair: this=has=too=many=equals"
397611urlDecodeForm :: BSL.ByteString -> Either Text Form
398−urlDecodeForm bs = toForm <$> traverse parsePair pairs
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
399619 where
400620 pairs = map (BSL8.split '=') (BSL8.split '&' bs)
401621
402− unescape = Text.decodeUtf8With lenientDecode . urlDecodeQuery . BSL.toStrict
622+ unescape = Text.decodeUtf8With lenientDecode . urlDecode True . BSL.toStrict
403623
404624 parsePair p =
405625 case map unescape p of
@@ -407,7 +627,6 @@ urlDecodeForm bs = toForm <$> traverse parsePair pairs
407627 [k] -> return (k, "")
408628 xs -> Left $ "not a valid pair: " <> Text.intercalate "=" xs
409629
410−data Proxy3 a b c = Proxy3
411630
412631-- | This is a convenience function for decoding a
413632-- @application/x-www-form-urlencoded@ 'BSL.ByteString' directly to a datatype
@@ -426,21 +645,48 @@ urlDecodeAsForm = fromForm <=< urlDecodeForm
426645--
427646-- This is effectively @'urlEncodeForm' . 'toForm'@.
428647--
429−-- >>> urlEncodeAsForm Person {name = "Dennis", age = 22}
430−-- "age=22&name=Dennis"
648+-- _NOTE:_ this encoding is unstable and may result in different key order
649+-- (but not values). For a stable encoding see 'urlEncodeAsFormStable'.
431650urlEncodeAsForm :: ToForm a => a -> BSL.ByteString
432651urlEncodeAsForm = urlEncodeForm . toForm
433652
653+-- | This is a convenience function for encoding a datatype that has instance
654+-- of 'ToForm' directly to a @application/x-www-form-urlencoded@
655+-- 'BSL.ByteString'.
656+--
657+-- This is effectively @'urlEncodeFormStable' . 'toForm'@.
658+--
659+-- >>> urlEncodeAsFormStable Person {name = "Dennis", age = 22}
660+-- "age=22&name=Dennis"
661+urlEncodeAsFormStable :: ToForm a => a -> BSL.ByteString
662+urlEncodeAsFormStable = urlEncodeFormStable . toForm
663+
434664-- | Find all values corresponding to a given key in a 'Form'.
435665--
436−-- >>> lookupKey "name" []
666+-- >>> lookupAll "name" []
437667-- []
438−-- >>> lookupKey "name" [("name", "Oleg")]
668+-- >>> lookupAll "name" [("name", "Oleg")]
439669-- ["Oleg"]
440−-- >>> lookupKey "name" [("name", "Oleg"), ("name", "David")]
670+-- >>> lookupAll "name" [("name", "Oleg"), ("name", "David")]
441671-- ["Oleg","David"]
442−lookupKey :: Text -> Form -> [Text]
443−lookupKey key = F.concat . HashMap.lookup key . unForm
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)
444690
445691-- | Lookup a unique value for a key.
446692-- Fail if there is zero or more than one value.
@@ -452,13 +698,43 @@ lookupKey key = F.concat . HashMap.lookup key . unForm
452698-- >>> lookupUnique "name" [("name", "Oleg"), ("name", "David")]
453699-- Left "Duplicate key \"name\""
454700lookupUnique :: Text -> Form -> Either Text Text
455−lookupUnique key form =
456− case lookupKey key form of
457− [v] -> pure v
458− [] -> Left $ "Could not find key " <> Text.pack (show key)
459− _ -> Left $ "Duplicate key " <> Text.pack (show key)
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
460735
461736-- | 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.
462738--
463739-- >>> parseUnique "age" [] :: Either Text Word8
464740-- Left "Could not find key \"age\""
@@ -473,16 +749,48 @@ lookupUnique key form =
473749parseUnique :: FromHttpApiData v => Text -> Form -> Either Text v
474750parseUnique key form = lookupUnique key form >>= parseQueryParam
475751
476−-- | Lookup all values for a given key in a 'Form' and parse them with 'parseQueryParams'.
752+-- | 'Generic'-based deriving options for 'ToForm' and 'FromForm'.
477753--
478−-- >>> parseAll "age" [] :: Either Text [Word8]
479−-- Right []
480−-- >>> parseAll "age" [("age", "8"), ("age", "seven")] :: Either Text [Word8]
481−-- Left "could not parse: `seven' (input does not start with a digit)"
482−-- >>> parseAll "age" [("age", "8"), ("age", "777")] :: Either Text [Word8]
483−-- Left "out of bounds: `777' (should be between 0 and 255)"
484−-- >>> parseAll "age" [("age", "12"), ("age", "25")] :: Either Text [Word8]
485−-- Right [12,25]
486−parseAll :: FromHttpApiData v => Text -> Form -> Either Text [v]
487−parseAll key = parseQueryParams . lookupKey key
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+ }
488794
795+sortOn :: Ord b => (a -> b) -> [a] -> [a]
796+sortOn f = sortBy (comparing f)