1{-# LANGUAGE ConstraintKinds #-} 2{-# LANGUAGE CPP #-} 3{-# LANGUAGE DataKinds #-} 4{-# LANGUAGE DefaultSignatures #-} 5{-# LANGUAGE DeriveGeneric #-} 6{-# LANGUAGE FlexibleContexts #-} 7{-# LANGUAGE FlexibleInstances #-} 8{-# LANGUAGE GeneralizedNewtypeDeriving #-} 9{-# LANGUAGE KindSignatures #-} 10{-# LANGUAGE MultiParamTypeClasses #-} 11{-# LANGUAGE OverloadedStrings #-} 12{-# LANGUAGE PolyKinds #-} 13{-# LANGUAGE ScopedTypeVariables #-} 14{-# LANGUAGE TypeFamilies #-} 15{-# LANGUAGE TypeOperators #-} 16{-# LANGUAGE UndecidableInstances #-} 17#include "overlapping-compat.h" 18module Web.Internal.FormUrlEncoded where 19 20import Prelude () 21import Prelude.Compat 22 23import Control.Applicative (Const(Const)) 24import Control.Arrow ((***)) 25import Control.Monad ((<=<)) 26import Data.ByteString.Builder (shortByteString, toLazyByteString) 27import qualified Data.ByteString.Lazy as BSL 28import qualified Data.ByteString.Lazy.Char8 as BSL8 29import Data.Coerce (coerce) 30import qualified Data.Foldable as F 31import Data.Functor.Identity (Identity(Identity)) 32import Data.Hashable (Hashable) 33import Data.HashMap.Strict (HashMap) 34import qualified Data.HashMap.Strict as HashMap 35import Data.Int (Int16, Int32, Int64, Int8) 36import Data.IntMap (IntMap) 37import qualified Data.IntMap as IntMap 38import Data.List (intersperse, sortBy) 39import Data.Map (Map) 40import qualified Data.Map as Map 41import Data.Monoid (All (..), Any (..), Dual (..), 42 Product (..), Sum (..)) 43import Data.Ord (comparing) 44import Data.Proxy (Proxy (..)) 45import Data.Semigroup (Semigroup (..)) 46import qualified Data.Semigroup as Semi 47import Data.Tagged (Tagged (..)) 48import Data.Text (Text) 49import qualified Data.Text as Text 50import qualified Data.Text.Encoding as Text 51import Data.Text.Encoding.Error (lenientDecode) 52import qualified Data.Text.Lazy as Lazy 53import Data.Time.Compat (Day, LocalTime, NominalDiffTime, 54 UTCTime, ZonedTime) 55import Data.Time.Calendar.Month.Compat (Month) 56import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..)) 57import Data.Void (Void) 58import Data.Word (Word16, Word32, Word64, Word8) 59import GHC.Exts (Constraint, IsList (..)) 60import GHC.Generics 61import GHC.TypeLits 62import Network.HTTP.Types.URI (urlDecode, urlEncodeBuilder) 63import Numeric.Natural (Natural) 64import Web.Internal.HttpApiData 65 66-- $setup 67-- >>> :set -XDeriveGeneric 68-- >>> :set -XOverloadedLists 69-- >>> :set -XOverloadedStrings 70-- >>> :set -XFlexibleContexts 71-- >>> :set -XScopedTypeVariables 72-- >>> :set -XTypeFamilies 73-- >>> import Data.Char (toLower) 74-- 75-- >>> data Person = Person { name :: String, age :: Int } deriving (Show, Generic) 76-- >>> instance ToForm Person 77-- >>> 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'). 89class ToFormKey k where 90 -- | Render a key for a 'Form'. 91 toFormKey :: k -> Text 92 93instance ToFormKey () where toFormKey = toQueryParam 94instance ToFormKey Char where toFormKey = toQueryParam 95 96instance ToFormKey Bool where toFormKey = toQueryParam 97instance ToFormKey Ordering where toFormKey = toQueryParam 98 99instance ToFormKey Double where toFormKey = toQueryParam 100instance ToFormKey Float where toFormKey = toQueryParam 101instance ToFormKey Int where toFormKey = toQueryParam 102instance ToFormKey Int8 where toFormKey = toQueryParam 103instance ToFormKey Int16 where toFormKey = toQueryParam 104instance ToFormKey Int32 where toFormKey = toQueryParam 105instance ToFormKey Int64 where toFormKey = toQueryParam 106instance ToFormKey Integer where toFormKey = toQueryParam 107instance ToFormKey Word where toFormKey = toQueryParam 108instance ToFormKey Word8 where toFormKey = toQueryParam 109instance ToFormKey Word16 where toFormKey = toQueryParam 110instance ToFormKey Word32 where toFormKey = toQueryParam 111instance ToFormKey Word64 where toFormKey = toQueryParam 112 113instance ToFormKey Day where toFormKey = toQueryParam 114instance ToFormKey LocalTime where toFormKey = toQueryParam 115instance ToFormKey ZonedTime where toFormKey = toQueryParam 116instance ToFormKey UTCTime where toFormKey = toQueryParam 117instance ToFormKey NominalDiffTime where toFormKey = toQueryParam 118instance ToFormKey Quarter where toFormKey = toQueryParam 119instance ToFormKey QuarterOfYear where toFormKey = toQueryParam 120instance ToFormKey Month where toFormKey = toQueryParam 121 122instance ToFormKey String where toFormKey = toQueryParam 123instance ToFormKey Text where toFormKey = toQueryParam 124instance ToFormKey Lazy.Text where toFormKey = toQueryParam 125 126instance ToFormKey All where toFormKey = toQueryParam 127instance ToFormKey Any where toFormKey = toQueryParam 128 129instance ToFormKey a => ToFormKey (Dual a) where toFormKey = coerce (toFormKey :: a -> Text) 130instance ToFormKey a => ToFormKey (Sum a) where toFormKey = coerce (toFormKey :: a -> Text) 131instance ToFormKey a => ToFormKey (Product a) where toFormKey = coerce (toFormKey :: a -> Text) 132 133instance ToFormKey a => ToFormKey (Semi.Min a) where toFormKey = coerce (toFormKey :: a -> Text) 134instance ToFormKey a => ToFormKey (Semi.Max a) where toFormKey = coerce (toFormKey :: a -> Text) 135instance ToFormKey a => ToFormKey (Semi.First a) where toFormKey = coerce (toFormKey :: a -> Text) 136instance ToFormKey a => ToFormKey (Semi.Last a) where toFormKey = coerce (toFormKey :: a -> Text) 137 138instance ToFormKey a => ToFormKey (Tagged b a) where toFormKey = coerce (toFormKey :: a -> Text) 139 140-- | @since 0.4.2 141instance ToFormKey a => ToFormKey (Identity a) where toFormKey = coerce (toFormKey :: a -> Text) 142 143-- | @since 0.4.2 144instance ToFormKey a => ToFormKey (Const a b) where 145 toFormKey = coerce (toFormKey :: a -> Text) 146 147instance ToFormKey Void where toFormKey = toQueryParam 148instance 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'. 151class FromFormKey k where 152 -- | Parse a key of a 'Form'. 153 parseFormKey :: Text -> Either Text k 154 155instance FromFormKey () where parseFormKey = parseQueryParam 156instance FromFormKey Char where parseFormKey = parseQueryParam 157 158instance FromFormKey Bool where parseFormKey = parseQueryParam 159instance FromFormKey Ordering where parseFormKey = parseQueryParam 160 161instance FromFormKey Double where parseFormKey = parseQueryParam 162instance FromFormKey Float where parseFormKey = parseQueryParam 163instance FromFormKey Int where parseFormKey = parseQueryParam 164instance FromFormKey Int8 where parseFormKey = parseQueryParam 165instance FromFormKey Int16 where parseFormKey = parseQueryParam 166instance FromFormKey Int32 where parseFormKey = parseQueryParam 167instance FromFormKey Int64 where parseFormKey = parseQueryParam 168instance FromFormKey Integer where parseFormKey = parseQueryParam 169instance FromFormKey Word where parseFormKey = parseQueryParam 170instance FromFormKey Word8 where parseFormKey = parseQueryParam 171instance FromFormKey Word16 where parseFormKey = parseQueryParam 172instance FromFormKey Word32 where parseFormKey = parseQueryParam 173instance FromFormKey Word64 where parseFormKey = parseQueryParam 174 175instance FromFormKey Day where parseFormKey = parseQueryParam 176instance FromFormKey LocalTime where parseFormKey = parseQueryParam 177instance FromFormKey ZonedTime where parseFormKey = parseQueryParam 178instance FromFormKey UTCTime where parseFormKey = parseQueryParam 179instance FromFormKey NominalDiffTime where parseFormKey = parseQueryParam 180instance FromFormKey Quarter where parseFormKey = parseQueryParam 181instance FromFormKey QuarterOfYear where parseFormKey = parseQueryParam 182instance FromFormKey Month where parseFormKey = parseQueryParam 183 184instance FromFormKey String where parseFormKey = parseQueryParam 185instance FromFormKey Text where parseFormKey = parseQueryParam 186instance FromFormKey Lazy.Text where parseFormKey = parseQueryParam 187 188instance FromFormKey All where parseFormKey = parseQueryParam 189instance FromFormKey Any where parseFormKey = parseQueryParam 190 191instance FromFormKey a => FromFormKey (Dual a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) 192instance FromFormKey a => FromFormKey (Sum a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) 193instance FromFormKey a => FromFormKey (Product a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) 194 195instance FromFormKey a => FromFormKey (Semi.Min a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) 196instance FromFormKey a => FromFormKey (Semi.Max a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) 197instance FromFormKey a => FromFormKey (Semi.First a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) 198instance FromFormKey a => FromFormKey (Semi.Last a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) 199 200instance FromFormKey a => FromFormKey (Tagged b a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) 201 202-- | @since 0.4.2 203instance FromFormKey a => FromFormKey (Identity a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) 204 205-- | @since 0.4.2 206instance FromFormKey a => FromFormKey (Const a b) where 207 parseFormKey = coerce (parseFormKey :: Text -> Either Text a) 208 209instance FromFormKey Void where parseFormKey = parseQueryParam 210instance FromFormKey Natural where parseFormKey = parseQueryParam 211 212-- | The contents of a form, not yet URL-encoded. 213-- 214-- 'Form' can be URL-encoded with 'urlEncodeForm' and URL-decoded with 'urlDecodeForm'. 215newtype Form = Form { unForm :: HashMap Text [Text] } 216 deriving (Eq, Read, Generic, Semigroup, Monoid) 217 218instance Show Form where 219 showsPrec d form = showParen (d > 10) $ 220 showString "fromList " . shows (toListStable form) 221 222-- | _NOTE:_ 'toList' is unstable and may result in different key order (but not values). 223-- For a stable conversion use 'toListStable'. 224instance 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'. 230toListStable :: Form -> [(Text, Text)] 231toListStable = sortOn fst . toList 232 233-- | Convert a value into 'Form'. 234-- 235-- An example type and instance: 236-- 237-- @ 238-- {-\# LANGUAGE OverloadedLists \#-} 239-- 240-- data Person = Person 241-- { name :: String 242-- , age :: Int } 243-- 244-- instance 'ToForm' Person where 245-- 'toForm' person = 246-- [ (\"name\", 'toQueryParam' (name person)) 247-- , (\"age\", 'toQueryParam' (age person)) ] 248-- @ 249-- 250-- Instead of manually writing @'ToForm'@ instances you can 251-- use a default generic implementation of @'toForm'@. 252-- 253-- To do that, simply add @deriving 'Generic'@ clause to your datatype 254-- and declare a 'ToForm' instance for your datatype without 255-- giving definition for 'toForm'. 256-- 257-- For instance, the previous example can be simplified into this: 258-- 259-- @ 260-- data Person = Person 261-- { name :: String 262-- , age :: Int 263-- } deriving ('Generic') 264-- 265-- instance 'ToForm' Person 266-- @ 267-- 268-- The default implementation of 'toForm' is 'genericToForm'. 269class ToForm a where 270 -- | Convert a value into 'Form'. 271 toForm :: a -> Form 272 default toForm :: (Generic a, GToForm a (Rep a)) => a -> Form 273 toForm = genericToForm defaultFormOptions 274 275instance ToForm Form where toForm = id 276 277instance (ToFormKey k, ToHttpApiData v) => ToForm [(k, v)] where 278 toForm = fromList . map (toFormKey *** toQueryParam) 279 280instance (ToFormKey k, ToHttpApiData v) => ToForm (Map k [v]) where 281 toForm = fromEntriesByKey . Map.toList 282 283instance (ToFormKey k, ToHttpApiData v) => ToForm (HashMap k [v]) where 284 toForm = fromEntriesByKey . HashMap.toList 285 286instance 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")] 293fromEntriesByKey :: (ToFormKey k, ToHttpApiData v) => [(k, [v])] -> Form 294fromEntriesByKey = Form . HashMap.fromListWith (<>) . map (toFormKey *** map toQueryParam) 295 296data Proxy3 a b c = Proxy3 297 298type 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 310-- | A 'Generic'-based implementation of 'toForm'. 311-- 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" 345genericToForm :: forall a. (Generic a, GToForm a (Rep a)) => FormOptions -> a -> Form 346genericToForm opts = gToForm (Proxy :: Proxy a) opts . from 347 348class GToForm t (f :: * -> *) where 349 gToForm :: Proxy t -> FormOptions -> f x -> Form 350 351instance (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 354instance (GToForm t f) => GToForm t (M1 D x f) where 355 gToForm p opts (M1 a) = gToForm p opts a 356 357instance (GToForm t f) => GToForm t (M1 C x f) where 358 gToForm p opts (M1 a) = gToForm p opts a 359 360instance 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 365instance (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 373instance (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 378instance 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 383instance NotSupported ToForm t "is a sum type" => GToForm t (f :+: g) where gToForm = error "impossible" 384 385-- | Parse 'Form' into a value. 386-- 387-- An example type and instance: 388-- 389-- @ 390-- data Person = Person 391-- { name :: String 392-- , age :: Int } 393-- 394-- instance 'FromForm' Person where 395-- 'fromForm' f = Person 396-- '<$>' 'parseUnique' "name" f 397-- '<*>' 'parseUnique' "age" f 398-- @ 399-- 400-- Instead of manually writing @'FromForm'@ instances you can 401-- use a default generic implementation of @'fromForm'@. 402-- 403-- To do that, simply add @deriving 'Generic'@ clause to your datatype 404-- and declare a 'FromForm' instance for your datatype without 405-- giving definition for 'fromForm'. 406-- 407-- For instance, the previous example can be simplified into this: 408-- 409-- @ 410-- data Person = Person 411-- { name :: String 412-- , age :: Int 413-- } deriving ('Generic') 414-- 415-- instance 'FromForm' Person 416-- @ 417-- 418-- The default implementation of 'fromForm' is 'genericFromForm'. 419-- It only works for records and it will use 'parseQueryParam' for each field's value. 420class FromForm a where 421 -- | 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 426instance FromForm Form where fromForm = pure 427 428-- | _NOTE:_ this conversion is unstable and may result in different key order (but not values). 429instance (FromFormKey k, FromHttpApiData v) => FromForm [(k, v)] where 430 fromForm = fmap (concatMap (\(k, vs) -> map ((,) k) vs)) . toEntriesByKey 431 432instance (Ord k, FromFormKey k, FromHttpApiData v) => FromForm (Map k [v]) where 433 fromForm = fmap (Map.fromListWith (<>)) . toEntriesByKey 434 435instance (Eq k, Hashable k, FromFormKey k, FromHttpApiData v) => FromForm (HashMap k [v]) where 436 fromForm = fmap (HashMap.fromListWith (<>)) . toEntriesByKey 437 438instance 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'. 445toEntriesByKey :: (FromFormKey k, FromHttpApiData v) => Form -> Either Text [(k, [v])] 446toEntriesByKey = 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'. 456toEntriesByKeyStable :: (Ord k, FromFormKey k, FromHttpApiData v) => Form -> Either Text [(k, [v])] 457toEntriesByKeyStable = fmap (sortOn fst) . toEntriesByKey 458 459-- | A 'Generic'-based implementation of 'fromForm'. 460-- 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"]}) 493genericFromForm :: forall a. (Generic a, GFromForm a (Rep a)) => FormOptions -> Form -> Either Text a 494genericFromForm opts f = to <$> gFromForm (Proxy :: Proxy a) opts f 495 496class GFromForm t (f :: * -> *) where 497 gFromForm :: Proxy t -> FormOptions -> Form -> Either Text (f x) 498 499instance (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 502instance GFromForm t f => GFromForm t (M1 D x f) where 503 gFromForm p opts f = M1 <$> gFromForm p opts f 504 505instance GFromForm t f => GFromForm t (M1 C x f) where 506 gFromForm p opts f = M1 <$> gFromForm p opts f 507 508instance 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 513instance (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 518instance (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 523instance 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 528instance 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'. 534urlEncodeForm :: Form -> BSL.ByteString 535urlEncodeForm = urlEncodeParams . toList 536 537-- | Encode a 'Form' to an @application/x-www-form-urlencoded@ 'BSL.ByteString'. 538-- 539-- For an unstable (but faster) encoding see 'urlEncodeForm'. 540-- 541-- Key-value pairs get encoded to @key=value@ and separated by @&@: 542-- 543-- >>> urlEncodeFormStable [("name", "Julian"), ("lastname", "Arni")] 544-- "lastname=Arni&name=Julian" 545-- 546-- Keys with empty values get encoded to just @key@ (without the @=@ sign): 547-- 548-- >>> urlEncodeFormStable [("is_test", "")] 549-- "is_test" 550-- 551-- Empty keys are allowed too: 552-- 553-- >>> urlEncodeFormStable [("", "foobar")] 554-- "=foobar" 555-- 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). 558-- 559-- >>> urlEncodeFormStable [("", "")] 560-- "" 561-- 562-- Everything is escaped with @'escapeURIString' 'isUnreserved'@: 563-- 564-- >>> urlEncodeFormStable [("fullname", "Andres Löh")] 565-- "fullname=Andres%20L%C3%B6h" 566urlEncodeFormStable :: Form -> BSL.ByteString 567urlEncodeFormStable = 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'. 572urlEncodeParams :: [(Text, Text)] -> BSL.ByteString 573urlEncodeParams = 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 579 580-- | Decode an @application/x-www-form-urlencoded@ 'BSL.ByteString' to a 'Form'. 581-- 582-- Key-value pairs get decoded normally: 583-- 584-- >>> urlDecodeForm "name=Greg&lastname=Weber" 585-- Right (fromList [("lastname","Weber"),("name","Greg")]) 586-- 587-- Keys with no values get decoded to pairs with empty values. 588-- 589-- >>> urlDecodeForm "is_test" 590-- Right (fromList [("is_test","")]) 591-- 592-- Empty keys are allowed: 593-- 594-- >>> urlDecodeForm "=foobar" 595-- Right (fromList [("","foobar")]) 596-- 597-- The empty string gets decoded into an empty 'Form': 598-- 599-- >>> urlDecodeForm "" 600-- Right (fromList []) 601-- 602-- Everything is un-escaped with 'unEscapeString': 603-- 604-- >>> urlDecodeForm "fullname=Andres%20L%C3%B6h" 605-- Right (fromList [("fullname","Andres L\246h")]) 606-- 607-- Improperly formed strings result in an error: 608-- 609-- >>> urlDecodeForm "this=has=too=many=equals" 610-- Left "not a valid pair: this=has=too=many=equals" 611urlDecodeForm :: BSL.ByteString -> Either Text Form 612urlDecodeForm = 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'. 617urlDecodeParams :: BSL.ByteString -> Either Text [(Text, Text)] 618urlDecodeParams 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 629 630 631-- | This is a convenience function for decoding a 632-- @application/x-www-form-urlencoded@ 'BSL.ByteString' directly to a datatype 633-- that has an instance of 'FromForm'. 634-- 635-- This is effectively @'fromForm' '<=<' 'urlDecodeForm'@. 636-- 637-- >>> urlDecodeAsForm "name=Dennis&age=22" :: Either Text Person 638-- Right (Person {name = "Dennis", age = 22}) 639urlDecodeAsForm :: FromForm a => BSL.ByteString -> Either Text a 640urlDecodeAsForm = 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'. 650urlEncodeAsForm :: ToForm a => a -> BSL.ByteString 651urlEncodeAsForm = urlEncodeForm . toForm 652 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" 661urlEncodeAsFormStable :: ToForm a => a -> BSL.ByteString 662urlEncodeAsFormStable = 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"] 672lookupAll :: Text -> Form -> [Text] 673lookupAll 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\"" 684lookupMaybe :: Text -> Form -> Either Text (Maybe Text) 685lookupMaybe 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\"" 700lookupUnique :: Text -> Form -> Either Text Text 701lookupUnique 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] 717parseAll :: FromHttpApiData v => Text -> Form -> Either Text [v] 718parseAll 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) 733parseMaybe :: FromHttpApiData v => Text -> Form -> Either Text (Maybe v) 734parseMaybe 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 749parseUnique :: FromHttpApiData v => Text -> Form -> Either Text v 750parseUnique 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}) 778data 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-- @ 790defaultFormOptions :: FormOptions 791defaultFormOptions = FormOptions 792 { fieldLabelModifier = id 793 } 794 795sortOn :: Ord b => (a -> b) -> [a] -> [a] 796sortOn f = sortBy (comparing f) 797