http-api-data-0.5/0000755000000000000000000000000007346545000012204 5ustar0000000000000000http-api-data-0.5/CHANGELOG.md0000644000000000000000000001100507346545000014012 0ustar00000000000000000.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)). 0.2.3 --- * Add more parser helpers for `Bounded` `Enum` types. 0.2.2 --- * Add instances for more `time` types: `LocalTime`, `ZonedTime`, `UTCTime` and `NominalDiffTime` 0.2.1 --- * Add helpers for multiple URL pieces and query params: * `toUrlPieces`, `parseUrlPieces` * `toQueryParams`, `parseQueryParams` 0.2 --- * Export helper functions from `Web.HttpApiData`: * `parseUrlPieceMaybe`, `parseHeaderMaybe`, `parseQueryParamMaybe` * `parseUrlPieceWithPrefix`, `parseHeaderWithPrefix`, `parseQueryParamWithPrefix` * `showTextData`, `readTextData`, `parseBoundedTextData` * Fix AMP related warnings 0.1.1 --- * Add `use-text-show` flag to optionally use more efficient `TextShow` instances http-api-data-0.5/LICENSE0000644000000000000000000000253107346545000013212 0ustar0000000000000000The following license covers this documentation, and the source code, except where otherwise indicated. Copyright 2015, Nickolay Kudasov. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. http-api-data-0.5/README.md0000644000000000000000000000262707346545000013472 0ustar0000000000000000# http-api-data [![Build Status](https://secure.travis-ci.org/fizruk/http-api-data.png?branch=master)](http://travis-ci.org/fizruk/http-api-data) [![Hackage package](http://img.shields.io/hackage/v/http-api-data.svg)](http://hackage.haskell.org/package/http-api-data) [![Stackage LTS](http://stackage.org/package/http-api-data/badge/lts)](http://stackage.org/lts/package/http-api-data) [![Stackage Nightly](http://stackage.org/package/http-api-data/badge/nightly)](http://stackage.org/nightly/package/http-api-data) This package defines typeclasses used for converting Haskell data types to and from HTTP API data. ### Examples Booleans: ``` >>> toUrlPiece True "true" >>> parseUrlPiece "false" :: Either Text Bool Right False >>> parseUrlPieces ["true", "false", "undefined"] :: Either Text [Bool] Left "could not parse: `undefined'" ``` Numbers: ``` >>> toQueryParam 45.2 "45.2" >>> parseQueryParam "452" :: Either Text Int Right 452 >>> toQueryParams [1..5] ["1","2","3","4","5"] >>> parseQueryParams ["127", "255"] :: Either Text [Int8] Left "out of bounds: `255' (should be between -128 and 127)" ``` Strings: ``` >>> toHeader "hello" "hello" >>> parseHeader "world" :: Either Text String Right "world" ``` Calendar day: ``` >>> toQueryParam (fromGregorian 2015 10 03) "2015-10-03" >>> toGregorian <$> parseQueryParam "2016-12-01" Right (2016,12,1) ``` ## Contributing Contributions and bug reports are welcome! http-api-data-0.5/Setup.hs0000644000000000000000000000005607346545000013641 0ustar0000000000000000import Distribution.Simple main = defaultMain http-api-data-0.5/http-api-data.cabal0000644000000000000000000000665707346545000015643 0ustar0000000000000000cabal-version: >= 1.10 name: http-api-data version: 0.5 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 maintainer: Nickolay Kudasov homepage: http://github.com/fizruk/http-api-data stability: unstable build-type: Simple extra-source-files: include/overlapping-compat.h test/*.hs CHANGELOG.md README.md tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5, GHC==8.8.4, GHC==8.10.7, GHC==9.0.2, GHC==9.2.3, GHC==9.4.1 flag use-text-show description: Use text-show library for efficient ToHttpApiData implementations. default: False manual: True library hs-source-dirs: src/ include-dirs: include/ -- GHC bundled build-depends: base >= 4.9 && < 4.17 , bytestring >= 0.10.8.1 && < 0.12 , containers >= 0.5.7.1 && < 0.7 , text >= 1.2.3.0 && < 1.3 || >=2.0 && <2.1 , transformers >= 0.5.2.0 && < 0.7 -- other-dependencies build-depends: attoparsec >= 0.13.2.2 && < 0.15 , attoparsec-iso8601 >= 1.1.0.0 && < 1.2 , base-compat >= 0.10.5 && < 0.13 , cookie >= 0.4.3 && < 0.5 , hashable >= 1.2.7.0 && < 1.5 , http-types >= 0.12.3 && < 0.13 , tagged >= 0.8.5 && < 0.9 , time-compat >= 1.9.5 && < 1.10 , unordered-containers >= 0.2.10.0 && < 0.3 , uuid-types >= 1.0.3 && < 1.1 if flag(use-text-show) cpp-options: -DUSE_TEXT_SHOW build-depends: text-show >= 3.8.2 && <3.10 exposed-modules: Web.HttpApiData 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 other-modules: Web.Internal.FormUrlEncodedSpec Web.Internal.HttpApiDataSpec Web.Internal.TestInstances hs-source-dirs: test ghc-options: -Wall default-language: Haskell2010 build-tool-depends: hspec-discover:hspec-discover >= 2.7.1 && <2.11 -- inherited depndencies build-depends: base , base-compat , bytestring , cookie , http-api-data , text , time-compat , unordered-containers , uuid-types if !impl(ghc >= 7.10) build-depends: nats build-depends: HUnit >= 1.6.0.0 && <1.7 , hspec >= 2.7.1 && <2.11 , QuickCheck >= 2.13.1 && <2.15 , quickcheck-instances >= 0.3.25.2 && <0.4 source-repository head type: git location: https://github.com/fizruk/http-api-data http-api-data-0.5/include/0000755000000000000000000000000007346545000013627 5ustar0000000000000000http-api-data-0.5/include/overlapping-compat.h0000644000000000000000000000032207346545000017604 0ustar0000000000000000#if __GLASGOW_HASKELL__ >= 710 #define OVERLAPPABLE_ {-# OVERLAPPABLE #-} #define OVERLAPPING_ {-# OVERLAPPING #-} #else {-# LANGUAGE OverlappingInstances #-} #define OVERLAPPABLE_ #define OVERLAPPING_ #endif http-api-data-0.5/src/Web/0000755000000000000000000000000007346545000013510 5ustar0000000000000000http-api-data-0.5/src/Web/FormUrlEncoded.hs0000644000000000000000000000146307346545000016720 0ustar0000000000000000-- | -- 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 http-api-data-0.5/src/Web/HttpApiData.hs0000644000000000000000000000355207346545000016214 0ustar0000000000000000-- | -- Convert Haskell values to and from HTTP API data -- such as URL pieces, headers and query parameters. module Web.HttpApiData ( -- * Examples -- $examples -- * Classes ToHttpApiData (..), FromHttpApiData (..), -- * @'Maybe'@ parsers parseUrlPieceMaybe, parseHeaderMaybe, parseQueryParamMaybe, -- * Prefix parsers parseUrlPieceWithPrefix, parseHeaderWithPrefix, parseQueryParamWithPrefix, -- * Multiple URL pieces toUrlPieces, parseUrlPieces, -- * Multiple query params toQueryParams, parseQueryParams, -- * Parsers for @'Bounded'@ @'Enum'@s parseBoundedUrlPiece, parseBoundedQueryParam, parseBoundedHeader, parseBoundedEnumOf, parseBoundedEnumOfI, parseBoundedTextData, -- * Lenient data LenientData (..), -- * Other helpers showTextData, readTextData, ) where import Web.Internal.HttpApiData -- $setup -- -- >>> :set -XOverloadedStrings -- >>> import Control.Applicative -- >>> import Data.Time.Compat -- >>> import Data.Int -- >>> import Data.Text (Text) -- >>> import Data.Version -- $examples -- -- Booleans: -- -- >>> toUrlPiece True -- "true" -- >>> parseUrlPiece "false" :: Either Text Bool -- Right False -- >>> parseUrlPieces ["true", "false", "undefined"] :: Either Text [Bool] -- Left "could not parse: `undefined'" -- -- Numbers: -- -- >>> toQueryParam 45.2 -- "45.2" -- >>> parseQueryParam "452" :: Either Text Int -- Right 452 -- >>> 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)" -- -- Strings: -- -- >>> toHeader "hello" -- "hello" -- >>> parseHeader "world" :: Either Text String -- Right "world" -- -- Calendar day: -- -- >>> toQueryParam (fromGregorian 2015 10 03) -- "2015-10-03" -- >>> toGregorian <$> parseQueryParam "2016-12-01" -- Right (2016,12,1) http-api-data-0.5/src/Web/Internal/0000755000000000000000000000000007346545000015264 5ustar0000000000000000http-api-data-0.5/src/Web/Internal/FormUrlEncoded.hs0000644000000000000000000007764207346545000020510 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# 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 #-} #include "overlapping-compat.h" module Web.Internal.FormUrlEncoded where import Prelude () import Prelude.Compat 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 Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Int (Int16, Int32, Int64, Int8) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.List (intersperse, sortBy) import Data.Map (Map) import qualified Data.Map as Map 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) 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 -- >>> :set -XOverloadedLists -- >>> :set -XOverloadedStrings -- >>> :set -XFlexibleContexts -- >>> :set -XScopedTypeVariables -- >>> :set -XTypeFamilies -- >>> import Data.Char (toLower) -- -- >>> 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 :: HashMap 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 . HashMap.fromListWith (flip (<>)) . fmap (\(k, v) -> (k, [v])) toList = concatMap (\(k, vs) -> map ((,) k) vs) . HashMap.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 instance (ToFormKey k, ToHttpApiData v) => ToForm [(k, v)] where toForm = fromList . map (toFormKey *** toQueryParam) instance (ToFormKey k, ToHttpApiData v) => ToForm (Map k [v]) where toForm = fromEntriesByKey . Map.toList instance (ToFormKey k, ToHttpApiData v) => ToForm (HashMap k [v]) where toForm = fromEntriesByKey . HashMap.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 . HashMap.fromListWith (<>) . map (toFormKey *** map toQueryParam) data Proxy3 a b c = Proxy3 type family NotSupported (cls :: k1) (a :: k2) (reason :: Symbol) :: Constraint where #if __GLASGOW_HASKELL__ < 800 -- this is just a placeholder case for older GHCs to not freak out on an empty closed type family NotSupported cls a "this type family is actually empty" = () #else 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)." ) #endif -- | 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 -- | _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, FromFormKey k, FromHttpApiData v) => FromForm (Map k [v]) where fromForm = fmap (Map.fromListWith (<>)) . toEntriesByKey instance (Eq k, Hashable k, FromFormKey k, FromHttpApiData v) => FromForm (HashMap k [v]) where fromForm = fmap (HashMap.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 . HashMap.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 . HashMap.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) http-api-data-0.5/src/Web/Internal/HttpApiData.hs0000644000000000000000000010446007346545000017770 0ustar0000000000000000{-# 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 Prelude () import Prelude.Compat import Control.Applicative (Const(Const)) import Control.Arrow (left, (&&&)) import Control.Monad ((<=<)) import qualified Data.Attoparsec.Text as Atto import qualified Data.Attoparsec.Time as Atto 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 as Map import Data.Monoid (All (..), Any (..), Dual (..), First (..), Last (..), Product (..), Sum (..)) import Data.Semigroup (Semigroup (..)) 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.Read (Reader, decimal, rational, signed) import Data.Time.Compat (Day, FormatTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime, formatTime, DayOfWeek (..), nominalDiffTimeToSeconds, secondsToNominalDiffTime) import Data.Time.Format.Compat (defaultTimeLocale, iso8601DateFormat) import Data.Time.Calendar.Month.Compat (Month) import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..), toYearQuarter) 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 -- >>> data BasicAuthToken = BasicAuthToken Text deriving (Show) -- >>> instance FromHttpApiData BasicAuthToken where parseHeader h = BasicAuthToken <$> parseHeaderWithPrefix "Basic " h; parseQueryParam p = BasicAuthToken <$> parseQueryParam p -- >>> import Data.Time.Compat -- >>> import Data.Version -- | 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.encodePathSegmentsRelative', -- but this may be overriden with a more efficient version. toEncodedUrlPiece :: a -> BS.Builder toEncodedUrlPiece = H.encodePathSegmentsRelative . (:[]) . toUrlPiece -- | 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] :: [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 -- | -- >>> toUrlPiece () -- "_" instance ToHttpApiData () where toUrlPiece () = "_" toEncodedUrlPiece = unsafeToEncodedUrlPiece 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 instance ToHttpApiData Void where toUrlPiece = absurd instance ToHttpApiData Natural where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData Bool where toUrlPiece = showTextData; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData Ordering where toUrlPiece = showTextData; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData Double where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData Float where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData Int where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData Int8 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData Int16 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData Int32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData Int64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData Integer where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData Word where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData Word8 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData Word16 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData Word32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData Word64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece -- | Note: this instance is not polykinded instance F.HasResolution a => ToHttpApiData (F.Fixed (a :: Type)) where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece -- | -- >>> toUrlPiece (fromGregorian 2015 10 03) -- "2015-10-03" instance ToHttpApiData Day where toUrlPiece = T.pack . show toEncodedUrlPiece = unsafeToEncodedUrlPiece timeToUrlPiece :: FormatTime t => String -> t -> Text timeToUrlPiece fmt = T.pack . formatTime defaultTimeLocale (iso8601DateFormat (Just fmt)) -- | -- >>> toUrlPiece $ TimeOfDay 14 55 23.1 -- "14:55:23.1" instance ToHttpApiData TimeOfDay where toUrlPiece = T.pack . formatTime defaultTimeLocale "%H:%M:%S%Q" toEncodedUrlPiece = unsafeToEncodedUrlPiece -- | -- >>> toUrlPiece $ LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 21.687) -- "2015-10-03T14:55:21.687" instance ToHttpApiData LocalTime where toUrlPiece = timeToUrlPiece "%H:%M:%S%Q" toEncodedUrlPiece = unsafeToEncodedUrlPiece -- | -- >>> toUrlPiece $ ZonedTime (LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 51.001)) utc -- "2015-10-03T14:55:51.001+0000" instance ToHttpApiData ZonedTime where toUrlPiece = timeToUrlPiece "%H:%M:%S%Q%z" toEncodedUrlPiece = unsafeToEncodedUrlPiece -- | -- >>> toUrlPiece $ UTCTime (fromGregorian 2015 10 03) 864.5 -- "2015-10-03T00:14:24.5Z" instance ToHttpApiData UTCTime where toUrlPiece = timeToUrlPiece "%H:%M:%S%QZ" toEncodedUrlPiece = unsafeToEncodedUrlPiece -- | -- >>> 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 -- | -- >>> toUrlPiece Q4 -- "q4" instance ToHttpApiData QuarterOfYear where toUrlPiece Q1 = "q1" toUrlPiece Q2 = "q2" toUrlPiece Q3 = "q3" toUrlPiece Q4 = "q4" -- | -- >>> import Data.Time.Calendar.Quarter.Compat (Quarter (..)) -- >>> MkQuarter 8040 -- 2010-Q1 -- -- >>> toUrlPiece $ MkQuarter 8040 -- "2010-q1" -- instance ToHttpApiData Quarter where toUrlPiece q = case toYearQuarter q of (y, qoy) -> T.pack (show y ++ "-" ++ f qoy) where f Q1 = "q1" f Q2 = "q2" f Q3 = "q3" f Q4 = "q4" -- | -- >>> import Data.Time.Calendar.Month.Compat (Month (..)) -- >>> MkMonth 24482 -- 2040-03 -- -- >>> toUrlPiece $ MkMonth 24482 -- "2040-03" -- instance ToHttpApiData Month where toUrlPiece = T.pack . formatTime defaultTimeLocale "%Y-%m" instance ToHttpApiData NominalDiffTime where toUrlPiece = toUrlPiece . nominalDiffTimeToSeconds 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) instance ToHttpApiData Any where toUrlPiece = coerce (toUrlPiece :: Bool -> Text) toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Bool -> BS.Builder) instance ToHttpApiData a => ToHttpApiData (Dual a) where toUrlPiece = coerce (toUrlPiece :: a -> Text) toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) instance ToHttpApiData a => ToHttpApiData (Sum a) where toUrlPiece = coerce (toUrlPiece :: a -> Text) toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) instance ToHttpApiData a => ToHttpApiData (Product a) where toUrlPiece = coerce (toUrlPiece :: a -> Text) toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) instance ToHttpApiData a => ToHttpApiData (First a) where toUrlPiece = coerce (toUrlPiece :: Maybe a -> Text) toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Maybe a -> BS.Builder) instance ToHttpApiData a => ToHttpApiData (Last a) where toUrlPiece = coerce (toUrlPiece :: Maybe a -> Text) toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Maybe a -> BS.Builder) instance ToHttpApiData a => ToHttpApiData (Semi.Min a) where toUrlPiece = coerce (toUrlPiece :: a -> Text) toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) instance ToHttpApiData a => ToHttpApiData (Semi.Max a) where toUrlPiece = coerce (toUrlPiece :: a -> Text) toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) instance ToHttpApiData a => ToHttpApiData (Semi.First a) where toUrlPiece = coerce (toUrlPiece :: a -> Text) toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) instance ToHttpApiData a => ToHttpApiData (Semi.Last a) where toUrlPiece = coerce (toUrlPiece :: a -> Text) toEncodedUrlPiece = coerce (toEncodedUrlPiece :: 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) -- | @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) -- | @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) -- | -- >>> 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 = runAtto Atto.day -- | -- >>> parseUrlPiece "14:55:01.333" :: Either Text TimeOfDay -- Right 14:55:01.333 instance FromHttpApiData TimeOfDay where parseUrlPiece = runAtto Atto.timeOfDay -- | -- >>> parseUrlPiece "2015-10-03T14:55:01" :: Either Text LocalTime -- Right 2015-10-03 14:55:01 instance FromHttpApiData LocalTime where parseUrlPiece = runAtto Atto.localTime -- | -- >>> 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 = runAtto Atto.zonedTime -- | -- >>> parseUrlPiece "2015-10-03T00:14:24Z" :: Either Text UTCTime -- Right 2015-10-03 00:14:24 UTC instance FromHttpApiData UTCTime where parseUrlPiece = runAtto Atto.utcTime -- | -- >>> 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 = runAtto Atto.month -- | -- >>> parseUrlPiece "2021-q1" :: Either Text Quarter -- Right 2021-Q1 instance FromHttpApiData Quarter where parseUrlPiece = runAtto Atto.quarter -- | -- >>> parseUrlPiece "q2" :: Either Text QuarterOfYear -- Right Q2 -- -- >>> parseUrlPiece "Q3" :: Either Text QuarterOfYear -- Right Q3 instance FromHttpApiData QuarterOfYear where parseUrlPiece t = case T.toLower t of "q1" -> return Q1 "q2" -> return Q2 "q3" -> return Q3 "q4" -> return Q4 _ -> Left "Invalid quarter of year" 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}) 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) ------------------------------------------------------------------------------- -- Attoparsec helpers ------------------------------------------------------------------------------- runAtto :: Atto.Parser a -> Text -> Either Text a runAtto p t = case Atto.parseOnly (p <* Atto.endOfInput) t of Left err -> Left (T.pack err) Right x -> Right x http-api-data-0.5/test/0000755000000000000000000000000007346545000013163 5ustar0000000000000000http-api-data-0.5/test/Spec.hs0000644000000000000000000000005407346545000014410 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} http-api-data-0.5/test/Web/Internal/0000755000000000000000000000000007346545000015454 5ustar0000000000000000http-api-data-0.5/test/Web/Internal/FormUrlEncodedSpec.hs0000644000000000000000000000437007346545000021477 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Web.Internal.FormUrlEncodedSpec (spec) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative import Data.Monoid #endif import Control.Monad ((<=<)) import qualified Data.ByteString.Lazy.Char8 as BSL import qualified Data.HashMap.Strict as HashMap 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 HashMap.member "rec1" f `shouldBe` True HashMap.member "rec2" f `shouldBe` True it "contains the correct record values" $ property $ \(x :: SimpleRec) -> do let f = unForm $ toForm x HashMap.lookup "rec1" f `shouldBe` Just [rec1 x] (parseQueryParams <$> HashMap.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)] Right r1 = fromForm f1 :: Either Text SimpleRec toForm r1 `shouldBe` f1 it "returns the underlying error" $ do let f = fromList [("rec1", "anything"), ("rec2", "bad")] Left e = 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 http-api-data-0.5/test/Web/Internal/HttpApiDataSpec.hs0000644000000000000000000001347507346545000021000 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Web.Internal.HttpApiDataSpec (spec) where import Prelude () import Prelude.Compat 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) -- | 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 -- | 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 } http-api-data-0.5/test/Web/Internal/TestInstances.hs0000644000000000000000000000405707346545000020605 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Web.Internal.TestInstances ( RandomCase(..) , SimpleRec(..) , NoEmptyKeyForm(..) ) where import Control.Applicative import Data.Char import qualified Data.HashMap.Strict as HashMap 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 (HashMap.delete "" m)