@@ -1,36 +1,67 @@
1+{-# LANGUAGE ConstraintKinds #-}
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE CPP #-}
3+{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DefaultSignatures #-}
4{-# LANGUAGE DefaultSignatures #-}
3{-# LANGUAGE DeriveGeneric #-}
5{-# LANGUAGE DeriveGeneric #-}
4{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7{-# LANGUAGE KindSignatures #-}
9{-# LANGUAGE KindSignatures #-}
10+{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE OverloadedStrings #-}
11{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE PolyKinds #-}
12{-# LANGUAGE PolyKinds #-}
10{-# LANGUAGE ScopedTypeVariables #-}
13{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE TypeFamilies #-}
14{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE TypeOperators #-}
15{-# LANGUAGE TypeOperators #-}
16+{-# LANGUAGE UndecidableInstances #-}
17+#include "overlapping-compat.h"
13module Web.Internal.FormUrlEncoded where
18module Web.Internal.FormUrlEncoded where
15−#if __GLASGOW_HASKELL__ < 710
20+import Prelude ()
16−import Control.Applicative
23+import Control.Applicative (Const(Const))
19−import Control.Arrow (first, second)
24+import Control.Arrow ((***))
20−import Control.Monad.State
25+import Control.Monad ((<=<))
26+import Data.ByteString.Builder (shortByteString, toLazyByteString)
21−import qualified Data.ByteString.Lazy as BSL
27+import qualified Data.ByteString.Lazy as BSL
22−import qualified Data.ByteString.Lazy.UTF8 as BSLUTF8
28+import qualified Data.ByteString.Lazy.Char8 as BSL8
29+import Data.Coerce (coerce)
23−import qualified Data.Map as M
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)
40+import qualified Data.Map as Map
24−import Data.Monoid
41+import Data.Monoid (All (..), Any (..), Dual (..),
25−import qualified Data.Text as T
42+ Product (..), Sum (..))
26−import Data.Text.Encoding (decodeUtf8With)
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
27−import Data.Text.Encoding.Error (lenientDecode)
51+import Data.Text.Encoding.Error (lenientDecode)
52+import qualified Data.Text.Lazy as Lazy
53+import Data.Time.Compat (Day, LocalTime, NominalDiffTime,
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)
28−import GHC.Exts (IsList (..))
59+import GHC.Exts (Constraint, IsList (..))
29import GHC.Generics
60import GHC.Generics
30−import Network.URI (escapeURIString, isUnreserved,
61+import GHC.TypeLits
31− unEscapeString)
62+import Network.HTTP.Types.URI (urlDecode, urlEncodeBuilder)
32−
63+import Numeric.Natural (Natural)
33−import Web.Internal.HttpApiData
64+import Web.Internal.HttpApiData
36-- >>> :set -XDeriveGeneric
67-- >>> :set -XDeriveGeneric
@@ -39,26 +70,165 @@ import Web.Internal.HttpApiData
39-- >>> :set -XFlexibleContexts
70-- >>> :set -XFlexibleContexts
40-- >>> :set -XScopedTypeVariables
71-- >>> :set -XScopedTypeVariables
41-- >>> :set -XTypeFamilies
72-- >>> :set -XTypeFamilies
42−-- >>> import Data.Either (isLeft)
73+-- >>> import Data.Char (toLower)
43−-- >>> import Data.List (sort)
74+--
44-- >>> data Person = Person { name :: String, age :: Int } deriving (Show, Generic)
75-- >>> data Person = Person { name :: String, age :: Int } deriving (Show, Generic)
45-- >>> instance ToForm Person
76-- >>> instance ToForm Person
46-- >>> instance FromForm Person
77-- >>> instance FromForm Person
79+-- >>> data Post = Post { title :: String, subtitle :: Maybe String, comments :: [String]} deriving (Generic, Show)
80+-- >>> instance ToForm Post
81+-- >>> instance FromForm Post
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
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
93+instance ToFormKey () where toFormKey = toQueryParam
94+instance ToFormKey Char where toFormKey = toQueryParam
96+instance ToFormKey Bool where toFormKey = toQueryParam
97+instance ToFormKey Ordering where toFormKey = toQueryParam
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
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
122+instance ToFormKey String where toFormKey = toQueryParam
123+instance ToFormKey Text where toFormKey = toQueryParam
124+instance ToFormKey Lazy.Text where toFormKey = toQueryParam
126+instance ToFormKey All where toFormKey = toQueryParam
127+instance ToFormKey Any where toFormKey = toQueryParam
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)
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)
138+instance ToFormKey a => ToFormKey (Tagged b a) where toFormKey = coerce (toFormKey :: a -> Text)
141+instance ToFormKey a => ToFormKey (Identity a) where toFormKey = coerce (toFormKey :: a -> Text)
144+instance ToFormKey a => ToFormKey (Const a b) where
145+ toFormKey = coerce (toFormKey :: a -> Text)
147+instance ToFormKey Void where toFormKey = toQueryParam
148+instance ToFormKey Natural where toFormKey = toQueryParam
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
155+instance FromFormKey () where parseFormKey = parseQueryParam
156+instance FromFormKey Char where parseFormKey = parseQueryParam
158+instance FromFormKey Bool where parseFormKey = parseQueryParam
159+instance FromFormKey Ordering where parseFormKey = parseQueryParam
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
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
184+instance FromFormKey String where parseFormKey = parseQueryParam
185+instance FromFormKey Text where parseFormKey = parseQueryParam
186+instance FromFormKey Lazy.Text where parseFormKey = parseQueryParam
188+instance FromFormKey All where parseFormKey = parseQueryParam
189+instance FromFormKey Any where parseFormKey = parseQueryParam
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)
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)
200+instance FromFormKey a => FromFormKey (Tagged b a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a)
203+instance FromFormKey a => FromFormKey (Identity a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a)
206+instance FromFormKey a => FromFormKey (Const a b) where
207+ parseFormKey = coerce (parseFormKey :: Text -> Either Text a)
209+instance FromFormKey Void where parseFormKey = parseQueryParam
210+instance FromFormKey Natural where parseFormKey = parseQueryParam
48-- | The contents of a form, not yet URL-encoded.
212-- | The contents of a form, not yet URL-encoded.
50−-- 'Form' can be URL-encoded with 'encodeForm' and URL-decoded with 'decodeForm'.
214+-- 'Form' can be URL-encoded with 'urlEncodeForm' and URL-decoded with 'urlDecodeForm'.
51−newtype Form = Form { unForm :: M.Map T.Text T.Text }
215+newtype Form = Form { unForm :: HashMap Text [Text] }
52− deriving (Eq, Read, Generic, Monoid)
216+ deriving (Eq, Read, Generic, Semigroup, Monoid)
54instance Show Form where
218instance Show Form where
55 showsPrec d form = showParen (d > 10) $
219 showsPrec d form = showParen (d > 10) $
56− showString "fromList " . shows (toList form)
220+ showString "fromList " . shows (toListStable form)
222+-- | _NOTE:_ 'toList' is unstable and may result in different key order (but not values).
223+-- For a stable conversion use 'toListStable'.
58instance IsList Form where
224instance IsList Form where
59− type Item Form = (T.Text, T.Text)
225+ type Item Form = (Text, Text)
60− fromList = Form . M.fromList
226+ fromList = Form . HashMap.fromListWith (flip (<>)) . fmap (\(k, v) -> (k, [v]))
61− toList = M.toList . unForm
227+ toList = concatMap (\(k, vs) -> map ((,) k) vs) . HashMap.toList . unForm
229+-- | A stable version of 'toList'.
230+toListStable :: Form -> [(Text, Text)]
231+toListStable = sortOn fst . toList
63-- | Convert a value into 'Form'.
233-- | Convert a value into 'Form'.
@@ -95,59 +265,122 @@ instance IsList Form where
95-- instance 'ToForm' Person
265-- instance 'ToForm' Person
98−-- The default implementation will use 'toQueryParam' for each field's value.
268+-- The default implementation of 'toForm' is 'genericToForm'.
99class ToForm a where
269class ToForm a where
100 -- | Convert a value into 'Form'.
270 -- | Convert a value into 'Form'.
101 toForm :: a -> Form
271 toForm :: a -> Form
102− default toForm :: (Generic a, GToForm (Rep a)) => a -> Form
272+ default toForm :: (Generic a, GToForm a (Rep a)) => a -> Form
103− toForm = genericToForm
273+ toForm = genericToForm defaultFormOptions
105−instance ToForm [(T.Text, T.Text)] where toForm = Form . M.fromList
106−instance ToForm (M.Map T.Text T.Text) where toForm = Form
107instance ToForm Form where toForm = id
275instance ToForm Form where toForm = id
277+instance (ToFormKey k, ToHttpApiData v) => ToForm [(k, v)] where
278+ toForm = fromList . map (toFormKey *** toQueryParam)
280+instance (ToFormKey k, ToHttpApiData v) => ToForm (Map k [v]) where
281+ toForm = fromEntriesByKey . Map.toList
283+instance (ToFormKey k, ToHttpApiData v) => ToForm (HashMap k [v]) where
284+ toForm = fromEntriesByKey . HashMap.toList
286+instance ToHttpApiData v => ToForm (IntMap [v]) where
287+ toForm = fromEntriesByKey . IntMap.toList
289+-- | Convert a list of entries groupped by key into a 'Form'.
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)
296+data Proxy3 a b c = Proxy3
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" = ()
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)." )
109-- | A 'Generic'-based implementation of 'toForm'.
310-- | A 'Generic'-based implementation of 'toForm'.
110-- This is used as a default implementation in 'ToForm'.
311-- This is used as a default implementation in 'ToForm'.
111−genericToForm :: (Generic a, GToForm (Rep a)) => a -> Form
312+--
112−genericToForm x = evalState (unGenericToFormS . gToForm $ from x) (Nothing, 0)
313+-- Note that this only works for records (i.e. product data types with named fields):
114−-- | A datatype for generically generating forms. The state keeps track of the
315+-- @
115−-- record name currently being inspected (if any) and the field number.
316+-- data Person = Person
116−newtype GenericToFormS a = GenericToFormS {
317+-- { name :: String
117− unGenericToFormS :: State (Maybe T.Text, Int) a
318+-- , age :: Int
118− } deriving (Functor, Applicative, Generic, Monad, MonadState (Maybe T.Text, Int))
319+-- } deriving ('Generic')
120−class GToForm (f :: * -> *) where
321+--
121− gToForm :: f x -> GenericToFormS Form
322+-- In this implementation each field's value gets encoded using `toQueryParam`.
122−
323+-- Two field types are exceptions:
123−instance (GToForm f, GToForm g) => GToForm (f :*: g) where
324+--
124− gToForm (a :*: b) = do
325+-- - for values of type @'Maybe' a@ an entry is added to the 'Form' only when it is @'Just' x@
125− a' <- gToForm a
326+-- and the encoded value is @'toQueryParam' x@; 'Nothing' values are omitted from the 'Form';
126− modify $ second (+ 1)
327+--
127− b' <- gToForm b
328+-- - for values of type @[a]@ (except @['Char']@) an entry is added for every item in the list;
128− return (a' <> b')
329+-- if the list is empty no entries are added to the 'Form';
130−instance (GToForm f, GToForm g) => GToForm (f :+: g) where
331+-- Here's an example:
131− gToForm (L1 a) = gToForm a
332+--
132− gToForm (R1 a) = gToForm a
333+-- @
133−
334+-- data Post = Post
336+-- , subtitle :: Maybe String
337+-- , comments :: [String]
338+-- } deriving ('Generic', 'Show')
340+-- instance 'ToForm' Post
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
348+class GToForm t (f :: * -> *) where
349+ gToForm :: Proxy t -> FormOptions -> f x -> Form
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
134−instance (GToForm f) => GToForm (M1 D x f) where
354+instance (GToForm t f) => GToForm t (M1 D x f) where
135− gToForm (M1 a) = gToForm a
355+ gToForm p opts (M1 a) = gToForm p opts a
137−instance (GToForm f) => GToForm (M1 C x f) where
357+instance (GToForm t f) => GToForm t (M1 C x f) where
138− gToForm (M1 a) = gToForm a
358+ gToForm p opts (M1 a) = gToForm p opts a
140−instance {-# OVERLAPPABLE #-} (Selector sel, GToForm f)
360+instance OVERLAPPABLE_ (Selector s, ToHttpApiData c) => GToForm t (M1 S s (K1 i c)) where
141− => GToForm (M1 S sel f) where
361+ gToForm _ opts (M1 (K1 c)) = fromList [(key, toQueryParam c)]
142− gToForm (M1 a) = modify (first $ const sel) >> gToForm a
362+ where
143− where sel = Just . T.pack $ selName (Proxy3 :: Proxy3 sel g p)
363+ key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)
145−instance (ToHttpApiData f) => GToForm (K1 i f) where
365+instance (Selector s, ToHttpApiData c) => GToForm t (M1 S s (K1 i (Maybe c))) where
146− gToForm (K1 a) = do
366+ gToForm _ opts (M1 (K1 c)) =
147− s <- get
367+ case c of
148− return . Form $ M.insert (name s) (toQueryParam a) $ mempty
368+ Nothing -> mempty
149− where name (Nothing, i) = T.pack $ show i
369+ Just x -> fromList [(key, toQueryParam x)]
150− name (Just x, _) = x
370+ where
371+ key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)
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)
376+ key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)
378+instance OVERLAPPING_ (Selector s) => GToForm t (M1 S s (K1 i String)) where
379+ gToForm _ opts (M1 (K1 c)) = fromList [(key, toQueryParam c)]
381+ key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)
383+instance NotSupported ToForm t "is a sum type" => GToForm t (f :+: g) where gToForm = error "impossible"
152-- | Parse 'Form' into a value.
385-- | Parse 'Form' into a value.
@@ -159,9 +392,9 @@ instance (ToHttpApiData f) => GToForm (K1 i f) where
159-- , age :: Int }
392-- , age :: Int }
161-- instance 'FromForm' Person where
394-- instance 'FromForm' Person where
162−-- 'fromForm' (Form m) = Person
395+-- 'fromForm' f = Person
163−-- '\<$\>' maybe (Left "key \"name\" not found") 'parseQueryParam' (lookup "name" m)
396+-- '<$>' 'parseUnique' "name" f
164−-- '\<*\>' maybe (Left "key \"age\" not found") 'parseQueryParam' (lookup "name" m)
397+-- '<*>' 'parseUnique' "age" f
167-- Instead of manually writing @'FromForm'@ instances you can
400-- Instead of manually writing @'FromForm'@ instances you can
@@ -182,156 +415,382 @@ instance (ToHttpApiData f) => GToForm (K1 i f) where
182-- instance 'FromForm' Person
415-- instance 'FromForm' Person
418+-- The default implementation of 'fromForm' is 'genericFromForm'.
185−-- The default implementation will use 'parseQueryParam' for each field's value.
419+-- It only works for records and it will use 'parseQueryParam' for each field's value.
186class FromForm a where
420class FromForm a where
187 -- | Parse 'Form' into a value.
421 -- | Parse 'Form' into a value.
188− fromForm :: Form -> Either T.Text a
422+ fromForm :: Form -> Either Text a
189− default fromForm :: (Generic a, GFromForm (Rep a))
423+ default fromForm :: (Generic a, GFromForm a (Rep a)) => Form -> Either Text a
190− => Form -> Either T.Text a
191− fromForm = genericFromForm
424+ fromForm = genericFromForm defaultFormOptions
426+instance FromForm Form where fromForm = pure
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
432+instance (Ord k, FromFormKey k, FromHttpApiData v) => FromForm (Map k [v]) where
433+ fromForm = fmap (Map.fromListWith (<>)) . toEntriesByKey
193−instance FromForm Form where fromForm = return
435+instance (Eq k, Hashable k, FromFormKey k, FromHttpApiData v) => FromForm (HashMap k [v]) where
194−instance FromForm [(T.Text, T.Text)] where fromForm = return . M.toList . unForm
436+ fromForm = fmap (HashMap.fromListWith (<>)) . toEntriesByKey
195−instance FromForm (M.Map T.Text T.Text) where fromForm = return . unForm
437+
438+instance FromHttpApiData v => FromForm (IntMap [v]) where
439+ fromForm = fmap (IntMap.fromListWith (<>)) . toEntriesByKey
441+-- | Parse a 'Form' into a list of entries groupped by key.
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
448+ parseGroup (k, vs) = (,) <$> parseFormKey k <*> traverse parseQueryParam vs
450+-- | Parse a 'Form' into a list of entries groupped by key.
452+-- >>> toEntriesByKeyStable [("name", "Nick"), ("color", "red"), ("color", "white")] :: Either Text [(Text, [Text])]
453+-- Right [("color",["red","white"]),("name",["Nick"])]
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
197-- | A 'Generic'-based implementation of 'fromForm'.
459-- | A 'Generic'-based implementation of 'fromForm'.
198-- This is used as a default implementation in 'FromForm'.
460-- This is used as a default implementation in 'FromForm'.
462+-- Note that this only works for records (i.e. product data types with named fields):
465+-- data Person = Person
468+-- } deriving ('Generic')
471+-- In this implementation each field's value gets decoded using `parseQueryParam`.
472+-- Two field types are exceptions:
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';
477+-- - for values of type @[a]@ (except @['Char']@) all entries are parsed to produce a list of parsed values;
479+-- Here's an example:
484+-- , subtitle :: Maybe String
485+-- , comments :: [String]
486+-- } deriving ('Generic', 'Show')
488+-- instance 'FromForm' Post
491+-- >>> urlDecodeAsForm "comments=Nice%20post%21&comments=%2B1&title=Test" :: Either Text Post
492+-- Right (Post {title = "Test", subtitle = Nothing, comments = ["Nice post!","+1"]})
199−genericFromForm :: (Generic a, GFromForm (Rep a))
493+genericFromForm :: forall a. (Generic a, GFromForm a (Rep a)) => FormOptions -> Form -> Either Text a
200− => Form -> Either T.Text a
201−genericFromForm f = to <$> gFromForm f
494+genericFromForm opts f = to <$> gFromForm (Proxy :: Proxy a) opts f
203−class GFromForm (f :: * -> *) where
496+class GFromForm t (f :: * -> *) where
204− gFromForm :: Form -> Either T.Text (f x)
497+ gFromForm :: Proxy t -> FormOptions -> Form -> Either Text (f x)
206−instance (GFromForm f, GFromForm g)
499+instance (GFromForm t f, GFromForm t g) => GFromForm t (f :*: g) where
207− => GFromForm (f :*: g) where
208− gFromForm f = (:*:) <$> gFromForm f <*> gFromForm f
500+ gFromForm p opts f = (:*:) <$> gFromForm p opts f <*> gFromForm p opts f
210−instance (GFromForm f, GFromForm g)
502+instance GFromForm t f => GFromForm t (M1 D x f) where
211− => GFromForm (f :+: g) where
503+ gFromForm p opts f = M1 <$> gFromForm p opts f
212− gFromForm f = case gFromForm f of
504+
213− Right a -> return $ L1 a
505+instance GFromForm t f => GFromForm t (M1 C x f) where
214− Left e1 -> case gFromForm f of
506+ gFromForm p opts f = M1 <$> gFromForm p opts f
215− Right b -> return $ R1 b
507+
216− Left e2 -> Left (e1 <> e2)
508+instance OVERLAPPABLE_ (Selector s, FromHttpApiData c) => GFromForm t (M1 S s (K1 i c)) where
217−
509+ gFromForm _ opts form = M1 . K1 <$> parseUnique key form
218−instance (Selector sel, FromHttpApiData f)
510+ where
219− => GFromForm (M1 S sel (K1 i f)) where
511+ key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)
220− gFromForm f = case M.lookup sel (unForm f) of
512+
221− Nothing -> Left $ "Could not find key " <> sel
513+instance (Selector s, FromHttpApiData c) => GFromForm t (M1 S s (K1 i (Maybe c))) where
222− Just v -> M1 . K1 <$> parseQueryParam v
514+ gFromForm _ opts form = M1 . K1 <$> parseMaybe key form
223− where sel = T.pack $ selName (Proxy3 :: Proxy3 sel g p)
515+ where
224−
516+ key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)
225−instance (GFromForm f) => GFromForm (M1 D x f) where
517+
226− gFromForm f = M1 <$> gFromForm f
518+instance (Selector s, FromHttpApiData c) => GFromForm t (M1 S s (K1 i [c])) where
227−
519+ gFromForm _ opts form = M1 . K1 <$> parseAll key form
228−instance (GFromForm f) => GFromForm (M1 C x f) where
520+ where
229− gFromForm f = M1 <$> gFromForm f
521+ key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)
523+instance OVERLAPPING_ (Selector s) => GFromForm t (M1 S s (K1 i String)) where
524+ gFromForm _ opts form = M1 . K1 <$> parseUnique key form
526+ key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)
528+instance NotSupported FromForm t "is a sum type" => GFromForm t (f :+: g) where gFromForm = error "impossible"
530+-- | Encode a 'Form' to an @application/x-www-form-urlencoded@ 'BSL.ByteString'.
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
231-- | Encode a 'Form' to an @application/x-www-form-urlencoded@ 'BSL.ByteString'.
537-- | Encode a 'Form' to an @application/x-www-form-urlencoded@ 'BSL.ByteString'.
539+-- For an unstable (but faster) encoding see 'urlEncodeForm'.
233-- Key-value pairs get encoded to @key=value@ and separated by @&@:
541-- Key-value pairs get encoded to @key=value@ and separated by @&@:
235−-- >>> encodeForm [("name", "Julian"), ("lastname", "Arni")]
543+-- >>> urlEncodeFormStable [("name", "Julian"), ("lastname", "Arni")]
236-- "lastname=Arni&name=Julian"
544-- "lastname=Arni&name=Julian"
238-- Keys with empty values get encoded to just @key@ (without the @=@ sign):
546-- Keys with empty values get encoded to just @key@ (without the @=@ sign):
240−-- >>> encodeForm [("is_test", "")]
548+-- >>> urlEncodeFormStable [("is_test", "")]
241-- "is_test"
549-- "is_test"
243-- Empty keys are allowed too:
551-- Empty keys are allowed too:
245−-- >>> encodeForm [("", "foobar")]
553+-- >>> urlEncodeFormStable [("", "foobar")]
246-- "=foobar"
554-- "=foobar"
248−-- However, if not key and value are empty, the key-value pair is ignored.
556+-- However, if both key and value are empty, the key-value pair is ignored.
249−-- (This prevents @'decodeForm' . 'encodeForm'@ from being a true isomorphism).
557+-- (This prevents @'urlDecodeForm' . 'urlEncodeFormStable'@ from being a true isomorphism).
251−-- >>> encodeForm [("", "")]
559+-- >>> urlEncodeFormStable [("", "")]
254-- Everything is escaped with @'escapeURIString' 'isUnreserved'@:
562-- Everything is escaped with @'escapeURIString' 'isUnreserved'@:
256−-- >>> encodeForm [("fullname", "Andres Löh")]
564+-- >>> urlEncodeFormStable [("fullname", "Andres Löh")]
257-- "fullname=Andres%20L%C3%B6h"
565-- "fullname=Andres%20L%C3%B6h"
258−encodeForm :: Form -> BSL.ByteString
566+urlEncodeFormStable :: Form -> BSL.ByteString
259−encodeForm xs =
567+urlEncodeFormStable = urlEncodeParams . sortOn fst . toList
260− let escape :: T.Text -> BSL.ByteString
568+
261− escape = BSLUTF8.fromString . escapeURIString isUnreserved . T.unpack
569+-- | Encode a list of key-value pairs to an @application/x-www-form-urlencoded@ 'BSL.ByteString'.
571+-- See also 'urlEncodeFormStable'.
262− encodePair :: (T.Text, T.Text) -> BSL.ByteString
572+urlEncodeParams :: [(Text, Text)] -> BSL.ByteString
263− encodePair (k, "") = escape k
573+urlEncodeParams = toLazyByteString . mconcat . intersperse (shortByteString "&") . map encodePair
264− encodePair (k, v) = escape k <> "=" <> escape v
574+ where
265− in BSL.intercalate "&" $ map encodePair $ toList xs
575+ escape = urlEncodeBuilder True . Text.encodeUtf8
577+ encodePair (k, "") = escape k
578+ encodePair (k, v) = escape k <> shortByteString "=" <> escape v
267-- | Decode an @application/x-www-form-urlencoded@ 'BSL.ByteString' to a 'Form'.
580-- | Decode an @application/x-www-form-urlencoded@ 'BSL.ByteString' to a 'Form'.
269-- Key-value pairs get decoded normally:
582-- Key-value pairs get decoded normally:
271−-- >>> decodeForm "name=Greg&lastname=Weber"
584+-- >>> urlDecodeForm "name=Greg&lastname=Weber"
272-- Right (fromList [("lastname","Weber"),("name","Greg")])
585-- Right (fromList [("lastname","Weber"),("name","Greg")])
274-- Keys with no values get decoded to pairs with empty values.
587-- Keys with no values get decoded to pairs with empty values.
276−-- >>> decodeForm "is_test"
589+-- >>> urlDecodeForm "is_test"
277-- Right (fromList [("is_test","")])
590-- Right (fromList [("is_test","")])
279-- Empty keys are allowed:
592-- Empty keys are allowed:
281−-- >>> decodeForm "=foobar"
594+-- >>> urlDecodeForm "=foobar"
282-- Right (fromList [("","foobar")])
595-- Right (fromList [("","foobar")])
284-- The empty string gets decoded into an empty 'Form':
597-- The empty string gets decoded into an empty 'Form':
286−-- >>> decodeForm ""
599+-- >>> urlDecodeForm ""
287-- Right (fromList [])
600-- Right (fromList [])
289-- Everything is un-escaped with 'unEscapeString':
602-- Everything is un-escaped with 'unEscapeString':
291−-- >>> decodeForm "fullname=Andres%20L%C3%B6h"
604+-- >>> urlDecodeForm "fullname=Andres%20L%C3%B6h"
292-- Right (fromList [("fullname","Andres L\246h")])
605-- Right (fromList [("fullname","Andres L\246h")])
294-- Improperly formed strings result in an error:
607-- Improperly formed strings result in an error:
296−-- >>> decodeForm "this=has=too=many=equals"
609+-- >>> urlDecodeForm "this=has=too=many=equals"
297-- Left "not a valid pair: this=has=too=many=equals"
610-- Left "not a valid pair: this=has=too=many=equals"
298−decodeForm :: BSL.ByteString -> Either T.Text Form
611+urlDecodeForm :: BSL.ByteString -> Either Text Form
299−decodeForm "" = return mempty
612+urlDecodeForm = fmap toForm . urlDecodeParams
300−decodeForm q = do
613+
301− let xs :: [T.Text]
614+-- | Decode an @application/x-www-form-urlencoded@ 'BSL.ByteString' to a list of key-value pairs.
616+-- See also 'urlDecodeForm'.
617+urlDecodeParams :: BSL.ByteString -> Either Text [(Text, Text)]
618+urlDecodeParams bs = traverse parsePair pairs
620+ pairs = map (BSL8.split '=') (BSL8.split '&' bs)
302− xs = T.splitOn "&" . decodeUtf8With lenientDecode . mconcat . BSL.toChunks $ q
622+ unescape = Text.decodeUtf8With lenientDecode . urlDecode True . BSL.toStrict
303− parsePair :: T.Text -> Either T.Text (T.Text, T.Text)
623+
304− parsePair p =
624+ parsePair p =
305− case T.splitOn "=" p of
625+ case map unescape p of
306− [k,v] -> return ( unescape k
626+ [k, v] -> return (k, v)
309− [k] -> return ( unescape k, "" )
627+ [k] -> return (k, "")
310− _ -> Left $ "not a valid pair: " <> p
628+ xs -> Left $ "not a valid pair: " <> Text.intercalate "=" xs
311− unescape :: T.Text -> T.Text
312− unescape = T.pack . unEscapeString . T.unpack . T.intercalate "%20" . T.splitOn "+"
313− toForm <$> mapM parsePair xs
315−data Proxy3 a b c = Proxy3
317-- | This is a convenience function for decoding a
631-- | This is a convenience function for decoding a
318-- @application/x-www-form-urlencoded@ 'BSL.ByteString' directly to a datatype
632-- @application/x-www-form-urlencoded@ 'BSL.ByteString' directly to a datatype
319-- that has an instance of 'FromForm'.
633-- that has an instance of 'FromForm'.
321−-- This is effectively @'fromForm' '<=<' 'decodeForm'@.
635+-- This is effectively @'fromForm' '<=<' 'urlDecodeForm'@.
323−-- >>> decodeAsForm "name=Dennis&age=22" :: Either T.Text Person
637+-- >>> urlDecodeAsForm "name=Dennis&age=22" :: Either Text Person
324-- Right (Person {name = "Dennis", age = 22})
638-- Right (Person {name = "Dennis", age = 22})
325−decodeAsForm :: FromForm a => BSL.ByteString -> Either T.Text a
639+urlDecodeAsForm :: FromForm a => BSL.ByteString -> Either Text a
326−decodeAsForm = fromForm <=< decodeForm
640+urlDecodeAsForm = fromForm <=< urlDecodeForm
642+-- | This is a convenience function for encoding a datatype that has instance
643+-- of 'ToForm' directly to a @application/x-www-form-urlencoded@
646+-- This is effectively @'urlEncodeForm' . 'toForm'@.
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
328-- | This is a convenience function for encoding a datatype that has instance
653-- | This is a convenience function for encoding a datatype that has instance
329-- of 'ToForm' directly to a @application/x-www-form-urlencoded@
654-- of 'ToForm' directly to a @application/x-www-form-urlencoded@
330-- 'BSL.ByteString'.
655-- 'BSL.ByteString'.
332−-- This is effectively @'encodeForm' . 'toForm'@.
657+-- This is effectively @'urlEncodeFormStable' . 'toForm'@.
334−-- >>> encodeAsForm Person {name = "Dennis", age = 22}
659+-- >>> urlEncodeAsFormStable Person {name = "Dennis", age = 22}
335-- "age=22&name=Dennis"
660-- "age=22&name=Dennis"
336−encodeAsForm :: ToForm a => a -> BSL.ByteString
661+urlEncodeAsFormStable :: ToForm a => a -> BSL.ByteString
337−encodeAsForm = encodeForm . toForm
662+urlEncodeAsFormStable = urlEncodeFormStable . toForm
664+-- | Find all values corresponding to a given key in a 'Form'.
666+-- >>> lookupAll "name" []
668+-- >>> lookupAll "name" [("name", "Oleg")]
670+-- >>> lookupAll "name" [("name", "Oleg"), ("name", "David")]
672+lookupAll :: Text -> Form -> [Text]
673+lookupAll key = F.concat . HashMap.lookup key . unForm
675+-- | Lookup an optional value for a key.
676+-- Fail if there is more than one value.
678+-- >>> lookupMaybe "name" []
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
688+ [v] -> pure (Just v)
689+ _ -> Left $ "Duplicate key " <> Text.pack (show key)
691+-- | Lookup a unique value for a key.
692+-- Fail if there is zero or more than one value.
694+-- >>> lookupUnique "name" []
695+-- Left "Could not find key \"name\""
696+-- >>> lookupUnique "name" [("name", "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
705+ Nothing -> Left $ "Could not find key " <> Text.pack (show key)
707+-- | Lookup all values for a given key in a 'Form' and parse them with 'parseQueryParams'.
709+-- >>> parseAll "age" [] :: Either Text [Word8]
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]
717+parseAll :: FromHttpApiData v => Text -> Form -> Either Text [v]
718+parseAll key = parseQueryParams . lookupAll key
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.
723+-- >>> parseMaybe "age" [] :: Either Text (Maybe Word8)
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)
733+parseMaybe :: FromHttpApiData v => Text -> Form -> Either Text (Maybe v)
734+parseMaybe key = parseQueryParams <=< lookupMaybe key
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.
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
749+parseUnique :: FromHttpApiData v => Text -> Form -> Either Text v
750+parseUnique key form = lookupUnique key form >>= parseQueryParam
752+-- | 'Generic'-based deriving options for 'ToForm' and 'FromForm'.
754+-- A common use case for non-default 'FormOptions'
755+-- is to strip a prefix off of field labels:
758+-- data Project = Project
759+-- { projectName :: String
760+-- , projectSize :: Int
761+-- } deriving ('Generic', 'Show')
763+-- myOptions :: 'FormOptions'
764+-- myOptions = 'FormOptions'
765+-- { 'fieldLabelModifier' = 'map' 'toLower' . 'drop' ('length' \"project\") }
767+-- instance 'ToForm' Project where
768+-- 'toForm' = 'genericToForm' myOptions
770+-- instance 'FromForm' Project where
771+-- 'fromForm' = 'genericFromForm' myOptions
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
783+-- | Default encoding 'FormOptions'.
787+-- { 'fieldLabelModifier' = id
790+defaultFormOptions :: FormOptions
791+defaultFormOptions = FormOptions
792+ { fieldLabelModifier = id
795+sortOn :: Ord b => (a -> b) -> [a] -> [a]
796+sortOn f = sortBy (comparing f)