http-api-data 0.2.4 → 0.7
raw patch · 15 files changed
Files
- CHANGELOG.md +177/−0
- README.md +3/−1
- Setup.hs +2/−0
- Setup.lhs +0/−48
- http-api-data.cabal +66/−31
- src/Web/FormUrlEncoded.hs +51/−0
- src/Web/HttpApiData.hs +6/−4
- src/Web/HttpApiData/Internal.hs +0/−570
- src/Web/Internal/FormUrlEncoded.hs +795/−0
- src/Web/Internal/HttpApiData.hs +905/−0
- test/DocTest.hs +0/−30
- test/Spec.hs +1/−132
- test/Web/Internal/FormUrlEncodedSpec.hs +63/−0
- test/Web/Internal/HttpApiDataSpec.hs +130/−0
- test/Web/Internal/TestInstances.hs +66/−0
CHANGELOG.md view
@@ -1,3 +1,180 @@+0.7++* Change Form representation to use Map (from `containers`) instead of `HashMap`.+ This prevents possible HashDOS attacks.++0.6.3++* Add To/FromForm instances for () and Void++0.6.2++* Support GHC-9.12+* Require `cookie-0.5.1`++0.6.1++* Require at least GHC-8.6+* Support `cookie-0.5.0`, see [#137](https://github.com/fizruk/http-api-data/pull/137).++ Note that `cookie-0.5.0`'s parser now removes double quotes around cookie values.++0.6+---++* Use [`text-iso8601`](https://hackage.haskell.org/package/text-iso8601)+ to parse and serialise `time` types. (Instead of `attoparsec-iso8601`).+ Due this change some formats are slightly changed:++ - Space between timezone is not accepted+ - Timezone offset can be between -23:59..23:59+ - Timezone offset is output with colon between hours and minutes++* Require at least GHC-8.2++0.5.1+-----++* Add `toEncodedQueryParam` to `ToHttpApiData` type class. It has default+ implementation using `toQueryParam`, but may be overriden with more efficient+ one.++0.5+---++* Use `attoparsec-iso8601-1.1.0.0`.+ `Day` and `UTCTime` parsers require at least 4 digits now, which is a breaking change.+* Drop GHC-7.8 and GHC-7.10 support.++0.4.3+-----++* Add `Quarter`, `QuarterOfYear` and `Month` instances+* Support `bytestring-0.11`++0.4.2+-----++* Add instances for `Const` and `Identity`++0.4.1.1+-------++* Allow cookie <0.5+* Change to `build-type: Simple`++0.4.1+-----++* Use `time-compat` to provide instances for `DayOfWeek`.++0.4+---++* `NominalDiffTime` instances preserve precision (roundtrip)+* Add `Semigroup.Min`, `Max`, `First`, `Last` instances+* Add `Tagged b a` instances++0.3.10+---++* Fix 'SetCookie' instances+ (see [#86](https://github.com/fizruk/http-api-data/pull/86))+* Add support for `Fixed`+ (see [#78](https://github.com/fizruk/http-api-data/pull/87))++0.3.9+---++* GHC-8.6 support+* Remove dependency on `uri-bytestring` and use functions from `http-types` instead+ (see [#75](https://github.com/fizruk/http-api-data/pull/75))+* Add support for `SetCookie`+ (see [#74](https://github.com/fizruk/http-api-data/pull/74))++0.3.8.1+---++* GHC-8.4.1 support++0.3.8+---++* Minor changes:+ * Stable URL-encoding for `Form`s (see [#67](https://github.com/fizruk/http-api-data/pull/67)):+ * Introduce `urlEncodeParams` and `urlDecodeParams`;+ * Introduce `urlEncodeAsFormStable` and use stable encoding for doctests;+ * Add `toEntriesByKeyStable` and `toListStable`;+ * Add `Semigroup` instance for `Form` (see [#69](https://github.com/fizruk/http-api-data/pull/69));+ * Relax upper bound on Cabal (see [#73](https://github.com/fizruk/http-api-data/pull/73)).++0.3.7.2+---++* Allow http-types-0.12+* .cabal file adjustments++0.3.7.1+---++* GHC-8.2 support (see [#55](https://github.com/fizruk/http-api-data/pull/55)).++0.3.7+---++* Minor changes:+ * Use [`attoparsec-iso8601`](http://hackage.haskell.org/package/attoparsec-iso8601)+ for parsing of time types. Now the accepted formats are the same as by `aeson`,+ i.e. parsers are more lenient+ (see [#41](https://github.com/fizruk/http-api-data/pull/41));+ * Preserve fractions of a second in `ToHttpApiData` instances (see [#53](https://github.com/fizruk/http-api-data/pull/53));+ * Add `ToHttpApiData` and `FromHttpApiData` instances for `TimeOfDay` (see [#53](https://github.com/fizruk/http-api-data/pull/53)).++0.3.6+---++* Minor change:+ * Add `toEncodedUrlPiece` class method for URL-encoded path segments (see [#50](https://github.com/fizruk/http-api-data/pull/50)); use efficient encoding for types whose values don't need URL-encoding.++0.3.5+---++* Minor changes:+ * Add `LenientData` which always succeeds to parse (see [#45](https://github.com/fizruk/http-api-data/pull/45)).++0.3.4+---++* Minor changes:+ * Add support for GHC 8.2, drop support for GHC 7.6 (see [#44](https://github.com/fizruk/http-api-data/pull/44)).++0.3.3+---++* Minor changes:+ * Expose `Form` constructor from `Web.FromUrlEncoded` (see [#40](https://github.com/fizruk/http-api-data/pull/40));+ * Fix example in `FromForm` documentation (see [#39](https://github.com/fizruk/http-api-data/issues/39)).++0.3.2+---++* Minor change:+ * Export `Form` type from `Web.FormUrlEncoded` (see [#37](https://github.com/fizruk/http-api-data/pull/37)).++0.3.1+---++* Minor changes:+ * Add instances for `Data.UUID` (see [#34](https://github.com/fizruk/http-api-data/pull/34)).++0.3+---+* Major changes:+ * Add `Web.FormUrlEncoded` to work with form data (see [#32](https://github.com/fizruk/http-api-data/pull/32)).++* Minor changes:+ * Add instances for `Numeric.Natural` (see [`d944721`](https://github.com/fizruk/http-api-data/commit/d944721ac94929a7ed9e66f25e23221799c08d83)).+ 0.2.4 --- * Make `parseHeader` total (instead of throwing exceptions on invalid Unicode, see [#30](https://github.com/fizruk/http-api-data/pull/30)).
README.md view
@@ -1,7 +1,9 @@ # http-api-data -[](http://hackage.haskell.org/package/http-api-data) [](http://travis-ci.org/fizruk/http-api-data)+[](http://hackage.haskell.org/package/http-api-data)+[](http://stackage.org/lts/package/http-api-data)+[](http://stackage.org/nightly/package/http-api-data) This package defines typeclasses used for converting Haskell data types to and from HTTP API data.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
− Setup.lhs
@@ -1,48 +0,0 @@-#!/usr/bin/runhaskell-\begin{code}-{-# OPTIONS_GHC -Wall #-}-module Main (main) where--import Data.List ( nub )-import Data.Version ( showVersion )-import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName )-import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )-import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )-import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose )-import Distribution.Simple.BuildPaths ( autogenModulesDir )-import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag )-import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )-import Distribution.Verbosity ( Verbosity )-import System.FilePath ( (</>) )--main :: IO ()-main = defaultMainWithHooks simpleUserHooks- { buildHook = \pkg lbi hooks flags -> do- generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi- buildHook simpleUserHooks pkg lbi hooks flags- }--generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()-generateBuildModule verbosity pkg lbi = do- let dir = autogenModulesDir lbi- createDirectoryIfMissingVerbose verbosity True dir- withLibLBI pkg lbi $ \_ libcfg -> do- withTestLBI pkg lbi $ \suite suitecfg -> do- rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines- [ "module Build_" ++ testName suite ++ " where"- , ""- , "autogen_dir :: String"- , "autogen_dir = " ++ show dir- , ""- , "deps :: [String]"- , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))- ]- where- formatdeps = map (formatone . snd)- formatone p = case packageName p of- PackageName n -> n ++ "-" ++ showVersion (packageVersion p)--testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]-testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys--\end{code}
http-api-data.cabal view
@@ -1,65 +1,100 @@+cabal-version: 1.12 name: http-api-data-version: 0.2.4+version: 0.7++synopsis: Converting to/from HTTP API data like URL pieces, headers and query parameters.+category: Web+description:+ This package defines typeclasses used for converting Haskell data types to and from HTTP API data.+ .+ Please see README.md+ license: BSD3 license-file: LICENSE author: Nickolay Kudasov <nickolay.kudasov@gmail.com> maintainer: Nickolay Kudasov <nickolay.kudasov@gmail.com>-synopsis: Converting to/from HTTP API data like URL pieces, headers and query parameters.-description: Please see README.md homepage: http://github.com/fizruk/http-api-data-category: Web stability: unstable-cabal-version: >= 1.8-build-type: Custom+build-type: Simple+ extra-source-files: test/*.hs CHANGELOG.md README.md +tested-with:+ GHC==8.6.5,+ GHC==8.8.4,+ GHC==8.10.7,+ GHC==9.0.2,+ GHC==9.2.8,+ GHC==9.4.8,+ GHC==9.6.7,+ GHC==9.8.4,+ GHC==9.10.1,+ GHC==9.12.2+ flag use-text-show description: Use text-show library for efficient ToHttpApiData implementations. default: False+ manual: True library hs-source-dirs: src/- build-depends: base >= 4.6 && < 4.10- , text >= 0.5- , bytestring- , time- , time-locale-compat >=0.1.1.0 && <0.2++ -- GHC bundled+ build-depends: base >= 4.12.0.0 && < 4.22+ , bytestring >= 0.10.8.2 && < 0.13+ , containers >= 0.6.0.1 && < 0.8+ , text >= 1.2.3.0 && < 1.3 || >=2.0 && <2.2++ -- other-dependencies+ build-depends:+ cookie >= 0.5.1 && < 0.6+ , hashable >= 1.4.4.0 && < 1.6+ , http-types >= 0.12.4 && < 0.13+ , text-iso8601 >= 0.1.1 && < 0.2+ , tagged >= 0.8.8 && < 0.9+ , time-compat >= 1.9.5 && < 1.10+ , uuid-types >= 1.0.6 && < 1.1+ if flag(use-text-show) cpp-options: -DUSE_TEXT_SHOW- build-depends: text-show >= 2+ build-depends: text-show >= 3.10.5 && <3.12+ exposed-modules: Web.HttpApiData- Web.HttpApiData.Internal+ Web.FormUrlEncoded+ Web.Internal.FormUrlEncoded+ Web.Internal.HttpApiData ghc-options: -Wall+ default-language: Haskell2010 test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs- hs-source-dirs: test/+ other-modules:+ Web.Internal.FormUrlEncodedSpec+ Web.Internal.HttpApiDataSpec+ Web.Internal.TestInstances+ hs-source-dirs: test ghc-options: -Wall- build-depends: HUnit- , hspec >= 1.3- , base >= 4 && < 5- , QuickCheck+ default-language: Haskell2010+ build-tool-depends: hspec-discover:hspec-discover >= 2.7.1 && <2.12+ -- inherited depndencies+ build-depends:+ base+ , bytestring+ , cookie , http-api-data , text- , time- , bytestring+ , time-compat+ , containers+ , uuid-types -test-suite doctest- ghc-options: -Wall- build-depends:- base,- directory >= 1.0,- doctest >= 0.11 && <0.12,- filepath- default-language: Haskell2010- hs-source-dirs: test- main-is: DocTest.hs- type: exitcode-stdio-1.0+ build-depends: hspec >= 2.7.1 && <2.12+ , QuickCheck >= 2.13.1 && <2.16+ , quickcheck-instances >= 0.3.25.2 && <0.4 source-repository head type: git
+ src/Web/FormUrlEncoded.hs view
@@ -0,0 +1,51 @@+-- |+-- Convert Haskell values to and from @application/xxx-form-urlencoded@ format.+module Web.FormUrlEncoded (+ -- * Classes+ ToForm (..),+ FromForm (..),++ -- ** Keys for 'Form' entries+ ToFormKey(..),+ FromFormKey(..),++ -- * 'Form' type+ Form(..),++ -- * Encoding and decoding @'Form'@s+ urlEncodeAsForm,+ urlEncodeAsFormStable,+ urlDecodeAsForm,++ urlEncodeForm,+ urlEncodeFormStable,+ urlDecodeForm,++ -- * 'Generic's+ genericToForm,+ genericFromForm,++ -- ** Encoding options+ FormOptions(..),+ defaultFormOptions,++ -- * Helpers+ toListStable,+ toEntriesByKey,+ toEntriesByKeyStable,+ fromEntriesByKey,++ lookupAll,+ lookupMaybe,+ lookupUnique,++ parseAll,+ parseMaybe,+ parseUnique,++ urlEncodeParams,+ urlDecodeParams,+) where++import Web.Internal.FormUrlEncoded+
src/Web/HttpApiData.hs view
@@ -35,21 +35,23 @@ parseBoundedEnumOfI, parseBoundedTextData, + -- * Lenient data+ LenientData (..),+ -- * Other helpers showTextData, readTextData, ) where -import Web.HttpApiData.Internal+import Web.Internal.HttpApiData -- $setup -- -- >>> :set -XOverloadedStrings -- >>> import Control.Applicative--- >>> import Data.Time+-- >>> import Data.Time.Compat -- >>> import Data.Int -- >>> import Data.Text (Text)--- >>> import Data.Time (Day) -- >>> import Data.Version -- $examples@@ -69,7 +71,7 @@ -- "45.2" -- >>> parseQueryParam "452" :: Either Text Int -- Right 452--- >>> toQueryParams [1..5]+-- >>> toQueryParams [1..5] :: [Text] -- ["1","2","3","4","5"] -- >>> parseQueryParams ["127", "255"] :: Either Text [Int8] -- Left "out of bounds: `255' (should be between -128 and 127)"
− src/Web/HttpApiData/Internal.hs
@@ -1,570 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeSynonymInstances #-}--- |--- Convert Haskell values to and from HTTP API data--- such as URL pieces, headers and query parameters.-module Web.HttpApiData.Internal where--#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-import Data.Traversable (Traversable(traverse))-#endif-import Control.Arrow ((&&&), left)-import Control.Monad ((<=<))--import Data.Monoid-import Data.ByteString (ByteString)-import qualified Data.ByteString as BS--import Data.Int-import Data.Word--import Data.Text (Text)-import Data.Text.Encoding (encodeUtf8, decodeUtf8')-import Data.Text.Read (signed, decimal, rational, Reader)-import qualified Data.Text as T-import qualified Data.Text.Lazy as L--import Data.Time.Locale.Compat-import Data.Time-import Data.Version--#if MIN_VERSION_base(4,8,0)-import Data.Void-#endif--import Text.Read (readMaybe)-import Text.ParserCombinators.ReadP (readP_to_S)--#if USE_TEXT_SHOW-import TextShow (TextShow, showt)-#endif---- | Convert value to HTTP API data.------ __WARNING__: Do not derive this using @DeriveAnyClass@ as the generated--- instance will loop indefinitely.-class ToHttpApiData a where- {-# MINIMAL toUrlPiece | toQueryParam #-}- -- | Convert to URL path piece.- toUrlPiece :: a -> Text- toUrlPiece = toQueryParam-- -- | Convert to HTTP header value.- toHeader :: a -> ByteString- toHeader = encodeUtf8 . toUrlPiece-- -- | Convert to query param value.- toQueryParam :: a -> Text- toQueryParam = toUrlPiece---- | Parse value from HTTP API data.------ __WARNING__: Do not derive this using @DeriveAnyClass@ as the generated--- instance will loop indefinitely.-class FromHttpApiData a where- {-# MINIMAL parseUrlPiece | parseQueryParam #-}- -- | Parse URL path piece.- parseUrlPiece :: Text -> Either Text a- parseUrlPiece = parseQueryParam-- -- | Parse HTTP header value.- parseHeader :: ByteString -> Either Text a- parseHeader = parseUrlPiece <=< (left (T.pack . show) . decodeUtf8')-- -- | Parse query param value.- parseQueryParam :: Text -> Either Text a- parseQueryParam = parseUrlPiece---- | Convert multiple values to a list of URL pieces.------ >>> toUrlPieces [1, 2, 3]--- ["1","2","3"]-toUrlPieces :: (Functor t, ToHttpApiData a) => t a -> t Text-toUrlPieces = fmap toUrlPiece---- | Parse multiple URL pieces.------ >>> parseUrlPieces ["true", "false"] :: Either Text [Bool]--- Right [True,False]--- >>> parseUrlPieces ["123", "hello", "world"] :: Either Text [Int]--- Left "could not parse: `hello' (input does not start with a digit)"-parseUrlPieces :: (Traversable t, FromHttpApiData a) => t Text -> Either Text (t a)-parseUrlPieces = traverse parseUrlPiece---- | Convert multiple values to a list of query parameter values.------ >>> toQueryParams [fromGregorian 2015 10 03, fromGregorian 2015 12 01]--- ["2015-10-03","2015-12-01"]-toQueryParams :: (Functor t, ToHttpApiData a) => t a -> t Text-toQueryParams = fmap toQueryParam---- | Parse multiple query parameters.------ >>> parseQueryParams ["1", "2", "3"] :: Either Text [Int]--- Right [1,2,3]--- >>> parseQueryParams ["64", "128", "256"] :: Either Text [Word8]--- Left "out of bounds: `256' (should be between 0 and 255)"-parseQueryParams :: (Traversable t, FromHttpApiData a) => t Text -> Either Text (t a)-parseQueryParams = traverse parseQueryParam---- | Parse URL path piece in a @'Maybe'@.------ >>> parseUrlPieceMaybe "12" :: Maybe Int--- Just 12-parseUrlPieceMaybe :: FromHttpApiData a => Text -> Maybe a-parseUrlPieceMaybe = either (const Nothing) Just . parseUrlPiece---- | Parse HTTP header value in a @'Maybe'@.------ >>> parseHeaderMaybe "hello" :: Maybe Text--- Just "hello"-parseHeaderMaybe :: FromHttpApiData a => ByteString -> Maybe a-parseHeaderMaybe = either (const Nothing) Just . parseHeader---- | Parse query param value in a @'Maybe'@.------ >>> parseQueryParamMaybe "true" :: Maybe Bool--- Just True-parseQueryParamMaybe :: FromHttpApiData a => Text -> Maybe a-parseQueryParamMaybe = either (const Nothing) Just . parseQueryParam---- | Default parsing error.-defaultParseError :: Text -> Either Text a-defaultParseError input = Left ("could not parse: `" <> input <> "'")---- | Convert @'Maybe'@ parser into @'Either' 'Text'@ parser with default error message.-parseMaybeTextData :: (Text -> Maybe a) -> (Text -> Either Text a)-parseMaybeTextData parse input =- case parse input of- Nothing -> defaultParseError input- Just val -> Right val--#if USE_TEXT_SHOW--- | /Lower case/.------ Convert to URL piece using @'TextShow'@ instance.--- The result is always lower cased.------ >>> showTextData True--- "true"------ This can be used as a default implementation for enumeration types:------ @--- data MyData = Foo | Bar | Baz deriving (Generic)--- --- instance TextShow MyData where--- showt = genericShowt------ instance ToHttpApiData MyData where--- toUrlPiece = showTextData--- @-showTextData :: TextShow a => a -> Text-showTextData = T.toLower . showt-#else--- | /Lower case/.------ Convert to URL piece using @'Show'@ instance.--- The result is always lower cased.------ >>> showTextData True--- "true"------ This can be used as a default implementation for enumeration types:------ >>> data MyData = Foo | Bar | Baz deriving (Show)--- >>> instance ToHttpApiData MyData where toUrlPiece = showTextData--- >>> toUrlPiece Foo--- "foo"-showTextData :: Show a => a -> Text-showTextData = T.toLower . showt---- | Like @'show'@, but returns @'Text'@.-showt :: Show a => a -> Text-showt = T.pack . show-#endif---- | /Case insensitive/.------ Parse given text case insensitive and then parse the rest of the input--- using @'parseUrlPiece'@.------ >>> parseUrlPieceWithPrefix "Just " "just 10" :: Either Text Int--- Right 10--- >>> parseUrlPieceWithPrefix "Left " "left" :: Either Text Bool--- Left "could not parse: `left'"------ This can be used to implement @'FromHttpApiData'@ for single field constructors:------ >>> data Foo = Foo Int deriving (Show)--- >>> instance FromHttpApiData Foo where parseUrlPiece s = Foo <$> parseUrlPieceWithPrefix "Foo " s--- >>> parseUrlPiece "foo 1" :: Either Text Foo--- Right (Foo 1)-parseUrlPieceWithPrefix :: FromHttpApiData a => Text -> Text -> Either Text a-parseUrlPieceWithPrefix pattern input- | T.toLower pattern == T.toLower prefix = parseUrlPiece rest- | otherwise = defaultParseError input- where- (prefix, rest) = T.splitAt (T.length pattern) input---- $setup--- >>> data BasicAuthToken = BasicAuthToken Text deriving (Show)--- >>> instance FromHttpApiData BasicAuthToken where parseHeader h = BasicAuthToken <$> parseHeaderWithPrefix "Basic " h; parseQueryParam p = BasicAuthToken <$> parseQueryParam p---- | Parse given bytestring then parse the rest of the input using @'parseHeader'@.------ @--- data BasicAuthToken = BasicAuthToken Text deriving (Show)------ instance FromHttpApiData BasicAuthToken where--- parseHeader h = BasicAuthToken \<$\> parseHeaderWithPrefix "Basic " h--- parseQueryParam p = BasicAuthToken \<$\> parseQueryParam p--- @------ >>> parseHeader "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" :: Either Text BasicAuthToken--- Right (BasicAuthToken "QWxhZGRpbjpvcGVuIHNlc2FtZQ==")-parseHeaderWithPrefix :: FromHttpApiData a => ByteString -> ByteString -> Either Text a-parseHeaderWithPrefix pattern input- | pattern `BS.isPrefixOf` input = parseHeader (BS.drop (BS.length pattern) input)- | otherwise = defaultParseError (showt input)---- | /Case insensitive/.------ Parse given text case insensitive and then parse the rest of the input--- using @'parseQueryParam'@.------ >>> parseQueryParamWithPrefix "z" "z10" :: Either Text Int--- Right 10-parseQueryParamWithPrefix :: FromHttpApiData a => Text -> Text -> Either Text a-parseQueryParamWithPrefix pattern input- | T.toLower pattern == T.toLower prefix = parseQueryParam rest- | otherwise = defaultParseError input- where- (prefix, rest) = T.splitAt (T.length pattern) input--#if USE_TEXT_SHOW--- | /Case insensitive/.------ Parse values case insensitively based on @'TextShow'@ instance.------ >>> parseBoundedTextData "true" :: Either Text Bool--- Right True--- >>> parseBoundedTextData "FALSE" :: Either Text Bool--- Right False------ This can be used as a default implementation for enumeration types:------ @--- data MyData = Foo | Bar | Baz deriving (Show, Bounded, Enum, Generic)------ instance TextShow MyData where--- showt = genericShowt------ instance FromHttpApiData MyData where--- parseUrlPiece = parseBoundedTextData--- @-parseBoundedTextData :: (TextShow a, Bounded a, Enum a) => Text -> Either Text a-#else--- | /Case insensitive/.------ Parse values case insensitively based on @'Show'@ instance.------ >>> parseBoundedTextData "true" :: Either Text Bool--- Right True--- >>> parseBoundedTextData "FALSE" :: Either Text Bool--- Right False------ This can be used as a default implementation for enumeration types:------ >>> data MyData = Foo | Bar | Baz deriving (Show, Bounded, Enum)--- >>> instance FromHttpApiData MyData where parseUrlPiece = parseBoundedTextData--- >>> parseUrlPiece "foo" :: Either Text MyData--- Right Foo-parseBoundedTextData :: (Show a, Bounded a, Enum a) => Text -> Either Text a-#endif-parseBoundedTextData = parseBoundedEnumOfI showTextData---- | Lookup values based on a precalculated mapping of their representations.-lookupBoundedEnumOf :: (Bounded a, Enum a, Eq b) => (a -> b) -> b -> Maybe a-lookupBoundedEnumOf f = flip lookup (map (f &&& id) [minBound..maxBound])---- | Parse values based on a precalculated mapping of their @'Text'@ representation.------ >>> parseBoundedEnumOf toUrlPiece "true" :: Either Text Bool--- Right True------ For case sensitive parser see 'parseBoundedEnumOfI'.-parseBoundedEnumOf :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a-parseBoundedEnumOf = parseMaybeTextData . lookupBoundedEnumOf---- | /Case insensitive/.------ Parse values case insensitively based on a precalculated mapping--- of their @'Text'@ representations.------ >>> parseBoundedEnumOfI toUrlPiece "FALSE" :: Either Text Bool--- Right False------ For case sensitive parser see 'parseBoundedEnumOf'.-parseBoundedEnumOfI :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a-parseBoundedEnumOfI f = parseBoundedEnumOf (T.toLower . f) . T.toLower---- | /Case insensitive/.------ Parse values case insensitively based on @'ToHttpApiData'@ instance.--- Uses @'toUrlPiece'@ to get possible values.-parseBoundedUrlPiece :: (ToHttpApiData a, Bounded a, Enum a) => Text -> Either Text a-parseBoundedUrlPiece = parseBoundedEnumOfI toUrlPiece---- | /Case insensitive/.------ Parse values case insensitively based on @'ToHttpApiData'@ instance.--- Uses @'toQueryParam'@ to get possible values.-parseBoundedQueryParam :: (ToHttpApiData a, Bounded a, Enum a) => Text -> Either Text a-parseBoundedQueryParam = parseBoundedEnumOfI toQueryParam---- | Parse values based on @'ToHttpApiData'@ instance.--- Uses @'toHeader'@ to get possible values.-parseBoundedHeader :: (ToHttpApiData a, Bounded a, Enum a) => ByteString -> Either Text a-parseBoundedHeader bs = case lookupBoundedEnumOf toHeader bs of- Nothing -> defaultParseError $ T.pack $ show bs- Just x -> return x---- | Parse URL piece using @'Read'@ instance.------ Use for types which do not involve letters:------ >>> readTextData "1991-06-02" :: Either Text Day--- Right 1991-06-02------ This parser is case sensitive and will not match @'showTextData'@--- in presense of letters:------ >>> readTextData (showTextData True) :: Either Text Bool--- Left "could not parse: `true'"------ See @'parseBoundedTextData'@.-readTextData :: Read a => Text -> Either Text a-readTextData = parseMaybeTextData (readMaybe . T.unpack)---- | Run @'Reader'@ as HTTP API data parser.-runReader :: Reader a -> Text -> Either Text a-runReader reader input =- case reader input of- Left err -> Left ("could not parse: `" <> input <> "' (" <> T.pack err <> ")")- Right (x, rest)- | T.null rest -> Right x- | otherwise -> defaultParseError input---- | Run @'Reader'@ to parse bounded integral value with bounds checking.------ >>> parseBounded decimal "256" :: Either Text Word8--- Left "out of bounds: `256' (should be between 0 and 255)"-parseBounded :: forall a. (Bounded a, Integral a) => Reader Integer -> Text -> Either Text a-parseBounded reader input = do- n <- runReader reader input- if (n > h || n < l)- then Left ("out of bounds: `" <> input <> "' (should be between " <> showt l <> " and " <> showt h <> ")")- else Right (fromInteger n)- where- l = toInteger (minBound :: a)- h = toInteger (maxBound :: a)---- |--- >>> toUrlPiece ()--- "_"-instance ToHttpApiData () where- toUrlPiece () = "_"--instance ToHttpApiData Char where toUrlPiece = T.singleton---- |--- >>> toUrlPiece (Version [1, 2, 3] [])--- "1.2.3"-instance ToHttpApiData Version where- toUrlPiece = T.pack . showVersion--#if MIN_VERSION_base(4,8,0)-instance ToHttpApiData Void where- toUrlPiece = absurd-#endif--instance ToHttpApiData Bool where toUrlPiece = showTextData-instance ToHttpApiData Ordering where toUrlPiece = showTextData--instance ToHttpApiData Double where toUrlPiece = showt-instance ToHttpApiData Float where toUrlPiece = showt-instance ToHttpApiData Int where toUrlPiece = showt-instance ToHttpApiData Int8 where toUrlPiece = showt-instance ToHttpApiData Int16 where toUrlPiece = showt-instance ToHttpApiData Int32 where toUrlPiece = showt-instance ToHttpApiData Int64 where toUrlPiece = showt-instance ToHttpApiData Integer where toUrlPiece = showt-instance ToHttpApiData Word where toUrlPiece = showt-instance ToHttpApiData Word8 where toUrlPiece = showt-instance ToHttpApiData Word16 where toUrlPiece = showt-instance ToHttpApiData Word32 where toUrlPiece = showt-instance ToHttpApiData Word64 where toUrlPiece = showt---- |--- >>> toUrlPiece (fromGregorian 2015 10 03)--- "2015-10-03"-instance ToHttpApiData Day where toUrlPiece = T.pack . show--timeToUrlPiece :: FormatTime t => String -> t -> Text-timeToUrlPiece fmt = T.pack . formatTime defaultTimeLocale (iso8601DateFormat (Just fmt))---- |--- >>> toUrlPiece $ LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 01)--- "2015-10-03T14:55:01"-instance ToHttpApiData LocalTime where toUrlPiece = timeToUrlPiece "%H:%M:%S"---- |--- >>> toUrlPiece $ ZonedTime (LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 01)) utc--- "2015-10-03T14:55:01+0000"-instance ToHttpApiData ZonedTime where toUrlPiece = timeToUrlPiece "%H:%M:%S%z"---- |--- >>> toUrlPiece $ UTCTime (fromGregorian 2015 10 03) 864--- "2015-10-03T00:14:24Z"-instance ToHttpApiData UTCTime where toUrlPiece = timeToUrlPiece "%H:%M:%SZ"--instance ToHttpApiData NominalDiffTime where toUrlPiece = toUrlPiece . (floor :: NominalDiffTime -> Integer)--instance ToHttpApiData String where toUrlPiece = T.pack-instance ToHttpApiData Text where toUrlPiece = id-instance ToHttpApiData L.Text where toUrlPiece = L.toStrict--instance ToHttpApiData All where toUrlPiece = toUrlPiece . getAll-instance ToHttpApiData Any where toUrlPiece = toUrlPiece . getAny--instance ToHttpApiData a => ToHttpApiData (Dual a) where toUrlPiece = toUrlPiece . getDual-instance ToHttpApiData a => ToHttpApiData (Sum a) where toUrlPiece = toUrlPiece . getSum-instance ToHttpApiData a => ToHttpApiData (Product a) where toUrlPiece = toUrlPiece . getProduct-instance ToHttpApiData a => ToHttpApiData (First a) where toUrlPiece = toUrlPiece . getFirst-instance ToHttpApiData a => ToHttpApiData (Last a) where toUrlPiece = toUrlPiece . getLast---- |--- >>> toUrlPiece (Just "Hello")--- "just Hello"-instance ToHttpApiData a => ToHttpApiData (Maybe a) where- toUrlPiece (Just x) = "just " <> toUrlPiece x- toUrlPiece Nothing = "nothing"---- |--- >>> toUrlPiece (Left "err" :: Either String Int)--- "left err"--- >>> toUrlPiece (Right 3 :: Either String Int)--- "right 3"-instance (ToHttpApiData a, ToHttpApiData b) => ToHttpApiData (Either a b) where- toUrlPiece (Left x) = "left " <> toUrlPiece x- toUrlPiece (Right x) = "right " <> toUrlPiece x---- |--- >>> parseUrlPiece "_" :: Either Text ()--- Right ()-instance FromHttpApiData () where- parseUrlPiece "_" = pure ()- parseUrlPiece s = defaultParseError s--instance FromHttpApiData Char where- parseUrlPiece s =- case T.uncons s of- Just (c, s') | T.null s' -> pure c- _ -> defaultParseError s---- |--- >>> showVersion <$> parseUrlPiece "1.2.3"--- Right "1.2.3"-instance FromHttpApiData Version where- parseUrlPiece s =- case reverse (readP_to_S parseVersion (T.unpack s)) of- ((x, ""):_) -> pure x- _ -> defaultParseError s--#if MIN_VERSION_base(4,8,0)--- | Parsing a @'Void'@ value is always an error, considering @'Void'@ as a data type with no constructors.-instance FromHttpApiData Void where- parseUrlPiece _ = Left "Void cannot be parsed!"-#endif--instance FromHttpApiData Bool where parseUrlPiece = parseBoundedUrlPiece-instance FromHttpApiData Ordering where parseUrlPiece = parseBoundedUrlPiece-instance FromHttpApiData Double where parseUrlPiece = runReader rational-instance FromHttpApiData Float where parseUrlPiece = runReader rational-instance FromHttpApiData Int where parseUrlPiece = parseBounded (signed decimal)-instance FromHttpApiData Int8 where parseUrlPiece = parseBounded (signed decimal)-instance FromHttpApiData Int16 where parseUrlPiece = parseBounded (signed decimal)-instance FromHttpApiData Int32 where parseUrlPiece = parseBounded (signed decimal)-instance FromHttpApiData Int64 where parseUrlPiece = parseBounded (signed decimal)-instance FromHttpApiData Integer where parseUrlPiece = runReader (signed decimal)-instance FromHttpApiData Word where parseUrlPiece = parseBounded decimal-instance FromHttpApiData Word8 where parseUrlPiece = parseBounded decimal-instance FromHttpApiData Word16 where parseUrlPiece = parseBounded decimal-instance FromHttpApiData Word32 where parseUrlPiece = parseBounded decimal-instance FromHttpApiData Word64 where parseUrlPiece = parseBounded decimal-instance FromHttpApiData String where parseUrlPiece = Right . T.unpack-instance FromHttpApiData Text where parseUrlPiece = Right-instance FromHttpApiData L.Text where parseUrlPiece = Right . L.fromStrict---- |--- >>> toGregorian <$> parseUrlPiece "2016-12-01"--- Right (2016,12,1)-instance FromHttpApiData Day where parseUrlPiece = readTextData--timeParseUrlPiece :: ParseTime t => String -> Text -> Either Text t-timeParseUrlPiece fmt = parseMaybeTextData (timeParseUrlPieceMaybe . T.unpack)- where- timeParseUrlPieceMaybe = parseTime defaultTimeLocale (iso8601DateFormat (Just fmt))---- |--- >>> parseUrlPiece "2015-10-03T14:55:01" :: Either Text LocalTime--- Right 2015-10-03 14:55:01-instance FromHttpApiData LocalTime where parseUrlPiece = timeParseUrlPiece "%H:%M:%S"---- |--- >>> parseUrlPiece "2015-10-03T14:55:01+0000" :: Either Text ZonedTime--- Right 2015-10-03 14:55:01 +0000-instance FromHttpApiData ZonedTime where parseUrlPiece = timeParseUrlPiece "%H:%M:%S%z"---- |--- >>> parseUrlPiece "2015-10-03T00:14:24Z" :: Either Text UTCTime--- Right 2015-10-03 00:14:24 UTC-instance FromHttpApiData UTCTime where parseUrlPiece = timeParseUrlPiece "%H:%M:%SZ"--instance FromHttpApiData NominalDiffTime where parseUrlPiece = fmap fromInteger . parseUrlPiece--instance FromHttpApiData All where parseUrlPiece = fmap All . parseUrlPiece-instance FromHttpApiData Any where parseUrlPiece = fmap Any . parseUrlPiece--instance FromHttpApiData a => FromHttpApiData (Dual a) where parseUrlPiece = fmap Dual . parseUrlPiece-instance FromHttpApiData a => FromHttpApiData (Sum a) where parseUrlPiece = fmap Sum . parseUrlPiece-instance FromHttpApiData a => FromHttpApiData (Product a) where parseUrlPiece = fmap Product . parseUrlPiece-instance FromHttpApiData a => FromHttpApiData (First a) where parseUrlPiece = fmap First . parseUrlPiece-instance FromHttpApiData a => FromHttpApiData (Last a) where parseUrlPiece = fmap Last . parseUrlPiece---- |--- >>> parseUrlPiece "Just 123" :: Either Text (Maybe Int)--- Right (Just 123)-instance FromHttpApiData a => FromHttpApiData (Maybe a) where- parseUrlPiece s- | T.toLower (T.take 7 s) == "nothing" = pure Nothing- | otherwise = Just <$> parseUrlPieceWithPrefix "Just " s---- |--- >>> parseUrlPiece "Right 123" :: Either Text (Either String Int)--- Right (Right 123)-instance (FromHttpApiData a, FromHttpApiData b) => FromHttpApiData (Either a b) where- parseUrlPiece s =- Right <$> parseUrlPieceWithPrefix "Right " s- <!> Left <$> parseUrlPieceWithPrefix "Left " s- where- infixl 3 <!>- Left _ <!> y = y- x <!> _ = x-
+ src/Web/Internal/FormUrlEncoded.hs view
@@ -0,0 +1,795 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+module Web.Internal.FormUrlEncoded where++import Control.Applicative (Const(Const))+import Control.Arrow ((***))+import Control.Monad ((<=<))+import Data.ByteString.Builder (shortByteString, toLazyByteString)+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Lazy.Char8 as BSL8+import Data.Coerce (coerce)+import qualified Data.Foldable as F+import Data.Functor.Identity (Identity(Identity))+import Data.Hashable (Hashable)+import qualified Data.Map.Strict as Map+import Data.Int (Int16, Int32, Int64, Int8)+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.List (intersperse, sortBy)+import Data.Monoid (All (..), Any (..), Dual (..),+ Product (..), Sum (..))+import Data.Ord (comparing)+import Data.Proxy (Proxy (..))+import Data.Semigroup (Semigroup (..))+import qualified Data.Semigroup as Semi+import Data.Tagged (Tagged (..))+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Data.Text.Encoding.Error (lenientDecode)+import qualified Data.Text.Lazy as Lazy+import Data.Time.Compat (Day, LocalTime, NominalDiffTime,+ UTCTime, ZonedTime)+import Data.Time.Calendar.Month.Compat (Month)+import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..))+import Data.Void (Void, absurd)+import Data.Word (Word16, Word32, Word64, Word8)+import GHC.Exts (Constraint, IsList (..))+import GHC.Generics+import GHC.TypeLits+import Network.HTTP.Types.URI (urlDecode, urlEncodeBuilder)+import Numeric.Natural (Natural)+import Web.Internal.HttpApiData++-- $setup+-- >>> :set -XDeriveGeneric -XOverloadedLists -XOverloadedStrings -XFlexibleContexts -XScopedTypeVariables -XTypeFamilies+-- >>> import GHC.Generics (Generic)+-- >>> import Data.Char (toLower)+-- >>> import Data.Text (Text)+-- >>> import Data.Word (Word8)+--+-- >>> data Person = Person { name :: String, age :: Int } deriving (Show, Generic)+-- >>> instance ToForm Person+-- >>> instance FromForm Person+--+-- >>> data Post = Post { title :: String, subtitle :: Maybe String, comments :: [String]} deriving (Generic, Show)+-- >>> instance ToForm Post+-- >>> instance FromForm Post+--+-- >>> data Project = Project { projectName :: String, projectSize :: Int } deriving (Generic, Show)+-- >>> let myOptions = FormOptions { fieldLabelModifier = map toLower . drop (length ("project" :: String)) }+-- >>> instance ToForm Project where toForm = genericToForm myOptions+-- >>> instance FromForm Project where fromForm = genericFromForm myOptions++-- | Typeclass for types that can be used as keys in a 'Form'-like container (like 'Map').+class ToFormKey k where+ -- | Render a key for a 'Form'.+ toFormKey :: k -> Text++instance ToFormKey () where toFormKey = toQueryParam+instance ToFormKey Char where toFormKey = toQueryParam++instance ToFormKey Bool where toFormKey = toQueryParam+instance ToFormKey Ordering where toFormKey = toQueryParam++instance ToFormKey Double where toFormKey = toQueryParam+instance ToFormKey Float where toFormKey = toQueryParam+instance ToFormKey Int where toFormKey = toQueryParam+instance ToFormKey Int8 where toFormKey = toQueryParam+instance ToFormKey Int16 where toFormKey = toQueryParam+instance ToFormKey Int32 where toFormKey = toQueryParam+instance ToFormKey Int64 where toFormKey = toQueryParam+instance ToFormKey Integer where toFormKey = toQueryParam+instance ToFormKey Word where toFormKey = toQueryParam+instance ToFormKey Word8 where toFormKey = toQueryParam+instance ToFormKey Word16 where toFormKey = toQueryParam+instance ToFormKey Word32 where toFormKey = toQueryParam+instance ToFormKey Word64 where toFormKey = toQueryParam++instance ToFormKey Day where toFormKey = toQueryParam+instance ToFormKey LocalTime where toFormKey = toQueryParam+instance ToFormKey ZonedTime where toFormKey = toQueryParam+instance ToFormKey UTCTime where toFormKey = toQueryParam+instance ToFormKey NominalDiffTime where toFormKey = toQueryParam+instance ToFormKey Quarter where toFormKey = toQueryParam+instance ToFormKey QuarterOfYear where toFormKey = toQueryParam+instance ToFormKey Month where toFormKey = toQueryParam++instance ToFormKey String where toFormKey = toQueryParam+instance ToFormKey Text where toFormKey = toQueryParam+instance ToFormKey Lazy.Text where toFormKey = toQueryParam++instance ToFormKey All where toFormKey = toQueryParam+instance ToFormKey Any where toFormKey = toQueryParam++instance ToFormKey a => ToFormKey (Dual a) where toFormKey = coerce (toFormKey :: a -> Text)+instance ToFormKey a => ToFormKey (Sum a) where toFormKey = coerce (toFormKey :: a -> Text)+instance ToFormKey a => ToFormKey (Product a) where toFormKey = coerce (toFormKey :: a -> Text)++instance ToFormKey a => ToFormKey (Semi.Min a) where toFormKey = coerce (toFormKey :: a -> Text)+instance ToFormKey a => ToFormKey (Semi.Max a) where toFormKey = coerce (toFormKey :: a -> Text)+instance ToFormKey a => ToFormKey (Semi.First a) where toFormKey = coerce (toFormKey :: a -> Text)+instance ToFormKey a => ToFormKey (Semi.Last a) where toFormKey = coerce (toFormKey :: a -> Text)++instance ToFormKey a => ToFormKey (Tagged b a) where toFormKey = coerce (toFormKey :: a -> Text)++-- | @since 0.4.2+instance ToFormKey a => ToFormKey (Identity a) where toFormKey = coerce (toFormKey :: a -> Text)++-- | @since 0.4.2+instance ToFormKey a => ToFormKey (Const a b) where+ toFormKey = coerce (toFormKey :: a -> Text)++instance ToFormKey Void where toFormKey = toQueryParam+instance ToFormKey Natural where toFormKey = toQueryParam++-- | Typeclass for types that can be parsed from keys of a 'Form'. This is the reverse of 'ToFormKey'.+class FromFormKey k where+ -- | Parse a key of a 'Form'.+ parseFormKey :: Text -> Either Text k++instance FromFormKey () where parseFormKey = parseQueryParam+instance FromFormKey Char where parseFormKey = parseQueryParam++instance FromFormKey Bool where parseFormKey = parseQueryParam+instance FromFormKey Ordering where parseFormKey = parseQueryParam++instance FromFormKey Double where parseFormKey = parseQueryParam+instance FromFormKey Float where parseFormKey = parseQueryParam+instance FromFormKey Int where parseFormKey = parseQueryParam+instance FromFormKey Int8 where parseFormKey = parseQueryParam+instance FromFormKey Int16 where parseFormKey = parseQueryParam+instance FromFormKey Int32 where parseFormKey = parseQueryParam+instance FromFormKey Int64 where parseFormKey = parseQueryParam+instance FromFormKey Integer where parseFormKey = parseQueryParam+instance FromFormKey Word where parseFormKey = parseQueryParam+instance FromFormKey Word8 where parseFormKey = parseQueryParam+instance FromFormKey Word16 where parseFormKey = parseQueryParam+instance FromFormKey Word32 where parseFormKey = parseQueryParam+instance FromFormKey Word64 where parseFormKey = parseQueryParam++instance FromFormKey Day where parseFormKey = parseQueryParam+instance FromFormKey LocalTime where parseFormKey = parseQueryParam+instance FromFormKey ZonedTime where parseFormKey = parseQueryParam+instance FromFormKey UTCTime where parseFormKey = parseQueryParam+instance FromFormKey NominalDiffTime where parseFormKey = parseQueryParam+instance FromFormKey Quarter where parseFormKey = parseQueryParam+instance FromFormKey QuarterOfYear where parseFormKey = parseQueryParam+instance FromFormKey Month where parseFormKey = parseQueryParam++instance FromFormKey String where parseFormKey = parseQueryParam+instance FromFormKey Text where parseFormKey = parseQueryParam+instance FromFormKey Lazy.Text where parseFormKey = parseQueryParam++instance FromFormKey All where parseFormKey = parseQueryParam+instance FromFormKey Any where parseFormKey = parseQueryParam++instance FromFormKey a => FromFormKey (Dual a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a)+instance FromFormKey a => FromFormKey (Sum a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a)+instance FromFormKey a => FromFormKey (Product a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a)++instance FromFormKey a => FromFormKey (Semi.Min a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a)+instance FromFormKey a => FromFormKey (Semi.Max a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a)+instance FromFormKey a => FromFormKey (Semi.First a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a)+instance FromFormKey a => FromFormKey (Semi.Last a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a)++instance FromFormKey a => FromFormKey (Tagged b a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a)++-- | @since 0.4.2+instance FromFormKey a => FromFormKey (Identity a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a)++-- | @since 0.4.2+instance FromFormKey a => FromFormKey (Const a b) where+ parseFormKey = coerce (parseFormKey :: Text -> Either Text a)++instance FromFormKey Void where parseFormKey = parseQueryParam+instance FromFormKey Natural where parseFormKey = parseQueryParam++-- | The contents of a form, not yet URL-encoded.+--+-- 'Form' can be URL-encoded with 'urlEncodeForm' and URL-decoded with 'urlDecodeForm'.+newtype Form = Form { unForm :: Map.Map Text [Text] }+ deriving (Eq, Read, Generic, Semigroup, Monoid)++instance Show Form where+ showsPrec d form = showParen (d > 10) $+ showString "fromList " . shows (toListStable form)++-- | _NOTE:_ 'toList' is unstable and may result in different key order (but not values).+-- For a stable conversion use 'toListStable'.+instance IsList Form where+ type Item Form = (Text, Text)+ fromList = Form . Map.fromListWith (flip (<>)) . fmap (\(k, v) -> (k, [v]))+ toList = concatMap (\(k, vs) -> map ((,) k) vs) . Map.toList . unForm++-- | A stable version of 'toList'.+toListStable :: Form -> [(Text, Text)]+toListStable = sortOn fst . toList++-- | Convert a value into 'Form'.+--+-- An example type and instance:+--+-- @+-- {-\# LANGUAGE OverloadedLists \#-}+--+-- data Person = Person+-- { name :: String+-- , age :: Int }+--+-- instance 'ToForm' Person where+-- 'toForm' person =+-- [ (\"name\", 'toQueryParam' (name person))+-- , (\"age\", 'toQueryParam' (age person)) ]+-- @+--+-- Instead of manually writing @'ToForm'@ instances you can+-- use a default generic implementation of @'toForm'@.+--+-- To do that, simply add @deriving 'Generic'@ clause to your datatype+-- and declare a 'ToForm' instance for your datatype without+-- giving definition for 'toForm'.+--+-- For instance, the previous example can be simplified into this:+--+-- @+-- data Person = Person+-- { name :: String+-- , age :: Int+-- } deriving ('Generic')+--+-- instance 'ToForm' Person+-- @+--+-- The default implementation of 'toForm' is 'genericToForm'.+class ToForm a where+ -- | Convert a value into 'Form'.+ toForm :: a -> Form+ default toForm :: (Generic a, GToForm a (Rep a)) => a -> Form+ toForm = genericToForm defaultFormOptions++instance ToForm Form where toForm = id++-- |+--+-- @since 0.6.3+instance ToForm Void where toForm = absurd++-- |+--+-- @since 0.6.3+instance ToForm () where toForm _ = Form Map.empty++instance (ToFormKey k, ToHttpApiData v) => ToForm [(k, v)] where+ toForm = fromList . map (toFormKey *** toQueryParam)++instance (ToFormKey k, ToHttpApiData v) => ToForm (Map.Map k [v]) where+ toForm = fromEntriesByKey . Map.toList++instance ToHttpApiData v => ToForm (IntMap [v]) where+ toForm = fromEntriesByKey . IntMap.toList++-- | Convert a list of entries groupped by key into a 'Form'.+--+-- >>> fromEntriesByKey [("name",["Nick"]),("color",["red","blue"])]+-- fromList [("color","red"),("color","blue"),("name","Nick")]+fromEntriesByKey :: (ToFormKey k, ToHttpApiData v) => [(k, [v])] -> Form+fromEntriesByKey = Form . Map.fromListWith (<>) . map (toFormKey *** map toQueryParam)++data Proxy3 a b c = Proxy3++type family NotSupported (cls :: k1) (a :: k2) (reason :: Symbol) :: Constraint where+ NotSupported cls a reason = TypeError+ ( 'Text "Cannot derive a Generic-based " ':<>: 'ShowType cls ':<>: 'Text " instance for " ':<>: 'ShowType a ':<>: 'Text "." ':$$:+ 'ShowType a ':<>: 'Text " " ':<>: 'Text reason ':<>: 'Text "," ':$$:+ 'Text "but Generic-based " ':<>: 'ShowType cls ':<>: 'Text " instances can be derived only for records" ':$$:+ 'Text "(i.e. product types with named fields)." )++-- | A 'Generic'-based implementation of 'toForm'.+-- This is used as a default implementation in 'ToForm'.+--+-- Note that this only works for records (i.e. product data types with named fields):+--+-- @+-- data Person = Person+-- { name :: String+-- , age :: Int+-- } deriving ('Generic')+-- @+--+-- In this implementation each field's value gets encoded using `toQueryParam`.+-- Two field types are exceptions:+--+-- - for values of type @'Maybe' a@ an entry is added to the 'Form' only when it is @'Just' x@+-- and the encoded value is @'toQueryParam' x@; 'Nothing' values are omitted from the 'Form';+--+-- - for values of type @[a]@ (except @['Char']@) an entry is added for every item in the list;+-- if the list is empty no entries are added to the 'Form';+--+-- Here's an example:+--+-- @+-- data Post = Post+-- { title :: String+-- , subtitle :: Maybe String+-- , comments :: [String]+-- } deriving ('Generic', 'Show')+--+-- instance 'ToForm' Post+-- @+--+-- >>> urlEncodeAsFormStable Post { title = "Test", subtitle = Nothing, comments = ["Nice post!", "+1"] }+-- "comments=Nice%20post%21&comments=%2B1&title=Test"+genericToForm :: forall a. (Generic a, GToForm a (Rep a)) => FormOptions -> a -> Form+genericToForm opts = gToForm (Proxy :: Proxy a) opts . from++class GToForm t (f :: * -> *) where+ gToForm :: Proxy t -> FormOptions -> f x -> Form++instance (GToForm t f, GToForm t g) => GToForm t (f :*: g) where+ gToForm p opts (a :*: b) = gToForm p opts a <> gToForm p opts b++instance (GToForm t f) => GToForm t (M1 D x f) where+ gToForm p opts (M1 a) = gToForm p opts a++instance (GToForm t f) => GToForm t (M1 C x f) where+ gToForm p opts (M1 a) = gToForm p opts a++instance {-# OVERLAPPABLE #-} (Selector s, ToHttpApiData c) => GToForm t (M1 S s (K1 i c)) where+ gToForm _ opts (M1 (K1 c)) = fromList [(key, toQueryParam c)]+ where+ key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)++instance (Selector s, ToHttpApiData c) => GToForm t (M1 S s (K1 i (Maybe c))) where+ gToForm _ opts (M1 (K1 c)) =+ case c of+ Nothing -> mempty+ Just x -> fromList [(key, toQueryParam x)]+ where+ key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)++instance (Selector s, ToHttpApiData c) => GToForm t (M1 S s (K1 i [c])) where+ gToForm _ opts (M1 (K1 cs)) = fromList (map (\c -> (key, toQueryParam c)) cs)+ where+ key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)++instance {-# OVERLAPPING #-} (Selector s) => GToForm t (M1 S s (K1 i String)) where+ gToForm _ opts (M1 (K1 c)) = fromList [(key, toQueryParam c)]+ where+ key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)++instance NotSupported ToForm t "is a sum type" => GToForm t (f :+: g) where gToForm = error "impossible"++-- | Parse 'Form' into a value.+--+-- An example type and instance:+--+-- @+-- data Person = Person+-- { name :: String+-- , age :: Int }+--+-- instance 'FromForm' Person where+-- 'fromForm' f = Person+-- '<$>' 'parseUnique' "name" f+-- '<*>' 'parseUnique' "age" f+-- @+--+-- Instead of manually writing @'FromForm'@ instances you can+-- use a default generic implementation of @'fromForm'@.+--+-- To do that, simply add @deriving 'Generic'@ clause to your datatype+-- and declare a 'FromForm' instance for your datatype without+-- giving definition for 'fromForm'.+--+-- For instance, the previous example can be simplified into this:+--+-- @+-- data Person = Person+-- { name :: String+-- , age :: Int+-- } deriving ('Generic')+--+-- instance 'FromForm' Person+-- @+--+-- The default implementation of 'fromForm' is 'genericFromForm'.+-- It only works for records and it will use 'parseQueryParam' for each field's value.+class FromForm a where+ -- | Parse 'Form' into a value.+ fromForm :: Form -> Either Text a+ default fromForm :: (Generic a, GFromForm a (Rep a)) => Form -> Either Text a+ fromForm = genericFromForm defaultFormOptions++instance FromForm Form where fromForm = pure++-- |+--+-- @since 0.6.3+instance FromForm Void where fromForm _ = Left "fromForm: Void"++-- |+--+-- @since 0.6.3+instance FromForm () where fromForm _ = Right ()++-- | _NOTE:_ this conversion is unstable and may result in different key order (but not values).+instance (FromFormKey k, FromHttpApiData v) => FromForm [(k, v)] where+ fromForm = fmap (concatMap (\(k, vs) -> map ((,) k) vs)) . toEntriesByKey++instance (Ord k, Eq k, Hashable k, FromFormKey k, FromHttpApiData v) => FromForm (Map.Map k [v]) where+ fromForm = fmap (Map.fromListWith (<>)) . toEntriesByKey++instance FromHttpApiData v => FromForm (IntMap [v]) where+ fromForm = fmap (IntMap.fromListWith (<>)) . toEntriesByKey++-- | Parse a 'Form' into a list of entries groupped by key.+--+-- _NOTE:_ this conversion is unstable and may result in different key order+-- (but not values). For a stable encoding see 'toEntriesByKeyStable'.+toEntriesByKey :: (FromFormKey k, FromHttpApiData v) => Form -> Either Text [(k, [v])]+toEntriesByKey = traverse parseGroup . Map.toList . unForm+ where+ parseGroup (k, vs) = (,) <$> parseFormKey k <*> traverse parseQueryParam vs++-- | Parse a 'Form' into a list of entries groupped by key.+--+-- >>> toEntriesByKeyStable [("name", "Nick"), ("color", "red"), ("color", "white")] :: Either Text [(Text, [Text])]+-- Right [("color",["red","white"]),("name",["Nick"])]+--+-- For an unstable (but faster) conversion see 'toEntriesByKey'.+toEntriesByKeyStable :: (Ord k, FromFormKey k, FromHttpApiData v) => Form -> Either Text [(k, [v])]+toEntriesByKeyStable = fmap (sortOn fst) . toEntriesByKey++-- | A 'Generic'-based implementation of 'fromForm'.+-- This is used as a default implementation in 'FromForm'.+--+-- Note that this only works for records (i.e. product data types with named fields):+--+-- @+-- data Person = Person+-- { name :: String+-- , age :: Int+-- } deriving ('Generic')+-- @+--+-- In this implementation each field's value gets decoded using `parseQueryParam`.+-- Two field types are exceptions:+--+-- - for values of type @'Maybe' a@ an entry is parsed if present in the 'Form'+-- and the is decoded with 'parseQueryParam'; if no entry is present result is 'Nothing';+--+-- - for values of type @[a]@ (except @['Char']@) all entries are parsed to produce a list of parsed values;+--+-- Here's an example:+--+-- @+-- data Post = Post+-- { title :: String+-- , subtitle :: Maybe String+-- , comments :: [String]+-- } deriving ('Generic', 'Show')+--+-- instance 'FromForm' Post+-- @+--+-- >>> urlDecodeAsForm "comments=Nice%20post%21&comments=%2B1&title=Test" :: Either Text Post+-- Right (Post {title = "Test", subtitle = Nothing, comments = ["Nice post!","+1"]})+genericFromForm :: forall a. (Generic a, GFromForm a (Rep a)) => FormOptions -> Form -> Either Text a+genericFromForm opts f = to <$> gFromForm (Proxy :: Proxy a) opts f++class GFromForm t (f :: * -> *) where+ gFromForm :: Proxy t -> FormOptions -> Form -> Either Text (f x)++instance (GFromForm t f, GFromForm t g) => GFromForm t (f :*: g) where+ gFromForm p opts f = (:*:) <$> gFromForm p opts f <*> gFromForm p opts f++instance GFromForm t f => GFromForm t (M1 D x f) where+ gFromForm p opts f = M1 <$> gFromForm p opts f++instance GFromForm t f => GFromForm t (M1 C x f) where+ gFromForm p opts f = M1 <$> gFromForm p opts f++instance {-# OVERLAPPABLE #-} (Selector s, FromHttpApiData c) => GFromForm t (M1 S s (K1 i c)) where+ gFromForm _ opts form = M1 . K1 <$> parseUnique key form+ where+ key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)++instance (Selector s, FromHttpApiData c) => GFromForm t (M1 S s (K1 i (Maybe c))) where+ gFromForm _ opts form = M1 . K1 <$> parseMaybe key form+ where+ key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)++instance (Selector s, FromHttpApiData c) => GFromForm t (M1 S s (K1 i [c])) where+ gFromForm _ opts form = M1 . K1 <$> parseAll key form+ where+ key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)++instance {-# OVERLAPPING #-} (Selector s) => GFromForm t (M1 S s (K1 i String)) where+ gFromForm _ opts form = M1 . K1 <$> parseUnique key form+ where+ key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)++instance NotSupported FromForm t "is a sum type" => GFromForm t (f :+: g) where gFromForm = error "impossible"++-- | Encode a 'Form' to an @application/x-www-form-urlencoded@ 'BSL.ByteString'.+--+-- _NOTE:_ this encoding is unstable and may result in different key order+-- (but not values). For a stable encoding see 'urlEncodeFormStable'.+urlEncodeForm :: Form -> BSL.ByteString+urlEncodeForm = urlEncodeParams . toList++-- | Encode a 'Form' to an @application/x-www-form-urlencoded@ 'BSL.ByteString'.+--+-- For an unstable (but faster) encoding see 'urlEncodeForm'.+--+-- Key-value pairs get encoded to @key=value@ and separated by @&@:+--+-- >>> urlEncodeFormStable [("name", "Julian"), ("lastname", "Arni")]+-- "lastname=Arni&name=Julian"+--+-- Keys with empty values get encoded to just @key@ (without the @=@ sign):+--+-- >>> urlEncodeFormStable [("is_test", "")]+-- "is_test"+--+-- Empty keys are allowed too:+--+-- >>> urlEncodeFormStable [("", "foobar")]+-- "=foobar"+--+-- However, if both key and value are empty, the key-value pair is ignored.+-- (This prevents @'urlDecodeForm' . 'urlEncodeFormStable'@ from being a true isomorphism).+--+-- >>> urlEncodeFormStable [("", "")]+-- ""+--+-- Everything is escaped with @'escapeURIString' 'isUnreserved'@:+--+-- >>> urlEncodeFormStable [("fullname", "Andres Löh")]+-- "fullname=Andres%20L%C3%B6h"+urlEncodeFormStable :: Form -> BSL.ByteString+urlEncodeFormStable = urlEncodeParams . sortOn fst . toList++-- | Encode a list of key-value pairs to an @application/x-www-form-urlencoded@ 'BSL.ByteString'.+--+-- See also 'urlEncodeFormStable'.+urlEncodeParams :: [(Text, Text)] -> BSL.ByteString+urlEncodeParams = toLazyByteString . mconcat . intersperse (shortByteString "&") . map encodePair+ where+ escape = urlEncodeBuilder True . Text.encodeUtf8++ encodePair (k, "") = escape k+ encodePair (k, v) = escape k <> shortByteString "=" <> escape v++-- | Decode an @application/x-www-form-urlencoded@ 'BSL.ByteString' to a 'Form'.+--+-- Key-value pairs get decoded normally:+--+-- >>> urlDecodeForm "name=Greg&lastname=Weber"+-- Right (fromList [("lastname","Weber"),("name","Greg")])+--+-- Keys with no values get decoded to pairs with empty values.+--+-- >>> urlDecodeForm "is_test"+-- Right (fromList [("is_test","")])+--+-- Empty keys are allowed:+--+-- >>> urlDecodeForm "=foobar"+-- Right (fromList [("","foobar")])+--+-- The empty string gets decoded into an empty 'Form':+--+-- >>> urlDecodeForm ""+-- Right (fromList [])+--+-- Everything is un-escaped with 'unEscapeString':+--+-- >>> urlDecodeForm "fullname=Andres%20L%C3%B6h"+-- Right (fromList [("fullname","Andres L\246h")])+--+-- Improperly formed strings result in an error:+--+-- >>> urlDecodeForm "this=has=too=many=equals"+-- Left "not a valid pair: this=has=too=many=equals"+urlDecodeForm :: BSL.ByteString -> Either Text Form+urlDecodeForm = fmap toForm . urlDecodeParams++-- | Decode an @application/x-www-form-urlencoded@ 'BSL.ByteString' to a list of key-value pairs.+--+-- See also 'urlDecodeForm'.+urlDecodeParams :: BSL.ByteString -> Either Text [(Text, Text)]+urlDecodeParams bs = traverse parsePair pairs+ where+ pairs = map (BSL8.split '=') (BSL8.split '&' bs)++ unescape = Text.decodeUtf8With lenientDecode . urlDecode True . BSL.toStrict++ parsePair p =+ case map unescape p of+ [k, v] -> return (k, v)+ [k] -> return (k, "")+ xs -> Left $ "not a valid pair: " <> Text.intercalate "=" xs+++-- | This is a convenience function for decoding a+-- @application/x-www-form-urlencoded@ 'BSL.ByteString' directly to a datatype+-- that has an instance of 'FromForm'.+--+-- This is effectively @'fromForm' '<=<' 'urlDecodeForm'@.+--+-- >>> urlDecodeAsForm "name=Dennis&age=22" :: Either Text Person+-- Right (Person {name = "Dennis", age = 22})+urlDecodeAsForm :: FromForm a => BSL.ByteString -> Either Text a+urlDecodeAsForm = fromForm <=< urlDecodeForm++-- | This is a convenience function for encoding a datatype that has instance+-- of 'ToForm' directly to a @application/x-www-form-urlencoded@+-- 'BSL.ByteString'.+--+-- This is effectively @'urlEncodeForm' . 'toForm'@.+--+-- _NOTE:_ this encoding is unstable and may result in different key order+-- (but not values). For a stable encoding see 'urlEncodeAsFormStable'.+urlEncodeAsForm :: ToForm a => a -> BSL.ByteString+urlEncodeAsForm = urlEncodeForm . toForm++-- | This is a convenience function for encoding a datatype that has instance+-- of 'ToForm' directly to a @application/x-www-form-urlencoded@+-- 'BSL.ByteString'.+--+-- This is effectively @'urlEncodeFormStable' . 'toForm'@.+--+-- >>> urlEncodeAsFormStable Person {name = "Dennis", age = 22}+-- "age=22&name=Dennis"+urlEncodeAsFormStable :: ToForm a => a -> BSL.ByteString+urlEncodeAsFormStable = urlEncodeFormStable . toForm++-- | Find all values corresponding to a given key in a 'Form'.+--+-- >>> lookupAll "name" []+-- []+-- >>> lookupAll "name" [("name", "Oleg")]+-- ["Oleg"]+-- >>> lookupAll "name" [("name", "Oleg"), ("name", "David")]+-- ["Oleg","David"]+lookupAll :: Text -> Form -> [Text]+lookupAll key = F.concat . Map.lookup key . unForm++-- | Lookup an optional value for a key.+-- Fail if there is more than one value.+--+-- >>> lookupMaybe "name" []+-- Right Nothing+-- >>> lookupMaybe "name" [("name", "Oleg")]+-- Right (Just "Oleg")+-- >>> lookupMaybe "name" [("name", "Oleg"), ("name", "David")]+-- Left "Duplicate key \"name\""+lookupMaybe :: Text -> Form -> Either Text (Maybe Text)+lookupMaybe key form =+ case lookupAll key form of+ [] -> pure Nothing+ [v] -> pure (Just v)+ _ -> Left $ "Duplicate key " <> Text.pack (show key)++-- | Lookup a unique value for a key.+-- Fail if there is zero or more than one value.+--+-- >>> lookupUnique "name" []+-- Left "Could not find key \"name\""+-- >>> lookupUnique "name" [("name", "Oleg")]+-- Right "Oleg"+-- >>> lookupUnique "name" [("name", "Oleg"), ("name", "David")]+-- Left "Duplicate key \"name\""+lookupUnique :: Text -> Form -> Either Text Text+lookupUnique key form = do+ mv <- lookupMaybe key form+ case mv of+ Just v -> pure v+ Nothing -> Left $ "Could not find key " <> Text.pack (show key)++-- | Lookup all values for a given key in a 'Form' and parse them with 'parseQueryParams'.+--+-- >>> parseAll "age" [] :: Either Text [Word8]+-- Right []+-- >>> parseAll "age" [("age", "8"), ("age", "seven")] :: Either Text [Word8]+-- Left "could not parse: `seven' (input does not start with a digit)"+-- >>> parseAll "age" [("age", "8"), ("age", "777")] :: Either Text [Word8]+-- Left "out of bounds: `777' (should be between 0 and 255)"+-- >>> parseAll "age" [("age", "12"), ("age", "25")] :: Either Text [Word8]+-- Right [12,25]+parseAll :: FromHttpApiData v => Text -> Form -> Either Text [v]+parseAll key = parseQueryParams . lookupAll key++-- | Lookup an optional value for a given key and parse it with 'parseQueryParam'.+-- Fail if there is more than one value for the key.+--+-- >>> parseMaybe "age" [] :: Either Text (Maybe Word8)+-- Right Nothing+-- >>> parseMaybe "age" [("age", "12"), ("age", "25")] :: Either Text (Maybe Word8)+-- Left "Duplicate key \"age\""+-- >>> parseMaybe "age" [("age", "seven")] :: Either Text (Maybe Word8)+-- Left "could not parse: `seven' (input does not start with a digit)"+-- >>> parseMaybe "age" [("age", "777")] :: Either Text (Maybe Word8)+-- Left "out of bounds: `777' (should be between 0 and 255)"+-- >>> parseMaybe "age" [("age", "7")] :: Either Text (Maybe Word8)+-- Right (Just 7)+parseMaybe :: FromHttpApiData v => Text -> Form -> Either Text (Maybe v)+parseMaybe key = parseQueryParams <=< lookupMaybe key++-- | Lookup a unique value for a given key and parse it with 'parseQueryParam'.+-- Fail if there is zero or more than one value for the key.+--+-- >>> parseUnique "age" [] :: Either Text Word8+-- Left "Could not find key \"age\""+-- >>> parseUnique "age" [("age", "12"), ("age", "25")] :: Either Text Word8+-- Left "Duplicate key \"age\""+-- >>> parseUnique "age" [("age", "seven")] :: Either Text Word8+-- Left "could not parse: `seven' (input does not start with a digit)"+-- >>> parseUnique "age" [("age", "777")] :: Either Text Word8+-- Left "out of bounds: `777' (should be between 0 and 255)"+-- >>> parseUnique "age" [("age", "7")] :: Either Text Word8+-- Right 7+parseUnique :: FromHttpApiData v => Text -> Form -> Either Text v+parseUnique key form = lookupUnique key form >>= parseQueryParam++-- | 'Generic'-based deriving options for 'ToForm' and 'FromForm'.+--+-- A common use case for non-default 'FormOptions'+-- is to strip a prefix off of field labels:+--+-- @+-- data Project = Project+-- { projectName :: String+-- , projectSize :: Int+-- } deriving ('Generic', 'Show')+--+-- myOptions :: 'FormOptions'+-- myOptions = 'FormOptions'+-- { 'fieldLabelModifier' = 'map' 'toLower' . 'drop' ('length' \"project\") }+--+-- instance 'ToForm' Project where+-- 'toForm' = 'genericToForm' myOptions+--+-- instance 'FromForm' Project where+-- 'fromForm' = 'genericFromForm' myOptions+-- @+--+-- >>> urlEncodeAsFormStable Project { projectName = "http-api-data", projectSize = 172 }+-- "name=http-api-data&size=172"+-- >>> urlDecodeAsForm "name=http-api-data&size=172" :: Either Text Project+-- Right (Project {projectName = "http-api-data", projectSize = 172})+data FormOptions = FormOptions+ { -- | Function applied to field labels. Handy for removing common record prefixes for example.+ fieldLabelModifier :: String -> String+ }++-- | Default encoding 'FormOptions'.+--+-- @+-- 'FormOptions'+-- { 'fieldLabelModifier' = id+-- }+-- @+defaultFormOptions :: FormOptions+defaultFormOptions = FormOptions+ { fieldLabelModifier = id+ }++sortOn :: Ord b => (a -> b) -> [a] -> [a]+sortOn f = sortBy (comparing f)
+ src/Web/Internal/HttpApiData.hs view
@@ -0,0 +1,905 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}+-- |+-- Convert Haskell values to and from HTTP API data+-- such as URL pieces, headers and query parameters.+module Web.Internal.HttpApiData where++import Control.Applicative (Const(Const))+import Control.Arrow (left, (&&&))+import Control.Monad ((<=<))+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as BS+import qualified Data.ByteString.Lazy as LBS+import Data.Coerce (coerce)+import Data.Data (Data)+import qualified Data.Fixed as F+import Data.Functor.Identity (Identity(Identity))+import Data.Int (Int16, Int32, Int64, Int8)+import Data.Kind (Type)+import qualified Data.Map.Strict as Map+import Data.Monoid (All (..), Any (..), Dual (..),+ First (..), Last (..),+ Product (..), Sum (..))+import qualified Data.Semigroup as Semi+import Data.Tagged (Tagged (..))+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8', decodeUtf8With,+ encodeUtf8)+import Data.Text.Encoding.Error (lenientDecode)+import qualified Data.Text.Lazy as L+import Data.Text.Lazy.Builder (Builder, toLazyText)+import Data.Text.Read (Reader, decimal, rational,+ signed)+import qualified Data.Time.ToText as TT+import qualified Data.Time.FromText as FT+import Data.Time.Compat (Day, LocalTime,+ NominalDiffTime, TimeOfDay,+ UTCTime, ZonedTime, DayOfWeek (..),+ nominalDiffTimeToSeconds,+ secondsToNominalDiffTime)+import Data.Time.Calendar.Month.Compat (Month)+import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..))+import Data.Typeable (Typeable)+import qualified Data.UUID.Types as UUID+import Data.Version (Version, parseVersion,+ showVersion)+import Data.Void (Void, absurd)+import Data.Word (Word16, Word32, Word64, Word8)+import qualified Network.HTTP.Types as H+import Numeric.Natural (Natural)+import Text.ParserCombinators.ReadP (readP_to_S)+import Text.Read (readMaybe)+import Web.Cookie (SetCookie, parseSetCookie,+ renderSetCookie)++#if USE_TEXT_SHOW+import TextShow (TextShow, showt)+#endif++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Data.Text (Text)+-- >>> import Data.Word (Word8)+-- >>> import Data.Text.Read (decimal)+-- >>> import Data.Time.Compat+-- >>> import Data.Time.Calendar.Month.Compat+-- >>> import Data.Time.Calendar.Quarter.Compat+-- >>> import Data.Version+-- >>> import Web.Cookie (SetCookie)+-- >>> data BasicAuthToken = BasicAuthToken Text deriving (Show)+-- >>> instance FromHttpApiData BasicAuthToken where parseHeader h = BasicAuthToken <$> parseHeaderWithPrefix "Basic " h; parseQueryParam p = BasicAuthToken <$> parseQueryParam p++-- | Convert value to HTTP API data.+--+-- __WARNING__: Do not derive this using @DeriveAnyClass@ as the generated+-- instance will loop indefinitely.+class ToHttpApiData a where+ {-# MINIMAL toUrlPiece | toQueryParam #-}+ -- | Convert to URL path piece.+ toUrlPiece :: a -> Text+ toUrlPiece = toQueryParam++ -- | Convert to a URL path piece, making sure to encode any special chars.+ -- The default definition uses @'H.urlEncodeBuilder' 'False'@+ -- but this may be overriden with a more efficient version.+ toEncodedUrlPiece :: a -> BS.Builder+ toEncodedUrlPiece = H.urlEncodeBuilder False . encodeUtf8 . toUrlPiece++ -- | Convert to HTTP header value.+ toHeader :: a -> ByteString+ toHeader = encodeUtf8 . toUrlPiece++ -- | Convert to query param value.+ toQueryParam :: a -> Text+ toQueryParam = toUrlPiece++ -- | Convert to URL query param,+ -- The default definition uses @'H.urlEncodeBuilder' 'True'@+ -- but this may be overriden with a more efficient version.+ --+ -- @since 0.5.1+ toEncodedQueryParam :: a -> BS.Builder+ toEncodedQueryParam = H.urlEncodeBuilder True . encodeUtf8 . toQueryParam++-- | Parse value from HTTP API data.+--+-- __WARNING__: Do not derive this using @DeriveAnyClass@ as the generated+-- instance will loop indefinitely.+class FromHttpApiData a where+ {-# MINIMAL parseUrlPiece | parseQueryParam #-}+ -- | Parse URL path piece.+ parseUrlPiece :: Text -> Either Text a+ parseUrlPiece = parseQueryParam++ -- | Parse HTTP header value.+ parseHeader :: ByteString -> Either Text a+ parseHeader = parseUrlPiece <=< (left (T.pack . show) . decodeUtf8')++ -- | Parse query param value.+ parseQueryParam :: Text -> Either Text a+ parseQueryParam = parseUrlPiece++-- | Convert multiple values to a list of URL pieces.+--+-- >>> toUrlPieces [1, 2, 3] :: [Text]+-- ["1","2","3"]+toUrlPieces :: (Functor t, ToHttpApiData a) => t a -> t Text+toUrlPieces = fmap toUrlPiece++-- | Parse multiple URL pieces.+--+-- >>> parseUrlPieces ["true", "false"] :: Either Text [Bool]+-- Right [True,False]+-- >>> parseUrlPieces ["123", "hello", "world"] :: Either Text [Int]+-- Left "could not parse: `hello' (input does not start with a digit)"+parseUrlPieces :: (Traversable t, FromHttpApiData a) => t Text -> Either Text (t a)+parseUrlPieces = traverse parseUrlPiece++-- | Convert multiple values to a list of query parameter values.+--+-- >>> toQueryParams [fromGregorian 2015 10 03, fromGregorian 2015 12 01] :: [Text]+-- ["2015-10-03","2015-12-01"]+toQueryParams :: (Functor t, ToHttpApiData a) => t a -> t Text+toQueryParams = fmap toQueryParam++-- | Parse multiple query parameters.+--+-- >>> parseQueryParams ["1", "2", "3"] :: Either Text [Int]+-- Right [1,2,3]+-- >>> parseQueryParams ["64", "128", "256"] :: Either Text [Word8]+-- Left "out of bounds: `256' (should be between 0 and 255)"+parseQueryParams :: (Traversable t, FromHttpApiData a) => t Text -> Either Text (t a)+parseQueryParams = traverse parseQueryParam++-- | Parse URL path piece in a @'Maybe'@.+--+-- >>> parseUrlPieceMaybe "12" :: Maybe Int+-- Just 12+parseUrlPieceMaybe :: FromHttpApiData a => Text -> Maybe a+parseUrlPieceMaybe = either (const Nothing) Just . parseUrlPiece++-- | Parse HTTP header value in a @'Maybe'@.+--+-- >>> parseHeaderMaybe "hello" :: Maybe Text+-- Just "hello"+parseHeaderMaybe :: FromHttpApiData a => ByteString -> Maybe a+parseHeaderMaybe = either (const Nothing) Just . parseHeader++-- | Parse query param value in a @'Maybe'@.+--+-- >>> parseQueryParamMaybe "true" :: Maybe Bool+-- Just True+parseQueryParamMaybe :: FromHttpApiData a => Text -> Maybe a+parseQueryParamMaybe = either (const Nothing) Just . parseQueryParam++-- | Default parsing error.+defaultParseError :: Text -> Either Text a+defaultParseError input = Left ("could not parse: `" <> input <> "'")++-- | Convert @'Maybe'@ parser into @'Either' 'Text'@ parser with default error message.+parseMaybeTextData :: (Text -> Maybe a) -> (Text -> Either Text a)+parseMaybeTextData parse input =+ case parse input of+ Nothing -> defaultParseError input+ Just val -> Right val++#if USE_TEXT_SHOW+-- | /Lower case/.+--+-- Convert to URL piece using @'TextShow'@ instance.+-- The result is always lower cased.+--+-- >>> showTextData True+-- "true"+--+-- This can be used as a default implementation for enumeration types:+--+-- @+-- data MyData = Foo | Bar | Baz deriving (Generic)+--+-- instance TextShow MyData where+-- showt = genericShowt+--+-- instance ToHttpApiData MyData where+-- toUrlPiece = showTextData+-- @+showTextData :: TextShow a => a -> Text+showTextData = T.toLower . showt+#else+-- | /Lower case/.+--+-- Convert to URL piece using @'Show'@ instance.+-- The result is always lower cased.+--+-- >>> showTextData True+-- "true"+--+-- This can be used as a default implementation for enumeration types:+--+-- >>> data MyData = Foo | Bar | Baz deriving (Show)+-- >>> instance ToHttpApiData MyData where toUrlPiece = showTextData+-- >>> toUrlPiece Foo+-- "foo"+showTextData :: Show a => a -> Text+showTextData = T.toLower . showt++-- | Like @'show'@, but returns @'Text'@.+showt :: Show a => a -> Text+showt = T.pack . show+#endif++-- | /Case insensitive/.+--+-- Parse given text case insensitive and then parse the rest of the input+-- using @'parseUrlPiece'@.+--+-- >>> parseUrlPieceWithPrefix "Just " "just 10" :: Either Text Int+-- Right 10+-- >>> parseUrlPieceWithPrefix "Left " "left" :: Either Text Bool+-- Left "could not parse: `left'"+--+-- This can be used to implement @'FromHttpApiData'@ for single field constructors:+--+-- >>> data Foo = Foo Int deriving (Show)+-- >>> instance FromHttpApiData Foo where parseUrlPiece s = Foo <$> parseUrlPieceWithPrefix "Foo " s+-- >>> parseUrlPiece "foo 1" :: Either Text Foo+-- Right (Foo 1)+parseUrlPieceWithPrefix :: FromHttpApiData a => Text -> Text -> Either Text a+parseUrlPieceWithPrefix pattern input+ | T.toLower pattern == T.toLower prefix = parseUrlPiece rest+ | otherwise = defaultParseError input+ where+ (prefix, rest) = T.splitAt (T.length pattern) input++-- | Parse given bytestring then parse the rest of the input using @'parseHeader'@.+--+-- @+-- data BasicAuthToken = BasicAuthToken Text deriving (Show)+--+-- instance FromHttpApiData BasicAuthToken where+-- parseHeader h = BasicAuthToken \<$\> parseHeaderWithPrefix "Basic " h+-- parseQueryParam p = BasicAuthToken \<$\> parseQueryParam p+-- @+--+-- >>> parseHeader "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" :: Either Text BasicAuthToken+-- Right (BasicAuthToken "QWxhZGRpbjpvcGVuIHNlc2FtZQ==")+parseHeaderWithPrefix :: FromHttpApiData a => ByteString -> ByteString -> Either Text a+parseHeaderWithPrefix pattern input+ | pattern `BS.isPrefixOf` input = parseHeader (BS.drop (BS.length pattern) input)+ | otherwise = defaultParseError (showt input)++-- | /Case insensitive/.+--+-- Parse given text case insensitive and then parse the rest of the input+-- using @'parseQueryParam'@.+--+-- >>> parseQueryParamWithPrefix "z" "z10" :: Either Text Int+-- Right 10+parseQueryParamWithPrefix :: FromHttpApiData a => Text -> Text -> Either Text a+parseQueryParamWithPrefix pattern input+ | T.toLower pattern == T.toLower prefix = parseQueryParam rest+ | otherwise = defaultParseError input+ where+ (prefix, rest) = T.splitAt (T.length pattern) input++#if USE_TEXT_SHOW+-- | /Case insensitive/.+--+-- Parse values case insensitively based on @'TextShow'@ instance.+--+-- >>> parseBoundedTextData "true" :: Either Text Bool+-- Right True+-- >>> parseBoundedTextData "FALSE" :: Either Text Bool+-- Right False+--+-- This can be used as a default implementation for enumeration types:+--+-- @+-- data MyData = Foo | Bar | Baz deriving (Show, Bounded, Enum, Generic)+--+-- instance TextShow MyData where+-- showt = genericShowt+--+-- instance FromHttpApiData MyData where+-- parseUrlPiece = parseBoundedTextData+-- @+parseBoundedTextData :: (TextShow a, Bounded a, Enum a) => Text -> Either Text a+#else+-- | /Case insensitive/.+--+-- Parse values case insensitively based on @'Show'@ instance.+--+-- >>> parseBoundedTextData "true" :: Either Text Bool+-- Right True+-- >>> parseBoundedTextData "FALSE" :: Either Text Bool+-- Right False+--+-- This can be used as a default implementation for enumeration types:+--+-- >>> data MyData = Foo | Bar | Baz deriving (Show, Bounded, Enum)+-- >>> instance FromHttpApiData MyData where parseUrlPiece = parseBoundedTextData+-- >>> parseUrlPiece "foo" :: Either Text MyData+-- Right Foo+parseBoundedTextData :: (Show a, Bounded a, Enum a) => Text -> Either Text a+#endif+parseBoundedTextData = parseBoundedEnumOfI showTextData++-- | Lookup values based on a precalculated mapping of their representations.+lookupBoundedEnumOf :: (Bounded a, Enum a, Eq b) => (a -> b) -> b -> Maybe a+lookupBoundedEnumOf f = flip lookup (map (f &&& id) [minBound..maxBound])++-- | Parse values based on a precalculated mapping of their @'Text'@ representation.+--+-- >>> parseBoundedEnumOf toUrlPiece "true" :: Either Text Bool+-- Right True+--+-- For case insensitive parser see 'parseBoundedEnumOfI'.+parseBoundedEnumOf :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a+parseBoundedEnumOf = parseMaybeTextData . lookupBoundedEnumOf++-- | /Case insensitive/.+--+-- Parse values case insensitively based on a precalculated mapping+-- of their @'Text'@ representations.+--+-- >>> parseBoundedEnumOfI toUrlPiece "FALSE" :: Either Text Bool+-- Right False+--+-- For case sensitive parser see 'parseBoundedEnumOf'.+parseBoundedEnumOfI :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a+parseBoundedEnumOfI f = parseBoundedEnumOf (T.toLower . f) . T.toLower++-- | /Case insensitive/.+--+-- Parse values case insensitively based on @'ToHttpApiData'@ instance.+-- Uses @'toUrlPiece'@ to get possible values.+parseBoundedUrlPiece :: (ToHttpApiData a, Bounded a, Enum a) => Text -> Either Text a+parseBoundedUrlPiece = parseBoundedEnumOfI toUrlPiece++-- | /Case insensitive/.+--+-- Parse values case insensitively based on @'ToHttpApiData'@ instance.+-- Uses @'toQueryParam'@ to get possible values.+parseBoundedQueryParam :: (ToHttpApiData a, Bounded a, Enum a) => Text -> Either Text a+parseBoundedQueryParam = parseBoundedEnumOfI toQueryParam++-- | Parse values based on @'ToHttpApiData'@ instance.+-- Uses @'toHeader'@ to get possible values.+parseBoundedHeader :: (ToHttpApiData a, Bounded a, Enum a) => ByteString -> Either Text a+parseBoundedHeader bs = case lookupBoundedEnumOf toHeader bs of+ Nothing -> defaultParseError $ T.pack $ show bs+ Just x -> return x++-- | Parse URL piece using @'Read'@ instance.+--+-- Use for types which do not involve letters:+--+-- >>> readTextData "1991-06-02" :: Either Text Day+-- Right 1991-06-02+--+-- This parser is case sensitive and will not match @'showTextData'@+-- in presence of letters:+--+-- >>> readTextData (showTextData True) :: Either Text Bool+-- Left "could not parse: `true'"+--+-- See @'parseBoundedTextData'@.+readTextData :: Read a => Text -> Either Text a+readTextData = parseMaybeTextData (readMaybe . T.unpack)++-- | Run @'Reader'@ as HTTP API data parser.+runReader :: Reader a -> Text -> Either Text a+runReader reader input =+ case reader input of+ Left err -> Left ("could not parse: `" <> input <> "' (" <> T.pack err <> ")")+ Right (x, rest)+ | T.null rest -> Right x+ | otherwise -> defaultParseError input++-- | Run @'Reader'@ to parse bounded integral value with bounds checking.+--+-- >>> parseBounded decimal "256" :: Either Text Word8+-- Left "out of bounds: `256' (should be between 0 and 255)"+parseBounded :: forall a. (Bounded a, Integral a) => Reader Integer -> Text -> Either Text a+parseBounded reader input = do+ n <- runReader reader input+ if (n > h || n < l)+ then Left ("out of bounds: `" <> input <> "' (should be between " <> showt l <> " and " <> showt h <> ")")+ else Right (fromInteger n)+ where+ l = toInteger (minBound :: a)+ h = toInteger (maxBound :: a)++-- | Convert to a URL-encoded path piece using 'toUrlPiece'.+-- /Note/: this function does not check if the result contains unescaped characters!+-- This function can be used to override 'toEncodedUrlPiece' as a more efficient implementation+-- when the resulting URL piece /never/ has to be escaped.+unsafeToEncodedUrlPiece :: ToHttpApiData a => a -> BS.Builder+unsafeToEncodedUrlPiece = BS.byteString . encodeUtf8 . toUrlPiece++-- | Convert to a URL-encoded query param using 'toQueryParam'.+-- /Note/: this function does not check if the result contains unescaped characters!+--+-- @since 0.5.1+unsafeToEncodedQueryParam :: ToHttpApiData a => a -> BS.Builder+unsafeToEncodedQueryParam = BS.byteString . encodeUtf8 . toQueryParam++-- |+-- >>> toUrlPiece ()+-- "_"+instance ToHttpApiData () where+ toUrlPiece _ = "_"+ toHeader _ = "_"+ toEncodedUrlPiece _ = "_"+ toEncodedQueryParam _ = "_"++instance ToHttpApiData Char where+ toUrlPiece = T.singleton++-- |+-- >>> toUrlPiece (Version [1, 2, 3] [])+-- "1.2.3"+instance ToHttpApiData Version where+ toUrlPiece = T.pack . showVersion+ toEncodedUrlPiece = unsafeToEncodedUrlPiece+ toEncodedQueryParam = unsafeToEncodedQueryParam++instance ToHttpApiData Void where toUrlPiece = absurd+instance ToHttpApiData Natural where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam++instance ToHttpApiData Bool where toUrlPiece = showTextData; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam+instance ToHttpApiData Ordering where toUrlPiece = showTextData; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam++instance ToHttpApiData Double where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam+instance ToHttpApiData Float where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam+instance ToHttpApiData Int where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam+instance ToHttpApiData Int8 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam+instance ToHttpApiData Int16 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam+instance ToHttpApiData Int32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam+instance ToHttpApiData Int64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam+instance ToHttpApiData Integer where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam+instance ToHttpApiData Word where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam+instance ToHttpApiData Word8 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam+instance ToHttpApiData Word16 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam+instance ToHttpApiData Word32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam+instance ToHttpApiData Word64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam++-- | Note: this instance is not polykinded+instance F.HasResolution a => ToHttpApiData (F.Fixed (a :: Type)) where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam++-- |+-- >>> toUrlPiece (fromGregorian 2015 10 03)+-- "2015-10-03"+instance ToHttpApiData Day where+ toUrlPiece = runTT TT.buildDay+ toEncodedUrlPiece = unsafeToEncodedUrlPiece+ toEncodedQueryParam = unsafeToEncodedQueryParam++-- |+-- >>> toUrlPiece $ TimeOfDay 14 55 23.1+-- "14:55:23.100"+instance ToHttpApiData TimeOfDay where+ toUrlPiece = runTT TT.buildTimeOfDay+ toEncodedUrlPiece = unsafeToEncodedUrlPiece+ -- no toEncodedQueryParam as : is unsafe char.++-- |+-- >>> toUrlPiece $ LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 21.687)+-- "2015-10-03T14:55:21.687"+instance ToHttpApiData LocalTime where+ toUrlPiece = runTT TT.buildLocalTime+ toEncodedUrlPiece = unsafeToEncodedUrlPiece+ -- no toEncodedQueryParam as : is unsafe char.++-- |+-- >>> toUrlPiece $ ZonedTime (LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 51.001)) utc+-- "2015-10-03T14:55:51.001Z"+--+-- >>> toUrlPiece $ ZonedTime (LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 51.001)) (TimeZone 120 True "EET")+-- "2015-10-03T14:55:51.001+02:00"+--+instance ToHttpApiData ZonedTime where+ toUrlPiece = runTT TT.buildZonedTime+ toEncodedUrlPiece = unsafeToEncodedUrlPiece+ -- no toEncodedQueryParam as : is unsafe char.++-- |+-- >>> toUrlPiece $ UTCTime (fromGregorian 2015 10 03) 864.5+-- "2015-10-03T00:14:24.500Z"+instance ToHttpApiData UTCTime where+ toUrlPiece = runTT TT.buildUTCTime+ toEncodedUrlPiece = unsafeToEncodedUrlPiece+ -- no toEncodedQueryParam as : is unsafe char.++-- |+-- >>> toUrlPiece Monday+-- "monday"+instance ToHttpApiData DayOfWeek where+ toUrlPiece Monday = "monday"+ toUrlPiece Tuesday = "tuesday"+ toUrlPiece Wednesday = "wednesday"+ toUrlPiece Thursday = "thursday"+ toUrlPiece Friday = "friday"+ toUrlPiece Saturday = "saturday"+ toUrlPiece Sunday = "sunday"++ toEncodedUrlPiece = unsafeToEncodedUrlPiece+ toEncodedQueryParam = unsafeToEncodedQueryParam++-- |+-- >>> toUrlPiece Q4+-- "q4"+instance ToHttpApiData QuarterOfYear where+ toUrlPiece = runTT TT.buildQuarterOfYear++ toEncodedUrlPiece = unsafeToEncodedUrlPiece+ toEncodedQueryParam = unsafeToEncodedQueryParam++-- |+-- >>> import Data.Time.Calendar.Quarter.Compat (Quarter (..))+-- >>> MkQuarter 8040+-- 2010-Q1+--+-- >>> toUrlPiece $ MkQuarter 8040+-- "2010-q1"+--+instance ToHttpApiData Quarter where+ toUrlPiece = runTT TT.buildQuarter++ toEncodedUrlPiece = unsafeToEncodedUrlPiece+ toEncodedQueryParam = unsafeToEncodedQueryParam++-- |+-- >>> import Data.Time.Calendar.Month.Compat (Month (..))+-- >>> MkMonth 24482+-- 2040-03+--+-- >>> toUrlPiece $ MkMonth 24482+-- "2040-03"+--+instance ToHttpApiData Month where+ toUrlPiece = runTT TT.buildMonth++ toEncodedUrlPiece = unsafeToEncodedUrlPiece+ toEncodedQueryParam = unsafeToEncodedQueryParam++instance ToHttpApiData NominalDiffTime where+ toUrlPiece = toUrlPiece . nominalDiffTimeToSeconds++ toEncodedQueryParam = unsafeToEncodedQueryParam+ toEncodedUrlPiece = unsafeToEncodedUrlPiece++instance ToHttpApiData String where toUrlPiece = T.pack+instance ToHttpApiData Text where toUrlPiece = id+instance ToHttpApiData L.Text where toUrlPiece = L.toStrict++instance ToHttpApiData All where+ toUrlPiece = coerce (toUrlPiece :: Bool -> Text)+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Bool -> BS.Builder)+ toEncodedQueryParam = coerce (toEncodedQueryParam :: Bool -> BS.Builder)++instance ToHttpApiData Any where+ toUrlPiece = coerce (toUrlPiece :: Bool -> Text)+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Bool -> BS.Builder)+ toEncodedQueryParam = coerce (toEncodedQueryParam :: Bool -> BS.Builder)++instance ToHttpApiData a => ToHttpApiData (Dual a) where+ toUrlPiece = coerce (toUrlPiece :: a -> Text)+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)+ toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder)++instance ToHttpApiData a => ToHttpApiData (Sum a) where+ toUrlPiece = coerce (toUrlPiece :: a -> Text)+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)+ toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder)++instance ToHttpApiData a => ToHttpApiData (Product a) where+ toUrlPiece = coerce (toUrlPiece :: a -> Text)+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)+ toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder)++instance ToHttpApiData a => ToHttpApiData (First a) where+ toUrlPiece = coerce (toUrlPiece :: Maybe a -> Text)+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Maybe a -> BS.Builder)+ toEncodedQueryParam = coerce (toEncodedQueryParam :: Maybe a -> BS.Builder)++instance ToHttpApiData a => ToHttpApiData (Last a) where+ toUrlPiece = coerce (toUrlPiece :: Maybe a -> Text)+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Maybe a -> BS.Builder)+ toEncodedQueryParam = coerce (toEncodedQueryParam :: Maybe a -> BS.Builder)++instance ToHttpApiData a => ToHttpApiData (Semi.Min a) where+ toUrlPiece = coerce (toUrlPiece :: a -> Text)+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)+ toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder)++instance ToHttpApiData a => ToHttpApiData (Semi.Max a) where+ toUrlPiece = coerce (toUrlPiece :: a -> Text)+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)+ toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder)++instance ToHttpApiData a => ToHttpApiData (Semi.First a) where+ toUrlPiece = coerce (toUrlPiece :: a -> Text)+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)+ toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder)++instance ToHttpApiData a => ToHttpApiData (Semi.Last a) where+ toUrlPiece = coerce (toUrlPiece :: a -> Text)+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)+ toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder)++-- |+-- >>> toUrlPiece (Just "Hello")+-- "just Hello"+instance ToHttpApiData a => ToHttpApiData (Maybe a) where+ toUrlPiece (Just x) = "just " <> toUrlPiece x+ toUrlPiece Nothing = "nothing"++-- |+-- >>> toUrlPiece (Left "err" :: Either String Int)+-- "left err"+-- >>> toUrlPiece (Right 3 :: Either String Int)+-- "right 3"+instance (ToHttpApiData a, ToHttpApiData b) => ToHttpApiData (Either a b) where+ toUrlPiece (Left x) = "left " <> toUrlPiece x+ toUrlPiece (Right x) = "right " <> toUrlPiece x++-- | /Note:/ this instance works correctly for alphanumeric name and value+--+-- >>> let Right c = parseUrlPiece "SESSID=r2t5uvjq435r4q7ib3vtdjq120" :: Either Text SetCookie+-- >>> toUrlPiece c+-- "SESSID=r2t5uvjq435r4q7ib3vtdjq120"+--+-- >>> toHeader c+-- "SESSID=r2t5uvjq435r4q7ib3vtdjq120"+--+instance ToHttpApiData SetCookie where+ toUrlPiece = decodeUtf8With lenientDecode . toHeader+ toHeader = LBS.toStrict . BS.toLazyByteString . renderSetCookie+ -- toEncodedUrlPiece = renderSetCookie -- doesn't do things.++-- | Note: this instance is not polykinded+instance ToHttpApiData a => ToHttpApiData (Tagged (b :: Type) a) where+ toUrlPiece = coerce (toUrlPiece :: a -> Text)+ toHeader = coerce (toHeader :: a -> ByteString)+ toQueryParam = coerce (toQueryParam :: a -> Text)+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)+ toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder)++-- | @since 0.4.2+instance ToHttpApiData a => ToHttpApiData (Const a b) where+ toUrlPiece = coerce (toUrlPiece :: a -> Text)+ toHeader = coerce (toHeader :: a -> ByteString)+ toQueryParam = coerce (toQueryParam :: a -> Text)+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)+ toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder)++-- | @since 0.4.2+instance ToHttpApiData a => ToHttpApiData (Identity a) where+ toUrlPiece = coerce (toUrlPiece :: a -> Text)+ toHeader = coerce (toHeader :: a -> ByteString)+ toQueryParam = coerce (toQueryParam :: a -> Text)+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)+ toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder)++-- |+-- >>> parseUrlPiece "_" :: Either Text ()+-- Right ()+instance FromHttpApiData () where+ parseUrlPiece "_" = pure ()+ parseUrlPiece s = defaultParseError s++instance FromHttpApiData Char where+ parseUrlPiece s =+ case T.uncons s of+ Just (c, s') | T.null s' -> pure c+ _ -> defaultParseError s++-- |+-- >>> showVersion <$> parseUrlPiece "1.2.3"+-- Right "1.2.3"+instance FromHttpApiData Version where+ parseUrlPiece s =+ case reverse (readP_to_S parseVersion (T.unpack s)) of+ ((x, ""):_) -> pure x+ _ -> defaultParseError s++-- | Parsing a @'Void'@ value is always an error, considering @'Void'@ as a data type with no constructors.+instance FromHttpApiData Void where+ parseUrlPiece _ = Left "Void cannot be parsed!"++instance FromHttpApiData Natural where+ parseUrlPiece s = do+ n <- runReader (signed decimal) s+ if n < 0+ then Left ("underflow: " <> s <> " (should be a non-negative integer)")+ else Right (fromInteger n)++instance FromHttpApiData Bool where parseUrlPiece = parseBoundedUrlPiece+instance FromHttpApiData Ordering where parseUrlPiece = parseBoundedUrlPiece+instance FromHttpApiData Double where parseUrlPiece = runReader rational+instance FromHttpApiData Float where parseUrlPiece = runReader rational+instance FromHttpApiData Int where parseUrlPiece = parseBounded (signed decimal)+instance FromHttpApiData Int8 where parseUrlPiece = parseBounded (signed decimal)+instance FromHttpApiData Int16 where parseUrlPiece = parseBounded (signed decimal)+instance FromHttpApiData Int32 where parseUrlPiece = parseBounded (signed decimal)+instance FromHttpApiData Int64 where parseUrlPiece = parseBounded (signed decimal)+instance FromHttpApiData Integer where parseUrlPiece = runReader (signed decimal)+instance FromHttpApiData Word where parseUrlPiece = parseBounded decimal+instance FromHttpApiData Word8 where parseUrlPiece = parseBounded decimal+instance FromHttpApiData Word16 where parseUrlPiece = parseBounded decimal+instance FromHttpApiData Word32 where parseUrlPiece = parseBounded decimal+instance FromHttpApiData Word64 where parseUrlPiece = parseBounded decimal+instance FromHttpApiData String where parseUrlPiece = Right . T.unpack+instance FromHttpApiData Text where parseUrlPiece = Right+instance FromHttpApiData L.Text where parseUrlPiece = Right . L.fromStrict++-- | Note: this instance is not polykinded+instance F.HasResolution a => FromHttpApiData (F.Fixed (a :: Type)) where+ parseUrlPiece = runReader rational++-- |+-- >>> toGregorian <$> parseUrlPiece "2016-12-01"+-- Right (2016,12,1)+instance FromHttpApiData Day where parseUrlPiece = runFT FT.parseDay++-- |+-- >>> parseUrlPiece "14:55:01.333" :: Either Text TimeOfDay+-- Right 14:55:01.333+instance FromHttpApiData TimeOfDay where parseUrlPiece = runFT FT.parseTimeOfDay++-- |+-- >>> parseUrlPiece "2015-10-03T14:55:01" :: Either Text LocalTime+-- Right 2015-10-03 14:55:01+instance FromHttpApiData LocalTime where parseUrlPiece = runFT FT.parseLocalTime++-- |+-- >>> parseUrlPiece "2015-10-03T14:55:01+0000" :: Either Text ZonedTime+-- Right 2015-10-03 14:55:01 +0000+--+-- >>> parseQueryParam "2016-12-31T01:00:00Z" :: Either Text ZonedTime+-- Right 2016-12-31 01:00:00 +0000+instance FromHttpApiData ZonedTime where parseUrlPiece = runFT FT.parseZonedTime++-- |+-- >>> parseUrlPiece "2015-10-03T00:14:24Z" :: Either Text UTCTime+-- Right 2015-10-03 00:14:24 UTC+instance FromHttpApiData UTCTime where parseUrlPiece = runFT FT.parseUTCTime++-- |+-- >>> parseUrlPiece "Monday" :: Either Text DayOfWeek+-- Right Monday+instance FromHttpApiData DayOfWeek where+ parseUrlPiece t = case Map.lookup (T.toLower t) m of+ Just dow -> Right dow+ Nothing -> Left $ "Incorrect DayOfWeek: " <> T.take 10 t+ where+ m :: Map.Map Text DayOfWeek+ m = Map.fromList [ (toUrlPiece dow, dow) | dow <- [Monday .. Sunday] ]+++instance FromHttpApiData NominalDiffTime where parseUrlPiece = fmap secondsToNominalDiffTime . parseUrlPiece++-- |+-- >>> parseUrlPiece "2021-01" :: Either Text Month+-- Right 2021-01+instance FromHttpApiData Month where parseUrlPiece = runFT FT.parseMonth++-- |+-- >>> parseUrlPiece "2021-q1" :: Either Text Quarter+-- Right 2021-Q1+instance FromHttpApiData Quarter where parseUrlPiece = runFT FT.parseQuarter++-- |+-- >>> parseUrlPiece "q2" :: Either Text QuarterOfYear+-- Right Q2+--+-- >>> parseUrlPiece "Q3" :: Either Text QuarterOfYear+-- Right Q3+instance FromHttpApiData QuarterOfYear where parseUrlPiece = runFT FT.parseQuarterOfYear++instance FromHttpApiData All where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text Bool)+instance FromHttpApiData Any where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text Bool)++instance FromHttpApiData a => FromHttpApiData (Dual a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)+instance FromHttpApiData a => FromHttpApiData (Sum a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)+instance FromHttpApiData a => FromHttpApiData (Product a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)+instance FromHttpApiData a => FromHttpApiData (First a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text (Maybe a))+instance FromHttpApiData a => FromHttpApiData (Last a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text (Maybe a))++instance FromHttpApiData a => FromHttpApiData (Semi.Min a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)+instance FromHttpApiData a => FromHttpApiData (Semi.Max a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)+instance FromHttpApiData a => FromHttpApiData (Semi.First a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)+instance FromHttpApiData a => FromHttpApiData (Semi.Last a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)++-- |+-- >>> parseUrlPiece "Just 123" :: Either Text (Maybe Int)+-- Right (Just 123)+instance FromHttpApiData a => FromHttpApiData (Maybe a) where+ parseUrlPiece s+ | T.toLower (T.take 7 s) == "nothing" = pure Nothing+ | otherwise = Just <$> parseUrlPieceWithPrefix "Just " s++-- |+-- >>> parseUrlPiece "Right 123" :: Either Text (Either String Int)+-- Right (Right 123)+instance (FromHttpApiData a, FromHttpApiData b) => FromHttpApiData (Either a b) where+ parseUrlPiece s =+ Right <$> parseUrlPieceWithPrefix "Right " s+ <!> Left <$> parseUrlPieceWithPrefix "Left " s+ where+ infixl 3 <!>+ Left _ <!> y = y+ x <!> _ = x++instance ToHttpApiData UUID.UUID where+ toUrlPiece = UUID.toText+ toHeader = UUID.toASCIIBytes+ toEncodedUrlPiece = unsafeToEncodedUrlPiece++instance FromHttpApiData UUID.UUID where+ parseUrlPiece = maybe (Left "invalid UUID") Right . UUID.fromText+ parseHeader = maybe (Left "invalid UUID") Right . UUID.fromASCIIBytes+++-- | Lenient parameters. 'FromHttpApiData' combinators always return `Right`.+--+-- @since 0.3.5+newtype LenientData a = LenientData { getLenientData :: Either Text a }+ deriving (Eq, Ord, Show, Read, Typeable, Data, Functor, Foldable, Traversable)++instance FromHttpApiData a => FromHttpApiData (LenientData a) where+ parseUrlPiece = Right . LenientData . parseUrlPiece+ parseHeader = Right . LenientData . parseHeader+ parseQueryParam = Right . LenientData . parseQueryParam++-- | /Note:/ this instance works correctly for alphanumeric name and value+--+-- >>> parseUrlPiece "SESSID=r2t5uvjq435r4q7ib3vtdjq120" :: Either Text SetCookie+-- Right (SetCookie {setCookieName = "SESSID", setCookieValue = "r2t5uvjq435r4q7ib3vtdjq120", setCookiePath = Nothing, setCookieExpires = Nothing, setCookieMaxAge = Nothing, setCookieDomain = Nothing, setCookieHttpOnly = False, setCookieSecure = False, setCookieSameSite = Nothing, setCookiePartitioned = False})+instance FromHttpApiData SetCookie where+ parseUrlPiece = parseHeader . encodeUtf8+ parseHeader = Right . parseSetCookie++-- | Note: this instance is not polykinded+instance FromHttpApiData a => FromHttpApiData (Tagged (b :: Type) a) where+ parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)+ parseHeader = coerce (parseHeader :: ByteString -> Either Text a)+ parseQueryParam = coerce (parseQueryParam :: Text -> Either Text a)++-- | @since 0.4.2+instance FromHttpApiData a => FromHttpApiData (Const a b) where+ parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)+ parseHeader = coerce (parseHeader :: ByteString -> Either Text a)+ parseQueryParam = coerce (parseQueryParam :: Text -> Either Text a)++-- | @since 0.4.2+instance FromHttpApiData a => FromHttpApiData (Identity a) where+ parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)+ parseHeader = coerce (parseHeader :: ByteString -> Either Text a)+ parseQueryParam = coerce (parseQueryParam :: Text -> Either Text a)++-------------------------------------------------------------------------------+-- Helpers+-------------------------------------------------------------------------------++runTT :: (a -> Builder) -> a -> Text+runTT f x = L.toStrict (toLazyText (f x))++runFT :: (Text -> Either String a) -> Text -> Either Text a+runFT f t = case f t of+ Left err -> Left (T.pack err)+ Right x -> Right x
− test/DocTest.hs
@@ -1,30 +0,0 @@-module Main where--import Build_doctest (autogen_dir, deps)-import Control.Applicative-import Control.Monad-import Data.List-import System.Directory-import System.FilePath-import Test.DocTest--main :: IO ()-main = getSources >>= \sources -> doctest $- "-isrc"- : ("-i" ++ autogen_dir)- : "-optP-include"- : ("-optP" ++ autogen_dir ++ "/cabal_macros.h")- : "-hide-all-packages"- : map ("-package="++) deps ++ sources--getSources :: IO [FilePath]-getSources = filter (isSuffixOf ".hs") <$> go "src"- where- go dir = do- (dirs, files) <- getFilesAndDirectories dir- (files ++) . concat <$> mapM go dirs--getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])-getFilesAndDirectories dir = do- c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir- (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c
test/Spec.hs view
@@ -1,132 +1,1 @@-{-# Language ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Main where--import Control.Applicative--import Data.Int-import Data.Char-import Data.Word-import Data.Time-import qualified Data.Text as T-import qualified Data.Text.Lazy as L-import qualified Data.ByteString as BS-import Data.Version--import Test.Hspec-import Test.Hspec.QuickCheck(prop)-import Test.QuickCheck--import Web.HttpApiData--instance Arbitrary T.Text where- arbitrary = T.pack <$> arbitrary--instance Arbitrary L.Text where- arbitrary = L.pack <$> arbitrary--instance Arbitrary Day where- arbitrary = liftA3 fromGregorian (fmap abs arbitrary) arbitrary arbitrary--instance Arbitrary LocalTime where- arbitrary = LocalTime- <$> arbitrary- <*> liftA3 TimeOfDay (choose (0, 23)) (choose (0, 59)) (fromInteger <$> choose (0, 60))--instance Eq ZonedTime where- ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y--instance Arbitrary ZonedTime where- arbitrary = ZonedTime- <$> arbitrary- <*> liftA3 TimeZone arbitrary arbitrary (vectorOf 3 (elements ['A'..'Z']))--instance Arbitrary UTCTime where- arbitrary = UTCTime <$> arbitrary <*> fmap fromInteger (choose (0, 86400))--instance Arbitrary NominalDiffTime where- arbitrary = fromInteger <$> arbitrary--instance Arbitrary Version where- arbitrary = (version . map abs) <$> nonempty- where- version branch = Version branch []- nonempty = liftA2 (:) arbitrary arbitrary--main :: IO ()-main = hspec spec--(<=>) :: Eq a => (a -> b) -> (b -> Either T.Text a) -> a -> Bool-(f <=> g) x = g (f x) == Right x--data Proxy a = Proxy--checkUrlPiece :: forall a. (Eq a, ToHttpApiData a, FromHttpApiData a, Show a, Arbitrary a) => Proxy a -> String -> Spec-checkUrlPiece _ name = prop name (toUrlPiece <=> parseUrlPiece :: a -> Bool)--data RandomCase a = RandomCase [Bool] a--instance ToHttpApiData a => Show (RandomCase a) where- show rc@(RandomCase _ x) = show (toUrlPiece rc) ++ " (original: " ++ show (toUrlPiece x) ++ ")"--instance Eq a => Eq (RandomCase a) where- RandomCase _ x == RandomCase _ y = x == y--instance Arbitrary a => Arbitrary (RandomCase a) where- arbitrary = liftA2 RandomCase nonempty arbitrary- where- nonempty = liftA2 (:) arbitrary arbitrary--instance ToHttpApiData a => ToHttpApiData (RandomCase a) where- toUrlPiece (RandomCase us x) = T.pack (zipWith (\u -> if u then toUpper else toLower) (cycle us) (T.unpack (toUrlPiece x)))--instance FromHttpApiData a => FromHttpApiData (RandomCase a) where- parseUrlPiece s = RandomCase [] <$> parseUrlPiece s---- | Check case insensitivity for @parseUrlPiece@.-checkUrlPieceI :: forall a. (Eq a, ToHttpApiData a, FromHttpApiData a, Show a, Arbitrary a) => Proxy a -> String -> Spec-checkUrlPieceI _ = checkUrlPiece (Proxy :: Proxy (RandomCase a))--spec :: Spec-spec = do- describe "toUrlPiece <=> parseUrlPiece" $ do- checkUrlPiece (Proxy :: Proxy ()) "()"- checkUrlPiece (Proxy :: Proxy Char) "Char"- checkUrlPieceI (Proxy :: Proxy Bool) "Bool"- checkUrlPieceI (Proxy :: Proxy Ordering) "Ordering"- checkUrlPiece (Proxy :: Proxy Int) "Int"- checkUrlPiece (Proxy :: Proxy Int8) "Int8"- checkUrlPiece (Proxy :: Proxy Int16) "Int16"- checkUrlPiece (Proxy :: Proxy Int32) "Int32"- checkUrlPiece (Proxy :: Proxy Int64) "Int64"- checkUrlPiece (Proxy :: Proxy Integer) "Integer"- checkUrlPiece (Proxy :: Proxy Word) "Word"- checkUrlPiece (Proxy :: Proxy Word8) "Word8"- checkUrlPiece (Proxy :: Proxy Word16) "Word16"- checkUrlPiece (Proxy :: Proxy Word32) "Word32"- checkUrlPiece (Proxy :: Proxy Word64) "Word64"- checkUrlPiece (Proxy :: Proxy String) "String"- checkUrlPiece (Proxy :: Proxy T.Text) "Text.Strict"- checkUrlPiece (Proxy :: Proxy L.Text) "Text.Lazy"- checkUrlPiece (Proxy :: Proxy Day) "Day"- checkUrlPiece (Proxy :: Proxy LocalTime) "LocalTime"- checkUrlPiece (Proxy :: Proxy ZonedTime) "ZonedTime"- checkUrlPiece (Proxy :: Proxy UTCTime) "UTCTime"- checkUrlPiece (Proxy :: Proxy NominalDiffTime) "NominalDiffTime"- checkUrlPiece (Proxy :: Proxy Version) "Version"-- checkUrlPiece (Proxy :: Proxy (Maybe String)) "Maybe String"- checkUrlPieceI (Proxy :: Proxy (Maybe Integer)) "Maybe Integer"- checkUrlPiece (Proxy :: Proxy (Either Integer T.Text)) "Either Integer Text"- checkUrlPieceI (Proxy :: Proxy (Either Version Day)) "Either Version Day"-- it "bad integers are rejected" $ do- parseUrlPieceMaybe (T.pack "123hello") `shouldBe` (Nothing :: Maybe Int)-- it "bounds checking works" $ do- parseUrlPieceMaybe (T.pack "256") `shouldBe` (Nothing :: Maybe Int8)- parseUrlPieceMaybe (T.pack "-10") `shouldBe` (Nothing :: Maybe Word)-- it "invalid utf8 is handled" $ do- parseHeaderMaybe (BS.pack [128]) `shouldBe` (Nothing :: Maybe T.Text)-+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/Web/Internal/FormUrlEncodedSpec.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Web.Internal.FormUrlEncodedSpec (spec) where++import Control.Monad ((<=<))+import qualified Data.ByteString.Lazy.Char8 as BSL+import qualified Data.Map.Strict as Map+import Data.Text (Text, unpack)+import Test.Hspec+import Test.QuickCheck++import GHC.Exts (fromList)++import Web.Internal.FormUrlEncoded+import Web.Internal.HttpApiData+import Web.Internal.TestInstances++spec :: Spec+spec = do+ genericSpec+ urlEncoding++genericSpec :: Spec+genericSpec = describe "Default (generic) instances" $ do++ context "ToForm" $ do++ it "contains the record names" $ property $ \(x :: SimpleRec) -> do+ let f = unForm $ toForm x+ Map.member "rec1" f `shouldBe` True+ Map.member "rec2" f `shouldBe` True++ it "contains the correct record values" $ property $ \(x :: SimpleRec) -> do+ let f = unForm $ toForm x+ Map.lookup "rec1" f `shouldBe` Just [rec1 x]+ (parseQueryParams <$> Map.lookup "rec2" f) `shouldBe` Just (Right [rec2 x])++ context "FromForm" $ do++ it "is the right inverse of ToForm" $ property $ \x (y :: Int) -> do+ let f1 = fromList [("rec1", x), ("rec2", toQueryParam y)]+ r1 = fromForm f1 :: Either Text SimpleRec+ fmap toForm r1 `shouldBe` Right f1++ it "returns the underlying error" $ do+ let f = fromList [("rec1", "anything"), ("rec2", "bad")]+ e = either id (const "no error") (fromForm f :: Either Text SimpleRec)+ unpack e `shouldContain` "input does not start with a digit"++urlEncoding :: Spec+urlEncoding = describe "urlEncoding" $ do++ it "urlDecodeForm (urlEncodeForm x) == Right x" $ property $ \(NoEmptyKeyForm x) -> do+ urlDecodeForm (urlEncodeForm x) `shouldBe` Right x++ it "urlDecodeAsForm == (fromForm <=< urlDecodeForm)" $ property $ \(x :: BSL.ByteString) -> do+ (urlDecodeAsForm x :: Either Text Form) `shouldBe` (fromForm <=< urlDecodeForm) x++ it "urlEncodeAsForm == urlEncodeForm . toForm" $ property $ \(x :: Form) -> do+ urlEncodeAsForm x `shouldBe` (urlEncodeForm . toForm) x++ it "urlDecodeForm \"\" == Right mempty" $ do+ urlDecodeForm "" `shouldBe` Right mempty
+ test/Web/Internal/HttpApiDataSpec.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Web.Internal.HttpApiDataSpec (spec) where+++import qualified Data.ByteString as BS+import Data.ByteString.Builder (toLazyByteString)+import Data.Char+import qualified Data.Fixed as F+import Data.Int+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Lazy as L+import Data.Time.Compat+import Data.Time.Calendar.Month.Compat (Month)+import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..))+import qualified Data.UUID.Types as UUID+import Data.Version+import Data.Word+import Web.Cookie (SetCookie, defaultSetCookie,+ setCookieName, setCookieValue)++import Data.Proxy++import Numeric.Natural++import Test.Hspec+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck++import Web.Internal.HttpApiData++import Web.Internal.TestInstances++(<=>) :: forall a b. (Show a, Show b, Eq a) => (a -> b) -> (b -> Either T.Text a) -> a -> Property+(f <=> g) x = counterexample+ (show lhs' ++ " : " ++ show lhs ++ " /= " ++ show rhs)+ (lhs == rhs)+ where+ lhs' = f x+ lhs = g lhs' :: Either T.Text a+ rhs = Right x :: Either T.Text a++encodedUrlPieceProp :: ToHttpApiData a => a -> Property+encodedUrlPieceProp x = toLazyByteString (toEncodedUrlPiece (toUrlPiece x)) === toLazyByteString (toEncodedUrlPiece x)++encodedQueryParamProp :: ToHttpApiData a => a -> Property+encodedQueryParamProp x = toLazyByteString (toEncodedQueryParam (toQueryParam x)) === toLazyByteString (toEncodedQueryParam x)++-- | Check 'ToHttpApiData' and 'FromHttpApiData' compatibility+checkUrlPiece :: forall a. (Eq a, ToHttpApiData a, FromHttpApiData a, Show a, Arbitrary a) => Proxy a -> String -> Spec+checkUrlPiece _ = checkUrlPiece' (arbitrary :: Gen a)++checkUrlPiece' :: forall a. (Eq a, ToHttpApiData a, FromHttpApiData a, Show a) => Gen a -> String -> Spec+checkUrlPiece' gen name = describe name $ do+ prop "toUrlPiece <=> parseUrlPiece" $ forAll gen (toUrlPiece <=> parseUrlPiece :: a -> Property)+ prop "toQueryParam <=> parseQueryParam" $ forAll gen (toQueryParam <=> parseQueryParam :: a -> Property)+ prop "toHeader <=> parseHeader" $ forAll gen (toHeader <=> parseHeader :: a -> Property)+ prop "toEncodedUrlPiece encodes correctly" $ forAll gen encodedUrlPieceProp+ prop "toEncodedQueryParam encodes correctly" $ forAll gen encodedQueryParamProp++-- | Check case insensitivity for @parseUrlPiece@.+checkUrlPieceI :: forall a. (Eq a, ToHttpApiData a, FromHttpApiData a, Arbitrary a) => Proxy a -> String -> Spec+checkUrlPieceI _ = checkUrlPiece (Proxy :: Proxy (RandomCase a))++spec :: Spec+spec = do+ describe "Instances" $ do+ checkUrlPiece (Proxy :: Proxy ()) "()"+ checkUrlPiece (Proxy :: Proxy Char) "Char"+ checkUrlPieceI (Proxy :: Proxy Bool) "Bool"+ checkUrlPieceI (Proxy :: Proxy Ordering) "Ordering"+ checkUrlPiece (Proxy :: Proxy Int) "Int"+ checkUrlPiece (Proxy :: Proxy Int8) "Int8"+ checkUrlPiece (Proxy :: Proxy Int16) "Int16"+ checkUrlPiece (Proxy :: Proxy Int32) "Int32"+ checkUrlPiece (Proxy :: Proxy Int64) "Int64"+ checkUrlPiece (Proxy :: Proxy Integer) "Integer"+ checkUrlPiece (Proxy :: Proxy Word) "Word"+ checkUrlPiece (Proxy :: Proxy Word8) "Word8"+ checkUrlPiece (Proxy :: Proxy Word16) "Word16"+ checkUrlPiece (Proxy :: Proxy Word32) "Word32"+ checkUrlPiece (Proxy :: Proxy Word64) "Word64"+ checkUrlPiece (Proxy :: Proxy String) "String"+ checkUrlPiece (Proxy :: Proxy T.Text) "Text.Strict"+ checkUrlPiece (Proxy :: Proxy L.Text) "Text.Lazy"+ checkUrlPiece (Proxy :: Proxy Day) "Day"+ checkUrlPiece (Proxy :: Proxy TimeOfDay) "TimeOfDay"+ checkUrlPiece (Proxy :: Proxy LocalTime) "LocalTime"+ checkUrlPiece (Proxy :: Proxy ZonedTime) "ZonedTime"+ checkUrlPiece (Proxy :: Proxy UTCTime) "UTCTime"+ checkUrlPiece (Proxy :: Proxy NominalDiffTime) "NominalDiffTime"+ checkUrlPiece (Proxy :: Proxy DayOfWeek) "DayOfWeek"+ checkUrlPiece (Proxy :: Proxy Quarter) "Quarter"+ checkUrlPiece (Proxy :: Proxy QuarterOfYear) "QuarterOfYear"+ checkUrlPiece (Proxy :: Proxy Month) "Month"+ checkUrlPiece (Proxy :: Proxy DayOfWeek) "DayOfWeek"+ checkUrlPiece (Proxy :: Proxy Version) "Version"+ checkUrlPiece (Proxy :: Proxy UUID.UUID) "UUID"+ checkUrlPiece' setCookieGen "Cookie"++ checkUrlPiece (Proxy :: Proxy F.Uni) "Uni"+ checkUrlPiece (Proxy :: Proxy F.Deci) "Deci"+ checkUrlPiece (Proxy :: Proxy F.Centi) "Centi"+ checkUrlPiece (Proxy :: Proxy F.Milli) "Milli"+ checkUrlPiece (Proxy :: Proxy F.Micro) "Micro"+ checkUrlPiece (Proxy :: Proxy F.Nano) "Nano"+ checkUrlPiece (Proxy :: Proxy F.Pico) "Pico"++ checkUrlPiece (Proxy :: Proxy (Maybe String)) "Maybe String"+ checkUrlPieceI (Proxy :: Proxy (Maybe Integer)) "Maybe Integer"+ checkUrlPiece (Proxy :: Proxy (Either Integer T.Text)) "Either Integer Text"+ checkUrlPieceI (Proxy :: Proxy (Either Version Day)) "Either Version Day"++ checkUrlPiece (Proxy :: Proxy Natural) "Natural"++ it "bad integers are rejected" $ do+ parseUrlPieceMaybe (T.pack "123hello") `shouldBe` (Nothing :: Maybe Int)++ it "bounds checking works" $ do+ parseUrlPieceMaybe (T.pack "256") `shouldBe` (Nothing :: Maybe Int8)+ parseUrlPieceMaybe (T.pack "-10") `shouldBe` (Nothing :: Maybe Word)++ it "invalid utf8 is handled" $ do+ parseHeaderMaybe (BS.pack [128]) `shouldBe` (Nothing :: Maybe T.Text)++setCookieGen :: Gen SetCookie+setCookieGen = do+ n <- TE.encodeUtf8 . T.pack . filter isAlphaNum <$> arbitrary+ v <- TE.encodeUtf8 . T.pack . filter isAlphaNum <$> arbitrary+ return $ defaultSetCookie { setCookieName = n, setCookieValue = v }
+ test/Web/Internal/TestInstances.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Web.Internal.TestInstances+ ( RandomCase(..)+ , SimpleRec(..)+ , NoEmptyKeyForm(..)+ ) where++import Control.Applicative -- for ghc < 9.6+import Data.Char+import qualified Data.Map.Strict as Map+import qualified Data.Text as T+import Data.Time.Compat+import GHC.Exts (fromList)+import GHC.Generics++import Test.QuickCheck+import Test.QuickCheck.Instances ()++import Web.Internal.FormUrlEncoded+import Web.Internal.HttpApiData++instance Eq ZonedTime where+ ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y++instance Arbitrary Form where+ arbitrary = fromList <$> arbitrary++data RandomCase a = RandomCase [Bool] a++instance ToHttpApiData a => Show (RandomCase a) where+ show rc@(RandomCase _ x) = show (toUrlPiece rc) ++ " (original: " ++ show (toUrlPiece x) ++ ")"++instance Eq a => Eq (RandomCase a) where+ RandomCase _ x == RandomCase _ y = x == y++instance Arbitrary a => Arbitrary (RandomCase a) where+ arbitrary = liftA2 RandomCase nonempty arbitrary+ where+ nonempty = liftA2 (:) arbitrary arbitrary++instance ToHttpApiData a => ToHttpApiData (RandomCase a) where+ toUrlPiece (RandomCase us x) = T.pack (zipWith (\u -> if u then toUpper else toLower) (cycle us) (T.unpack (toUrlPiece x)))++instance FromHttpApiData a => FromHttpApiData (RandomCase a) where+ parseUrlPiece s = RandomCase [] <$> parseUrlPiece s++data SimpleRec = SimpleRec { rec1 :: T.Text, rec2 :: Int }+ deriving (Eq, Show, Read, Generic)++instance ToForm SimpleRec+instance FromForm SimpleRec++instance Arbitrary SimpleRec where+ arbitrary = SimpleRec <$> arbitrary <*> arbitrary++newtype NoEmptyKeyForm =+ NoEmptyKeyForm { unNoEmptyKeyForm :: Form }+ deriving Show++instance Arbitrary NoEmptyKeyForm where+ arbitrary = NoEmptyKeyForm . removeEmptyKeys <$> arbitrary+ where+ removeEmptyKeys (Form m) = Form (Map.delete "" m)